23 changed files with 2246 additions and 375 deletions
@ -1,7 +1,8 @@
|
||||
#puts -nonewline stdout "info script\r\n" |
||||
#puts stdout "[info script]" |
||||
puts stdout "::argc" |
||||
puts stdout $::argc |
||||
puts stdout "::argv" |
||||
puts stdout "$::argv" |
||||
|
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv one arg per line, each line followed by dotted line." |
||||
foreach a $::argv { |
||||
puts stdout $a |
||||
puts stdout [string repeat - 40] |
||||
} |
||||
|
||||
@ -0,0 +1,28 @@
|
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv one arg per line, each line followed by dotted line." |
||||
foreach a $::argv { |
||||
puts stdout $a |
||||
puts stdout [string repeat - 40] |
||||
} |
||||
flush stdout |
||||
puts stdout "****** raw args******" |
||||
package require twapi |
||||
set rawcmdline [twapi::get_process_commandline [pid]] |
||||
puts stdout $rawcmdline |
||||
puts stdout "****** ******" |
||||
flush stdout |
||||
set cl_to_argv [twapi::get_command_line_args $rawcmdline] |
||||
puts stdout "======twapi CommandLineToArgvW interpretation of args =====" |
||||
foreach ca $cl_to_argv { |
||||
puts stdout $ca |
||||
puts stdout [string repeat = 40] |
||||
} |
||||
puts stdout \n |
||||
package require punk::winrun |
||||
set cl_to_argv [punk::winrun::unquote_wintcl $rawcmdline] |
||||
puts stdout "======winrun::unquote_wintcl interpretation of args =====" |
||||
foreach ca $cl_to_argv { |
||||
puts stdout $ca |
||||
puts stdout [string repeat = 40] |
||||
} |
||||
puts stdout \n |
||||
@ -0,0 +1,285 @@
|
||||
# -*- tcl -*- |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application calc676 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval calc676 { |
||||
# Tcl version of a Calc command for TIP 676. |
||||
# |
||||
# Prototype for an expression evaluator which does no internal substitution, |
||||
# instead expecting any substitutions on its arguments to have been done |
||||
# in advance by the usual Tcl mechanisms. To avoid unpleasant surprises |
||||
# as warned about by Peter Da Silva, each token must be supplied as a |
||||
# separate argument, e.g. calc 2 * abs( $x - $y ) NOT calc 2*abs($x-$y) |
||||
# Only numeric and boolean values and operations are supported as there |
||||
# is no way to distinguish arbitrary string values from operators they |
||||
# might happen to mimic. |
||||
|
||||
variable tokens |
||||
variable tokpos |
||||
variable depth |
||||
|
||||
proc calc args { |
||||
variable tokens |
||||
variable tokpos |
||||
variable depth |
||||
|
||||
if {[llength $args] == 0} {error "Calc: nothing to calculate"} |
||||
set tokens $args |
||||
set tokpos 0 |
||||
set depth 0 |
||||
set code [parse 0] |
||||
#puts "GENERATED CODE:\n$code" |
||||
set result [::tcl::unsupported::assemble $code] |
||||
#puts "OUTPUT = '$result'" |
||||
return $result |
||||
} |
||||
|
||||
# Pratt Parser loosely based on https://www.rosettacode.org/wiki/Arithmetic_evaluation#Nim |
||||
|
||||
variable inprec |
||||
variable incode |
||||
|
||||
# Define infix operators, their precedences and bytecodes |
||||
foreach {op prec code} { |
||||
) 0 - |
||||
, 0 - |
||||
? 1 - |
||||
: 1 - |
||||
|| 2 lor |
||||
&& 3 land |
||||
| 4 bitor |
||||
^ 5 bitxor |
||||
& 6 bitand |
||||
== 7 eq |
||||
!= 7 neq |
||||
< 8 lt |
||||
> 8 gt |
||||
<= 8 le |
||||
>= 8 ge |
||||
<< 9 lshift |
||||
>> 9 rshift |
||||
+ 10 add |
||||
- 10 sub |
||||
* 11 mult |
||||
/ 11 div |
||||
% 11 mod |
||||
** 12 expon |
||||
} { |
||||
set inprec($op) $prec |
||||
set incode($op) $code |
||||
} |
||||
|
||||
variable precode |
||||
# Define prefix operators and their bytecodes |
||||
foreach {op code} { |
||||
+ uplus |
||||
- uminus |
||||
! not |
||||
~ bitnot |
||||
} { |
||||
set precode($op) $code |
||||
} |
||||
variable preprec |
||||
|
||||
# Prefix ops all have the same precedence |
||||
set preprec 13 |
||||
|
||||
# Parse expression until we hit an operator with precedence lower than min_prec. |
||||
# The expression is supplied as a list of tokens in the global var tokens. |
||||
# The current position in the input is in global var tokpos. |
||||
# Returns the TAL bytecode to evaluate the expression. |
||||
proc parse min_prec { |
||||
variable inprec |
||||
variable incode |
||||
variable tokens |
||||
variable tokpos |
||||
variable depth |
||||
|
||||
set token [lindex $tokens $tokpos] |
||||
set dep [incr depth] |
||||
#puts "[string repeat { } $dep]PARSE min_prec=$min_prec tokpos=$tokpos token='$token'" |
||||
incr tokpos |
||||
set opcodes [parsePrefix $token] |
||||
set depth $dep |
||||
|
||||
while {$tokpos < [llength $tokens]} { |
||||
|
||||
set token [lindex $tokens $tokpos] |
||||
if {[info exists inprec($token)]} { |
||||
set tok_prec $inprec($token) |
||||
} else { |
||||
error "Calc: expected operator but found '$token'" |
||||
} |
||||
#puts "[string repeat { } $dep]PARSE token=$token tok_prec=$tok_prec" |
||||
if {$tok_prec < $min_prec} { |
||||
break |
||||
} |
||||
# Binary ops are left-associative except for ** |
||||
if {$tok_prec == $min_prec && $token ne "**"} { |
||||
break |
||||
} |
||||
# if-then-else needs special handling |
||||
incr tokpos |
||||
if {$token eq "?"} { |
||||
append opcodes [parseTernary] |
||||
continue |
||||
} |
||||
# Infix operator |
||||
append opcodes [parse $tok_prec] "$incode($token); " |
||||
} |
||||
#puts "[string repeat { } $dep]PARSE opcodes='$opcodes'" |
||||
set depth [expr {$dep - 1}] |
||||
return $opcodes |
||||
} |
||||
|
||||
# Parse expression up to the first operator at the same level of parentheses. |
||||
# Returns the bytecode to evaluate the subexpression. |
||||
proc parsePrefix token { |
||||
variable preprec |
||||
variable precode |
||||
variable tokens |
||||
variable tokpos |
||||
variable depth |
||||
|
||||
set dep [incr depth] |
||||
#puts "[string repeat { } $dep]PARSEPREFIX token=`$token` tokpos=$tokpos" |
||||
|
||||
# Is it a number? In C would use Tcl_GetNumberFromObj() here |
||||
if {[string is entier $token] || [string is double $token]} { |
||||
return "push $token; " |
||||
} |
||||
# Is it boolean? In C would use Tcl_GetBoolean() here |
||||
if {[string is boolean $token]} { |
||||
return "push $token; " |
||||
} |
||||
# Parenthesised subexpression? |
||||
if {$token eq "("} { |
||||
set opcodes [parse 0] |
||||
set token [lindex $tokens $tokpos] |
||||
if {$token eq ")"} { |
||||
incr tokpos |
||||
return $opcodes |
||||
} |
||||
error "Calc: expected ')' but found '$token'" |
||||
} |
||||
# Unary operator? |
||||
if {$token in {+ - ! ~}} { |
||||
return "[parse $preprec]$precode($token); " |
||||
} |
||||
# Function call? |
||||
if {[regexp {^([[:alpha:]]+)\($} $token - name]} { |
||||
set fun [namespace which tcl::mathfunc::$name] |
||||
if {$fun ne {}} { |
||||
set opcodes "push $fun; " |
||||
append opcodes [parseFuncArgs] |
||||
return $opcodes |
||||
} |
||||
} |
||||
error "Calc: expected start of expression but found '$token'" |
||||
} |
||||
|
||||
# Parse zero or more arguments to a math function. The arguments are |
||||
# expressions separated by commas and terminated by a closing parenthesis. |
||||
# Returns the bytecode to evaluate the arguments and call the function. |
||||
proc parseFuncArgs {} { |
||||
variable tokens |
||||
variable depth |
||||
variable tokpos |
||||
|
||||
set dep [incr depth] |
||||
#puts "[string repeat { } $dep]PARSEFUNCARGS tokpos=$tokpos" |
||||
|
||||
set token [lindex $tokens $tokpos] |
||||
set arg_num 1 |
||||
while 1 { |
||||
if {$token eq ")"} { |
||||
incr tokpos |
||||
append opcodes "invokeStk $arg_num; " |
||||
return $opcodes |
||||
} |
||||
append opcodes [parse 0] |
||||
incr arg_num |
||||
|
||||
set token [lindex $tokens $tokpos] |
||||
switch $token { |
||||
, { incr tokpos } |
||||
) {} |
||||
default { |
||||
error "Calc: expected ')' or ',' but found '$token'" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# We have just seen the '?' of an if-then-else, so parse the rest of that. |
||||
# Returns the bytecode to check the previous condition, then evaluate the |
||||
# appropriate branch. |
||||
proc parseTernary {} { |
||||
variable inprec |
||||
variable tokens |
||||
variable tokpos |
||||
variable depth |
||||
|
||||
set dep [incr depth] |
||||
#puts "[string repeat { } $dep]PARSETERNARY tokpos=$tokpos" |
||||
|
||||
set else else[incr ::labelcount] |
||||
set end end$::labelcount |
||||
append opcodes "jumpFalse $else; [parse $inprec(:)]" |
||||
|
||||
set token [lindex $tokens $tokpos] |
||||
if {$token ne ":"} { |
||||
error "Calc: expected ':' but found '$token'" |
||||
} |
||||
incr tokpos |
||||
|
||||
append opcodes "jump $end; label $else; [parse $inprec(:)]" |
||||
append opcodes "label $end; nop; " |
||||
return $opcodes |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide calc676 [namespace eval calc676 { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,51 @@
|
||||
# -*- tcl -*- |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tcl 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tcl { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tcl [namespace eval punk::tcl { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,817 @@
|
||||
# -*- tcl -*- |
||||
# 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. |
||||
|
||||
#see also: https://daviddeley.com/autohotkey/parameters/parameters.htm#WINNOSTANDARD |
||||
#https://learn.microsoft.com/en-gb/archive/blogs/twistylittlepassagesallalike/everyone-quotes-command-line-arguments-the-wrong-way |
||||
|
||||
#see also: Tip 424: Improving [exec] |
||||
#https://core.tcl-lang.org/tips/doc/trunk/tip/424.md |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winrun { |
||||
namespace export * |
||||
proc twapi_exec {cmdline args} { |
||||
package require twapi |
||||
set psinfo [twapi::create_process {} -cmdline $cmdline {*}$args] |
||||
} |
||||
proc tw_run {cmdline} { |
||||
#twapi::create_file to redirect? |
||||
package require twapi |
||||
set psinfo [twapi::create_process {} -cmdline $cmdline -returnhandles 1] |
||||
lassign $psinfo _pid _tid hpid htid |
||||
set waitresult [twapi::wait_on_handle $hpid -wait -1] |
||||
#e.g timeout, signalled |
||||
if {$waitresult eq "timeout"} { |
||||
puts stderr "tw_run: timeout waiting for process" |
||||
} |
||||
set code [twapi::get_process_exit_code $hpid] |
||||
twapi::close_handle $htid |
||||
twapi::close_handle $hpid |
||||
return [dict create exitcode $code] |
||||
} |
||||
|
||||
#completely raw to windows createprocess API - caller will really need to understand what they're doing. |
||||
proc runraw {args} { |
||||
foreach w $args { |
||||
append cmdline $w " " |
||||
} |
||||
set cmdline [string range $cmdline 0 end-1] |
||||
#puts stdout --$cmdline |
||||
tw_run $cmdline |
||||
} |
||||
|
||||
|
||||
#apparently there is no windows API function to do the reverse of CommandLineToArgvW |
||||
proc quote_win {args} { |
||||
#The algorithm used here is that shown in ArgvQuote from the following article: |
||||
#https://learn.microsoft.com/en-gb/archive/blogs/twistylittlepassagesallalike/everyone-quotes-command-line-arguments-the-wrong-way |
||||
# -- --- ---- --- --- --- --- --- --- --- --- |
||||
set splitargs [internal::get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
set quiet 0 |
||||
if {"-quiet" in $runopts} { |
||||
set quiet 1 |
||||
} |
||||
set verbose 0 |
||||
if {"-verbose" in $runopts} { |
||||
set verbose 1 |
||||
} |
||||
# -- --- ---- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set raw_cmdline "" |
||||
set tcl_list [list] |
||||
set i 0 |
||||
foreach a $cmdargs { |
||||
set copy [internal::objclone $a] |
||||
append raw_cmdline "$copy " |
||||
lappend tcl_list $copy |
||||
if {$i == 0 && !$quiet} { |
||||
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 |
||||
} |
||||
|
||||
#don't run regexp on the list rep |
||||
#set wordranges [regexp -inline -all -indices {\S+} $raw_cmdline] |
||||
#set raw_parts [list] |
||||
#foreach range $wordranges { |
||||
# set word [string range $raw_cmdline {*}$range] |
||||
# lappend raw_parts [internal::objclone $word] |
||||
#} |
||||
|
||||
|
||||
set cmdline "" |
||||
set i 0 |
||||
foreach w $tcl_list { |
||||
#puts "== processing word $w" |
||||
if {$w ne "" && [string first " " $w] < 0 && [string first \t $w] < 0 && [string first \n $w] < 0 && [string first {"} $w] < 0 && [string first \v $w] < 0} { |
||||
append cmdline "$w " |
||||
continue |
||||
} |
||||
append cmdline {"} |
||||
set chars [split $w ""] |
||||
set wordlen [string length $w] |
||||
set nlast [expr {$wordlen -1}] |
||||
for {set n 0} {$n<$wordlen} {incr n} { |
||||
set char [lindex $chars $n] |
||||
set num_backslashes 0 |
||||
while {$char eq "\\" && $n<$nlast} { |
||||
incr num_backslashes |
||||
incr n |
||||
set char [lindex $chars $n] |
||||
} |
||||
if {$n > $nlast} { |
||||
append cmdline [string repeat "\\" [expr {$num_backslashes * 2}]] |
||||
break |
||||
} elseif {$char eq {"}} { |
||||
#escape all backslashes and the following double-quote |
||||
append cmdline [string repeat "\\" [expr {$num_backslashes * 2 + 1}]] $char |
||||
} else { |
||||
append cmdline [string repeat "\\" $num_backslashes] $char |
||||
} |
||||
|
||||
} |
||||
append cmdline {" } |
||||
incr i |
||||
} |
||||
set cmdline [string range $cmdline 0 end-1] |
||||
# ----------------- |
||||
if {$verbose} { |
||||
puts stdout --cmdline->$cmdline |
||||
} |
||||
# ----------------- |
||||
#tw_run $cmdline |
||||
#assert - can be treated as tcl list ? |
||||
return $cmdline |
||||
} |
||||
interp alias "" [namespace current]::quote_wintcl "" ::punk::winrun::quote_win ;#just for symmetry with unquote_wintcl |
||||
|
||||
proc unquote_win {standard_quoted_cmdline} { |
||||
#This twapi call uses the windows api function: CommandLineToArgvW (Twapi_CommandLineToArgv calls it and handles the winchars conversion) |
||||
# - a quoted first word such as the following will not turn out well: "\"cmd\"" |
||||
# - First word on commandline is expected to be the program name - and not wrapped in extra double quotes even if it contains spaces. |
||||
twapi::get_command_line_args $standard_quoted_cmdline |
||||
} |
||||
|
||||
#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. |
||||
proc quote_cmd {args} { |
||||
lassign [internal::get_run_opts $args] _r runopts _c cmdargs |
||||
set use_prequoted [expr {"-useprequoted" in $runopts}] |
||||
set use_preescaped [expr {"-usepreescaped" in $runopts}] |
||||
set verbose [expr {"-verbose" in $runopts}] |
||||
#As this quoting scheme allows & > < etc to execute depending on quote state - it doesn't make sense to default to blocking %var% or !var! here. |
||||
set disallowvars [expr {"-disallowvars" in $runopts}] |
||||
|
||||
if {![llength $cmdargs]} { |
||||
return "Usage: quote_cmd ?runopt? ... ?--? ?cmd? ?cmdarg? ..." |
||||
} |
||||
foreach a $cmdargs { |
||||
set copy [internal::objclone $a] |
||||
append raw_cmdline "$copy " |
||||
lappend tcl_list $copy |
||||
} |
||||
|
||||
set cmdline "" |
||||
set i 0 |
||||
set meta_chars [list {"} "(" ")" ^ < > & |] |
||||
#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. |
||||
append cmdline [string range $w 1 end] " " |
||||
continue |
||||
} |
||||
} |
||||
|
||||
|
||||
for {set n 0} {$n<$wordlen} {incr n} { |
||||
set char [lindex $chars $n] |
||||
set num_carets 0 |
||||
while {$char eq "^" && $n<$nlast} { |
||||
incr num_carets |
||||
incr n |
||||
set char [lindex $chars $n] |
||||
} |
||||
|
||||
if {$char eq {"}} { |
||||
if {$cmd_in_quotes} { |
||||
append qword [string repeat "^" [expr {$num_carets *2 + 1}]] {"} |
||||
set cmd_in_quotes [expr {!$cmd_in_quotes}] |
||||
} else { |
||||
#cmd.exe echo behaviour: |
||||
# ^" -> " |
||||
# ^^" -> ^" |
||||
# ^^^" -> ^" |
||||
# ^^^^" -> ^^" |
||||
if {$num_carets % 2} { |
||||
set cmd_in_quotes 0 ;#odd number of preceding carets make this dquote a literal stay out of quotes mode |
||||
append qword [string repeat "^" [expr {$num_carets}]] {"} ;# |
||||
} else { |
||||
set cmd_in_quotes 1; #carets all refer to each other - quote is uncareted. |
||||
append qword [string repeat "^" [expr {$num_carets + 1}]] {"} ;# |
||||
} |
||||
} |
||||
#set cmd_in_quotes [expr {!$cmd_in_quotes}] |
||||
} else { |
||||
if {$cmd_in_quotes} { |
||||
if {$char in $meta_chars} { |
||||
append qword [string repeat "^" [expr {$num_carets *2 + 1}]] $char ;# |
||||
} else { |
||||
append qword [string repeat "^" [expr {$num_carets *2}]] $char ;# |
||||
} |
||||
} else { |
||||
if {$char in $meta_chars} { |
||||
append qword [string repeat "^" [expr {$num_carets}]] $char |
||||
} else { |
||||
append qword [string repeat "^" [expr {$num_carets}]] $char |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
append cmdline $qword " " |
||||
incr i |
||||
} |
||||
set cmdline [string range $cmdline 0 end-1] |
||||
if {$verbose} { |
||||
puts stdout --cmdline->$cmdline |
||||
} |
||||
return $cmdline |
||||
} |
||||
|
||||
#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? |
||||
#don't caret quotes. |
||||
proc quote_cmdpassthru {args} { |
||||
lassign [internal::get_run_opts $args] _r runopts _c cmdargs |
||||
set allowvars [expr {"-allowvars" in $runopts}] |
||||
set verbose [expr {"-verbose" in $runopts}] |
||||
#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 |
||||
#In practice - it seems less consistent/reliable |
||||
proc quote_cmdpassthru_test {args} { |
||||
lassign [internal::get_run_opts $args] _r runopts _c cmdargs |
||||
set allowvars [expr {"-allowvars" in $runopts}] |
||||
set verbose [expr {"-verbose" in $runopts}] |
||||
|
||||
set tcl_list [lmap v $cmdargs {internal::objclone $v}] |
||||
set meta_chars [list {"} "(" ")" ^ < > & |] |
||||
if {!$allowvars} { |
||||
lappend meta_chars % ! |
||||
} |
||||
set cmdline "" |
||||
foreach w $tcl_list { |
||||
set chars [split $w ""] |
||||
set wordlen [llength $chars] |
||||
#set nlast [expr {$wordlen -1}] |
||||
set qword "" |
||||
for {set n 0} {$n<$wordlen} {incr n} { |
||||
set num_slashes 0 |
||||
while {[lindex $chars $n] eq "\\" && $n<$wordlen} { |
||||
incr num_slashes |
||||
incr n |
||||
} |
||||
if {[lindex $chars $n] eq {"}} { |
||||
append qword [string repeat "\\" [expr {$num_slashes *2}]] {""} ;#double up both |
||||
} else { |
||||
#don't double up slashes if not followed by dquote |
||||
append qword [string repeat "\\" $num_slashes] [lindex $chars $n] |
||||
} |
||||
} |
||||
if {[string first {"} $qword] >=0} { |
||||
append cmdline {"} $qword {"} " " |
||||
} else { |
||||
append cmdline $qword " " |
||||
} |
||||
} |
||||
set cmdline [string range $cmdline 0 end-1] |
||||
if {$verbose} { |
||||
puts stdout --cmdline->$cmdline |
||||
} |
||||
return $cmdline |
||||
} |
||||
|
||||
#caret quoting of all meta_chars |
||||
proc quote_cmdblock {args} { |
||||
lassign [internal::get_run_opts $args] _r runopts _c cmdargs |
||||
set allowvars [expr {"-allowvars" in $runopts}] |
||||
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] |
||||
puts "quote_win win : $standard_escape_line" |
||||
puts "unquote_win CommandLineToArgvW : $argv_from_win32" |
||||
puts " argument count : [llength $argv_from_win32]" |
||||
#so far - gives same output as windows api - this may vary by os version? |
||||
#set argv_from_wintcl [unquote_wintcl $standard_escape_line] |
||||
#puts "unquote_wintcl tcl implementation : $argv_from_win32" |
||||
puts [string repeat - 20] |
||||
|
||||
puts "quote_cmd cmd.exe style quoting : [quote_cmd {*}$args]" |
||||
puts [string repeat - 20] |
||||
|
||||
set cline_blocked [quote_cmdblock {*}$args] |
||||
set cline_blocked_argv [unquote_win $cline_blocked] |
||||
puts "quote_cmdblock cmd.exe protect : $cline_blocked" |
||||
puts "unquote_win CommandLineToArgvW : $cline_blocked_argv" |
||||
puts " argument count : [llength $cline_blocked_argv]" |
||||
puts [string repeat - 20] |
||||
|
||||
set cline_passthru [quote_cmdpassthru {*}$args] |
||||
set cline_passthru_argv [unquote_win $cline_passthru] |
||||
puts "quote_cmdpassthru to argv parser : $cline_passthru" |
||||
puts "unquote_win CommandLineToArgvW : $cline_passthru_argv" |
||||
puts " argument count : [llength $cline_passthru_argv]" |
||||
puts [string repeat - 20] |
||||
|
||||
#if {[file exists [file dirname [info nameofexecutable]]/../scriptlib/showargs.tcl]} { |
||||
# runraw tclsh showargs.tcl {*}$cline_blocked |
||||
#} |
||||
return $argv_from_win32 |
||||
} |
||||
|
||||
proc import {pattern {ns ""}} { |
||||
set pattern ::punk::winrun::$pattern |
||||
if {$ns eq ""} { |
||||
set ns [uplevel 1 {namespace current}] |
||||
} |
||||
internal::nsimport_noclobber $pattern $ns |
||||
} |
||||
|
||||
namespace eval internal { |
||||
# -- --- --- |
||||
#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 |
||||
set options [list "-allowvars" "-allowquotes" "-disallowvars" "-useprequoted" "-usepreescaped" "-quiet" "-verbose" "-verbose2" "-echo" "-nonewline"] |
||||
set aliases [dict create\ |
||||
-av -allowvars\ |
||||
-dv -disallowvars\ |
||||
-aq -allowquotes\ |
||||
-up -useprequoted\ |
||||
-ue -usepreescaped\ |
||||
-q -quiet\ |
||||
-v -verbose\ |
||||
-vv -verbose2\ |
||||
-e -echo\ |
||||
-n -nonewline\ |
||||
] |
||||
#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} { |
||||
puts stderr "Warning - conflicting options -allowvars & -disallowvars specified: $arglist" |
||||
} |
||||
|
||||
#maintain order: runopts $runopts cmdargs $cmdargs as first 4 args (don't break 'lassign [get_runopts $args] _ runopts _ cmdargs') |
||||
#todo - add new keys after these indicating type of commandline etc. |
||||
return [list runopts $runopts cmdargs $cmdargs] |
||||
} |
||||
|
||||
#maintenance: home is punk::ns package |
||||
proc nsimport_noclobber {pattern {ns ""}} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "nsimport_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {$ns eq ""} { |
||||
set ns [uplevel 1 {namespace current}] |
||||
} elseif {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} ;# end ns internal |
||||
#comment out for manual import |
||||
import * :: |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winrun [namespace eval punk::winrun { |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -0,0 +1,15 @@
|
||||
puts stdout "launching punk87" |
||||
|
||||
set dirname [file dirname [info script]] |
||||
if {[file tail $dirname] eq "bin"} { |
||||
if {[file exists [file join $dirname ../src/punk86.vfs/main.tcl]]} { |
||||
#tclsh [file join $dirname ../src/punk86.vfs/main.tcl] {*}$::argv |
||||
source [file join $dirname ../src/punk86.vfs/main.tcl] |
||||
} else { |
||||
puts stderr "Unable to locate punk87 entry-point main.tcl" |
||||
} |
||||
} else { |
||||
puts stderr "punk87 launch script must be run from the punk bin folder" |
||||
} |
||||
puts stdout "-done-" |
||||
|
||||
Loading…
Reference in new issue