#note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns)
#note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns)
}
}
set rhs [string map $dict_tagval $rhs]
set rhs [string map $dict_tagval $rhs] ;#obsolete?
dict set folderdict $tpath [list source $pkg sourcetype package]
dict set folderdict $tpath [list source $pkg sourcetype package]
} else {
} else {
puts stderr "punk::mix template_folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability"
puts stderr "punk::cap::templates::folders WARNING - unable to determine base folder for package '$pkg' which is registered with punk::mix as a provider of 'templates' capability"
}
}
} else {
} else {
puts stderr "punk::mix template_folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates"
puts stderr "punk::cap::templates::folders WARNING - registered pkg 'pkg' has capability 'templates' but no 'relpath' key - unable to use as source of templates"
#leading colon makes it hard (impossible?) to call directly if not within the namespace
#leading colon makes it hard (impossible?) to call directly if not within the namespace
#todo - change semantics of args - it's not particularly useful to pass namespaces as separated items - would be better to accept options (e.g nslist option -types)
proc ns/ {v {ns_or_glob ""} args} {
proc ns/ {v args} {
variable ns_current ;#change active ns of repl by setting ns_current
variable ns_current ;#change active ns of repl by setting ns_current
set out [nslist [nsjoin $ns_current *] -types [list children]]
} else {
set out [nslist [nsjoin $ns_current *] -types [list all]]
}
#todo - cooperate with repl
set ns_display "\n$ns_current"
set types [list all]
if {$ns_current in [info commands $ns_current] } {
set nspathcommands 0
if {![catch [list namespace ensemble configure $ns_current] ensemble_info]} {
if {$v eq "/"} {
if {[llength $ensemble_info] > 0} {
set types [list children]
#this namespace happens to match ensemble command.
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info.
set ns_display "\n[a+ yellow bold]$ns_current[a+]"
}
}
}
if {$v eq "///"} {
set nspathcommands 1
}
}
append out $ns_display
return $out
#todo - cooperate with repl?
set out ""
if {$ns_or_glob eq ""} {
set is_absolute 1
set ns_queried $ns_current
set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands]
} else {
} else {
set atail [lassign $args a1]
set is_absolute [string match ::* $ns_or_glob]
if {$a1 in [list :: ""]} {
set has_globchars [regexp {[*?]} $ns_or_glob]
set ns_current ::
tailcall ns/ $v {*}$atail
}
set is_absolute [string match ::* $a1]
if {$is_absolute} {
if {$is_absolute} {
if {![llength $atail] && [regexp {[*?]} $a1]} {
if {!$has_globchars} {
#set out [get_nslist -match $a1]
if {![namespace exists $ns_or_glob]} {
set out [nslist $a1]
error "cannot change to namespace $ns_or_glob"
append out "\n$a1"
return $out
}
}
set nsparent [nsprefix $a1]
set ns_current $ns_or_glob
set nstail [nstail $a1]
set ns_queried $ns_current
if {[nseval $nsparent [list ::namespace exists $nstail]]} {
tailcall ns/ $v ""
set ns_current $a1
} else {
tailcall ns/ $v {*}$atail
set ns_queried $ns_or_glob
set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands]
}
}
error "cannot change to namespace $a1"
} else {
} else {
set nsnext [nsjoin $ns_current $a1]
if {!$has_globchars} {
if {![llength $atail] && [regexp {[*?]} $a1]} {
set nsnext [nsjoin $ns_current $ns_or_glob]
#set out [get_nslist -match $nsnext]
if {![namespace exists $nsnext]} {
set out [nslist $nsnext]
error "cannot change to namespace $ns_or_glob"
append out "\n$nsnext"
return $out
}
}
if {[nseval $ns_current [list ::namespace exists $a1]]} {
set ns_current $nsnext
set ns_current $nsnext
tailcall ns/ $v {*}$atail
set ns_queried $nsnext
set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands]
} else {
} else {
error "cannot change to namespace $nsnext"
set ns_queried [nsjoin $ns_current $ns_or_glob]
set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands]
}
}
}
set ns_display "\n$ns_queried"
if {$ns_current eq $ns_queried} {
if {$ns_current in [info commands $ns_current] } {
if {![catch [list namespace ensemble configure $ns_current] ensemble_info]} {
if {[llength $ensemble_info] > 0} {
#this namespace happens to match ensemble command.
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info.
set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]"
}
}
}
}
}
}
}
}
append out $ns_display
return $out
}
#create possibly nested namespace structure - but only if not already existant
#create possibly nested namespace structure - but only if not already existant
@ -381,7 +384,17 @@ namespace eval punk::ns {
return "^[join $pats ::]\$"
return "^[join $pats ::]\$"
}
}
proc globmatchns {glob path} {
proc globmatchns {glob path} {
return [regexp [nsglob_as_re $glob] $path]
#the total set of namespaces is *generally* reasonably bounded so we could just cache all globs, perhaps with some pretty high limit for sanity.. (a few thousand?) review - memory cost?
# Tcl (reportedly https://wiki.tcl-lang.org/page/regexp) only caches 'up to 30'dynamically - but should cache more if more stored.
variable ns_re_cache
if {![dict exists $ns_re_cache $glob]} {
if {[dict size $ns_re_cache] > 4200} {
#shimmer dict to list and back doesn't seem to affect internal rep of regexp items therein.
set ns_re_cache [lrange $ns_re_cache 400 end] ;#chop 200 items off beginning of dict
}
dict set ns_re_cache $glob [nsglob_as_re $glob]
}
return [regexp [dict get $ns_re_cache $glob] $path]
}
}
proc nstree {{location ""}} {
proc nstree {{location ""}} {
@ -392,6 +405,9 @@ namespace eval punk::ns {
list_as_lines [nstree_list $location]
list_as_lines [nstree_list $location]
}
}
#important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure.
#e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util
proc nstree_list {location args} {
proc nstree_list {location args} {
package require struct::list
package require struct::list
#puts "> nstree_list $location $args"
#puts "> nstree_list $location $args"
@ -408,13 +424,20 @@ namespace eval punk::ns {
# -- ---- --- --- --- ---
# -- ---- --- --- --- ---
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]]
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]]
set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars
if {!$has_globchars && !$allbelow && ![llength $subnslist]} {
#short circuit trivial case
return [list $location]
}
set base ""
set base ""
set tailparts ""
set tailparts [list]
if {$CALLDEPTH == 0} {
if {$CALLDEPTH == 0} {
set parts [nsparts $ns_absolute]
set parts [nsparts $ns_absolute]
lset parts 0 ::
lset parts 0 ::
set idx 0
set idx 0
if {$has_globchars} {
foreach seg $parts {
foreach seg $parts {
if {![regexp {[*?]} $seg]} {
if {![regexp {[*?]} $seg]} {
set base [nsjoin $base $seg]
set base [nsjoin $base $seg]
@ -424,12 +447,15 @@ namespace eval punk::ns {
}
}
incr idx
incr idx
}
}
} else {
set base $ns_absolute
}
} else {
} else {
set base $location
set base $location
set tailparts $subnslist
set tailparts $subnslist
}
}
if {![namespace exists $base]} {
if {![namespace exists $base]} {
return ""
return [list]
}
}
#set parent [nsprefix $ns_absolute]
#set parent [nsprefix $ns_absolute]
#set tail [nstail $ns_absolute]
#set tail [nstail $ns_absolute]
@ -447,7 +473,6 @@ namespace eval punk::ns {
set nslist [nstree_list $base -subnslist {} -allbelow 1]
set nslist [nstree_list $base -subnslist {} -allbelow 1]
set allchildren [nschildren $ch] ; #only returns 1 level deeper
if {$allbelow == 0 && !$has_globchars} {
set allchildren [list]
} else {
set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper
}
#nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string.
#nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string.
# By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {}
# By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {}
set commands [linelist -block {} [nscommands -raw [nsjoin $ch $glob]]]
#by convention - returning just \n represents a single result of the empty string whereas no results
#by convention - returning just \n represents a single result of the empty string whereas no results
#after passing through linelist this becomes {} {} which appears as a list of two empty strings.
#after passing through linelist this becomes {} {} which appears as a list of two empty strings.
#this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines
#this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines
@ -912,9 +988,22 @@ namespace eval punk::ns {
}
}
#JMN
set location $ch
set location $ch
set exportpatterns [namespace eval $location {::namespace export}]
set exportpatterns [namespace eval $location {::namespace export}]
set nspathlist [namespace eval $location {::namespace path}]
set nspathdict [dict create]
if {$nspathcommands} {
foreach pathns $nspathlist {
set pathcommands [lmap v [info commands ${pathns}::*] {namespace tail $v}]
set matched [lsearch -all -inline $pathcommands $glob]
dict set nspathdict $pathns [dict create commands $matched]
}
} else {
foreach pathns $nspathlist {
dict set nspathdict $pathns [dict create] ;#use consistent structure when nspathcommands false
#review - ansi codes will be very confusing in some scenarios!
#review - ansi codes will be very confusing in some scenarios!
#todo - only output color when requested (how?) or via repltelemetry ?
#todo - only output color when requested (how?) or via repltelemetry ?
interp alias {} nscommands {} .= ,'ok'@0.= {
interp alias {} nscommands2 {} .= ,'ok'@0.= {
#Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x
#Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x
#unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings)
#unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings)
#we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings.
#we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings.
#unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings)
#we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings.
if {![llength $results]} {
return {}
} else {
return [join $results \n]\n
}
}
interp alias {} nscommands {} punk::ns::nscommands
interp alias {} nscommands1 {} .= ,'ok'@0.= {
interp alias {} nscommands1 {} .= ,'ok'@0.= {
set commandns [namespace current]
set commandns [namespace current]
#upvar caseresult caseresult
#upvar caseresult caseresult
@ -1268,6 +1431,173 @@ namespace eval punk::ns {
}
}
namespace eval internal {
#maintenance: similar in punk::winrun
proc get_run_opts {options alias_dict arglist} {
if {[catch {
set callerinfo [info level -1]
} errM]} {
set caller ""
} else {
set caller [lindex $callerinfo 0]
}
#update alias dict mapping shortnames to longnames - longnames to self
foreach o $options {
dict set alias_dict $o $o
}
set known_runopts [dict keys $alias_dict]
set runopts [list]
set cmdargs [list]
set first_eopt_posn [lsearch $arglist --]
if {$first_eopt_posn >=0} {
set pre_eopts [lrange $arglist 0 $first_eopt_posn-1]
set is_eopt_for_runopts 1 ;#default assumption that it is for this function rather than part of user's commandline - cycle through previous args to disprove.
foreach pre $pre_eopts {
if {$pre ni $known_runopts} {
set is_eopt_for_runopts 0; #the first -- isn't for us.
}
}
} else {
set is_eopt_for_runopts 0
}
#split on first -- if only known opts preceding (or nothing preceeding) - otherwise split on first arg that doesn't look like an option and bomb if unrecognised flags before it.
if {$is_eopt_for_runopts} {
set idx_first_cmdarg [expr $first_eopt_posn + 1]
set runopts [lrange $arglist 0 $idx_first_cmdarg-2] ;#exclude -- from runopts - it's just a separator.
} else {
set idx_first_cmdarg [lsearch -not $arglist "-*"]
set runopts [lrange $arglist 0 $idx_first_cmdarg-1]
}
set cmdargs [lrange $arglist $idx_first_cmdarg end]
foreach o $runopts {
if {$o ni $known_runopts} {
error "$caller: Unknown runoption $o - known options $known_runopts"
}
}
set runopts [lmap o $runopts {dict get $alias_dict $o}]
if {"-allowvars" in $runopts && "-disallowvars" in $runopts} {
set no_warnings [expr {"-nowarnings" in $runopts}]
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns
if {[string tolower $pkg_or_existing_ns] in [list :: global]} {
set ns ::
set ver "";# tcl version?
} else {
if {[string match ::* $pkg_or_existing_ns]} {
if {![namespace exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]]
} else {
set ver ""
}
set ns $pkg_or_existing_ns
} else {
set ver [package require $pkg_or_existing_ns]
set ns ::$pkg_or_existing_ns
}
}
if {[namespace exists $ns]} {
if {[llength $cmdargs]} {
set binding {}
#if {[info level] == 1} {
# #up 1 is global
# set get_vars [list info vars]
#} else {
# set get_vars [list info locals]
#}
#set vars [uplevel 1 {*}$get_vars]
#set vars [namespace eval $ns {info vars}]
#review - upvar in apply within ns eval vs direct access of ${ns}::varname
set capture [namespace eval $ns {
apply { varnames {
while {"prev_args_[incr n]" in $varnames} {}
set capturevars [dict create]
set capturearrs [dict create]
foreach fullv $varnames {
set v [namespace tail $fullv]
upvar 1 $v var
if {$v eq "args"} {
dict set capturevars "prev_args$n" [list var $var]
} else {
if {(![array exists var])} {
dict set capturevars $v $var
} else {
dict set capturearrs $v [array get var]
}
}
}
return [dict create vars $capturevars arrs $capturearrs]
} } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns)
} ]
set arglist [lassign $cmdargs scriptblock]
if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} {
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix 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) J.M.Noble 2023
#
# @@ Meta Begin
# Application punk::winrun 999999.0a1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
#package require twapi ;#not loaded here because as of 2023-11 load is *very* slow. Todo - query APN re return to faster partial loading facility for twapi subsets.
#slow twapi load at startup can be ameliorated by async loading the dll in another thread in circumstances where it's not needed immediately anyway - but this doesn't help for filters where we need twapi functionality asap.
if {"[string index $copy 0][string index $copy end]" eq {""}} {
#review legit reasons to call with quoted first arg. Such users can use the -q flag so that this warning can remain to help in general debugging
puts stderr "WARNING: quote_win first argument should not be pre-quoted if it is to be interpreted correctly on windows (e.g with CommandLineToArgvW)"
}
}
incr i
}
if {[llength $cmdargs] > 0} {
set raw_cmdline [string range $raw_cmdline 0 end-1] ;#trim 1 trailing space
}
if {$verbose} {
puts stdout "==raw_cmdline== $raw_cmdline" ;# string built from list elements is different to string rep of original list which potentially has Tcl escapes visible
#equivalent of unquote_win implemented in Tcl - for testing if assumptions are correct, and whether the api does something different between os versions.
#There are differences in particular with repeated double quotes.
#This function seems to behave in alignment with how tclsh gets it's argv parameters - whereas Twapi 4.7.2 CommandLineToArgvW splits differently
#e.g for commandline: cmd """a b c""" etc
#unquote_wintcl and tclsh ::argv give 2 args, "a b c" , etc
#CommandLineToArgvW gives 4 args "a , b , c" , etc
#
proc unquote_wintcl {standard_quoted_cmdline} {
#with reference to https://daviddeley.com/autohotkey/parameters/parameters.htm post2008 ms C/C++ commandline parameter parsing algorithm (section 5.10)
set paramlist [list]
set remainder $standard_quoted_cmdline
set lastremlen [string length $standard_quoted_cmdline]
#note 1st arg (program name) - anything up to first whitespace or anything within first 2 double-quotes encountered - so escaped doublequotes can't be part of first word.
while {[string length $remainder]} {
if {[llength $paramlist] == 0} {
set pinfo [get_firstparam_wintcl $remainder]
} else {
set pinfo [get_nextparam_wintcl $remainder]
}
if {[dict get $pinfo status] ne "ok"} {
puts stderr "paramlist so far: '$paramlist'"
error "unquote_wintcl error [dict get $pinfo status]"
}
lappend paramlist [dict get $pinfo param]
set remainder [dict get $pinfo remainder]
set remainder [string trimleft $remainder " \t"]
set remlen [string length $remainder]
if {$remlen && ($remlen >= $lastremlen)} {
#sanity check
error "unquote_wintcl failed to progress in parsing cmdline $standard_quoted_cmdline - stuck with remainder $remlen"
}
set lastremlen $remlen
}
return $paramlist
}
#get 'program name' first word under different rules to subsequent arguments in the cmdline
proc get_firstparam_wintcl {cmdline} {
set in_doublequote_part 0
set chars [split $cmdline ""]
set chunklen [llength $chars]
set n 0
set p ""
if {[lindex $chars 0] eq {"}} {
set in_doublequote_part 1
} else {
append p [lindex $chars 0]
}
incr n
while {$n<$chunklen && ($in_doublequote_part || ([lindex $chars $n] ni [list " " \t]))} {
if {[lindex $chars $n] eq {"}} {
break
}
append p [lindex $chars $n]
incr n
}
set rem [string range $cmdline $n+1 end]
#puts "----p>$p<------r>$rem<-----"
return [dict create status "ok" param $p remainder $rem]
}
#non first-word parsing.
proc get_nextparam_wintcl {cmdline} {
#post 2008 windows double-quote handling system.
set chars [split $cmdline ""]
set chunklen [llength $chars]
set status "parsing"
set p ""
set in_doublequote_part 0
#allow n to go 1 above highest index in $chars for this algorithm
for {set n 0} {$n<=$chunklen} {incr n} {
set copychar true
set num_backslashes 0
while {[lindex $chars $n] eq "\\"} {
incr num_backslashes
incr n
}
if {[lindex $chars $n] eq {"}} {
if {$num_backslashes % 2 == 0} {
#even
if {$in_doublequote_part} {
if {[lindex $chars $n+1] eq {"}} {
incr n ;#move to second {"}
} else {
set copychar false
set in_doublequote_part 0
}
} else {
set copychar false
set in_doublequote_part 1
}
}
#whether odd or even, dividing by 2 does what we need
set num_backslashes [expr {$num_backslashes / 2}]
}
append p [string repeat "\\" $num_backslashes]
if {$n == $chunklen || (!$in_doublequote_part && [lindex $chars $n] in [list " " \t])} {
set status "ok"
break
}
if {$copychar} {
append p [lindex $chars $n]
}
}
set rem [string range $cmdline $n+1 end]
#puts "----p>$p<------r>$rem<-----"
return [dict create status $status param $p remainder $rem]
}
proc runwin {args} {
tw_run [quote_win {*}$args]
}
#an experiment - this is essentially an identity transform unless flags are set. - result afer cmd.exe processes escapes is the same as running raw with no quoting
#this follows the advice of 'don't let cmd see any double quotes unescaped' - but that's effectively a pretty useless strategy.
#The -useprequoted and -usepreescaped flags are the only difference
#these rely on the fact we can prepend a caret to each argument without affecting the resulting string - and use that as an indicator to treat specific input 'arguments' differently i.e by keeping existing escapes only.
#note that %var% and !var! work the same whether within a double quote section or not
if {$disallowvars} {
lappend meta_chars % !
}
#unbalanced quotes in %varname% will affect output - but aren't seen by this parser - which means they will only result in double escaping - not exiting escape mode. (this is good)
#!varname! with delayed expansion (cmd.exe /v /c ...) seems to be safer as it doesn't appear to allow breakage of quoting
set cmd_in_quotes 0
#todo - transition of cmd_in_quotes from 0 -> 1 only is affected by number of carets preceding quote!
foreach w $tcl_list {
set qword ""
set wordlen [string length $w]
set nlast [expr {$wordlen -1}]
set chars [split $w ""]
set wordlen [string length $w]
set nlast [expr {$wordlen -1}]
if {$use_prequoted} {
if {[string range $w 0 1] eq {^"}} {
#pass entire argument (less leading caret) through with existing quoting - no adjustment to cmd_in_quotes state.
append cmdline [string range $w 1 end] " "
continue
}
}
if {$use_preescaped} {
if {[string index $w 0] eq {^}} {
#pass entire argument (less leading caret) through with existing quoting - no adjustment to cmd_in_quotes state.
#This does what Sebres has implemented for Tcl's exec already - pass through that works for non builtins that are run via cmd.exe and require standard argv parsing
#
#tracked blocking of vars - after winquoting when in quotes,prefix % with (unslashed) quote - when outside quotes - prefix with ^
#(always using unslashed quotes considered - seems more likely to cause prolems with the argv parsing)
# ! can't be blocked with carets ... always use quotes
#other cmd specials - block only outside of quotes
#existing carets?
#note that /v changes the way carets go through - we need twice as many ^ when /v in place e.g x^^^^y to get x^y vs x^^y to get x^y when /v not present - review - can we sensibly detect /v?
#review - may need to force quoting of barewords by quote_win to ensure proper behaviour if bareword contains cmd specials?
#?always treatable as a list? review
set tcl_list [lmap v $cmdargs {internal::objclone $v}]
set meta_chars [list {<} {>} & |] ;#caret-quote when outside of cmd.exe's idea of a quoted section - carets will disappear from passed on string
set cmdline ""
set in_quotes 0
foreach w $tcl_list {
set winquoted [quote_win x $w] ;#pass bogus app-name as first word - as first word subject to different rules
set chars [split [string range $winquoted 2 end] ""] ;# strip bogus before splitting
set had_quotes 0
if {{"} in $chars} {
set had_quotes 1
}
set wordlen [llength $chars]
#set nlast [expr {$wordlen -1}]
set qword ""
for {set n 0} {$n<$wordlen} {incr n} {
set num_slashes 0
if {[lindex $chars $n] eq {"}} {
set in_quotes [expr {!$in_quotes}]
append qword {"}
} elseif {[lindex $chars $n] in [list "%"]} {
if {$allowvars} {
set tail [lrange $chars $n+1 end]
#??
}
#if %var% was in original string - a variable named %"var"% can be substituted after we have done our quoting.
#no matter what quoting scheme we use - there will be a corresponding string between %'s that can in theory be exploited if
if {$in_quotes} {
#note that the *intended* quoting will be opposite to the resultant quoting from wrapping with quote_win
#therefore, counterintuitively we can enable the var when in_quotes is true here, and &cmd won't run.
#double quotes in the var don't seem to cause cmd.exe to change it's concept of in_quotes so &cmd also won't run
#However.. backspace can can break quoting. e.g \b&cmd
if {$allowvars} {
append qword [lindex $chars $n]
} else {
append qword {"} [lindex $chars $n] {"} ;#add in pairs so we don't disturb structure for argv
}
} else {
#allow vars here is also dangerous we need to lookahead and scan the value and quote accordingly
if {$allowvars} {
append qword [lindex $chars $n]
} else {
append qword {^} [lindex $chars $n]
}
}
} elseif {[lindex $chars $n] eq "!"} {
if {$allowvars} {
append qword "!"
} else {
append qword {"} {!} {"}
}
} elseif {[lindex $chars $n] eq "^"} {
if {$in_quotes} {
append qword {"^^"} ;#add quotes in pairs so we don't disturb structure for argv
} else {
append qword {^^}
}
} else {
if {[lindex $chars $n] in $meta_chars} {
if {$in_quotes} {
append qword [lindex $chars $n]
} else {
append qword "^" [lindex $chars $n]
}
} else {
append qword [lindex $chars $n]
}
}
}
append cmdline $qword " "
}
set cmdline [string range $cmdline 0 end-1]
if {$verbose} {
puts stdout --cmdline->$cmdline
}
return $cmdline
}
# - This approach with repeated double quotes gives inconsistent behaviour between twapi CommandLineToArgvW and tclsh -
#prepare arguments that are given to cmd.exe such that they will be passed through to an executable that uses standard windows commandline parsing such as CommandLineToArgvW
#for each arg:
#double up any backslashes that precede double quotes, double up existing double quotes - then wrap in a single set of double quotes if argument had any quotes in it.
#This doesn't use \" or ^ style escaping - but the 2008+ argv processing on windows supposedly does what we want with doubled-up quotes and slashes, and cmd.exe passes them through
set allowquotes [expr {"-allowquotes" in $runopts}]
set verbose [expr {"-verbose" in $runopts}]
set tcl_list [lmap v $cmdargs {internal::objclone $v}]
set cmdline ""
set i 0
set meta_chars [list "(" ")" ^ < > & |]
if {!$allowvars} {
lappend meta_chars % !
}
if {!$allowquotes} {
lappend meta_chars {"}
}
foreach w $tcl_list {
set wordlen [string length $w]
set nlast [expr {$wordlen -1}]
set chars [split $w ""]
foreach char $chars {
if {$char in $meta_chars} {
append cmdline "^$char"
} else {
append cmdline $char
}
}
append cmdline " "
incr i
}
set cmdline [string range $cmdline 0 end-1]
if {$verbose} {
puts stdout --cmdline->$cmdline
}
return $cmdline
}
proc quote_cmd2 {args} {
set cmdargs $args
set tcl_list [lmap v $cmdargs {internal::objclone $v}]
set cmdline ""
set i 0
set meta_chars [list {"} "(" ")" ^ < > & |] ;#deliberately don't include % - it should work quoted or not.
#unbalanced quotes in %varname% will affect output - but aren't seen by this parser - which means they will only result in double escaping - not exiting escape mode. (this is good)
set cmd_in_quotes 0
foreach w $tcl_list {
set wordlen [string length $w]
set nlast [expr {$wordlen -1}]
set chars [split $w ""]
foreach char $chars {
if {$char eq {"}} {
append cmdline {^"}
set cmd_in_quotes [expr {!$cmd_in_quotes}]
} else {
if {$cmd_in_quotes} {
if {$char in $meta_chars} {
append cmdline "^$char"
} else {
append cmdline $char
}
} else {
append cmdline $char
}
}
}
append cmdline " "
incr i
}
set cmdline [string range $cmdline 0 end-1]
puts stdout --cmdline->$cmdline
return $cmdline
}
proc runcmd {args} {
set cmdline [quote_cmd {*}$args]
tw_run $cmdline
}
proc runcmdpassthru {args} {
set cmdline [quote_cmdpassthru {*}$args]
tw_run $cmdline
}
proc runcmdblock {args} {
set cmdline [quote_cmdblock {*}$args]
tw_run $cmdline
}
#round-trip test
#use standard(!) win arg quoting first - then deconstruct using the win32 api, and the tcl implementation
proc testrawline {rawcmdline} {
puts "input string : $rawcmdline"
set win_argv [unquote_win $rawcmdline]
puts "unquote_win CommandLineToArgvW : $win_argv"
set wintcl_argv [unquote_wintcl $rawcmdline]
puts "unquote_wintcl : $wintcl_argv"
return $win_argv
}
proc testlineargs {args} {
puts "input list : $args"
puts " argument count : [llength $args]"
puts "input string : [join $args " "]"
puts [string repeat - 20]
set standard_escape_line [quote_win {*}$args]
set argv_from_win32 [unquote_win $standard_escape_line]
#get a copy of the item without affecting internal rep
#this isn't critical for most usecases - but can be of use for example when trying not to shimmer path objects to strings (filesystem performance impact in some cases)
proc objclone {obj} {
append obj2 $obj {}
}
# -- --- ---
#get_run_opts - allow completely arbitrary commandline following controlling flags - with no collision issues if end-of-opts flag "--" is used.
#singleton flags allowed preceding commandline. (no support for option-value pairs in the controlling flags)
#This precludes use of executable beginning with a dash unless -- provided as first argument or with only known run-opts preceding it.
#This should allow any first word for commandlist even -- itself if a protective -- provided at end of any arguments intended to control the function.
proc get_run_opts {arglist} {
if {[catch {
set callerinfo [info level -1]
} errM]} {
set caller ""
} else {
set caller [lindex $callerinfo 0]
}
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value
#build alias dict mapping shortnames to longnames - longnames to self
set alias_dict $aliases
foreach o $options {
dict set alias_dict $o $o
}
set known_runopts [dict keys $alias_dict]
set runopts [list]
set cmdargs [list]
set first_eopt_posn [lsearch $arglist --]
if {$first_eopt_posn >=0} {
set pre_eopts [lrange $arglist 0 $first_eopt_posn-1]
set is_eopt_for_runopts 1 ;#default assumption that it is for this function rather than part of user's commandline - cycle through previous args to disprove.
foreach pre $pre_eopts {
if {$pre ni $known_runopts} {
set is_eopt_for_runopts 0; #the first -- isn't for us.
}
}
} else {
set is_eopt_for_runopts 0
}
#split on first -- if only known opts preceding (or nothing preceeding) - otherwise split on first arg that doesn't look like an option and bomb if unrecognised flags before it.
if {$is_eopt_for_runopts} {
set idx_first_cmdarg [expr $first_eopt_posn + 1]
set runopts [lrange $arglist 0 $idx_first_cmdarg-2] ;#exclude -- from runopts - it's just a separator.
} else {
set idx_first_cmdarg [lsearch -not $arglist "-*"]
set runopts [lrange $arglist 0 $idx_first_cmdarg-1]
}
set cmdargs [lrange $arglist $idx_first_cmdarg end]
foreach o $runopts {
if {$o ni $known_runopts} {
error "$caller: Unknown runoption $o - known options $known_runopts"
}
}
set runopts [lmap o $runopts {dict get $alias_dict $o}]
if {"-allowvars" in $runopts && "-disallowvars" in $runopts} {
