You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1733 lines
100 KiB
1733 lines
100 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'dev make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::mix::commandset::scriptwrap 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_scriptwrap 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {scriptwrap polyglot tool}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {scriptwrap tool}] [comment {-- Description at end of page heading --}] |
|
#[require punk::mix::commandset::scriptwrap] |
|
#[keywords module commandset launcher scriptwrap] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of scriptwrap |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by poshinfo |
|
#[list_begin itemized] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
|
|
package require punk::lib |
|
package require punk::args |
|
package require punk::mix |
|
package require punk::mix::base |
|
package require punk::fileline |
|
|
|
|
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
#[item] [package {punk::lib}] |
|
#[item] [package {punk::args}] |
|
#[item] [package {punk::mix}] |
|
#[item] [package {punk::base}] |
|
#[item] [package {punk::fileline}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
namespace eval punk::mix::commandset::scriptwrap { |
|
#*** !doctools |
|
#[subsection {Namespace punk::mix::commandset::scriptwrap}] |
|
#[para] Core API functions for punk::mix::commandset::scriptwrap |
|
#[list_begin definitions] |
|
|
|
namespace export * |
|
|
|
namespace eval fileline { |
|
namespace import ::punk::fileline::lib::* |
|
namespace import ::punk::fileline::class::* |
|
} |
|
|
|
proc templates {args} { |
|
package require overtype |
|
package require textblock |
|
set tdict_low_to_high [templates_dict {*}$args] |
|
#convert to screen order - with higher priority at the top |
|
set tdict [dict create] |
|
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
|
dict set tdict $k [dict get $tdict_low_to_high $k] |
|
} |
|
|
|
#set pathinfolist [dict values $tdict] |
|
set names [dict keys $tdict] |
|
|
|
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *]; #first key of templates_dict is path |
|
set paths [list] |
|
set pathtypes [list] |
|
dict for {nm tinfo} $tdict { |
|
lappend paths [dict get $tinfo path] |
|
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
|
} |
|
|
|
package require textblock |
|
set title(name) "Template Name" |
|
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {string length $v}]] |
|
set col(name) [string repeat " " $widest(name)] |
|
|
|
set title(pathtype) "[a+ green]Path\nType[a]" |
|
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {textblock::width $v}]] |
|
set col(pathtype) [string repeat " " $widest(pathtype)] |
|
|
|
set title(path) "Path" |
|
set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {string length $v}]] |
|
set col(path) [string repeat " " $widest(path)] |
|
|
|
|
|
|
|
|
|
set tablewidth [expr {$widest(name) + 1 + $widest(pathtype) + $widest(path)}] |
|
set table "" |
|
append table [string repeat - $tablewidth] \n |
|
append table [textblock::join -- [overtype::left $col(name) $title(name)] " " [overtype::left $col(pathtype) $title(pathtype)] " " [overtype::left $col(path) $title(path)]] \n |
|
append table [string repeat - $tablewidth] \n |
|
|
|
foreach n $names pt $pathtypes p $paths { |
|
append table "[overtype::left $col(name) $n] [overtype::left $col(pathtype) $pt] [overtype::left $col(path) $p]" \n |
|
} |
|
|
|
|
|
return $table |
|
} |
|
proc templates_dict {args} { |
|
package require punk::cap |
|
if {[punk::cap::capability_has_handler punk.templates]} { |
|
return [punk::cap::call_handler punk.templates get_itemdict_scriptappwrappers {*}$args] |
|
} else { |
|
put stderr "commandset::scriptwrap::templates_dict WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
|
} |
|
return |
|
} |
|
|
|
|
|
#A batch file with unix line-endings is sensitive to label positioning. |
|
#batch file with windows crlf line endings can exhibit this problem - but probably only if specifically crafted with long lines deliberately designed to trigger it. |
|
#see: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888 (Call and goto may fail when the batch file has Unix line endings) |
|
#The windows batch file scanner appears to parse in 512 Byte chunks. |
|
#If a label following a call/goto is at a position spanning a 512 byte block as counted from the call/goto site (callsite assumed to be EOL - works for basic cases at least) then the label won't be found. |
|
#A label preceding a call/goto site can't span a 512 byte boundary as counted from the beginning of the file |
|
#checkfile produces warnings and errors in ansi-coloured form (both to stdout and a summary in the return value) |
|
#The script should then be adjusted with comments and/or whitespace and checkfile should be re-run to confirm there are no new boundary-spanning labels. |
|
#checkfile needs to be run even on previously tested scriptwrapper templates because the final :exit label is beyond the payloads and so could span a 512 Byte block |
|
#It is more likely to catch issues if adjustments are made to the initial batch-script code in a template. |
|
# |
|
#cmd allows labels at call sites to span lines with line continuation character ^ |
|
#target labels can't span lines with ^ - cmd doesn't recognise them (They possibly do span in a way - but but the newlines may be included in the label - so they may be hard/impossible to call). |
|
#Note that we can't filter obviously non-batch-script lines before processing - as the way batch label-scanning works it scans in chunks of 512 bytes so all lines are relevant. |
|
#This means label-like things could be incorrectly found in other script data - that's partly the point of this check |
|
#Note that we can't filter obviously non-batch-script lines before processing - as the way batch label-scanning works it scans in chunks of 512 bytes so all lines are relevant. |
|
#This means label-like things could be incorrectly found in other script data - that's partly the point of this check. |
|
proc checkfile {filepath args} { |
|
if {![file exists $filepath]} { |
|
error "punk::mix::commandset:scriptwrap error cannot find file '$filepath'" |
|
} |
|
set crlf_lf_replacements [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message |
|
# -ignore_rems 1 allows testing of alignment state if rems were stripped - todo - lf/crlf-preserving rem strip function |
|
set opts [dict create\ |
|
-ignore_rems 0\ |
|
-substitutionmap {}\ |
|
-crlf_lf_replacements $crlf_lf_replacements\ |
|
] |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-ignore_rems - -substitutionmap - -crlf_lf_replacements { |
|
dict set opts $k $v |
|
} |
|
default { |
|
error "checkfile error - unknown option '$k'. Known options: [dict keys $opts]" |
|
} |
|
} |
|
} |
|
# -- --- --- --- --- --- --- |
|
set opt_ignore_rems [dict get $opts -ignore_rems] |
|
set opt_substitutionmap [dict get $opts -substitutionmap] |
|
set opt_crlf_lf_replacements [dict get $opts -crlf_lf_replacements] |
|
# -- --- --- --- --- --- --- |
|
|
|
# #### load file #### |
|
##set raw_filedata [fcat -translation binary $filepath] |
|
# - as we may need to look at data beyond a ctrl-z (\x1A) section |
|
set fd [open $filepath r] |
|
fconfigure $fd -translation binary |
|
set raw_filedata [read $fd] |
|
close $fd |
|
# ################### |
|
|
|
|
|
set objFile [fileline::textinfo new $raw_filedata] |
|
|
|
if {$opt_ignore_rems} { |
|
#! todo |
|
error "-ignore_rems unimplemented" |
|
if 0 { |
|
#todo - rebuild a raw_filedata value from the resultant lines |
|
#review. @REM can appear after other commands and an ampersand for example. |
|
# - we are interested in stripping lines with leading REMs |
|
# - need to work out if a REM line with dos line-continuation should |
|
|
|
set data "" |
|
set skipped_rems 0 |
|
foreach ln [split $filedata \n] { |
|
set ln [string trim $ln] |
|
if {[string match @REM* $ln] || [string match REM* $ln] || [string match @rem* $ln] || [string match rem* $ln]} { |
|
#ignore |
|
incr skipped_rems |
|
} else { |
|
append data $ln \n ;#!! |
|
} |
|
} |
|
puts stderr "Skipped $skipped_rems rem lines" |
|
set dsize [string length $data] |
|
} |
|
} else { |
|
set dsize [string length $raw_filedata] |
|
} |
|
|
|
puts stdout "Examining [$objFile chunklen] bytes of file $filepath for cmd script issues." |
|
set le_info [$objFile chunk_le_counts 0 end] |
|
set lf_count [dict get $le_info lf] |
|
set crlf_count [dict get $le_info crlf] |
|
set unterminated_count [dict get $le_info unterminated] |
|
set total_count [expr {$lf_count + $crlf_count + $unterminated_count}] |
|
puts stdout "lines ending in lf : $lf_count" |
|
puts stdout "lines ending in crlf : $crlf_count" |
|
puts stdout "unterminated lines : $unterminated_count" ;#commonly 1 for trailing data at end of file. More than one is likely to be an error - or perhaps a policy plugin with different concept of lines? |
|
puts stdout "crlf + lf + unterminated: $total_count" |
|
puts stdout "line count : [$objFile linecount]" |
|
if {$total_count != [$objFile linecount]} { |
|
puts stdout "[a+ yellow bold]WARNING: Linecount mismatch with line-endings - seems fishy[a]" |
|
} |
|
if {$unterminated_count > 1} { |
|
puts stdout "[a+ yellow bold]WARNING: More than one unterminated line reported - seems fishy[a]" |
|
} |
|
puts "Checking line based labels and 512 byte boundaries from call sites for possible labels and code execution points." |
|
set line_count [$objFile linecount] |
|
set callid 0 ;#id for callsite and objects created |
|
set file_offset 0 |
|
set error_labels [list] |
|
set warning_labels [list] |
|
set call_labels_found [dict create] |
|
set target_labels_found [dict create] |
|
set possible_target_labels_found [dict create] |
|
set warning_target_labels_found [dict create] |
|
for {set callingline_index 0} {$callingline_index < $line_count} {incr callingline_index} { |
|
set callingline_info [$objFile lineinfo $callingline_index] |
|
set callingline_payload [dict get $callingline_info payload] |
|
set callingline_len [dict get $callingline_info linelen] |
|
set callingline_num [expr {$callingline_index + 1}] |
|
|
|
set callposn -1 |
|
set trimln [string trim $callingline_payload] |
|
|
|
#if {[string match "rem *" $trimln] || [string match "@rem *" $trimln] || [string match "REM *" $trimln] || [string match "@REM *" $trimln]} {} |
|
#ignore things that look like a call that are beind a REM |
|
switch -glob -nocase -- $trimln { |
|
"rem *" - "@rem *" { |
|
|
|
} |
|
default { |
|
#todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace! |
|
|
|
#todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? |
|
#foreach search_regex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] {} |
|
foreach search_regex [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)} {(.*\|\|.*)(@*GOTO\s*:)(\S.*)}] { |
|
if {[regexp $search_regex $callingline_payload _m precall call labelplus]} { |
|
#todo further checks to see if it's actually a batch script line |
|
# - - - - work out what cmd.exe considers start of 512B boundaries when scanning from a callsite |
|
#callposn affected by newlines? |
|
#set callposn [expr {$file_offset + [string length $callingline_payload]}] ;#take callposn as end of line .. review - multiline statements? |
|
set callposn [expr {$file_offset + $callingline_len}] |
|
|
|
#Note there are anomalies around target labels in bracketed sections such as IF blocks |
|
#this is bad practice - as it can lead to unbalanced braces - but batch files can still work under cmd.exe with them in some cases |
|
#e.g unbalanced trailing bracket may be ignored. |
|
#A working script with target-labels in braces can fail due to boundary issues we don't detect (callsite for boundary counting may need to be at end of entire multiline if block??) |
|
#For now - just make sure punk templates don't do this - but it would be nice to be able to detect. |
|
|
|
#set callposn $file_offset |
|
#set callposn [expr {$file_offset + [string length $precall]}] |
|
# - - - - |
|
break |
|
} |
|
} |
|
set callsite_labelfound 0 ;#until proven |
|
if {$callposn != -1} { |
|
set callposn_lineindex [lindex [$objFile chunkrange_to_linerange $callposn $callposn] 0] |
|
#the line represented by callposn may actually be beyond the calling_line_index |
|
set labelinfo [batchlib::get_callsite_label $labelplus] |
|
if {[dict get $labelinfo labelfound]} { |
|
set callsite_labelfound 1 |
|
set label [dict get $labelinfo label] |
|
set call_label_record [list label $label line $callingline_num] |
|
dict lappend call_labels_found $label $call_label_record |
|
} else { |
|
puts stderr "[a+ yellow bold]WARNING - apparent callsite $callposn but couldn't verify label[a]" |
|
puts stderr "Line:\n$trimln" |
|
} |
|
} |
|
|
|
#todo - multiple calls on one line. - also - determine what cmd considers the starting point for forward scanning when call is in a structure such as an if statement. |
|
if {$callsite_labelfound} { |
|
puts stdout "[a+ bold cyan]CALLSITE on line $callingline_num ending at byte $callposn[a]" |
|
set callsummary [string range "${call}${labelplus}" 0 100] |
|
if {[string length $callsummary] < [string length ${call}${labelplus}]} { |
|
puts stdout " CALLSITE: $callsummary (truncated to 100 bytes)" |
|
} else { |
|
puts stdout " CALLSITE: '${call}${labelplus}'" |
|
} |
|
puts stdout " [a+ cyan]FULLINE: $callingline_payload[a]" |
|
|
|
|
|
|
|
################################## |
|
#set labelpluswords [regexp -inline -all {\S+} $labelplus] ;#don't assume labelplus can be treated as Tcl list - use regexp to split |
|
#NOTE it is invalid to assume label always terminated by space - pair of % characters (variable substitution) can contain a space without terminating label |
|
#set word1 [lindex $labelpluswords 0] |
|
|
|
|
|
################################## |
|
|
|
|
|
set labelsize [string length $label] |
|
#scan forward for labels at boundaries |
|
set forward_chunk [$objFile chunk $callposn end] |
|
set forward_chunk_base $callposn ;#name for clarity |
|
|
|
incr callid |
|
set callvar "call-${callid}_fromline-${callingline_num}" |
|
upvar 0 $callvar objForwardScan |
|
set objForwardScan [fileline::textinfo new $forward_chunk] |
|
|
|
|
|
|
|
################################################################################################################################## |
|
#Forward scan 1 - check at normal line boundaries - and see if collides with a chunk boundary - and if the label is obscured or ok |
|
set dsize [$objForwardScan chunklen] |
|
set num_boundaries [expr {$dsize / 512} ] |
|
puts "scanning $dsize forward bytes in file starting at $forward_chunk_base for label '$label' - num_boundaries: $num_boundaries" |
|
set total_offset $file_offset |
|
set found_forward_label 0 |
|
foreach scanlineinfo [$objForwardScan lineinfolist 0 end] { |
|
set scanline_start [dict get $scanlineinfo start] |
|
set scanline_bytes [dict get $scanlineinfo linelen] |
|
set scanline [dict get $scanlineinfo payload] |
|
|
|
set line_start_global [expr {$forward_chunk_base + $scanline_start}] |
|
set line_index_global [lindex [$objFile chunkrange_to_linerange $line_start_global $line_start_global] 0] |
|
set line_num_global [expr {$line_index_global + 1}] |
|
|
|
set trimscanline [string trim $scanline] |
|
|
|
set found_targetlabel_at_line 0 ;# until disproven |
|
if {[string first : $scanline] >= 0} { |
|
set labelinfo [batchlib::get_target_label_from_line $scanline] |
|
if {[dict get $labelinfo labelfound] && [dict get $labelinfo label] eq $label} { |
|
#add to target_labels_found record below |
|
set scan_target_label_record [list label $label line $line_num_global] |
|
set found_targetlabel_at_line 1 |
|
} |
|
} |
|
|
|
if {$found_targetlabel_at_line} { |
|
set scan_target_label_same_line_seen false |
|
if {[dict exists $target_labels_found $label]} { |
|
set thislabel_records [dict get $target_labels_found $label] |
|
foreach previous $thislabel_records { |
|
if {[dict get $previous line] eq $line_num_global} { |
|
set scan_target_label_same_line_seen true |
|
} |
|
} |
|
} |
|
incr found_forward_label |
|
if {!$scan_target_label_same_line_seen} { |
|
set label_posn_in_line [string first : $scanline] |
|
set labelposn [expr {$scanline_start + $label_posn_in_line}] |
|
#we only really care about exactly landing on a boundary or else the next 512 byte boundaries above the labelposn |
|
if {($labelposn % 512) == 0} { |
|
set ubound [expr {($labelposn / 512) * 512}] |
|
} else { |
|
set ubound [expr {(($labelposn / 512)+1) * 512}] |
|
} |
|
set lbound [expr {$ubound - $labelsize}] |
|
if {($labelposn >= $lbound) && ($labelposn <= $ubound)} { |
|
dict set scan_target_label_record error linestart_and_call_offset_bytes |
|
lappend error_labels [list label $label linestart_and_call_offset_bytes $labelposn callsite [list call ${call}${labelplus} call_linenum $callingline_num] bad_target_line $line_num_global] |
|
puts stdout "[a+ bold red]ERROR: file line: $line_num_global target-label $trimscanline at line-beginning and with byte offset from callsite: $labelposn offset in file: $line_start_global[a]" |
|
puts stdout "[a+ bold red] This target-label appears to span the 512byte boundary at byte $ubound[a] [a+ yellow bold]from callsite.[a]" |
|
puts [$objForwardScan chunk_boundary_display [dict get $scanlineinfo start] [dict get $scanlineinfo end] 512 -linebase $callposn_lineindex+1 -limit 1] ;#+1 on callposn_linindex to do editor-style linenums |
|
} else { |
|
dict set scan_target_label_record ok 1 |
|
puts stdout "[a+ bold green]OK: file line: $line_num_global target-label $trimscanline at line-beginning and with byte offset from callsite: $labelposn offset in file: $line_start_global[a]" |
|
} |
|
dict lappend target_labels_found $label $scan_target_label_record |
|
} else { |
|
puts stdout "OK - seen label $label on $line_num_global before" |
|
} |
|
} |
|
incr total_offset $scanline_bytes |
|
} |
|
################################################################################################################################## |
|
|
|
|
|
#todo |
|
#forward scan 2 - check any boundaries missed above because the label isn't at the begining of a line |
|
#these are potentially hidden labels that could activate without requiring the label be at the beginning of a line |
|
#check boundary spans relative to start of this objForwardScan chunk |
|
|
|
#adjust boundary-search by resetting counter each time crlf encountered |
|
set forward_lines [$objForwardScan chunkrange_to_lineinfolist 0 end] |
|
set boundary_positions [list 0] |
|
set scanner_offset 0 |
|
set scanner_position 0 |
|
foreach forwardbline_info $forward_lines { |
|
#review - do we need to check the payload in case we have configured the textinfo object to split the file only on lf - (not true by default) |
|
set forwardbline_len [dict get $forwardbline_info linelen] |
|
set forwardbline_spaninfo [fileline::range_spans_chunk_boundaries [expr {$scanner_position + $scanner_offset}] [expr {$scanner_position + $scanner_offset + $forwardbline_len}] 512] |
|
set forwardbline_boundaries [dict get $forwardbline_spaninfo boundaries] |
|
|
|
foreach b $forwardbline_boundaries { |
|
set relb [expr $b + $scanner_offset] |
|
if {$relb <= [dict get $forwardbline_info end]} { |
|
lappend boundary_positions $relb |
|
} else { |
|
#leave it for the next line - as we may need to adjust offset anyway |
|
break |
|
} |
|
} |
|
if {[dict get $forwardbline_info le] eq "crlf"} { |
|
set scanner_offset [expr {[dict get $forwardbline_info end] - [lindex $boundary_positions end]}] ;#reset on crlf |
|
#puts "+++++ set scanner_offset $scanner_offset" |
|
} |
|
set scanner_position [dict get $forwardbline_info end] |
|
} |
|
set boundary_positions [lsearch -all -not -inline $boundary_positions 0] |
|
if {[llength $boundary_positions]} { |
|
puts stdout "[a+ blue bold]----> [llength $forward_lines] forward lines, boundaries (possibly with offsets) to check $boundary_positions[a]" |
|
} else { |
|
puts stdout "[a+ blue bold]----> [llength $forward_lines] forward lines, No boundaries to check (generally expected for files with crlf line endings and no extremely long lines)[a]" |
|
} |
|
|
|
|
|
if {[llength $boundary_positions]} { |
|
puts stdout "line $callingline_num scan from call label $label ending at position $callposn. Next Callsite-relative boundary [lindex $boundary_positions 0]" |
|
|
|
for {set i 0} {$i < [llength $boundary_positions]} {incr i} { |
|
set b [lindex $boundary_positions $i] |
|
if {$i < [llength $boundary_positions]-1} { |
|
set nextb [lindex $boundary_positions $i+1] |
|
set top $nextb |
|
} else { |
|
set top end |
|
} |
|
|
|
set forwardbline_infolist [$objForwardScan chunkrange_to_lineinfolist $b $top -show_truncated 1] |
|
set forwardbline_info [lindex $forwardbline_infolist 0] |
|
if {[dict get $forwardbline_info is_truncated]} { |
|
set payload_from_boundary [dict get $forwardbline_info truncated] |
|
} else { |
|
set payload_from_boundary [dict get $forwardbline_info payload] |
|
} |
|
set forwardbline_len [dict get $forwardbline_info linelen] |
|
set forwardbline_index [dict get $forwardbline_info lineindex] |
|
set forwardbline_start [dict get $forwardbline_info start] |
|
set forwardbline_start_global [expr {$forward_chunk_base + $forwardbline_start}] |
|
set forwardbline_index_global [lindex [$objFile chunkrange_to_linerange $forwardbline_start_global $forwardbline_start_global] 0] |
|
set forwardbline_num_global [expr {$forwardbline_index_global + 1}] |
|
|
|
set found_targetlabel_at_boundary 0 |
|
if {[string first : $payload_from_boundary] >= 0} { |
|
#puts stdout "Possible label at boundary $b - testing" |
|
set labelinfo [batchlib::get_target_label_from_line $payload_from_boundary] |
|
if {[dict get $labelinfo labelfound] && [dict get $labelinfo label] eq $label} { |
|
incr found_forward_label |
|
set found_targetlabel_at_boundary 1 |
|
} elseif {[dict get $labelinfo labelfound]} { |
|
set unsearched_label [dict get $labelinfo label] |
|
puts stderr "[a+ cyan]Line $forwardbline_num_global: Found an item that cmd may interpret as a target label because of its location at a boundary $b - but it doesn't seem to be the one we are looking for. Looking for '$label' Found: '[dict get $labelinfo label]'[a]" |
|
puts stderr "[a+ yellow]Warning - if the label '$unsearched_label' on line $forwardbline_num_global isn't meant to be a target - it may be safest to make sure batch script isn't using CALL or GOTO with target :$unsearched_label" |
|
puts stdout "linedata:\n" |
|
#puts stdout "'$payload_from_boundary'" |
|
puts [$objForwardScan chunk_boundary_display [dict get $forwardbline_info start] [dict get $forwardbline_info end] 0 -boundaries $b -linebase $callposn_lineindex+1 -limit 1] |
|
|
|
#dubious value to check call_labels_found - as we didn't run through and find all call labels first! |
|
if {$unsearched_label in [dict keys $call_labels_found]} { |
|
set boundary_target_label_record [list label $unsearched_label line $forwardbline_num_global error found_via_boundary_check_on_a_different_call_label] |
|
dict lappend warning_target_labels_found $unsearched_label $boundary_target_label_record |
|
} else { |
|
set possible_target_label_record [list label $unsearched_label line $forwardbline_num_global] |
|
dict lappend possible_target_labels_found $unsearched_label $possible_target_label_record |
|
} |
|
} else { |
|
set note "" |
|
if {[dict exists $labelinfo note]} { |
|
set note [dict get $labelinfo note] |
|
} |
|
if {$note ne "prefix_fail"} { |
|
puts stdout "no label detected at boundary $b - probably ok. Note from target-label scanner: $note" |
|
} |
|
} |
|
if {$found_targetlabel_at_boundary} { |
|
set target_label_record [list label $label line $forwardbline_num_global error call_offset_bytes] |
|
dict lappend target_labels_found $label $target_label_record |
|
set note "possibly unreliable or dangerous target-label at line $forwardbline_num_global may execute line [expr {$forwardbline_num_global +1}].\n" |
|
append note "Target label not at line start but was found by scanning 512byte chunks from callsite with count resets at any crlf encountered\n" |
|
append note "Adjust spacing between line $callingline_num and $forwardbline_num_global to avoid the 512 boundary - and re-test for other boundary problems" |
|
lappend error_labels [list label $label call_offset_bytes $b callsite [list call ${call}${labelplus} call_linenum $callingline_num] note $note] |
|
puts stdout "[a+ bold red]ERROR: line $forwardbline_num_global target-label [dict get $labelinfo rawlabel] found at boundary and with byte offset from callsite: $b [a]" |
|
puts stdout "[a+ bold red] This target-label appears to fall at or just after the 512byte boundary at byte $b[a] [a+ yellow bold]from callsite.[a]" |
|
puts stdout "[a+ bold yellow]Code may execute at line [expr {$forwardbline_num_global + 1}] (or at next 512Byte boundary in some circumstances)[a]" |
|
puts stdout "[a+ bold yellow]Recommend adjusting spacing between line $callingline_num and $forwardbline_num_global[a]" |
|
puts stdout [$objForwardScan chunk_boundary_display [dict get $forwardbline_info start] [dict get $forwardbline_info end] 0 -boundaries $b -linebase $callposn_lineindex+1 -limit 1] |
|
} |
|
#if found any label - peek at next boundary |
|
if {[dict get $labelinfo labelfound] && $i+1 < [llength $boundary_positions]} { |
|
set next_lineinfolist [$objForwardScan chunkrange_to_lineinfolist $nextb end -show_truncated 1] |
|
set next_lineinfo [lindex $next_lineinfolist 0] |
|
puts "peek next boundary data - line [expr {$forwardbline_num_global + 1}]:" |
|
#if {[dict get $next_lineinfo is_truncated]} { |
|
# puts [dict get $next_lineinfo truncated] |
|
#} else { |
|
# puts [dict get $next_lineinfo payload] |
|
#} |
|
puts [$objForwardScan chunk_boundary_display [dict get $next_lineinfo start] [dict get $next_lineinfo end] 0 -boundaries $nextb -linebase $callposn_lineindex+1 -limit 1] |
|
} |
|
} |
|
} |
|
} |
|
$objForwardScan destroy |
|
|
|
#scan behind for labels at boundaries - using offset from start of file |
|
#we do a backward scan even if a forward label has been found, so that we can warn of duplicate labels. |
|
|
|
set prior_start 0 |
|
set prior_end $callingline_index ;#only scan from file start to call-site |
|
|
|
set pline_begin 0 |
|
set found_backward_label 0 |
|
set p_linenum 0 |
|
for {set pidx $prior_start} {$pidx <= $prior_end} {incr pidx} { |
|
set plineinfo [$objFile lineinfo $pidx] |
|
set pline [dict get $plineinfo payload] |
|
incr p_linenum |
|
set pline_bytes [dict get $plineinfo linelen] ;#includes lf or crlf ending bytes |
|
set pline_start $pline_begin |
|
if {$pline_start != [dict get $plineinfo start]} { |
|
error "checkfile error: line $p_linenum - calculated start $pline_start not equal to stored start [dict get $plineinfo start]" |
|
} |
|
set pline_end [expr {$pline_begin + $pline_bytes -1}] |
|
if {$pline_end != [dict get $plineinfo end]} { |
|
error "checkfile error: line $p_linenum - calculated end $pline_end not equal to stored end [dict get $plineinfo end]" |
|
} |
|
|
|
|
|
set trimpline [string trim $pline] |
|
#todo - process leading part of line before : |
|
#e.g the following are valid (leading # is not part of the examples) |
|
# ====== : label |
|
# also |
|
#%=== == : label |
|
# also |
|
#%= ,,,, ;;; = : label |
|
|
|
#these token delimiters (; , = 0x0B ox0C 0xFF <space> <tab>) |
|
#can also occur after the colon e.g |
|
#: ;label |
|
|
|
#the following is a valid target for @GOTO :#something |
|
#: ;#something |
|
|
|
#It is possible for closing bracket ) to also be invisible if there is no open ( active |
|
#This only seems to work for a single ) at beggining of the line multiple ) even separated by spaces or ; etc seem to stop the target being found. |
|
#The lone unbalanced ) can act like a comment in other contexts - and can appear multiple times, but only if first ) on the line is followed by a delimiter |
|
#Essentially all characters following the first ) are ignored - but if the first is something like )) then cmd tries to interpret that as a command and fails |
|
# e.g |
|
#) ignored |
|
#);)))) ignored |
|
#)) causes error as cmd tries to run "))" as a command. |
|
#This is a reason why *target* labels shouldn't appear in bracketed blocks - as code jumps to a point where ( ) will be unbalanced |
|
|
|
#target labels are literal with regards to % ie not subject to % expansion - but ^ must still be processed |
|
if {[string first : $pline] >= 0} { |
|
#space (and some other chars) allowed between colon and label at target - (but not at callsite) |
|
set labelinfo [batchlib::get_target_label_from_line $pline] |
|
if {[dict get $labelinfo labelfound] && [dict get $labelinfo label] eq $label} { |
|
set target_label_record [list label $label line $p_linenum] |
|
puts stdout "$labelinfo" |
|
incr found_backward_label |
|
set prior_label_posn_in_line [string first : $pline] |
|
set prior_label_posn [expr {$pline_begin + $prior_label_posn_in_line}] |
|
if {($prior_label_posn % 512) == 0} { |
|
set p_ubound [expr {($prior_label_posn / 512) * 512}] |
|
} else { |
|
set p_ubound [expr {(($prior_label_posn /512) +1) * 512}] |
|
} |
|
set p_lbound [expr {$p_ubound - $labelsize}] |
|
if {($prior_label_posn >= $p_lbound) && ($prior_label_posn <= $p_ubound)} { |
|
dict set target_label_record error linestart_and_overlap |
|
lappend error_labels [list label $label linestart_and_overlap $prior_label_posn callsite [list call ${call}${labelplus} call_linenum $callingline_num]] |
|
puts stdout "[a+ bold red]ERROR: target-label '$trimpline' at line $p_linenum and offset from file start: $prior_label_posn line start: $pline_begin[a]" |
|
puts stdout "[a+ bold red] This target-label appears to span the 512byte boundary at byte $p_ubound[a] [a+ yellow bold]from file start[a]" |
|
puts [$objFile chunk_boundary_display [dict get $plineinfo start] [dict get $plineinfo end] 512 -linebase 1 -limit 1] |
|
} else { |
|
dict set target_label_record ok 1 |
|
puts stdout "[a+ bold green]OK: file line: $p_linenum target-label '$trimpline' before call from line $callingline_num. Target is at offset from file start: $prior_label_posn line start: $pline_begin[a]" |
|
} |
|
dict lappend call_labels_found $label $target_label_record |
|
} |
|
#else - label we weren't searching for - even if at file boundary it should be picked up when actually searched? review |
|
} |
|
set spaninfo [fileline::range_spans_chunk_boundaries $pline_start $pline_end 512] |
|
if {[dict get $spaninfo is_span]} { |
|
#puts stdout "boundary spanning line $p_linenum byte range $pline_start -> $pline_end [a+ bold purple]$spaninfo[a]" |
|
#check boundaries within the line |
|
set boundaries [dict get $spaninfo boundaries] |
|
foreach b $boundaries { |
|
if {$b == 0} { |
|
#skip - beginning of line already handled (review?) |
|
continue |
|
} |
|
#overlap test is just a warning - we have a label-like thing overlapping the boundary |
|
#todo - take account of fact that target label can be ": <whitespace or label-ignorable chars> labelname" - so using just labelsize won't detect all overlaps |
|
#The label could even be at the end of a long line that appears at first to be a comment e.g something like |
|
# : whatever : sneakylabel |
|
# or |
|
#@REM ============================================================================================================================================================ : sneakylabel |
|
|
|
#The fact that it overlaps - means it's probably not being found with lf line-endings - and only the label :whatever should be found with crlf endings |
|
#- but we won't always catch that something's fishy |
|
#review |
|
set overlaptail [string range $pline [expr {$b - $labelsize}] [expr {($b + $labelsize) -1}]] ;#subtracting labelsize gives earliest possible overlap |
|
if {[string match "*:$label *" $overlaptail] } { |
|
lappend warning_labels [list label $label warning label_spanning callsite [list call ${call}${labelplus} call_linenum $callingline_num]] |
|
puts stdout "[a+ bold yellow] WARNING: possible label $label spans boundary $b from start of file" |
|
} |
|
|
|
set pline_tail [string range $pline $b end] |
|
|
|
if {[string first : $pline_tail] >= 0} { |
|
set labelinfo [batchlib::get_target_label_from_line $pline_tail] |
|
set labelfound 0 |
|
if {[dict get $labelinfo labelfound] && [dict get $labelinfo label] eq $label} { |
|
set labelfound 1 |
|
} elseif {[dict get $labelinfo labelfound]} { |
|
puts stdout "Note: detected target label [dict get $labelinfo label] at file offset $b at boundary with no preceeding newline - but it's not the one we're currently scanning for" |
|
} |
|
if {$labelfound} { |
|
set label_found_name [dict get $labelinfo label] |
|
incr found_backward_label |
|
|
|
lappend error_labels [list label $label_found_name file_offset_bytes $b note "label at boundary but no preceeding newline - cmd may interpret as label and execute following line or code at next boundary" callsite [list call ${call}${labelplus} call_linenum $callingline_num]] |
|
|
|
puts stdout "[a+ bold red]ERROR: *possible* label '$label_found_name' at line $p_linenum and offset from file start: $b line start: $pline_begin[a]" |
|
puts stdout "[a+ bold red] This label with no preceeding newline appears to span the 512byte boundary at byte $b[a] [a+ yellow bold]from file start[a]" |
|
puts stdout "[a+ bold red] cmd.exe may find this label - but it probably shouldn't be relied upon[a]" |
|
puts stdout "[a+ bold yellow] label starting at $b : $pline_tail[a]" |
|
|
|
set target_label_record [list label $label_found_name line $p_linenum] |
|
if {$label_found_name in [dict keys $call_labels_found]} { |
|
dict set target_label_record error "called_label_at_file_offset_boundary" |
|
dict lappend target_labels_found $label_found_name $target_label_record |
|
} else { |
|
#review - we need to get better at finding all calls! |
|
dict set target_label_record error "uncalled_label_at_file_offset_boundary" |
|
dict lappend possible_target_labels_found $label_found_name $target_label_record |
|
} |
|
|
|
|
|
set tail_start $b |
|
set tail_end [expr {$b + [string length $pline_tail]}] |
|
set tail_spaninfo [fileline::range_spans_chunk_boundaries $tail_start $tail_end 512] |
|
if {[dict get $tail_spaninfo is_span]} { |
|
set tail_boundaries [dict get $tail_spaninfo boundaries] |
|
set extra_tail_boundaries [lsearch -all -inline -not $tail_boundaries $b] |
|
if {[llength $extra_tail_boundaries]} { |
|
puts "Line $p_linenum also spans additional boundaries: $extra_tail_boundaries" |
|
set next_boundary [lindex $extra_tail_boundaries 0] |
|
#boundary doesn't reset if no crlf - we are still within the line - so can calc from line beginning |
|
set next_boundary_data [string range $pline [expr {$pline_begin + $next_boundary}] end] |
|
puts "Line $p_linenum data at next boundary: [a+ yellow bold]$next_boundary_data[a]" |
|
puts [$objFile chunk_boundary_display [dict get $plineinfo start] [dict get $plineinfo end] 0 -boundaries $next_boundary -linebase 1 -limit 1] |
|
|
|
puts "[a+ yellow bold]NOTE: cmd may attempt to treat this data as code[a]" |
|
} |
|
} else { |
|
if {$pidx+1 < [$objFile linecount]} { |
|
set nextlineinfo [$objFile lineinfo $pidx+1] |
|
set nextpayload [dict get $nextlineinfo payload] |
|
puts "Line $p_linenum + 1 has data: [a+ yellow bold]$nextpayload[a]" |
|
puts "[a+ yellow bold]NOTE: cmd may attempt to treat this data as code[a]" |
|
} else { |
|
#EOF reached |
|
} |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
} |
|
incr pline_begin $pline_bytes |
|
} |
|
|
|
if {$found_forward_label == 0} { |
|
if {[string toupper $label] eq "EOF"} { |
|
#EOF/eof label is special - it doesn't have to exist - but if it does - it probably shouldn't be spanning a boundary |
|
puts stdout "[a+ bold green]OK: label :$label doesn't exist - but it's usually not meant to. callsite: [list call ${call}${labelplus} call_linenum $callingline_num] [a]" |
|
} else { |
|
if {$found_backward_label == 0} { |
|
lappend warning_labels [list label $label warning label_not_found callsite [list call ${call}${labelplus} call_linenum $callingline_num]] |
|
puts stdout "[a+ bold yellow]WARNING: label :$label not found (in forward or backward scan)[a]" |
|
} |
|
} |
|
} |
|
if {($found_forward_label + $found_backward_label) > 1} { |
|
#puts "target_labels_found: $target_labels_found" |
|
dict for {targetkey targethits} $target_labels_found { |
|
set targetlines [list] |
|
foreach record $targethits { |
|
lappend targetlines [dict get $record line] |
|
} |
|
set remaining [list] |
|
set previous "" ; |
|
foreach lnum [lsort -integer -increasing $targetlines] { |
|
if {$previous eq ""} { |
|
lappend remaining $lnum |
|
} else { |
|
if {$lnum-1 == $previous} { |
|
puts stdout "[a+ green bold]OK[a] - target-label $targetkey appears on immediately adjacent lines $previous and $lnum - assuming it is a boundary-avoidance tactic rather than an inadvertent duplicate" |
|
set remaining [lrange $remaining 0 end-1];#retain latest - we will allow a run of targets on subsequent lines |
|
} |
|
lappend remaining $lnum |
|
} |
|
set previous [lindex $remaining end] |
|
} |
|
if {[llength $remaining] > 1} { |
|
lappend warning_labels [list label $label warning multiple_target_labels_found callsite [list call ${call}${labelplus} call_linenum $callingline_num]] |
|
puts stdout "[a+ bold yellow]WARNING: label :$label seems to appear multiple times[a]" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} ;# end switch |
|
incr file_offset $callingline_len ;#including per-line stored line-ending |
|
} |
|
if {[dict size $possible_target_labels_found] > 0} { |
|
#puts stdout "Possibly bogus target-labels: [dict keys $possible_target_labels_found]" |
|
set bogus_summary [list] |
|
dict for {pb pbrecords} $possible_target_labels_found { |
|
if {$pb in [dict keys $call_labels_found]} { |
|
puts stdout "[a+ yellow bold]Warning - target for label $pb was found with a record as being possibly bogus. record: $pbrecords [a]" |
|
puts stdout "[a+ yellow bold]Consider moving this target-label and re-checking[a]" |
|
puts stdout "[a+ yellow bold]It may be a call label line that was found by boundary scanning - which shouldn't really happen[a]" |
|
puts stdout "Call record [dict get $call_labels_found $pb]" |
|
lappend warning_labels [list label $pb warning possibly_bogus_target list_of_target_hits $pbrecords] |
|
} |
|
set blines [list] |
|
foreach rec $pbrecords { |
|
lappend blines [dict get $rec line] |
|
} |
|
lappend bogus_summary [list label $pb found_on_lines $blines] |
|
} |
|
puts stdout "[a+ cyan]Possibly bogus target-labels: $bogus_summary[a]" |
|
puts stdout "These are usually nothing to be concerned about. Some will almost always turn up in a polyglot script that contains batch script." |
|
puts stdout "If some of the label names appear to contain newlines, or are prefixes of or exact matches with legitimate labels - you might consider adjusting the boundary spacing with whitespace or comments to get a different result." |
|
} |
|
set result "" |
|
if {[llength $warning_labels]} { |
|
append result "WARNING:" \n |
|
append result "The following labels had warnings" \n |
|
foreach w $warning_labels { |
|
append result " [a+ bold yellow]$w[a]" \n |
|
} |
|
} |
|
if {[llength $error_labels]} { |
|
append result "ERROR: label location errors found" \n |
|
append result "The following labels appear to span 512 Byte boundaries or occur on boundaries without a preceding newline and are likely to cause batch script errors" \n |
|
append result "For labels spanning boundaries the label is likely to be missed by the batch interpreter" \n |
|
append result "For labels occuring at boundaries but not at the beginning of a line, the label may be interpreted as a label when not expected, and the interpreter may run code on next line or next boundary" \n |
|
append result "Try adding comments and/or spacing between the call site at the call_lineum indicated and the label and then re-test in case there are further boundary collisions" \n |
|
foreach err $error_labels { |
|
append result " [a+ bold red]$err[a]" \n |
|
} |
|
} |
|
if {[dict size $warning_target_labels_found] > 0} { |
|
puts stdout "target-labels with minor warnings: [dict keys $warning_target_labels_found]" |
|
} |
|
append result "call-labels-found: [dict keys $call_labels_found]" \n |
|
append result "target-labels-found: [dict keys $target_labels_found]" \n |
|
if {![llength $warning_labels] && ![llength $error_labels]} { |
|
puts stderr \n |
|
puts stderr "[a+ green bold]OK No warnings or errors considered major enough to return in result.[a]" |
|
} |
|
return $result |
|
} |
|
#specific filepath to just wrap one script at the xxx-pre-launch-suprocess site |
|
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf |
|
proc multishell {filepath_or_scriptset args} { |
|
set opts [dict create\ |
|
-askme 1\ |
|
-outputfolder "\uFFFF"\ |
|
-template "\uFFFF"\ |
|
-returnextra 0\ |
|
-force 0\ |
|
] |
|
#set known_opts [dict keys $defaults] |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-askme - -outputfolder - -template - -returnextra - -force { |
|
dict set opts $k $v |
|
} |
|
default { |
|
error "punk::mix::commandset::multishell error. Unrecognized option '$k'. Known-options: [dict keys $opts]" |
|
} |
|
} |
|
} |
|
|
|
set usage "" |
|
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n |
|
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n |
|
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n |
|
if {![string length $filepath_or_scriptset]} { |
|
puts stderr "No filepath_or_scriptset specified" |
|
puts stderr $usage |
|
return false |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
set opt_askme [dict get $opts -askme] |
|
set opt_template [dict get $opts -template] |
|
set opt_outputfolder [dict get $opts -outputfolder] |
|
set opt_returnextra [dict get $opts -returnextra] |
|
set opt_force [dict get $opts -force] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
|
|
set ext [file extension $filepath_or_scriptset] |
|
set startdir [pwd] |
|
|
|
|
|
|
|
#first check if relative or absolute path matches a file |
|
if {[file pathtype $filepath_or_scriptset] eq "absolute"} { |
|
set specified_path $filepath_or_scriptset |
|
} else { |
|
set specified_path [file join $startdir $filepath_or_scriptset] |
|
} |
|
set ext [string trim [file extension $filepath_or_scriptset] .] |
|
set allowed_extensions [list wrapconfig tcl ps1 sh bash pl] |
|
set extension_langs [list tcl tcl ps1 powershell sh sh bash bash pl perl] |
|
#set allowed_extensions [list tcl] |
|
set found_script 0 |
|
if {[file exists $specified_path]} { |
|
set found_script 1 |
|
} else { |
|
foreach e [concat $allowed_extensions [string toupper $allowed_extensions]] { |
|
if {[file exists $filepath_or_scriptset.$e]} { |
|
set found_script 1 |
|
break |
|
} |
|
} |
|
} |
|
|
|
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function |
|
set scriptset [file rootname [file tail $specified_path]] |
|
if {$found_script} { |
|
if {[file type $specified_path] eq "file"} { |
|
set specified_root [file dirname $specified_path] |
|
set pathinfo [punk::repo::find_repos [file dirname $specified_path]] |
|
set projectroot [dict get $pathinfo closest] |
|
if {[string length $projectroot]} { |
|
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder |
|
set scriptroot [file dirname $specified_path] |
|
if {[file exists $scriptroot/wrappers]} { |
|
set customwrapper_folder $scriptroot/wrappers |
|
} else { |
|
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
|
} |
|
} else { |
|
#outside of any project |
|
set scriptroot [file dirname $specified_path] |
|
if {[file exists $scriptroot/wrappers]} { |
|
set customwrapper_folder $scriptroot/wrappers |
|
} else { |
|
#no customwrapper folder available |
|
set customwrapper_folder "" |
|
} |
|
} |
|
} else { |
|
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
|
puts stderr $usage |
|
return false |
|
} |
|
} else { |
|
set pathinfo [punk::repo::find_repos $startdir] |
|
set projectroot [dict get $pathinfo closest] |
|
if {[string length $projectroot]} { |
|
if {[llength [file split $filepath_or_scriptset]] > 1} { |
|
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" |
|
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" |
|
puts stderr $usage |
|
return false |
|
} else { |
|
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension |
|
set scriptroot $projectroot/src/scriptapps |
|
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
|
#check something matches the scriptset.. |
|
set something_found "" |
|
if {[file exists $scriptroot/$scriptset]} { |
|
set found_script 1 |
|
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too |
|
} else { |
|
foreach e $allowed_extensions { |
|
if {[file exists $scriptroot/$scriptset.$e]} { |
|
set found_script 1 |
|
set something_found $scriptroot/$scriptset.$e |
|
break |
|
} |
|
} |
|
} |
|
if {!$found_script} { |
|
puts stderr "Searched within $scriptroot" |
|
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" |
|
puts stderr $usage |
|
return false |
|
} else { |
|
if {[file type $something_found] ne "file"} { |
|
puts stderr "Found '$something_found'" |
|
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
|
puts stderr $usage |
|
return false |
|
} |
|
} |
|
} |
|
|
|
} else { |
|
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" |
|
puts stderr $usage |
|
return false |
|
} |
|
} |
|
#assertion - customwrapper_folder var exists - but might be empty |
|
|
|
|
|
if {[string length $ext]} { |
|
#If there was an explicitly supplied extension - then that file should exist |
|
if {![file exists $scriptroot/$scriptset.$ext]} { |
|
puts stderr "Explicit extension .$ext was supplied - but matching file not found." |
|
puts stderr $usage |
|
return false |
|
} else { |
|
if {$ext eq "wrapconfig"} { |
|
set process_extensions ALLFOUNDORCONFIGURED |
|
} else { |
|
set process_extensions $ext |
|
} |
|
} |
|
} else { |
|
#no explicit extension - process all for scriptset |
|
set process_extensions ALLFOUNDORCONFIGURED |
|
} |
|
#process_extensions - either a single one - or all found or as per .wrapconfig |
|
|
|
if {$opt_template eq "\uFFFF"} { |
|
set templatename punk.multishell.cmd |
|
} else { |
|
set templatename $opt_template |
|
} |
|
set templatename_root [file rootname [file tail $templatename]] |
|
|
|
#determine name of file on disk based on whether templatename is prefixed with vendor. |
|
set templatename_vendor "" |
|
set templatename_fileroot $templatename_root |
|
if {[llength [split $templatename_root .]] > 1} { |
|
set tparts [split $templatename_root .] |
|
set templatename_vendor [lindex $tparts 0] |
|
set templatename_fileroot [join [lrange $tparts 1 end] .] |
|
} |
|
|
|
#assertion: templatename_fileroot is the base of the filname without the vendor and first dot |
|
|
|
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
|
set tpldirs [list] |
|
dict for {tdir tsourceinfo} $template_base_dict { |
|
set vendor [dict get $tsourceinfo vendor] |
|
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { |
|
lappend tpldirs $tdir |
|
} elseif {[file exists $tdir/utility/scriptappwrappers/${templatename_fileroot}[file extension $templatename]]} { |
|
lappend tpldirs $tdir |
|
} |
|
} |
|
|
|
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
|
set wrapper_template [file join $customwrapper_folder $templatename] |
|
} else { |
|
if {![llength $tpldirs]} { |
|
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" |
|
append msg \n "Searched [dict size $template_base_dict] template dirs" |
|
error $msg |
|
} |
|
|
|
#last pkg with templates cap which was loaded has highest precedence |
|
set wrapper_template "" |
|
foreach tdir [lreverse $tpldirs] { |
|
set ftest1 [file join $tdir utility scriptappwrappers $templatename] |
|
set ftest2 [file join $tdir utility scriptappwrappers $templatename_fileroot[file extension $templatename]] |
|
if {[file exists $ftest1]} { |
|
set wrapper_template $ftest1 |
|
break |
|
} elseif {[file exists $ftest2]} { |
|
set wrapper_template $ftest2 |
|
break |
|
} |
|
} |
|
} |
|
|
|
if {$wrapper_template eq "" || ![file exists $wrapper_template]} { |
|
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" |
|
} |
|
|
|
|
|
if {$opt_outputfolder eq "\uFFFF"} { |
|
#outputfolder not explicitly specified by caller |
|
if {[string length $projectroot]} { |
|
set output_folder [file join $projectroot/bin] |
|
} else { |
|
set output_folder $startdir |
|
} |
|
} else { |
|
if {[file pathtype $opt_outputfolder] eq "relative"} { |
|
if {[string length $projectroot]} { |
|
set output_folder [file join $projectroot $opt_outputfolder] |
|
} else { |
|
set output_folder [file join $startdir $opt_outputfolder] |
|
} |
|
} else { |
|
set output_folder $opt_outputfolder |
|
} |
|
} |
|
if {![file isdirectory $output_folder]} { |
|
error "wrap_in_multishell: output folder '$output_folder' not found. Please ensure target directory exists" |
|
} |
|
|
|
|
|
#todo |
|
#output_file extension may also depend on the template being used.. and/or the .wrapconfig |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set output_extension cmd |
|
} else { |
|
set output_extension sh |
|
} |
|
set output_file [file join $output_folder $scriptset.$output_extension] |
|
if {[file exists $output_file]} { |
|
set fdexisting [open $output_file r] |
|
fconfigure $fdexisting -translation binary |
|
set existing_file_data [read $fdexisting] |
|
close $fdexisting |
|
set objFile_existing [fileline::textinfo new $existing_file_data] |
|
puts stdout "wrap_in_multishell: target file $output_file already exists. File size: [$objFile_existing chunklen] Line count: [$objFile_existing linecount]" |
|
if {!$opt_force} { |
|
if {$opt_askme} { |
|
set answer [util::askuser "Do you want to overwrite $output_file? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "aborting due to user response '$answer' (required Y or y to proceed) use -force 1 or -askme 0 to avoid prompts." |
|
$objFile_existing destroy |
|
error "aborting.." |
|
} |
|
} else { |
|
$objFile_existing destroy |
|
error "aborting.." |
|
} |
|
} else { |
|
puts stdout "overwriting $output_file because -force = $opt_force" |
|
} |
|
} |
|
|
|
|
|
set fdt [open $wrapper_template r] |
|
fconfigure $fdt -translation binary |
|
set template_data [read $fdt] |
|
close $fdt |
|
puts stdout "Read [string length $template_data] bytes of template data.." |
|
set template_lines [split $template_data \n] |
|
puts stdout "Displaying first 3 lines of template between dashed lines..." |
|
puts stdout "-----------------------------------------------" |
|
foreach ln [lrange $template_lines 0 3] { |
|
puts stdout $ln |
|
} |
|
puts stdout "-----------------------------------------------\n" |
|
#foreach ln $template_lines { |
|
#} |
|
|
|
set list_input_files [list] |
|
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { |
|
#todo - look for .wrapconfig or all extensions for the scriptset |
|
puts stderr "Sorry - only single input file supported. Supply a file extension or use a .wrapconfig with a single input file for now - implementation incomplete" |
|
return false |
|
} else { |
|
lappend list_input_files $scriptroot/$scriptset.$ext |
|
} |
|
|
|
#todo - split template at each <ext-*-subprocess> etc marker and build a dict of parts |
|
|
|
|
|
#hack - process one input |
|
set filepath [lindex $list_input_files 0] |
|
|
|
set fdscript [open $filepath r] |
|
fconfigure $fdscript -translation binary |
|
set script_data [read $fdscript] |
|
close $fdscript |
|
puts stdout "Read [string length $script_data] bytes of template data.." |
|
set script_lines [split $script_data \n] |
|
puts stdout "Displaying first 3 lines of your script between dashed lines..." |
|
puts stdout "-----------------------------------------------" |
|
foreach ln [lrange $script_lines 0 3] { |
|
puts stdout $ln |
|
} |
|
puts stdout "-----------------------------------------------\n" |
|
puts stdout "Target for above script data is '$output_file'" |
|
set lang [dict get $extension_langs [string tolower $ext]] |
|
puts stdout "Language of script being wrapped is $lang" |
|
if {$opt_askme} { |
|
set answer [util::askuser "Does this look correct? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." |
|
return |
|
} |
|
} |
|
|
|
set start_idx 0 |
|
set end_idx 0 |
|
set line_idx 0 |
|
set existing_payload [list] |
|
foreach ln $template_lines { |
|
|
|
if {[string match "#<$lang-pre-launch-subprocess>*" $ln]} { |
|
set start_idx $line_idx |
|
} elseif {[string match "#</$lang-pre-launch-subprocess>*" $ln]} { |
|
set end_idx $line_idx |
|
break |
|
} elseif {$start_idx > 0} { |
|
if {$end_idx > 0} { |
|
lappend existing_payload [string trim $ln] |
|
} |
|
} else { |
|
|
|
} |
|
incr line_idx |
|
} |
|
if {($start_idx == 0) || ($end_idx == 0)} { |
|
error "wrap_in_multishell was unable to find payload area in template marked with #<$lang-pre-launch-subprocess> and #</$lang-pre-launch-subprocess> on separate lines" |
|
} |
|
set existing_string [join $existing_payload \n] |
|
if {[string length [string trim $existing_string]]} { |
|
puts stdout "EXISTING <$lang-pre-launch-subprocess> PAYLOAD!!" |
|
puts stdout "-----------------------------------------------\n" |
|
puts stdout $existing_string |
|
puts stdout "-----------------------------------------------\n" |
|
error "wrap_in_multishell found existing payload for language $lang ... aborting." |
|
#todo - allow overwrite only in files outside of punkshell distribution? |
|
if 0 { |
|
puts stderr "Found existing $lang payload.. overwrite?" |
|
if {$opt_askme} { |
|
set answer [util::askuser "Are you sure you want to replace the $lang payload shown above? Y|N"] |
|
if {[string tolower $answer] ne "y"} { |
|
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
|
return |
|
} |
|
} |
|
} |
|
} |
|
|
|
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line |
|
set tpl_tail_lines [lrange $template_lines $end_idx end] |
|
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] |
|
puts stdout "New script is [string length $newscript] bytes" |
|
puts stdout $newscript |
|
set fdtarget [open $output_file w] |
|
fconfigure $fdtarget -translation binary |
|
puts -nonewline $fdtarget $newscript |
|
close $fdtarget |
|
puts stdout "Wrote script file at $output_file" |
|
set check_result [checkfile $output_file] |
|
set with_errors "" |
|
set with_warnings "" |
|
set call_labels [list] |
|
set target_labels [list] |
|
set errorlist [list] |
|
set warninglist [list] |
|
if {$check_result ne ""} { |
|
puts stdout $check_result |
|
set check_lines [split $check_result \n] |
|
foreach cl $check_lines { |
|
set trimcl [string trim $cl] |
|
if {[string match "ERROR:*" $trimcl]} { |
|
set with_errors "[a+ bold red]with errors[a]" |
|
lappend errorlist $trimcl |
|
} |
|
if {[string match "WARNING:*" $trimcl]} { |
|
set with_warnings "[a+ bold yellow] with warnings[a]" |
|
lappend errorlist $trimcl |
|
} |
|
if {[string match "call-labels-found:*" $trimcl]} { |
|
set call_labels [string trim [string range $trimcl [string length "call-labels-found:"] end]] |
|
} |
|
if {[string match "target-labels-found:*" $trimcl]} { |
|
set target_labels [string trim [string range $trimcl [string length "target-labels-found:"] end]] |
|
} |
|
} |
|
} else { |
|
puts stderr "Expected output from checkfile - but got none" |
|
} |
|
#even though chmod might exist on windows - we will leave permissions alone |
|
if {$::tcl_platform(platform) ne "windows"} { |
|
catch {exec chmod +x $output_file} |
|
} |
|
puts stdout "-done- $with_errors $with_warnings" |
|
if {$opt_returnextra} { |
|
set result [list filename $output_file batch_call_labels $call_labels batch_target_labels $target_labels] |
|
if {[llength $warninglist]} { |
|
dict set result warnings $warninglist |
|
} |
|
if {[llength $errorlist]} { |
|
dict set result errors $errorlist |
|
} |
|
} else { |
|
set result [list filename $output_file] |
|
} |
|
|
|
return $result |
|
} |
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap ---}] |
|
|
|
namespace eval lib { |
|
#*** !doctools |
|
#[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] |
|
#[para] Library API functions for punk::mix::commandset::scriptwrap |
|
#[list_begin definitions] |
|
|
|
|
|
proc get_wrapper_folders {args} { |
|
set argd [punk::args::get_dict { |
|
#*** !doctools |
|
#[call [fun get_wrapper_folders] [arg args] ] |
|
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo |
|
#[para] Arguments: |
|
# [list_begin arguments] |
|
# [arg_def string args] name-value pairs -scriptpath <path> |
|
# [list_end] |
|
@id -id ::punk::mix::commandset::scriptwrap |
|
@cmd -name punk::mix::commandset::get_wrapper_folders |
|
|
|
@opts -anyopts 0 |
|
-scriptpath -default "" -type directory\ |
|
-help "" |
|
#todo -help folder within a punk.templates provided area??? |
|
|
|
@values -minvalues 0 -maxvalues 0 |
|
} $args] |
|
|
|
# -- --- --- --- --- --- --- --- --- |
|
set opt_scriptpath [dict get $argd opts -scriptpath] |
|
# -- --- --- --- --- --- --- --- --- |
|
|
|
set wrapper_template_bases [list] |
|
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] |
|
dict for {tbase folderinfo} $tbasedict { |
|
set wrapf [file join $tbase utility/scriptappwrappers] |
|
if {[file isdirectory $wrapf]} { |
|
lappend wrapper_template_bases [list basefolder $wrapf sourceinfo $folderinfo] |
|
} |
|
} |
|
return $wrapper_template_bases |
|
} |
|
|
|
|
|
|
|
proc _scriptapp_tag_from_line {line} { |
|
set result [list istag 0 raw ""] ;#default assumption. All |
|
#---- |
|
set startc [string first "#" $line] ;#tags must be commented |
|
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname> |
|
# @REM # etc < blah # <tagname> etc |
|
#--- |
|
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace |
|
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. |
|
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. |
|
dict set result indent [string length $indent] |
|
set starttag [string first "<" $line] |
|
set pretag [string range $line $startc $starttag-1] |
|
if {[string match "*>*" $pretag]} { |
|
return [list istag 0 raw $line reason pretag_contents] |
|
} |
|
set closetag [string first ">" $line] |
|
set inelement [string range $line $starttag+1 $closetag-1] |
|
if {[string match "*<*" $inelement]} { |
|
return [list istag 0 raw $line reason tag_malformed_angles] |
|
} |
|
set elementchars [split $inelement ""] |
|
set numslashes [llength [lsearch -all $elementchars "/"]] |
|
if {$numslashes == 0} { |
|
dict set result type "open" |
|
} elseif {$numslashes == 1} { |
|
if {[lindex $elementchars 0] eq "/"} { |
|
dict set result type "close" |
|
} elseif {[lindex $elementchars end] eq "/"} { |
|
dict set result type "openclose" |
|
} else { |
|
return [list istag 0 raw $line reason tag_malformed_slashes] |
|
} |
|
} else { |
|
return [list istag 0 raw $line reason tag_malformed_extraslashes] |
|
} |
|
if {[dict get $result type] eq "open"} { |
|
dict set result name $inelement |
|
} elseif {[dict get $result type] eq "close"} { |
|
dict set result name [string range $inelement 1 end] |
|
} else { |
|
dict set result name [string range $inelement 0 end-1] |
|
} |
|
dict set result istag 1 |
|
dict set result raw $line |
|
return $result |
|
} |
|
|
|
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) |
|
#we don't verify 'something' against known tags - as custom templates can have own tags |
|
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line |
|
# |
|
#e.g for the line: |
|
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/> |
|
#The .wrapconfig might contain |
|
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
|
# |
|
proc scriptapp_wrapper_get_tags {wrapperdata} { |
|
set wrapperdata [string map [list \r\n \n] $wrapperdata] |
|
set lines [split $wrapperdata \n] |
|
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags |
|
set status 0 |
|
set tags [dict create] |
|
set errors [list] |
|
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem |
|
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. |
|
foreach ln $lines { |
|
set lntrim [string trim $ln] |
|
if {![string length $lntrim]} { |
|
incr linenum |
|
continue |
|
} |
|
if {[string match "*#*<*>*" $lntrim] || [string match "*:*<*>*" $lntrim]} { |
|
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent |
|
if {[dict get $taginfo istag]} { |
|
set nm [dict get $taginfo name] |
|
if {[dict exists $errortags $nm]} { |
|
#tag is already in error condition - |
|
} else { |
|
set tp [dict get $taginfo type] ;# type singular - related to just one line |
|
#set raw [dict get $taginfo raw] #equivalent to $ln |
|
if {[dict exists $tags $nm]} { |
|
#already seen tag name |
|
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) |
|
if {[dict get $tags $nm types] ne "open"} { |
|
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
|
dict incr errortags $nm |
|
} else { |
|
#we already have open - expect only close |
|
if {$tp ne "close"} { |
|
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
|
dict incr errortags $nm |
|
} else { |
|
#close after open |
|
dict set tags $nm types [list open close] |
|
dict set tags $nm end $linenum |
|
set taglines [dict get $tags $nm taglines] |
|
if {[llength $taglines] != 1} { |
|
error "Unexpected result when closing tag $nm. Existing taglines length not 1." |
|
} |
|
dict set tags $nm taglines [concat $taglines $ln] |
|
} |
|
} |
|
} else { |
|
#first seen of tag name |
|
switch -- $tp { |
|
close { |
|
lappend errors "line: $linenum tag $nm encountered type $p close first" |
|
dict incr errortags $nm |
|
} |
|
open { |
|
dict set tags $nm types open |
|
dict set tags $nm indent [dict get $taginfo indent] |
|
dict set tags $nm start $linenum |
|
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag |
|
} |
|
openclose { |
|
dict set tags $nm types openclose |
|
dict set tags $nm indent [dict get $taginfo indent] |
|
dict set tags $nm start $linenum |
|
dict set tags $nm end $linenum |
|
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag |
|
} |
|
} |
|
} |
|
} |
|
} else { |
|
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist |
|
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" |
|
} |
|
} |
|
#whether the line is tag or not append to any tags_in_data |
|
#foreach t [dict keys $tags_in_data] { |
|
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data |
|
#} |
|
incr linenum |
|
} |
|
#assert [expr {$linenum -1 == [llength $lines]}] |
|
if {[llength $errors]} { |
|
set status 0 |
|
} else { |
|
set status 1 |
|
} |
|
if {$linenum == 0} { |
|
|
|
} |
|
return [dict create ok $status linecount [llength $lines] data $tags errors $errors] |
|
} |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::lib ---}] |
|
} |
|
|
|
namespace eval batchlib { |
|
#*** !doctools |
|
#[subsection {Namespace punk::mix::commandset::scriptwrap::batchlib}] |
|
#[para] Utility funcions for processing windows .bat files |
|
#[list_begin definitions] |
|
|
|
#see also: https://www.dostips.com/forum/viewtopic.php?t=3803 'Rules for label names vs GOTO and CALL |
|
# review - we may need different get_callsite_label functions? |
|
|
|
proc get_callsite_label {labelstart} { |
|
#labelstart is the character immediately following the colon (which is optional at callsite) - a label such as ::label doesn't seem valid at call or target sites |
|
#e.g for @goto %= possible comment=% :mylabe%%l etc |
|
#we would expect to be passed only "mylabe%%1 etc" |
|
#It is up to the caller to determine where a callsite label begins. |
|
#note that: |
|
#@REM ----- |
|
#@goto ^ |
|
#:label |
|
#@REM----- |
|
# is a valid callsite - but doesn't appear to be found by the label scanner as it's own target label even though :label is on it's own line from non-batch perspective |
|
# so the caller will have to do some batch-style line processing to find all call sites |
|
#Also, for the following 2 lines |
|
#@REM ^ |
|
#:label |
|
# the label will be found - yet if the :label was a command such as @GOTO - it would not be run as a callsite |
|
|
|
|
|
#a quick'n'dirty fix for some ways various escapes are handled within labels at callsite. |
|
#There seem to be very different rules for labels at target site - presumably because they are not part of a command |
|
# Mostly it seems target labels are more literal with regards to % chars - but ^ are processed the same way at target label |
|
#some rules.. |
|
#callsite labels can't have space between : and label - but target labels can |
|
#label terminated by =,: even if prefixed by ^ and even if in squotes or dquotes |
|
#squotes and dquotes otherwise pass through as part of label |
|
#may resolve variables within the label - but characters from variable value can terminate. |
|
#as we don't have access to the variable values - we should normalize %varname% to empty string at callsite - but perhaps emit warning somewhere |
|
# The target labels don't seem to |
|
#a single % resolves to empty - depending. (starts invar processing - and decides if it was a var depending on whether it was closed?) |
|
#sequences of % don't begin a var - number of % in labelname = number of %s divided by 2 and rounded down. ie 1->0 2->1 3-> 1 4->2 5->2 6->3 etc |
|
#spaces in % wrapped var names don't terminate label |
|
#spaces aren't escaped by ^ or quoting |
|
#sequences of ^ seem to follow same counting rule as % |
|
#e.g @goto :la%path%bel where path begins with C:\Program Files.. becomes label :laC |
|
|
|
if {[string index $labelstart 0] in [list : " " \t = {;}]} { |
|
#return everything as tail - nothing was consumed |
|
return [list labelfound 0 note "invalid first character for callsite label" tail $labelstart] |
|
} |
|
|
|
#The due to whitespace and most chars except : and % being alowed inside vars - it seems the best first step |
|
# -------------- start % handling % |
|
set inputchars [split $labelstart ""] |
|
set percentrun 0 ;#0|1 because we use invar-toggling rather than running total of number of percents in a sequence |
|
set invar 0 |
|
set labelout "" |
|
set varsfound [list] |
|
set varterminals [list :] |
|
set labelterminals [list + , {;} = " " \t] |
|
set varname "" |
|
set caretseq 0 |
|
set inputconsumed 0 |
|
foreach c $inputchars { |
|
if {!$invar} { |
|
switch -- $c { |
|
"%" { |
|
set caretseq 0 |
|
set lookahead [lrange $inputchars $inputconsumed+1 end] |
|
if {"%" in $lookahead} { |
|
set invar 1 |
|
incr percentrun |
|
} else { |
|
incr percentrun |
|
} |
|
} |
|
"^" { |
|
if {$caretseq} { |
|
set caretseq 0 |
|
append labelout "^" ;#for every pair encountered in direct sequence - second gets included in label |
|
} else { |
|
set caretseq 1 |
|
} |
|
} |
|
default { |
|
set caretseq 0 |
|
if {$percentrun && ($c in [list 0 1 2 3 4 5 6 7 8 9])} { |
|
#subst %i with value - here we have no way of getting that - so use blank - user will get warning that target not found |
|
set percentrun 0 |
|
} else { |
|
append labelout [string repeat % [expr {$percentrun / 2}]] |
|
set percentrun 0 |
|
if {$c in $labelterminals} { |
|
break |
|
} |
|
append labelout $c |
|
} |
|
} |
|
} |
|
} else { |
|
#in var - don't do anything with carets(?) |
|
switch -- $c { |
|
% { |
|
if {$percentrun == 1} { |
|
#double percent - rather than just an empty var - emit one % |
|
append labelout % |
|
set invar 0 |
|
set percentrun 0 |
|
} else { |
|
#presume percentrun is 0 |
|
set invar 0 |
|
lappend varsfound $varname; set varname "" |
|
} |
|
} |
|
: { |
|
#$varterminals |
|
set invar 0 |
|
lappend varsfound $varname; set varname "" |
|
} |
|
default { |
|
if {$percentrun && ($c in [list 0 1 2 3 4 5 6 7 8 9])} { |
|
#review - seems to terminate var - and substitute? |
|
#this branch untested - case where we have %i and further % - what if it was %1var% ? does %1 get substituted ? or %1var% - test |
|
set invar 0 |
|
append varname $c |
|
} else { |
|
append varname $c |
|
} |
|
set percentrun 0 |
|
} |
|
} |
|
|
|
|
|
#if {$c eq "%" && $percentrun == 1} { |
|
# #double percent - rather than just an empty var - emit one % |
|
# append labelout % |
|
# set invar 0 |
|
# set percentrun 0 |
|
#} elseif {$c eq "%"} { |
|
# #presume percentrun is 0 |
|
# set invar 0 |
|
# lappend varsfound $varname; set varname "" |
|
#} elseif {$c in $varterminals} { |
|
# set invar 0 |
|
# lappend varsfound $varname; set varname "" |
|
#} else { |
|
# if {$percentrun && ($c in [list 0 1 2 3 4 5 6 7 8 9])} { |
|
# #review - seems to terminate var - and substitute? |
|
# #this branch untested - case where we have %i and further % - what if it was %1var% ? does %1 get substituted ? or %1var% - test |
|
# set invar 0 |
|
# append varname $c |
|
# } else { |
|
# append varname $c |
|
# } |
|
# set percentrun 0 |
|
#} |
|
} |
|
incr inputconsumed |
|
} |
|
# -------------- end % handling % |
|
set tail [string range $labelstart $inputconsumed end] |
|
#caret -- etc |
|
if {$labelout eq ""} { |
|
set resultdict [dict create labelfound 0] |
|
if {[llength $varsfound]} { |
|
dict set resultdict vars $varsfound |
|
dict set resultdict note "empty label but vars exist - may be legit" |
|
} else { |
|
dict set resultdict note "empty label - no vars" |
|
} |
|
dict set resultdict tail $tail |
|
return $resultdict |
|
} |
|
|
|
return [list labelfound 1 label $labelout tail $tail] |
|
} |
|
proc get_target_label_from_line {labelline} { |
|
#scan a whole line - or a 'line' starting at some chunk boundary we found for a label |
|
#caller should resolve any trailing caret and subsequent line and include them in the call |
|
#note that we may be scanning all sorts of things in a polyglot file - but we're interested in seeing if cmd.exe might interpret it as a label |
|
#target labels don't have %var% processing - they will be literal |
|
set firstcolon [string first : $labelline] |
|
if {$firstcolon == -1} { |
|
return [list labelfound 0 note "no_colon"] |
|
} |
|
set prefixpart [string range $labelline 0 $firstcolon-1] |
|
set targetpart [string range $labelline $firstcolon+1 end] |
|
|
|
set prefixok 1;#default assumption |
|
set invisible_prefix_chars [list {;} , = " " \t] |
|
set prefixchars [split $prefixpart ""] |
|
# % and ^ in the prefix - whether doubled etc or not - will stop label being found |
|
#ANY first char seems to be allowed in prefixpart (it won't be colon, because we already split on that) |
|
#perhaps this is done by cmd.exe to reduce off-by-one errors?? weird... |
|
# but it does allow labels to be found in certain # tcl/bashsh comment lines, which could be both dangerous and ...useful. |
|
#start prefix check at char 1 instead of 0 |
|
foreach pchar [lrange $prefixchars 1 end] { |
|
if {$pchar ni $invisible_prefix_chars} { |
|
set prefixok 0 |
|
break |
|
} |
|
} |
|
if {!$prefixok} { |
|
return [list labelfound 0 note "prefix_fail"] |
|
} |
|
|
|
#no problems before colon - now see if targetpart can be interpreted as a label |
|
#we again have some potential invisible chars before label begins. |
|
set charindex [expr {$firstcolon +1}] ;#track position so we can return index of where we believe label begins |
|
set targetchars [split $targetpart ""] |
|
set inlabel 0 |
|
set labelposn -1 |
|
# --- |
|
set inlabel_terminals [list : + " " \t \r \n] ;# , ; = don't seem to terminate a target label, but do terminate a calling label |
|
# + and whitespace terminate caller and target |
|
# --- |
|
# consider: |
|
#@goto :14^ |
|
# :14^ |
|
#caller is searching for label "14" but won't match - presumably target scanner has escaped the trailing space |
|
set label "" |
|
set rawlabel "" |
|
set caretseq 0 ;# 0|1 |
|
foreach tchar $targetchars { |
|
if {$tchar in [list + :]} { |
|
break |
|
} |
|
if {!$inlabel} { |
|
if {$tchar ni $invisible_prefix_chars} { |
|
#beginning of target label |
|
set labelposn $charindex |
|
set inlabel 1 |
|
append rawlabel $tchar |
|
if {$tchar eq "^"} { |
|
set caretseq 1 |
|
} else { |
|
append label $tchar |
|
} |
|
} |
|
} else { |
|
if {$tchar in $inlabel_terminals} { |
|
#caret stops them from terminating |
|
if {$caretseq} { |
|
set caretseq 0 |
|
append label $tchar |
|
append rawlabel $tchar |
|
} else { |
|
break |
|
} |
|
} else { |
|
append rawlabel $tchar |
|
if {$tchar eq "^"} { |
|
if {$caretseq} { |
|
set caretseq 0 |
|
append label "^" ;#for every pair encountered in direct sequence - second gets included in label |
|
} else { |
|
set caretseq 1 |
|
} |
|
} else { |
|
set caretseq 0 |
|
append label $tchar ;#for target labels - all including %var% is directly part of the label target |
|
} |
|
} |
|
} |
|
incr charindex |
|
} |
|
if {$labelposn == -1} { |
|
return [list labelfound 0 note "no_label_found_after_colon"] |
|
} |
|
|
|
#return rawlabel so we can see it as it appears in the data - as opposed to how it is interpreted as a label by cmd.exe |
|
return [list labelfound 1 label $label rawlabel $rawlabel] |
|
} |
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::scriptwrap::batchlib ---}] |
|
} |
|
|
|
} |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |