diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index bc20be7a..3d454ca8 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -6976,7 +6976,7 @@ namespace eval punk { -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } }] set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts vals + lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] # -- --- --- --- --- --- @@ -7560,80 +7560,14 @@ namespace eval punk { #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. interp alias {} mode {} punk::mode - - #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns - - - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a - } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {[expr {$acount - 1}] == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } - } - } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - - return $matched + tailcall punk::lib::aliases $glob } - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" - } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] - } - return [interp alias "" $aliasorglob "" {*}$args] - } else { - if {![string length $aliasorglob]} { - set aliaslist [punk::aliases] - puts -nonewline stderr $aliaslist - return - } - #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] - if {[llength $target]} { - return $target - } - - if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::aliases $aliasorglob] - puts -nonewline stderr $aliaslist - return - } - return [list] - } + tailcall punk::lib::alias $aliasorglob {*}$args } + #pipeline-toys - put in lib/scriptlib? ##geometric mean #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index aaec24ae..748e39a1 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -105,6 +105,8 @@ tcl::namespace::eval punk::aliascore { #functions must be in export list of their source namespace set aliases [tcl::dict::create\ + aliases ::punk::lib::aliases\ + alias ::punk::lib::alias\ tstr ::punk::lib::tstr\ list_as_lines ::punk::lib::list_as_lines\ lines_as_list ::punk::lib::lines_as_list\ @@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore { set opts [dict merge $defaults $args] set opt_force [dict get $opts -force] + #we never override existing aliases to ::repl::interp* even if -force = 1 + #(these are our safebase aliases) + set ignore_pattern "::repl::interp*" + set ignore_aliases [list] + variable aliases - if {!$opt_force} { - set existing [list] - set conflicts [list] - foreach {a cmd} $aliases { - if {[tcl::info::commands ::$a] ne ""} { - lappend existing $a - if {[llength $cmd] > 1} { - #use alias mechanism - set existing_target [interp alias "" $a] - } else { - #using namespace import - #check origin - set existing_target [tcl::namespace::origin $cmd] + set existing [list] + set conflicts [list] + foreach {a cmd} $aliases { + if {[tcl::info::commands ::$a] ne ""} { + lappend existing $a + set existing_alias [interp alias "" $a] + if {$existing_alias ne ""} { + set existing_target $existing_alias + if {[string match $ignore_pattern $existing_target]} { + #don't consider it a conflict - will use ignore_aliases to exclude it below + lappend ignore_aliases $a + continue } - if {$existing_target ne $cmd} { - #command exists in global ns but doesn't match our defined aliases/imports - lappend conflicts $a + } else { + if {[catch {tcl::namespace::origin $a} existing_command]} { + set existing_command "" } + set existing_target $existing_command + } + + if {$existing_target ne $cmd} { + #command exists in global ns but doesn't match our defined aliases/imports + lappend conflicts $a } } - if {[llength $conflicts]} { - error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" - } } + if {!$opt_force && [llength $conflicts]} { + error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" + } + set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { #puts "aliascore $a -> $cmd" + if {$a in $ignore_aliases} { + continue + } if {[llength $cmd] > 1} { interp alias {} $a {} {*}$cmd } else { @@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore { } } #tcl::namespace::delete $tempns - return [dict keys $aliases] + return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts] } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 515e440c..0f66fc40 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -58,7 +58,7 @@ # #setting -type none indicates a flag that doesn't take a value (solo flag) # -nocomplain -type none # *values -min 1 -max -1 -# } $args]] opts values +# } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { @@ -68,7 +68,7 @@ #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls #[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *opts *values +#[para]valid * lines being with *proc *leaders *opts *values #[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args call above may be something like: @@ -299,6 +299,22 @@ tcl::namespace::eval punk::args { } return $result } + proc flatzip {l1 l2} { + concat {*}[lmap a $l1 b $l2 {list $a $b}] + } + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + proc zero_to_n {n} { + lseq 0 $n + } + } else { + proc zero_to_n {n} { + lsearch -all [lrepeat $n 0] * + } + } + #todo? -synonym/alias ? (applies to opts only not values) #e.g -background -aliases {-bg} -default White @@ -309,8 +325,8 @@ tcl::namespace::eval punk::args { variable argspec_cache #variable argspecs ;#REVIEW!! variable argspec_ids - variable initial_optspec_defaults - variable initial_valspec_defaults + #variable initial_optspec_defaults + #variable initial_valspec_defaults #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. #review - check if there is a built-into-tcl way to do this quickly @@ -335,6 +351,19 @@ tcl::namespace::eval punk::args { -regexprepass {}\ -validationtransform {}\ ] + set leaderspec_defaults [tcl::dict::create\ + -type string\ + -optional 0\ + -allow_ansi 1\ + -validate_ansistripped 0\ + -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ + -choicerestricted 1\ + -multiple 0\ + -regexprepass {}\ + -validationtransform {}\ + ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -357,15 +386,20 @@ tcl::namespace::eval punk::args { #default -allow_ansi to 1 and -validate_ansistripped to 0 and -strip_ansi 0 - it takes time to strip ansi #todo - detect if anything in the spec uses -allow_ansi 0, -validate_ansistripped 1 or -strip_ansi 1 and set a flag indicating if punk::ansi::ta::detect should be run on the argslist + set leader_required [list] set opt_required [list] set val_required [list] + set arg_info [tcl::dict::create] set arg_checks [tcl::dict::create] set opt_defaults [tcl::dict::create] set opt_names [list] ;#defined opts + + set leader_defaults [tcl::dict::create] set val_defaults [tcl::dict::create] set opt_solos [list] #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end + set leader_names [list] set val_names [list] set records [list] @@ -439,10 +473,14 @@ tcl::namespace::eval punk::args { } set proc_info {} set id_info {} ;#e.g -children ?? + set leader_min 0 + set leader_max 0 ;#default 0 but if leader_min is set switches to -1 for no limit + #(common case of no leaders specified) set opt_any 0 set val_min 0 set val_max -1 ;#-1 for no limit set spec_id "" + set argspace "leaders" ;#leaders -> options -> values foreach ln $records { set trimln [tcl::string::trim $ln] switch -- [tcl::string::index $trimln 0] { @@ -477,6 +515,10 @@ tcl::namespace::eval punk::args { set proc_info $starspecs } opts { + if {$argspace eq "values"} { + error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + } + set argspace "options" foreach {k v} $starspecs { switch -- $k { -any - @@ -537,7 +579,86 @@ tcl::namespace::eval punk::args { } } } + leaders { + if {$argspace in [list options values]} { + error "punk::args::definition - *leaders declaration must come before all options and values" + } + foreach {k v} $starspecs { + switch -- $k { + -min - + -minvalues { + if {$v < 0} { + error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + } + set leader_min $v + if {$leader_max == 0} { + set leader_max -1 + } + } + -max - + -maxvalues { + if {$v < -1} { + error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + } + set leader_max $v + } + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + #review - only apply to certain types? + tcl::dict::set leaderspec_defaults $k $v + } + -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { + if {$v} { + tcl::dict::unset leaderspec_defaults $k + } + } + -type { + switch -- $v { + int - integer { + set v int + } + char - character { + set v char + } + bool - boolean { + set v bool + } + dict - dictionary { + set v dict + } + list { + + } + default { + #todo - disallow unknown types unless prefixed with custom- + } + } + tcl::dict::set leaderspec_defaults $k $v + } + -optional - + -allow_ansi - + -validate_ansistripped - + -strip_ansi - + -regexprepass - + -regexprefail - + -validationtransform - + -multiple { + tcl::dict::set leaderspec_defaults $k $v + } + default { + set known { -min -minvalues -max -maxvalues\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ + -type -optional -allow_ansi -validate_ansistripped -strip_ansi -multiple\ + -regexprepass -regexprefail -validationtransform\ + } + error "punk::args::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + } + } + } + + } values { + set argspace "values" foreach {k v} $starspecs { switch -- $k { -min - @@ -610,11 +731,16 @@ tcl::namespace::eval punk::args { } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" } } continue } elseif {$firstchar eq "-"} { + if {$argspace eq "leaders"} { + set argspace "options" + } elseif {$argspace eq "values"} { + error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname @@ -625,8 +751,16 @@ tcl::namespace::eval punk::args { set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs - tcl::dict::set argspecs -ARGTYPE value - lappend val_names $argname + if {$argspace eq "leaders"} { + tcl::dict::set argspecs -ARGTYPE leader + lappend leader_names $argname + if {$leader_max == 0} { + set leader_max [llength $leader_names] + } + } else { + tcl::dict::set argspecs -ARGTYPE value + lappend val_names $argname + } set is_opt 0 } #assert - we only get here if it is a value or flag specification line. @@ -634,7 +768,11 @@ tcl::namespace::eval punk::args { if {$is_opt} { set spec_merged $optspec_defaults } else { - set spec_merged $valspec_defaults + if {$argspace eq "values"} { + set spec_merged $valspec_defaults + } else { + set spec_merged $leaderspec_defaults + } } foreach {spec specval} $argspecs { #literal-key switch - bytecompiled to jumpTable @@ -727,22 +865,36 @@ tcl::namespace::eval punk::args { if {$is_opt} { lappend opt_required $argname } else { - lappend val_required $argname + if {$argspace eq "leaders"} { + lappend leader_required $argname + } else { + lappend val_required $argname + } } } if {[tcl::dict::exists $argspecs -default]} { if {$is_opt} { tcl::dict::set opt_defaults $argname [tcl::dict::get $argspecs -default] } else { - tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + if {$argspace eq "leaders"} { + tcl::dict::set leader_defaults $argname [tcl::dict::get $argspecs -default] + } else { + tcl::dict::set val_defaults $argname [tcl::dict::get $argspecs -default] + } } } } + # REVIEW + foreach leadername [lrange $leader_names 0 end] { + if {[tcl::dict::get $arg_info $leadername -multiple]} { + error "bad key -multiple on argument spec for leader '$valname'. Only the last value argument specification can be marked -multiple" + } + } #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" } } if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { @@ -750,14 +902,25 @@ tcl::namespace::eval punk::args { set spec_id "autoid_[incr id_counter]" } + #todo - document that ambiguities in API are likely if both *leaders and *values used + #todo - do some checks for obvious bad definitions involving a mix of *leaders and *values (e.g with optional options) - set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen - set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + + set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + set opt_checks_defaults [tcl::dict::remove $optspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen + set val_checks_defaults [tcl::dict::remove $valspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minlen set result [tcl::dict::create\ id $spec_id\ arg_info $arg_info\ arg_checks $arg_checks\ + leader_defaults $leader_defaults\ + leader_required $leader_required\ + leader_names $leader_names\ + leader_min $leader_min\ + leader_max $leader_max\ + leaderspec_defaults $leaderspec_defaults\ + leader_checks_defaults $leader_checks_defaults\ opt_defaults $opt_defaults\ opt_required $opt_required\ opt_names $opt_names\ @@ -782,13 +945,33 @@ tcl::namespace::eval punk::args { return $result } - proc get_spec {id} { + proc get_spec {id {patternlist *}} { variable argspec_ids if {[tcl::dict::exists $argspec_ids $id]} { - return [tcl::dict::get $argspec_ids $id] + if {$patternlist eq "*"} { + return [tcl::dict::get $argspec_ids $id] + } else { + set spec [tcl::dict::get $argspec_ids $id] + set result "" + set specdict [definition $spec] + set arg_info [dict get $specdict arg_info] + foreach pat $patternlist { + set matches [dict keys $arg_info $pat] + foreach m $matches { + set def [dict get $arg_info $m] + set def [dict remove $def -ARGTYPE] + append result \n "$m $def" + } + } + return $result + } } return } + #proc get_spec_leaders ?? + #proc get_spec_opts ?? + #proc get_spec_values ?? + proc get_spec_ids {{match *}} { variable argspec_ids return [tcl::dict::keys $argspec_ids $match] @@ -876,17 +1059,17 @@ tcl::namespace::eval punk::args { $t add_column -headers $blank_header_col $t add_column -headers $blank_header_col if {"$procname$prochelp" eq ""} { - $t configure_header 0 -values {Arg Type Default Multiple Help} + $t configure_header 0 -values {Arg Type Default Multi Help} } elseif {$procname eq ""} { $t configure_header 0 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] - $t configure_header 1 -values {Arg Type Default Multiple Help} + $t configure_header 1 -values {Arg Type Default Multi Help} } elseif {$prochelp eq ""} { $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] - $t configure_header 1 -values {Arg Type Default Multiple Help} + $t configure_header 1 -values {Arg Type Default Multi Help} } else { $t configure_header 0 -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] $t configure_header 1 -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] - $t configure_header 2 -values {Arg Type Default Multiple Help} + $t configure_header 2 -values {Arg Type Default Multi Help} } @@ -894,7 +1077,8 @@ tcl::namespace::eval punk::args { #set A_DEFAULT [a+ brightwhite Brightgreen] set A_DEFAULT "" set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) set A_PREFIX [a+ green] ;#use a+ so colour off can apply if {$A_PREFIX eq ""} { set A_PREFIX [a+ underline] @@ -930,20 +1114,21 @@ tcl::namespace::eval punk::args { set opt_names_display $opt_names } } - set trailing_val_names [dict get $spec_dict val_names] ;#temporarily assign all as trailing - set leading_val_names [list] - dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - if {![string match -* $argname]} { - lappend leading_val_names [lpop trailing_val_names 0] - } else { - break - } - } - if {![llength $leading_val_names] && ![llength $opt_names]} { - #all vals were actually trailing - no opts - set trailing_val_names $leading_val_names - set leading_val_names {} - } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} set leading_val_names_display $leading_val_names set trailing_val_names_display $trailing_val_names @@ -954,7 +1139,7 @@ tcl::namespace::eval punk::args { foreach argshow $argnames_display arg $argnames { set arginfo [dict get $spec_dict arg_info $arg] if {[dict exists $arginfo -default]} { - set default $A_DEFAULT[dict get $arginfo -default]$RST + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { set default "" } @@ -1022,7 +1207,14 @@ tcl::namespace::eval punk::args { } else { set multiple "" } - $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] + if {[::punk::args::Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { + set argshow "?${argshow}?" + } + set typeshow [dict get $arginfo -type] + if {$typeshow eq "none"} { + set typeshow "$typeshow $soloflag" + } + $t add_row [list $argshow $typeshow $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG } @@ -1087,7 +1279,7 @@ tcl::namespace::eval punk::args { #[para]argumentname -key val -ky2 val2... #[para]where the valid keys for each option specification are: -default -type -range -choices #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value - #[para]lines beginning with *proc *opts or *values also take -key val pairs and can be used to set defaults and control settings. + #[para]lines beginning with *proc *leaders *opts or *values also take -key val pairs and can be used to set defaults and control settings. #[para]*opts or *values lines can appear multiple times with defaults affecting flags/values that follow. #[arg_def list rawargs] #[para] This is a list of the arguments to parse. Usually it will be the $args value from the containing proc, @@ -1162,363 +1354,242 @@ tcl::namespace::eval punk::args { # todo - consider allowing last leading positional to have -multiple 1 but only if there exists an eopts marker later (--) ? set opts $opt_defaults set pre_values {} - dict for {a info} $arg_info { - #todo - flag for possible subhandler - whether leading - or not (shellfilter concept) - if {![string match -* $a]} { - lappend pre_values [lpop rawargs 0] - } else { - break - } - } - #assert - rawargs has been reduced by leading positionals + #dict for {a info} $arg_info { + # #todo - flag for possible subhandler - whether leading - or not (shellfilter concept) + # if {![string match -* $a]} { + # #lappend pre_values [lpop rawargs 0] + # if {[catch {lpop rawargs 0} val]} { + # break + # } else { + # lappend pre_values $val + # } + # } else { + # break + # } + #} - if {$id ne "jtest"} { - set arglist {} - set post_values {} - #val_min, val_max - #puts stderr "rawargs: $rawargs" - #puts stderr "arg_info: $arg_info" - if {[lsearch $rawargs -*] >= 0} { - #at least contains flaglike things.. - set maxidx [expr {[llength $rawargs] -1}] - if {$val_max == -1} { - set vals_total_possible [llength $rawargs] - set vals_remaining_possible $vals_total_possible - } else { - set vals_total_possible $val_max - set vals_remaining_possible $vals_total_possible + set argnames [dict keys $arg_info] + set optnames [lsearch -all -inline $argnames -*] + set ridx 0 + set rawargs_copy $rawargs + if {$leader_max != 0} { + foreach r $rawargs_copy { + if {$leader_max != -1 && $ridx > $leader_max-1} { + break } - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - set remaining_args_including_this [expr {[llength $rawargs] - $i}] - #lowest val_min is 0 - if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] + if {[string match -* $r]} { + if {$r eq "--"} { break } - - if {[tcl::string::match -* $a]} { - if {$a eq "--"} { - #remaining num args <= val_min already covered above - if {$val_max != -1} { - #finite max number of vals - if {$remaining_args_including_this == $val_max} { - #assume it's a value. - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - } else { - #assume it's an end-of-options marker - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - } else { - #unlimited number of post_values accepted - #treat this as eopts - we don't care if remainder look like options or not - lappend flagsreceived -- - set arglist [lrange $rawargs 0 $i] - set post_values [lrange $rawargs $i+1 end] - } - break - } else { - set fullopt [tcl::prefix match -error "" $opt_names $a] - if {$fullopt ne ""} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { - #non-solo - #check if it was actually a value that looked like a flag - if {$i == $maxidx} { - #if no optvalue following - assume it's a value - #(caller should probably have used -- before it) - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - - set flagval [lindex $rawargs $i+1] - if {[dict get $arg_info $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - #review - what if user sets first value that happens to match a default? - if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { - #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - incr vals_remaining_possible -2 - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt - } - } else { - #solo - if {[tcl::dict::get $arg_info $fullopt -multiple]} { - if {[tcl::dict::get $opts $fullopt] == 0} { - #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - incr vals_remaining_possible -1 - } - lappend flagsreceived $fullopt ;#dups ok - } else { - #unmatched option flag - #comparison to val_min already done above - if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { - #todo - look at optspec_default and see if solo/vs opt-val pair - #we may need to lookahead by 2 regarding val_max val_min - - #even with optany - assume an unknown within the space of possible values is a value - #unmatched option in right position to be considered a value - treat like eopts - #review - document that an unspecified arg within range of possible values will act like eopts -- - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] - break - } - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option - tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $opt_checks_defaults - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[tcl::dict::get $arg_info $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - lappend flagsreceived $a ;#adhoc flag as supplied - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a - } - incr vals_remaining_possible -2 - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $arg_info $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 - } - } else { - tcl::dict::set opts $a 1 - } - incr vals_remaining_possible -1 - } - } else { - #set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" - arg_error $errmsg $argspecs $fullopt - } - } - } + set matchopt [::tcl::prefix::match -error {} $optnames $r] + if {$matchopt ne ""} { + #flaglike matches a known flag - don't treat as leader + break + } + if {![string match -* [lindex $argnames $ridx]]} { + #there is a named leading positional for this position + lappend pre_values [lpop rawargs 0] + incr ridx + continue } else { - #not flaglike - set arglist [lrange $rawargs 0 $i-1] - set post_values [lrange $rawargs $i end] break } } - set values [list {*}$pre_values {*}$post_values] - } else { - set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected - set arglist [list] + lappend pre_values [lpop rawargs 0] + incr ridx } - #puts stderr "--> arglist: $arglist" - #puts stderr "--> values: $values" } + #assert - rawargs has been reduced by leading positionals - if {$id eq "jtest"} { - if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { - lappend flagsreceived -- - set values [lrange $rawargs $eopts+1 end] - set arglist [lrange $rawargs 0 $eopts-1] - set maxidx [expr {[llength $arglist]-1}] + set leaders [list] + set arglist {} + set post_values {} + #val_min, val_max + #puts stderr "rawargs: $rawargs" + #puts stderr "arg_info: $arg_info" + if {[lsearch $rawargs -*] >= 0} { + #at least contains flaglike things.. + set maxidx [expr {[llength $rawargs] -1}] + if {$val_max == -1} { + set vals_total_possible [llength $rawargs] + set vals_remaining_possible $vals_total_possible + } else { + set vals_total_possible $val_max + set vals_remaining_possible $vals_total_possible + } for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $arglist $i] - if {![tcl::string::match -* $a]} { - #we can't treat as first positional arg - as it comes before the eopt indicator -- - arg_error "punk::args::get_dict bad options for [Get_caller]. Expected flag (leading -) at position $i got:$rawargs" $argspecs + set a [lindex $rawargs $i] + set remaining_args_including_this [expr {[llength $rawargs] - $i}] + #lowest val_min is 0 + if {$remaining_args_including_this <= $val_min} { + # if current arg is -- it will pass through as a value here + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break } - if {![catch {tcl::prefix match -message "options for %caller%. Unexpected option" $opt_names $a } fullopt]} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { - #non-solo - set flagval [lindex $arglist $i+1] - if {[dict get $arg_info $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - #review - what if user sets first value that happens to match a default? - if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { - #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt [list $flagval] + if {[tcl::string::match -* $a]} { + if {$a eq "--"} { + #remaining num args <= val_min already covered above + if {$val_max != -1} { + #finite max number of vals + if {$remaining_args_including_this == $val_max} { + #assume it's a value. + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] } else { - tcl::dict::lappend opts $fullopt $flagval + #assume it's an end-of-options marker + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] } } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt + #unlimited number of post_values accepted + #treat this as eopts - we don't care if remainder look like options or not + lappend flagsreceived -- + set arglist [lrange $rawargs 0 $i] + set post_values [lrange $rawargs $i+1 end] } + break } else { - #type none (solo-flag) - if {[tcl::dict::get $arg_info $fullopt -multiple]} { - if {[tcl::dict::get $opts $fullopt] == 0} { - #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - } - lappend flagsreceived $fullopt ;#dups ok - } else { - if {$opt_any} { - set newval [lindex $arglist $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option - tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $opt_checks_defaults - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[tcl::dict::get $arg_info $a -multiple]} { - tcl::dict::lappend opts $a $newval - } else { - tcl::dict::set opts $a $newval - } - lappend flagsreceived $a ;#adhoc flag as supplied - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a - } - } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $arg_info $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 - } else { - tcl::dict::lappend opts $a 1 + set fullopt [tcl::prefix match -error "" $opt_names $a] + if {$fullopt ne ""} { + if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { + #non-solo + #check if it was actually a value that looked like a flag + if {$i == $maxidx} { + #if no optvalue following - assume it's a value + #(caller should probably have used -- before it) + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break } - } else { - tcl::dict::set opts $a 1 - } - } - } else { - #delay Get_caller so only called in the unhappy path - set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] - arg_error $errmsg $argspecs $fullopt - } - } - } - } else { - if {[lsearch $rawargs -*] >= 0} { - #no -- end of opts indicator - #to support option values with leading dash e.g -offset -1 , we can't just use the last flagindex to determine start of positional args. - #we break on first non-flag looking argument that isn't in an option's value position and use that index as the division. - #The caller should use -- if the first positional arg is likely or has the potential to start with a dash. - - set maxidx [expr {[llength $rawargs]-1}] - for {set i 0} {$i <= $maxidx} {incr i} { - set a [lindex $rawargs $i] - #we can automatically rule out arguments containing whitespace from the set of simple flags beginning with a dash - #This helps for example when first value is a dict or list in which the first item happens to begin with a dash - #explicit -- still safer in many cases, but this is a reasonable and fast enough test - if {![tcl::string::match -* $a] || [regexp {\s+} $a]} { - #assume beginning of positional args - incr i -1 - break - } - - if {![catch {tcl::prefix match -message "options for %caller%. Unexpected option" $opt_names $a } fullopt]} { - if {[tcl::dict::get $arg_info $fullopt -type] ne "none"} { - #non-solo - set flagval [lindex $rawargs $i+1] - if {[dict get $arg_info $fullopt -multiple]} { - #don't lappend to default - we need to replace if there is a default - #review - what if user sets first value that happens to match a default? - if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { - #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt [list $flagval] - } else { - tcl::dict::lappend opts $fullopt $flagval - } - } else { - tcl::dict::set opts $fullopt $flagval - } - #incr i to skip flagval - if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt - } - } else { - #type none (solo-flag) - if {[tcl::dict::get $arg_info $fullopt -multiple]} { - if {[tcl::dict::get $opts $fullopt] == 0} { - #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified - tcl::dict::set opts $fullopt 1 - } else { - tcl::dict::lappend opts $fullopt 1 - } - } else { - tcl::dict::set opts $fullopt 1 - } - } - lappend flagsreceived $fullopt ;#dups ok - } else { - if {$opt_any} { - set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option - tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt - tcl::dict::set arg_checks $a $opt_checks_defaults - if {[tcl::dict::get $arg_info $a -type] ne "none"} { - if {[tcl::dict::get $arg_info $a -multiple]} { - tcl::dict::lappend opts $a $newval + set flagval [lindex $rawargs $i+1] + if {[dict get $arg_info $fullopt -multiple]} { + #don't lappend to default - we need to replace if there is a default + #review - what if user sets first value that happens to match a default? + if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { + #first occurrence of this flag, whilst stored value matches default + tcl::dict::set opts $fullopt [list $flagval] + } else { + tcl::dict::lappend opts $fullopt $flagval + } } else { - tcl::dict::set opts $a $newval + tcl::dict::set opts $fullopt $flagval } - lappend flagsreceived $a ;#adhoc flag as supplied + #incr i to skip flagval + incr vals_remaining_possible -2 if {[incr i] > $maxidx} { - arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last option $fullopt at index [expr {$i-1}] which is not marked with -type none" $argspecs $fullopt } } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none - if {[tcl::dict::get $arg_info $a -multiple]} { - if {![tcl::dict::exists $opts $a]} { - tcl::dict::set opts $a 1 + #solo + if {[tcl::dict::get $arg_info $fullopt -multiple]} { + if {[tcl::dict::get $opts $fullopt] == 0} { + #review - what if default at time opt was specified is not zero? we will end up with more items in the list than the number of times the flag was specified + tcl::dict::set opts $fullopt 1 } else { - tcl::dict::lappend opts $a 1 + tcl::dict::lappend opts $fullopt 1 } } else { - tcl::dict::set opts $a 1 + tcl::dict::set opts $fullopt 1 } + incr vals_remaining_possible -1 } + lappend flagsreceived $fullopt ;#dups ok } else { - #delay Get_caller so only called in the unhappy path - set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] - arg_error $errmsg $argspecs $fullopt + #unmatched option flag + #comparison to val_min already done above + if {$val_max ne -1 && $remaining_args_including_this <= $val_max} { + #todo - look at optspec_default and see if solo/vs opt-val pair + #we may need to lookahead by 2 regarding val_max val_min + + #even with optany - assume an unknown within the space of possible values is a value + #unmatched option in right position to be considered a value - treat like eopts + #review - document that an unspecified arg within range of possible values will act like eopts -- + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break + } + if {$opt_any} { + set newval [lindex $rawargs $i+1] + #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt + tcl::dict::set arg_checks $a $opt_checks_defaults + if {[tcl::dict::get $arg_info $a -type] ne "none"} { + if {[tcl::dict::get $arg_info $a -multiple]} { + tcl::dict::lappend opts $a $newval + } else { + tcl::dict::set opts $a $newval + } + lappend flagsreceived $a ;#adhoc flag as supplied + if {[incr i] > $maxidx} { + arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs $a + } + incr vals_remaining_possible -2 + } else { + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + if {[tcl::dict::get $arg_info $a -multiple]} { + if {![tcl::dict::exists $opts $a]} { + tcl::dict::set opts $a 1 + } else { + tcl::dict::lappend opts $a 1 + } + } else { + tcl::dict::set opts $a 1 + } + incr vals_remaining_possible -1 + } + } else { + #set errmsg [tcl::string::map [list %caller% [Get_caller]] $fullopt] + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" + arg_error $errmsg $argspecs $fullopt + } } } + } else { + #not flaglike + set arglist [lrange $rawargs 0 $i-1] + set post_values [lrange $rawargs $i end] + break } - set arglist [lrange $rawargs 0 $i] - set values [lrange $rawargs $i+1 end] - #puts "$i--->arglist:$arglist" - #puts "$i--->values:$values" - } else { - set values $rawargs ;#no -flags detected - set arglist [list] } + #set values [list {*}$pre_values {*}$post_values] + set leaders $pre_values + set values $post_values + } else { + set leaders $pre_values + set values $rawargs + #set values [list {*}$pre_values {*}$rawargs] ;#no -flags detected + set arglist [list] } - } + #puts stderr "--> arglist: $arglist" + #puts stderr "--> values: $values" + set positionalidx 0 ;#index for unnamed positionals (both leaders and values) + set ldridx 0 + set leadernames_received [list] + set leaders_dict $leader_defaults + set num_leaders [llength $leaders] + foreach leadername $leader_names ldr $leaders { + if {$ldridx+1 > $num_leaders} { + break + } + if {$leadername ne ""} { + tcl::dict::set leaders_dict $leadername $ldr + lappend leadernames_received $leadername + } else { + tcl::dict::set leaders_dict $positionalidx $ldr + tcl::dict::set arg_info $positionalidx $leaderspec_defaults + tcl::dict::set arg_checks $positionalidx $leader_checks_defaults + lappend leadernames_received $positionalidx + } + incr ldridx + incr positionalidx + } set validx 0 set in_multiple "" @@ -1547,13 +1618,29 @@ tcl::namespace::eval punk::args { tcl::dict::lappend values_dict $in_multiple $val #name already seen } else { - tcl::dict::set values_dict $validx $val - tcl::dict::set arg_info $validx $valspec_defaults - tcl::dict::set arg_checks $validx $val_checks_defaults - lappend valnames_received $validx + tcl::dict::set values_dict $positionalidx $val + tcl::dict::set arg_info $positionalidx $valspec_defaults + tcl::dict::set arg_checks $positionalidx $val_checks_defaults + lappend valnames_received $positionalidx } } incr validx + incr positionalidx + } + + if {$leader_max == -1} { + #only check min + if {$num_leaders < $leader_min} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected at least $leader_min" $argspecs + } + } else { + if {$num_leaders < $leader_min || $num_leaders > $leader_max} { + if {$leader_min == $leader_max} { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected exactly $leader_min" $argspecs + } else { + arg_error "bad number of leading values for [Get_caller]. Got $num_leaders leaders. Expected between $leader_min and $leader_max inclusive" $argspecs + } + } } if {$val_max == -1} { @@ -1592,6 +1679,9 @@ tcl::namespace::eval punk::args { # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us + if {[llength [set missing [punklib_ldiff $leader_required $leadernames_received]]]} { + arg_error "Required leader missing for [Get_caller]. missing values: '$missing' marked with -optional false - so must be present" $argspecs + } if {[llength [set missing [punklib_ldiff $opt_required $flagsreceived]]]} { arg_error "Required option missing for [Get_caller]. missing flags: '$missing' are marked with -optional false - so must be present in full-length form" $argspecs } @@ -1605,7 +1695,7 @@ tcl::namespace::eval punk::args { #todo - allow defaults outside of choices/ranges #check types,ranges,choices - set opts_and_values [tcl::dict::merge $opts $values_dict] + set opts_and_values [tcl::dict::merge $leaders_dict $opts $values_dict] #set combined_defaults [tcl::dict::merge $val_defaults $opt_defaults] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash #puts "---opts_and_values:$opts_and_values" #puts "---arg_info:$arg_info" @@ -1657,10 +1747,16 @@ tcl::namespace::eval punk::args { set choiceprefix [tcl::dict::get $thisarg -choiceprefix] set choicerestricted [tcl::dict::get $thisarg -choicerestricted] set nocase [tcl::dict::get $thisarg -nocase] - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - set dname opts - } else { - set dname values_dict + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + set dname leaders_dict + } + option { + set dname opts + } + value { + set dname values_dict + } } set idx 0 ;# #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes @@ -1819,8 +1915,8 @@ tcl::namespace::eval punk::args { lappend pass_quick_list_e_check $e_check } } - set remaining_e [punk::lib::ldiff $vlist $pass_quick_list_e] - set remaining_e_check [punk::lib::ldiff $vlist_check $pass_quick_list_e_check] + set remaining_e [punklib_ldiff $vlist $pass_quick_list_e] + set remaining_e_check [punklib_ldiff $vlist_check $pass_quick_list_e_check] } if {$regexprefail ne ""} { foreach e $remaining_e e_check $remaining_e_check { @@ -2036,23 +2132,37 @@ tcl::namespace::eval punk::args { if {$is_strip_ansi} { set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname $stripped_list - } else { - tcl::dict::set values_dict $argname $stripped_list + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict $argname $stripped_list + } + option { + tcl::dict::set opts $argname $stripped_list + } + value { + tcl::dict::set values_dict $argname $stripped_list + } } } else { - if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { - tcl::dict::set opts $argname [lindex $stripped_list 0] - } else { - tcl::dict::set values_dict [lindex $stripped_list 0] + switch -- [tcl::dict::get $thisarg -ARGTYPE] { + leader { + tcl::dict::set leaders_dict [lindex $stripped_list 0] + } + option { + tcl::dict::set opts $argname [lindex $stripped_list 0] + } + value { + tcl::dict::set values_dict [lindex $stripped_list 0] + } } } } } #maintain order of opts $opts values $values as caller may use lassign. - return [tcl::dict::create opts $opts values $values_dict] + set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] + set received_posns [concat {*}[lmap a $receivednames b [zero_to_n [expr {[llength $receivednames]-1}]] {list $a $b}]] ;#flat zip named with overall posn including opts + return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] } #proc sample1 {p1 args} { @@ -2063,6 +2173,16 @@ tcl::namespace::eval punk::args { #} + punk::args::definition { + *id punk::args::TEST + *opts -optional 0 + -o1 -default 111 -help "opt 1 mandatory" + *opts -optional 1 + -o2 -default 222 -help "opt 2 optional" + *values -min 0 -max 1 + v -help\ + "v1 optional" + } #*** !doctools diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index f56fd7a2..d1042cea 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1556,7 +1556,7 @@ namespace eval punk::fileline::lib { set argd [punk::args::get_dict { -offset -default 0 } $args] - lassign [dict values $argd] opts remainingargs + lassign [dict values $argd] leaders opts remainingargs } diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index ebb4a992..b5a8356d 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -211,6 +211,9 @@ tcl::namespace::eval punk::lib::compat { #*** !doctools #[list_begin definitions] + + + if {"::lremove" ne [info commands ::lremove]} { #puts stderr "Warning - no built-in lremove" interp alias {} lremove {} ::punk::lib::compat::lremove @@ -393,6 +396,80 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } + #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) + proc aliases {{glob *}} { + set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns_mapped [string map {:: \uFFFF} $ns] + #puts stderr "aliases ns: $ns_mapped" + set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: + if {![string length [lindex $segments end]]} { + #special case for :: only include leading segment rather thatn {} {} + set segments [lrange $segments 0 end-1] + } + set segcount [llength $segments] ;#only match number of segments matching current ns + + + set all_aliases [interp aliases {}] + set matched [list] + foreach a $all_aliases { + #normalize with leading :: + if {![string match ::* $a]} { + set abs ::$a + } else { + set abs $a + } + + set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] + set acount [llength $asegs] + #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" + if {[expr {$acount - 1}] == $segcount} { + if {[lrange $asegs 0 end-1] eq $segments} { + if {[string match $glob [lindex $asegs end]]} { + #report this alias in the current namespace - even though there may be no matching command + lappend matched $a ;#add raw alias token which may or may not have leading :: + } + } + } + } + #set matched_abs [lsearch -all -inline $all_aliases $glob] + + return $matched + } + + proc alias {{aliasorglob ""} args} { + set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $args]} { + if {$aliasorglob in [interp aliases ""]} { + set existing [interp alias "" $aliasorglob] + puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + } + if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + return [interp alias "" $aliasorglob ""] + } + return [interp alias "" $aliasorglob "" {*}$args] + } else { + if {![string length $aliasorglob]} { + set aliaslist [punk::lib::aliases] + puts -nonewline stderr $aliaslist + return + } + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias + set target [interp alias "" $aliasorglob] + if {[llength $target]} { + return $target + } + + if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { + set aliaslist [punk::lib::aliases $aliasorglob] + puts -nonewline stderr $aliaslist + return + } + return [list] + } + } + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == # Maintenance - This is the primary source for tm_version... functions # - certain packages script require these but without package dependency @@ -2894,7 +2971,7 @@ namespace eval punk::lib { lassign [tcl::dict::values [punk::args::get_dict { -joinchar -default \n *values -min 1 -max 1 - } $args]] opts values + } $args]] leaders opts values puts "opts:$opts" puts "values:$values" return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] @@ -2936,7 +3013,7 @@ namespace eval punk::lib { lassign [tcl::dict::values [punk::args::get_dict { *opts -any 1 -block -default {} - } $args]] opts valuedict + } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] } diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 6abeb799..66f87868 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -153,7 +153,7 @@ namespace eval punk::mix::commandset::module { module -type string }] set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts values + lassign [dict values $argd] leaders opts values set module [dict get $values module] #set opts [dict merge $defaults $args] diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index 909444a3..268341d1 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -643,7 +643,7 @@ tcl::namespace::eval punk::nav::fs { *values -min 0 -max -1 } set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts values_dict + lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] set opt_formatsizes [dict get $opts -formatsizes] @@ -726,6 +726,7 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { + *id punk::nav::fs::dirfiles_dict *opts -any 0 -searchbase -default "" -tailglob -default "\uFFFF" @@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs { *values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts vals + lassign [dict values $argd] leaders opts vals set searchspecs [dict values $vals] #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" @@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs { *values -min 1 -max -1 -type dict } set argd [punk::args::get_dict $argspecs $args] - lassign [dict values $argd] opts vals + lassign [dict values $argd] leaders opts vals set list_of_dicts [dict values $vals] diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 7c75d1f7..4db394dc 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -20,8 +20,8 @@ package require punk::lib package require punk::args -tcl::namespace::eval ::punk_dynamic::ns { - +tcl::namespace::eval ::punk::ns::evaluator { + #eval-_NS_xxx_NS_etc procs } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -29,6 +29,12 @@ tcl::namespace::eval punk::ns { variable ns_current "::" variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp + catch { + package require debug + debug define punk.ns.compile + #debug on punk.ns.compile + #debug level punk.ns.compile 3 + } #leading colon makes it hard (impossible?) to call directly if not within the namespace proc ns/ {v {ns_or_glob ""} args} { @@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns { return $body } proc nseval {fqns script} { + #create one proc for each fully qualified namespace to evaluate script if {![string match ::* $fqns]} { error "nseval only accepts a fully qualified namespace" } - set loc [string map {:: _sep_} $fqns] + set loc [string map {:: _NS_} $fqns] #set cmd ::punk::pipecmds::nseval_$loc - set cmd ::punk_dynamic::ns::eval-$loc + set cmd ::punk::ns::evaluator::eval-$loc if {$cmd ni [info commands $cmd]} { append body \n [nseval_script $fqns] proc $cmd {script} $body - debug.punk.pipe.compile {proc $cmd} 6 + debug.punk.ns.compile {proc $cmd} 2 } tailcall $cmd $script } @@ -800,14 +807,23 @@ tcl::namespace::eval punk::ns { - set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] - set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + #set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}] + set chwidest1 [tcl::mathfunc::max {*}$lenlist1] + + #set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] + set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]] #wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed - set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] - set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + #set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]] + + #set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]] + #set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]] + #set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] + set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]] set displaylist [list] set col1 [string repeat " " [expr {$chwidest1 + 8}]] @@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns { *values -min 1 -max 1 sourcepattern -type string -optional 0 } - lassign [dict values [punk::args::get_dict $argspecs $args]] opts values + lassign [dict values [punk::args::get_dict $argspecs $args]] leaders opts values set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 0a3ef980..d00430ab 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -662,7 +662,7 @@ namespace eval punk::path { *values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 } $args] - lassign [dict values $argd] opts values + lassign [dict values $argd] leaders opts values set tailglobs [dict values $values] # -- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 784aeb65..422fb62b 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -2857,7 +2857,7 @@ namespace eval repl { set ::argc 0 set ::argv {} set ::auto_path %autopath% - #puts stdout "safe interp" + #puts stdout "safebase interp" #flush stdout namespace eval ::codeinterp { variable errstack {} @@ -2879,6 +2879,17 @@ namespace eval repl { } else { interp share {} [shellfilter::stack::item_tophandle stderr] code } + interp eval code { + package require punk::lib + package require textblock ;#may fail to load term::ansi::code::macros - (only required for altg) + } + + #JMN + interp eval code { + package require shellfilter + } + + #work around bug in safe base which won't load Tcl libs that have deeper nesting #(also affects tcllib page/plugins folder) set termversions [package versions term] @@ -2896,13 +2907,15 @@ namespace eval repl { } #code invokehidden source c:/repo/jn/shellspy/modules/punk/lib-0.1.1.tm - code alias detok ::safe::DetokPath code + code alias detok ::safe::DetokPath code ;#temp - this violates the point of the {$p(:X:)} paths #review - exit should do something slightly different # see ::safe::interpDelete code alias exit ::repl::interphelpers::quit code alias ::md5::md5 ::repl::interphelpers::md5 + code alias ::fconfigure ::fconfigure ;#needed for shellfilter + code alias ::file ::file interp eval code [list package provide md5 $md5version] } else { interp create code diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm new file mode 100644 index 00000000..52c01ab8 --- /dev/null +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -0,0 +1,1491 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 +# +# @@ Meta Begin +# Application punk::safe 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::safe 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk::safe - safebase interpreters}] [comment {-- Description at end of page heading --}] +#[require punk::safe] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::safe +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::safe +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::safe::class { + #*** !doctools + #[subsection {Namespace punk::safe::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::safe::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::safe::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + # ------------------------------------------------------------------------------ + # Using Interpreter Names with Namespace Qualifiers + # ------------------------------------------------------------------------------ + # (1) We wish to preserve compatibility with existing code, in which Safe Base + # interpreter names have no namespace qualifiers. + # (2) safe::interpCreate and the rest of the Safe Base previously could not + # accept namespace qualifiers in an interpreter name. + # (3) The interp command will accept namespace qualifiers in an interpreter + # name, but accepts distinct interpreters that will have the same command + # name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). + # (4) To satisfy these constraints, Safe Base interpreter names will be fully + # qualified namespace names with no excess colons and with the leading "::" + # omitted. + # (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. + # Reject such names. + # (6) We could: + # (a) EITHER reject usable but non-compliant names (e.g. excess colons) in + # interpCreate, interpInit; + # (b) OR accept such names and then translate to a compliant name in every + # command. + # The problem with (b) is that the user will expect to use the name with the + # interp command and will find that it is not recognised. + # E.g "interpCreate ::foo" creates interpreter "foo", and the user's name + # "::foo" works with all the Safe Base commands, but "interp eval ::foo" + # fails. + # So we choose (a). + # (7) The command + # namespace upvar ::punk::safe::system S$child state + # becomes + # namespace upvar ::punk::safe::system [VarName $child] state + # ------------------------------------------------------------------------------ + + proc RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $child} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return + } + + proc VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] + } + + + # Helper function to resolve the dual way of specifying staticsok (either + # by -noStatics or -statics 0) + proc InterpStatics {argd} { + set statics [dict get $argd opts -statics] + set noStatics [dict get $argd opts -noStatics] + set flag [dict exists $argd received] ;#-noStatics was explicitly supplied as an argument + if {$flag + && (!$noStatics == !$statics) + && [dict exists $argd received -statics]} { + return -code error "conflicting values given for -statics and -noStatics" + } + if {$flag} { + return [expr {!$noStatics}] + } else { + return $statics + } + } + + # Helper function to resolve the dual way of specifying nested loading + # (either by -nestedLoadOk or -nested 1) + proc InterpNested {argd} { + set nested [dict get $argd opts -nested] + set nestedLoadOk [dict get $argd opts -nestedLoadOk] + set flag [dict exists $argd received -nestedLoadOk] + if {$flag + && (!$nestedLoadOk != !$nested) + && [dict exists $argd received -nested]} { + return -code error "conflicting values given for -nested and -nestedLoadOk" + } + if {$flag} { + return $nestedLoadOk + } else { + return $nested + } + } + + #Returns the virtual token for directory number N. + proc PathToken {n} { + # We need to have a ":" in the token string so [file join] on the + # mac won't turn it into a relative path. + return "\$p(:$n:)" ;# Form tested by case 7.2 + } + + # + # translate virtual path into real path + # + proc TranslatePath {child path} { + namespace upvar ::punk::safe::system [VarName $child] state + + # somehow strip the namespaces 'functionality' out (the danger is that + # we would strip valid macintosh "../" queries... : + if {[string match "*::*" $path] || [string match "*..*" $path]} { + return -code error "invalid characters in path $path" + } + # Use a cached map instead of computed local vars and subst. + return [string map $state(access_path,map) $path] + } + + # file name control (limit access to files/resources that should be a + # valid tcl source file) + proc CheckFileName {child file} { + # This used to limit what can be sourced to ".tcl" and forbid files + # with more than 1 dot and longer than 14 chars, but I changed that + # for 8.4 as a safe interp has enough internal protection already to + # allow sourcing anything. - hobbs + + if {![file exists $file]} { + # don't tell the file path + return -code error "no such file or directory" + } + + if {![file readable $file]} { + # don't tell the file path + return -code error "not readable" + } + } + + + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::safe::lib ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::safe { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + namespace path {::punk::safe::lib} + #variable xyz + + + + #*** !doctools + #[subsection {Namespace punk::safe}] + #[para] Core API functions for punk::safe + #[list_begin definitions] + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + # Accessor method for ::punk::safe::system::AutoPathSync + # Usage: ::punk::safe::setSyncMode ?newValue? + # Respond to changes by calling Setup again, preserving any + # caller-defined logging. This allows complete equivalence with + # prior Safe Base behavior if AutoPathSync is true. + # + # >>> WARNING <<< + # + # DO NOT CHANGE AutoPathSync EXCEPT BY THIS COMMAND - IT IS VITAL THAT WHENEVER + # THE VALUE CHANGES, THE EXISTING PARSE TOKENS ARE DELETED AND Setup IS CALLED + # AGAIN. + # (The initialization of AutoPathSync at the end of this file is acceptable + # because Setup has not yet been called.) + + proc setSyncMode {args} { + upvar ::punk::safe::system::AutoPathSync AutoPathSync + #*** !doctools + #[call [fun setSyncMode] [arg args]] + + switch -- [llength $args] { + 0 {} + 1 { + set newValue [lindex $args 0] + if {![string is boolean -strict $newValue]} { + return -code error "new value must be a valid boolean" + } + set args [expr {$newValue && $newValue}] + if {([info vars ::punk::safe::system::S*] ne {}) && ($args != $AutoPathSync)} { + return -code error \ + "cannot set new value while Safe Base child interpreters exist" + } + if {($args != $AutoPathSync)} { + set AutoPathSync {*}$args + #::tcl::OptKeyDelete ::safe::interpCreate + #::tcl::OptKeyDelete ::safe::interpIC + set TmpLog [setLogCmd] + ::punk::safe::system::Setup + setLogCmd $TmpLog + } + } + default { + set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} + return -code error $msg + } + } + + return $AutoPathSync + } + + # Set (or get) the logging mechanism + + proc setLogCmd {args} { + upvar ::punk::safe::system::Log Log + switch -- [llength $args] { + 0 { + return $Log + } + 1 { + set Log [lindex $args 0] + } + default { + set Log $args + } + } + + if {$Log eq ""} { + # Disable logging completely. Calls to it will be compiled out + # of all users. + proc ::punk::safe::Log {args} {} + } else { + # Activate logging, define proper command. + + proc ::punk::safe::Log {child msg {type ERROR}} { + upvar ::punk::safe::system::Log Log + {*}$Log "$type for child $child : $msg" + return + } + } + } + + proc interpCreate {args} { + upvar ::punk::safe::system::AutoPathSync AutoPathSync + if {$AutoPathSync} { + #REVIEW + set autoPath {} + } + set argd [punk::args::get_by_id punk::safe::interpCreate $args] + set child [dict get $argd leaders child] + set autoPath [dict get $argd opts -autoPath] + punk::safe::lib::RejectExcessColons $child + + set withAutoPath [dict exists $argd received -autoPath] ;#boolean as to whether -autoPath was explicitly supplied + punk::safe::system::do_interpCreate $child\ + [dict get $argd opts -accessPath]\ + [InterpStatics $argd]\ + [InterpNested $argd]\ + [dict get $argd opts -deleteHook]\ + $autoPath\ + $withAutoPath + + + } + proc interpInit {args} { + upvar ::punk::safe::system::AutoPathSync AutoPathSync + if {$AutoPathSync} { + set autoPath {} + } + set argd [punk::args::get_by_id punk::safe::interpIC $args] + set child [dict get $argd leaders child] + set autoPath [dict get $argd opts -autoPath] + if {![::interp exists $child]} { + return -code error "\"$child\" is not an interpreter" + } + punk::safe::lib::RejectExcessColons $child + + set withAutoPath [dict exists $argd received -autoPath] + do_interpInit $child\ + [dict get $argd opts -accessPath]\ + [InterpStatics $argd]\ + [InterpNested $argd]\ + [dict get $argd opts -deleteHook]\ + $autoPath\ + $withAutoPath + } + + # Check that the given child is "one of us" + proc CheckInterp {child} { + namespace upvar ::punk::safe::system [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { + return -code error \ + "\"$child\" is not an interpreter managed by ::punk::safe::" + } + } + + # Interface/entry point function and front end for "Configure". This code + # is awfully pedestrian because it would need more coupling and support + # between the way we store the configuration values in safe::interp's and + # the Opt package. Obviously we would like an OptConfigure to avoid + # duplicating all this code everywhere. + # -> TODO (the app should share or access easily the program/value stored + # by opt) + + # This is even more complicated by the boolean flags with no values that + # we had the bad idea to support for the sake of user simplicity in + # create/init but which makes life hard in configure... + # So this will be hopefully written and some integrated with opt1.0 + # (hopefully for tcl9.0 ?) + proc interpConfigure {args} { + upvar ::punk::safe::system::AutoPathSync AutoPathSync + + switch [llength $args] { + 1 { + # If we have exactly 1 argument the semantic is to return all + # the current configuration. We still call OptKeyParse though + # we know that "child" is our given argument because it also + # checks for the "-help" option. + set argd [punk::args::get_by_id punk::safe::interpIC $args] + set child [dict get $argd leaders child] + + CheckInterp $child + namespace upvar ::punk::safe::system [VarName $child] state + + set TMP [list \ + [list -accessPath $state(access_path)] \ + [list -statics $state(staticsok)] \ + [list -nested $state(nestedok)] \ + [list -deleteHook $state(cleanupHook)] \ + ] + if {!$AutoPathSync} { + lappend TMP [list -autoPath $state(auto_path)] + } + return [join $TMP] + } + 2 { + # If we have exactly 2 arguments the semantic is a "configure get" + lassign $args child arg + + set spec_dict [punk::args::definition [punk::args::get_spec punk::safe::interpIC]] + set opt_names [dict get $spec_dict opt_names] + + CheckInterp $child + set name [tcl::prefix::match -error {} $opt_names $arg] + namespace upvar ::punk::safe::system [VarName $child] state + + switch -exact -- $name { + -accessPath { + return [list -accessPath $state(access_path)] + } + -autoPath { + if {$AutoPathSync} { + return -code error "unknown flag $name (bug)" + } else { + return [list -autoPath $state(auto_path)] + } + } + -statics { + return [list -statics $state(staticsok)] + } + -nested { + return [list -nested $state(nestedok)] + } + -deleteHook { + return [list -deleteHook $state(cleanupHook)] + } + -noStatics { + # it is most probably a set in fact but we would need + # then to jump to the set part and it is not *sure* + # that it is a set action that the user want, so force + # it to use the unambiguous -statics ?value? instead: + return -code error\ + "ambiguous query (get or set -noStatics ?)\ + use -statics instead" + } + -nestedLoadOk { + return -code error\ + "ambiguous query (get or set -nestedLoadOk ?)\ + use -nested instead" + } + default { + return -code error "unknown flag $name. Known options: $opt_names" + } + } + } + default { + # Otherwise we want to parse the arguments like init and create did + + #set Args [::tcl::OptKeyParse ::safe::interpIC $args] + set argd [punk::args::get_by_id punk::safe::interpIC $args] + set child [dict get $argd leaders child] + CheckInterp $child + namespace upvar ::punk::safe::system [VarName $child] state + + # Get the current (and not the default) values of whatever has + # not been given: + if {![dict exists $argd received -accessPath]} { + set doreset 0 + set accessPath $state(access_path) + } else { + set doreset 1 + } + if {(!$AutoPathSync) && (![dict exists $argd received -autoPath])} { + set autoPath $state(auto_path) + } elseif {$AutoPathSync} { + set autoPath {} + } else { + #review + set autoPath [dict get $argd opts -autoPath] + } + + if { + ![dict exists $argd received -statics] + && ![dict exists $argd received -noStatics] + } then { + set statics $state(staticsok) + } else { + set statics [InterpStatics $argd] + } + if { + [dict exists $argd received -nested] || + [dict exists $argd received -nestedLoadOk] + } then { + set nested [InterpNested $argd] + } else { + set nested $state(nestedok) + } + if {![dict exists $argd received -deleteHook]} { + set deleteHook $state(cleanupHook) + } else { + set deleteHook [dict get $argd opts -deleteHook] + } + # Now reconfigure + set withAutoPath [dict exists $argd received -autoPath] + ::punk::safe::system::InterpSetConfig $child $accessPath $statics $nested $deleteHook $autoPath $withAutoPath + + # auto_reset the child (to completely sync the new access_path) tests safe-9.8 safe-9.9 + if {$doreset} { + if {[catch {::interp eval $child {auto_reset}} msg]} { + Log $child "auto_reset failed: $msg" + } else { + Log $child "successful auto_reset" NOTICE + } + + # Sync the paths used to search for Tcl modules. + ::interp eval $child {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_child)] > 0} { + ::interp eval $child [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_child)]] + } + + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $child {package names}] { + if {[::interp eval $child [list package provide $pkg]] eq ""} { + ::interp eval $child [list package forget $pkg] + } + } + } + return + } + } + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::safe ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::safe::system { + namespace path {::punk::safe ::punk::safe::lib} + + #*** !doctools + #[subsection {Namespace punk::safe::system}] + #[para] Internal functions that are not part of the API + + # AutoPathSync + # + # Set AutoPathSync to 0 to give a child's ::auto_path the same meaning as + # for an unsafe interpreter: the package command will search its directories + # and first-level subdirectories for pkgIndex.tcl files; the auto-loader + # will search its directories for tclIndex files. The access path and + # module path will be maintained as separate values, and ::auto_path will + # not be updated when the user calls ::punk::safe::interpAddToAccessPath to add to + # the access path. If the user specifies an access path when calling + # interpCreate, interpInit or interpConfigure, it is the user's + # responsibility to define the child's auto_path. If these commands are + # called with no (or empty) access path, the child's auto_path will be set + # to a tokenized form of the parent's auto_path, and these directories and + # their first-level subdirectories will be added to the access path. + # + # Set to 1 for "traditional" behavior: a child's entire access path and + # module path are copied to its ::auto_path, which is updated whenever + # the user calls ::punk::safe::interpAddToAccessPath to add to the access path. + variable AutoPathSync 0 + + # Log command, set via 'setLogCmd'. Logging is disabled when empty. + variable Log {} + + + proc Setup {} { + #### + # + # Setup the arguments parsing + # + #### + variable AutoPathSync + + set OPTS { + *id punk::safe::OPTS + *opts -optional 1 + -accessPath -type list -default {} -help\ + "access path for the child" + -noStatics -type none -default 0 -help\ + "prevent loading of statically linked pkgs" + -statics -type boolean -default true -help\ + "loading of statically linked pkgs" + -nestedLoadOk -type none -default 0 -help\ + "allow nested loading" + -nested -type boolean -default false -help\ + "nested loading" + -deleteHook -default {} -help\ + "delete hook" + } + if {!$AutoPathSync} { + append OPTS \n {-autoPath -type list -default {} -help\ + "::auto_path for the child"} + } + punk::args::definition $OPTS + set optlines [punk::args::get_spec punk::safe::OPTS -*] + + set INTERPCREATE { + *id punk::safe::interpCreate + *leaders + child -type string -default "" -optional 1 -help\ + "name of the child (optional)" + } + append INTERPCREATE \n $optlines + append INTERPCREATE \n {*values -max 0} + punk::args::definition $INTERPCREATE + + + set INTERPIC { + *id punk::safe::interpIC + *leaders + child -type string -optional 0 -help\ + "name of the child" + } + append INTERPIC \n $optlines + append INTERPIC \n {*values -max 0} + punk::args::definition $INTERPIC + + + #### + # + # Default: No logging. + # + #### + + punk::safe::setLogCmd {} + + # Log eventually. + # To enable error logging, set Log to {puts stderr} for instance, + # via setLogCmd. + return + } + + proc do_interpCreate { + child + access_path + staticsok + nestedok + deletehook + autoPath + withAutoPath + } { + # Create the child. + # If evaluated in ::punk::safe, the interpreter command for foo is ::foo; + # but for foo::bar is ::punk::safe::foo::bar. So evaluate in :: instead. + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] + } else { + # empty argument: generate child name + set child [::interp create -safe] + } + Log $child "Created" NOTICE + + # Initialize it. (returns child name) + do_interpInit $child $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath + } + + proc do_interpInit { + child + access_path + staticsok + nestedok + deletehook + autoPath + withAutoPath + } { + + # Configure will generate an access_path when access_path is empty. + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath + + # NB we need to add [namespace current], aliases are always absolute + # paths. + + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, + # convertto, and system, but not "encoding system " to set the + # system encoding. + # Handling Tcl Modules, we need a restricted form of Glob. + # This alias interposes on the 'exit' command and cleanly terminates + # the child. + + foreach {command alias} { + source AliasSource + load AliasLoad + exit interpDelete + glob AliasGlob + } { + ::interp alias $child $command {} [namespace current]::$alias $child + } + + # UGLY POINT! These commands are safe (they're ensembles with unsafe + # subcommands), but is assumed to not be by existing policies so it is + # hidden by default. Hack it... + foreach command {encoding file} { + ::interp alias $child $command {} interp invokehidden $child $command + } + + # This alias lets the child have access to a subset of the 'file' + # command functionality. + foreach subcommand {dirname extension rootname tail} { + ::interp alias $child ::tcl::file::$subcommand {} \ + ::punk::safe::system::AliasFileSubcommand $child $subcommand + } + + # Subcommand of 'encoding' that has special handling; [encoding system] is + # OK provided it has no other arguments passed to it. + ::interp alias $child ::tcl::encoding::system {} \ + ::punk::safe::system::AliasEncodingSystem $child + + # Subcommands of info + ::interp alias $child ::tcl::info::nameofexecutable {} \ + ::punk::safe::system::AliasExeName $child + + # Source init.tcl and tm.tcl into the child, to get auto_load and + # other procedures defined: + + if {[catch {::interp eval $child { + source [file join $tcl_library init.tcl] + }} msg opt]} { + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into child $child ($msg)" + } + + if {[catch {::interp eval $child { + source [file join $tcl_library tm.tcl] + }} msg opt]} { + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into child $child ($msg)" + } + + # Sync the paths used to search for Tcl modules. This can be done only + # now, after tm.tcl was loaded. + namespace upvar ::punk::safe::system [VarName $child] state + if {[llength $state(tm_path_child)] > 0} { + ::interp eval $child [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_child)]] + } + return $child + } + + # + # InterpSetConfig (was setAccessPath) : + # Sets up child virtual access path and corresponding structure within + # the parent. Also sets the tcl_library in the child to be the first + # directory in the path. + # NB: If you change the path after the child has been initialized you + # probably need to call "auto_reset" in the child in order that it gets + # the right auto_index() array values. + # + # It is the caller's responsibility, if it supplies a non-empty value for + # access_path, to make the first directory in the path suitable for use as + # tcl_library, and (if ![setSyncMode]), to set the child's ::auto_path. + + proc InterpSetConfig {child access_path staticsok nestedok deletehook autoPath withAutoPath} { + global auto_path + variable AutoPathSync + + # determine and store the access path if empty + if {$access_path eq ""} { + set access_path $auto_path + + # Make sure that tcl_library is in auto_path and at the first + # position (needed by setAccessPath) + set where [lsearch -exact $access_path [info library]] + if {$where < 0} { + # not found, add it. + set access_path [linsert $access_path 0 [info library]] + Log $child "tcl_library was not in auto_path,\ + added it to child's access_path" NOTICE + } elseif {$where != 0} { + # not first, move it first + set access_path [linsert \ + [lreplace $access_path $where $where] \ + 0 [info library]] + Log $child "tcl_libray was not in first in auto_path,\ + moved it to front of child's access_path" NOTICE + } + + set raw_auto_path $access_path + + # Add 1st level subdirs (will searched by auto loading from tcl + # code in the child using glob and thus fail, so we add them here + # so by default it works the same). + set access_path [AddSubDirs $access_path] + } else { + set raw_auto_path $autoPath + } + + if {$withAutoPath} { + set raw_auto_path $autoPath + } + + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ + nestedok=$nestedok deletehook=($deletehook)" NOTICE + + if {!$AutoPathSync} { + Log $child "Setting auto_path=($raw_auto_path)" NOTICE + } + + namespace upvar ::punk::safe::system [VarName $child] state + + + # clear old autopath if it existed + # build new one + # Extend the access list with the paths used to look for Tcl Modules. + # We save the virtual form separately as well, as syncing it with the + # child has to be defered until the necessary commands are present for + # setup. + set norm_access_path {} + set child_access_path {} + set map_access_path {} + set remap_access_path {} + set child_tm_path {} + + set i 0 + foreach dir $access_path { + set token [PathToken $i] + lappend child_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + incr i + } + + # Set the child auto_path to a tokenized raw_auto_path. + # Silently ignore any directories that are not in the access path. + # If [setSyncMode], SyncAccessPath will overwrite this value with the + # full access path. + # If ![setSyncMode], Safe Base code will not change this value. + set tokens_auto_path {} + foreach dir $raw_auto_path { + if {[dict exists $remap_access_path $dir]} { + lappend tokens_auto_path [dict get $remap_access_path $dir] + } + } + ::interp eval $child [list set auto_path $tokens_auto_path] + + # Add the tcl::tm directories to the access path. + set morepaths [::tcl::tm::list] + set firstpass 1 + while {[llength $morepaths]} { + set addpaths $morepaths + set morepaths {} + + foreach dir $addpaths { + # Prevent the addition of dirs on the tm list to the + # result if they are already known. + if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend child_tm_path [dict get $remap_access_path $dir] + } + continue + } + + set token [PathToken $i] + lappend access_path $dir + lappend child_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the child_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend child_tm_path $token + } + incr i + + # [Bug 2854929] + # Recursively find deeper paths which may contain + # modules. Required to handle modules with names like + # 'platform::shell', which translate into + # 'platform/shell-X.tm', i.e arbitrarily deep + # subdirectories. + lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] + } + set firstpass 0 + } + + set state(access_path) $access_path + set state(access_path,map) $map_access_path + set state(access_path,remap) $remap_access_path + set state(access_path,norm) $norm_access_path + set state(access_path,child) $child_access_path + set state(tm_path_child) $child_tm_path + set state(staticsok) $staticsok + set state(nestedok) $nestedok + set state(cleanupHook) $deletehook + + if {!$AutoPathSync} { + set state(auto_path) $raw_auto_path + } + + SyncAccessPath $child + return + } + + # AliasSource is the target of the "source" alias in safe interpreters. + proc AliasSource {child args} { + set argc [llength $args] + # Extended for handling of Tcl Modules to allow not only "source + # filename", but "source -encoding E filename" as well. + if {[lindex $args 0] eq "-encoding"} { + incr argc -2 + set encoding [lindex $args 1] + set at 2 + if {$encoding eq "identity"} { + Log $child "attempt to use the identity encoding" + return -code error "permission denied" + } + } else { + set at 0 + set encoding utf-8 + } + if {$argc != 1} { + set msg "wrong # args: should be \"source ?-encoding E? fileName\"" + Log $child "$msg ($args)" + return -code error $msg + } + set file [lindex $args $at] + + # get the real path from the virtual one. + if {[catch { + set realfile [TranslatePath $child $file] + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # check that the path is in the access path of that child + if {[catch { + FileInAccessPath $child $realfile + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. + if {[catch { + CheckFileName $child $realfile + } msg]} { + Log $child "$realfile:$msg" + return -code error -errorcode {POSIX EACCES} $msg + } + + # Passed all the tests, lets source it. Note that we do this all manually + # because we want to control [info script] in the child so information + # doesn't leak so much. [Bug 2913625] + set old [::interp eval $child {info script}] + set replacementMsg "script error" + set code [catch { + set f [open $realfile] + fconfigure $f -encoding $encoding -eofchar \x1A + set contents [read $f] + close $f + ::interp eval $child [list info script $file] + } msg opt + ] + + if {$code == 0} { + # See [Bug 1d26e580cf] + if {[string index $contents 0] eq "\uFEFF"} { + set contents [string range $contents 1 end] + } + set code [catch {::interp eval $child $contents} msg opt] + set replacementMsg $msg + } + catch {interp eval $child [list info script $old]} + # Note that all non-errors are fine result codes from [source], so we must + # take a little care to do it properly. [Bug 2923613] + if {$code == 1} { + Log $child $msg + return -code error $replacementMsg + } + return -code $code -options $opt $msg + } + + + # AliasLoad is the target of the "load" alias in safe interpreters. + proc AliasLoad {child file args} { + set argc [llength $args] + if {$argc > 2} { + set msg "load error: too many arguments" + Log $child "$msg ($argc) {$file $args}" + return -code error $msg + } + + # prefix (can be empty if file is not). + set prefix [lindex $args 0] + + namespace upvar ::punk::safe::system [VarName $child] state + + # Determine where to load. load use a relative interp path and {} + # means self, so we can directly and safely use passed arg. + set target [lindex $args 1] + if {$target ne ""} { + # we will try to load into a sub sub interp; check that we want to + # authorize that. + if {!$state(nestedok)} { + Log $child "loading to a sub interp (nestedok)\ + disabled (trying to load $prefix to $target)" + return -code error "permission denied (nested load)" + } + } + + # Determine what kind of load is requested + if {$file eq ""} { + # static loading + if {$prefix eq ""} { + set msg "load error: empty filename and no prefix" + Log $child $msg + return -code error $msg + } + if {!$state(staticsok)} { + Log $child "static loading disabled\ + (trying to load $prefix to $target)" + return -code error "permission denied (static library)" + } + } else { + # file loading + + # get the real path from the virtual one. + try { + set file [TranslatePath $child $file] + } on error msg { + Log $child $msg + return -code error "permission denied" + } + + # check the translated path + try { + FileInAccessPath $child $file + } on error msg { + Log $child $msg + return -code error "permission denied (path)" + } + } + + try { + return [::interp invokehidden $child load $file $prefix $target] + } on error msg { + # Some libraries return no error message. + set msg0 "load of library for prefix $prefix failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } + Log $child $msg + return -code error $msg + } + } + + + + + # FileInAccessPath raises an error if the file is not found in the list of + # directories contained in the (parent side recorded) child's access path. + + # the security here relies on "file dirname" answering the proper + # result... needs checking ? + proc FileInAccessPath {child file} { + namespace upvar ::punk::safe::system [VarName $child] state + set access_path $state(access_path) + + if {[file isdirectory $file]} { + return -code error "\"$file\": is a directory" + } + set parent [file dirname $file] + + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_parent [file normalize $parent] + + namespace upvar ::punk::safe::system [VarName $child] state + if {$norm_parent ni $state(access_path,norm)} { + return -code error "\"$file\": not in access_path" + } + } + + proc DirInAccessPath {child dir} { + namespace upvar ::punk::safe::system [VarName $child] state + set access_path $state(access_path) + + if {[file isfile $dir]} { + return -code error "\"$dir\": is a file" + } + + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_dir [file normalize $dir] + + namespace upvar ::punk::safe::system [VarName $child] state + if {$norm_dir ni $state(access_path,norm)} { + return -code error "\"$dir\": not in access_path" + } + } + + # This procedure is used to report an attempt to use an unsafe member of an + # ensemble command. + + proc BadSubcommand {child command subcommand args} { + set msg "not allowed to invoke subcommand $subcommand of $command" + Log $child $msg + return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg + } + + # AliasEncodingSystem is the target of the "encoding system" alias in safe + # interpreters. + proc AliasEncodingSystem {child args} { + try { + # Must not pass extra arguments; safe interpreters may not set the + # system encoding but they may read it. + if {[llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"encoding system\"" + } + } on error {msg options} { + Log $child $msg + return -options $options $msg + } + tailcall ::interp invokehidden $child tcl:encoding:system + } + + # Various minor hiding of platform features. [Bug 2913625] + + proc AliasExeName {child} { + return "" + } + + # AliasFileSubcommand handles selected subcommands of [file] in safe + # interpreters that are *almost* safe. In particular, it just acts to + # prevent discovery of what home directories exist. + + proc AliasFileSubcommand {child subcommand name} { + tailcall ::interp invokehidden $child tcl:file:$subcommand $name + } + + # AliasGlob is the target of the "glob" alias in safe interpreters. + + proc AliasGlob {child args} { + variable AutoPathSync + Log $child "GLOB ! $args" NOTICE + set cmd {} + set at 0 + array set got { + -directory 0 + -nocomplain 0 + -join 0 + -tails 0 + -- 0 + } + + if {$::tcl_platform(platform) eq "windows"} { + set dirPartRE {^(.*)[\\/]([^\\/]*)$} + } else { + set dirPartRE {^(.*)/([^/]*)$} + } + + set dir {} + set virtualdir {} + + while {$at < [llength $args]} { + switch -glob -- [set opt [lindex $args $at]] { + -nocomplain - -- - -tails { + lappend cmd $opt + set got($opt) 1 + incr at + } + -join { + set got($opt) 1 + incr at + } + -types - -type { + lappend cmd -types [lindex $args [incr at]] + incr at + } + -directory { + if {$got($opt)} { + return -code error \ + {"-directory" cannot be used with "-path"} + } + set got($opt) 1 + set virtualdir [lindex $args [incr at]] + incr at + } + -* { + Log $child "Safe base rejecting glob option '$opt'" + return -code error "Safe base rejecting glob option '$opt'" + # unsafe/unnecessary options rejected: -path + } + default { + break + } + } + if {$got(--)} break + } + + # Get the real path from the virtual one and check that the path is in the + # access path of that child. Done after basic argument processing so that + # we know if -nocomplain is set. + if {$got(-directory)} { + try { + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir + } on error msg { + Log $child $msg + if {$got(-nocomplain)} return + return -code error "permission denied" + } + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $child {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" + } + + # Apply the -join semantics ourselves (hence -join not copied to $cmd) + if {$got(-join)} { + set args [lreplace $args $at end [join [lrange $args $at end] "/"]] + } + + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + + set firstPattern [llength $cmd] + foreach opt [lrange $args $at end] { + if {![regexp $dirPartRE $opt -> thedir thefile]} { + set thedir . + # The *.tm search comes here. + } + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { + set mapped 0 + foreach d [glob -directory [TranslatePath $child $virtualdir] \ + -types d -tails *] { + catch { + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] + lappend cmd [file join $d $thefile] + set mapped 1 + } + } + if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). + } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. + try { + DirInAccessPath $child [TranslatePath $child \ + [file join $virtualdir $thedir]] + } on error msg { + Log $child $msg + if {$got(-nocomplain)} continue + return -code error "permission denied" + } + lappend cmd $opt + } + + Log $child "GLOB = $cmd" NOTICE + + if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + return + } + try { + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. + set entries [::interp invokehidden $child glob {*}$cmd] + } on error msg { + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. + Log $child $msg + return -code error "script error" + } + + Log $child "GLOB < $entries" NOTICE + + # Translate path back to what the child should see. + set res {} + set l [string length $dir] + foreach p $entries { + if {[string equal -length $l $dir $p]} { + set p [string replace $p 0 [expr {$l-1}] $virtualdir] + } + lappend res $p + } + + Log $child "GLOB > $res" NOTICE + return $res + } + + + # Add (only if needed, avoid duplicates) 1 level of sub directories to an + # existing path list. Also removes non directories from the returned + # list. + proc AddSubDirs {pathList} { + set res {} + foreach dir $pathList { + if {[file isdirectory $dir]} { + # check that we don't have it yet as a children of a previous + # dir + if {$dir ni $res} { + lappend res $dir + } + foreach sub [glob -directory $dir -nocomplain *] { + if {[file isdirectory $sub] && ($sub ni $res)} { + # new sub dir, add it ! + lappend res $sub + } + } + } + } + return $res + } + + # + # Sets the child auto_path to its recorded access path. Also sets + # tcl_library to the first token of the access path. + # + proc SyncAccessPath {child} { + variable AutoPathSync + namespace upvar ::punk::safe::system [VarName $child] state + + set child_access_path $state(access_path,child) + if {$AutoPathSync} { + ::interp eval $child [list set auto_path $child_access_path] + + Log $child "auto_path in $child has been set to $child_access_path"\ + NOTICE + } + + # This code assumes that info library is the first element in the + # list of access path's. See -> InterpSetConfig for the code which + # ensures this condition. + + ::interp eval $child [list \ + set tcl_library [lindex $child_access_path 0]] + return + } + +} + +tcl::namespace::eval punk::safe { + # internal variables (must not begin with "S") + + + # The package maintains a state array per child interp under its + # control. The name of this array is S. This array is + # brought into scope where needed, using 'namespace upvar'. The S + # prefix is used to avoid that a child interp called "Log" smashes + # the "Log" variable. + # + # The array's elements are: + # + # access_path : List of paths accessible to the child. + # access_path,norm : Ditto, in normalized form. + # access_path,child : Ditto, as the path tokens as seen by the child. + # access_path,map : dict ( token -> path ) + # access_path,remap : dict ( path -> token ) + # auto_path : List of paths requested by the caller as child's ::auto_path. + # tm_path_child : List of TM root directories, as tokens seen by the child. + # staticsok : Value of option -statics + # nestedok : Value of option -nested + # cleanupHook : Value of option -deleteHook + # + # In principle, the child can change its value of ::auto_path - + # - a package might add a path (that is already in the access path) for + # access to tclIndex files; + # - the script might remove some elements of the auto_path. + # However, this is really the business of the parent, and the auto_path will + # be reset whenever the token mapping changes (i.e. when option -accessPath is + # used to change the access path). + # -autoPath is now stored in the array and is no longer obtained from + # the child. + +} +::punk::safe::system::Setup + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::safe [tcl::namespace::eval punk::safe { + variable pkg punk::safe + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/safe-buildversion.txt b/src/modules/punk/safe-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/safe-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/shellfilter-0.1.9.tm b/src/modules/shellfilter-0.1.9.tm index a74d9c11..fe443ece 100644 --- a/src/modules/shellfilter-0.1.9.tm +++ b/src/modules/shellfilter-0.1.9.tm @@ -13,46 +13,60 @@ tcl::namespace::eval shellfilter::log { variable allow_adhoc_tags 1 variable open_logs [tcl::dict::create] + variable is_enabled 0 + + proc disable {} { + variable is_enabled + set is_enabled 0 + proc ::shellfilter::log::open {tag settingsdict} {} + proc ::shellfilter::log::write {tag msg} {} + proc ::shellfilter::log::write_sync {tag msg} {} + proc ::shellfilter::log::close {tag} {} + } - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - package require shellthread - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + proc enable {} { + variable is_enabled + set is_enabled 1 + #'tag' is an identifier for the log source. + # each tag will use it's own thread to write to the configured log target + proc ::shellfilter::log::open {tag {settingsdict {}}} { + upvar ::shellfilter::sources sourcelist + if {![dict exists $settingsdict -tag]} { + tcl::dict::set settingsdict -tag $tag + } else { + #review + if {$tag ne [tcl::dict::get $settingsdict -tag]} { + error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" + } } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + lappend sourcelist $tag } + + #note new_worker + set worker_tid [shellthread::manager::new_worker $tag $settingsdict] + #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" + return $worker_tid } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + proc ::shellfilter::log::write {tag msg} { + upvar ::shellfilter::sources sourcelist + variable allow_adhoc_tags + if {!$allow_adhoc_tags} { + if {$tag ni $sourcelist} { + error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" + } + } + shellthread::manager::write_log $tag $msg + } + #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written + proc ::shellfilter::log::write_sync {tag msg} { + shellthread::manager::write_log $tag $msg -async 0 + } + proc ::shellfilter::log::close {tag} { + #shellthread::manager::close_worker $tag + shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed + } + } #review @@ -73,6 +87,12 @@ tcl::namespace::eval shellfilter::log { } } } + if {[catch {package require shellthread}]} { + shellfilter::log::disable + } else { + shellfilter::log::enable + } + } namespace eval shellfilter::pipe { #write channel for program. workerthread reads other end of fifo2 and writes data somewhere @@ -1594,7 +1614,13 @@ namespace eval shellfilter::stack { set tag "SHELLFILTER::STACK" #JMN - load from config #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - ::shellfilter::log::open $tag {-syslog ""} + if {[catch { + ::shellfilter::log::open $tag {-syslog ""} + } err]} { + #e.g safebase interp can't load required modules such as shellthread (or Thread) + puts stderr "shellfilter::show_pipeline cannot open log" + return + } ::shellfilter::log::write $tag "transform stack for $pipename $args" foreach tf $stack { ::shellfilter::log::write $tag " $tf" diff --git a/src/modules/termscheme-999999.0a1.0.tm b/src/modules/termscheme-999999.0a1.0.tm new file mode 100644 index 00000000..4c623d9c --- /dev/null +++ b/src/modules/termscheme-999999.0a1.0.tm @@ -0,0 +1,181 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 +# +# @@ Meta Begin +# Application termscheme 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_termscheme 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require termscheme] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of termscheme +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by termscheme +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval termscheme::class { + #*** !doctools + #[subsection {Namespace termscheme::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval termscheme { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace termscheme}] + #[para] Core API functions for termscheme + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace termscheme ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval termscheme::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace termscheme::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace termscheme::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval termscheme::system { + #*** !doctools + #[subsection {Namespace termscheme::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide termscheme [tcl::namespace::eval termscheme { + variable pkg termscheme + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/termscheme-buildversion.txt b/src/modules/termscheme-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/termscheme-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index c0b59a50..af9cf41d 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -62,7 +62,14 @@ catch {package require patternpunk} package require overtype #safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. -package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +if {[catch { + package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional? +} errM]} { + #catch this too in case stderr not available + catch { + puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM" + } +} package require textutil @@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock { lassign [punk::args::get_dict { -ansiresets -default 1 -type integer blocks -type string -multiple 1 - } $args] _o opts _v values + } $args] _l leaders _o opts _v values set blocks [tcl::dict::get $values blocks] set idx 0 @@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock { *values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." - memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { + memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { corner noncorner top bottom vertical horizontal left right hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj }\ @@ -8110,7 +8117,7 @@ tcl::namespace::eval textblock { Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 1 -max 1 + *values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} {