Browse Source

make.tcl add support cookfs and more pkg diagnosis, modules - add punk::trie - error option prefix display, more fixes

master
Julian Noble 1 month ago
parent
commit
3bb49e9f40
  1. 1299
      src/make.tcl
  2. 37
      src/modules/punk-0.1.tm
  3. 145
      src/modules/punk/args-999999.0a1.0.tm
  4. 5
      src/modules/punk/config-0.1.tm
  5. 160
      src/modules/punk/du-999999.0a1.0.tm
  6. 1
      src/modules/punk/fileline-999999.0a1.0.tm
  7. 169
      src/modules/punk/lib-999999.0a1.0.tm
  8. 25
      src/modules/punk/mix/base-0.1.tm
  9. 7
      src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
  10. 6
      src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  11. 2
      src/modules/punk/mix/util-999999.0a1.0.tm
  12. 52
      src/modules/punk/nav/fs-999999.0a1.0.tm
  13. 26
      src/modules/punk/packagepreference-999999.0a1.0.tm
  14. 31
      src/modules/punk/repl-0.1.tm
  15. 24
      src/modules/punk/repl/codethread-999999.0a1.0.tm
  16. 5
      src/modules/punk/repo-999999.0a1.0.tm
  17. 600
      src/modules/punk/trie-999999.0a1.0.tm
  18. 3
      src/modules/punk/trie-buildversion.txt
  19. 8
      src/modules/textblock-999999.0a1.0.tm

1299
src/make.tcl

File diff suppressed because it is too large Load Diff

37
src/modules/punk-0.1.tm

@ -213,6 +213,13 @@ namespace eval punk {
proc objclone {obj} { proc objclone {obj} {
append obj2 $obj {} append obj2 $obj {}
} }
proc set_clone {varname obj} {
#maintenance: also punk::lib::set_clone
#e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val]
append obj2 $obj {}
uplevel 1 [list set $varname $obj2]
}
interp alias "" strlen "" ::punk::strlen interp alias "" strlen "" ::punk::strlen
interp alias "" str_len "" ::punk::strlen interp alias "" str_len "" ::punk::strlen
interp alias "" objclone "" ::punk::objclone interp alias "" objclone "" ::punk::objclone
@ -2122,7 +2129,7 @@ namespace eval punk {
} }
{@V\*@*} - {@v\*@*} { {@V\*@*} - {@v\*@*} {
#dict value glob - return values #dict value glob - return values
set active_key_type "dict" set active_key_type dict
set keyglob [string range $index 4 end] set keyglob [string range $index 4 end]
append script [tstr -return string -allowcommands { append script [tstr -return string -allowcommands {
if {[catch {dict size $leveldata}]} { if {[catch {dict size $leveldata}]} {
@ -2132,7 +2139,7 @@ namespace eval punk {
if {$get_not} { if {$get_not} {
lappend INDEX_OPERATIONS globvalue-get-values-not lappend INDEX_OPERATIONS globvalue-get-values-not
append script \n [string map [list <keyglob> $keyglob] { append script \n [string map [list <keyglob> $keyglob] {
# set active_key_type "dict" index_operation: globvalue-get-values-not" # set active_key_type "dict" ;# index_operation: globvalue-get-values-not
set assigned [list] set assigned [list]
tcl::dict::for {k v} $leveldata { tcl::dict::for {k v} $leveldata {
if {![string match <keyglob> $v]} { if {![string match <keyglob> $v]} {
@ -2144,7 +2151,7 @@ namespace eval punk {
} else { } else {
lappend INDEX_OPERATIONS globvalue-get-values lappend INDEX_OPERATIONS globvalue-get-values
append script \n [string map [list <keyglob> $keyglob] { append script \n [string map [list <keyglob> $keyglob] {
# set active_key_type "dict" index_operation: globvalue-get-value # set active_key_type "dict" ;#index_operation: globvalue-get-value
set assigned [dict values $leveldata <keyglob>] set assigned [dict values $leveldata <keyglob>]
}] }]
} }
@ -2166,7 +2173,7 @@ namespace eval punk {
} else { } else {
lappend INDEX_OPERATIONS globkeyvalue-get-pairs lappend INDEX_OPERATIONS globkeyvalue-get-pairs
append script \n [string map [list <keyvalglob> $keyvalglob] { append script \n [string map [list <keyvalglob> $keyvalglob] {
# set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not
set assigned [dict create] set assigned [dict create]
tcl::dict::for {k v} $leveldata { tcl::dict::for {k v} $leveldata {
if {[string match <keyvalglob> $k] || [string match <keyvalglob> $v]} { if {[string match <keyvalglob> $k] || [string match <keyvalglob> $v]} {
@ -4952,17 +4959,14 @@ namespace eval punk {
} else { } else {
#tags ? #tags ?
#debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5
if 0 { if {false} {
#set s [list uplevel 1 [concat $rhs $segment_members_filled]] #set s [list uplevel 1 [concat $rhs $segment_members_filled]]
if {![info exists pscript]} { if {![info exists pscript]} {
upvar ::_pipescript pscript upvar ::_pipescript pscript
} }
if {![info exists pscript]} { if {![info exists pscript]} {
#set pscript $s #set pscript $s
set pscript [funcl::o_of_n 1 $segment_members] set pscript [funcl::o_of_n 1 $segment_members]
} else { } else {
#set pscript [string map [list <p> $pscript] {uplevel 1 [concat $rhs $segment_members_filled [<p>]]}] #set pscript [string map [list <p> $pscript] {uplevel 1 [concat $rhs $segment_members_filled [<p>]]}]
#set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled "
@ -4972,6 +4976,7 @@ namespace eval punk {
} }
} }
set cmdlist_result [uplevel 1 $segment_members_filled] set cmdlist_result [uplevel 1 $segment_members_filled]
#set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]]
set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]]
@ -7321,16 +7326,22 @@ namespace eval punk {
if {$topic in [list tcl]} { if {$topic in [list tcl]} {
if {[punk::lib::system::has_script_var_bug]} { if {[punk::lib::system::has_tclbug_script_var]} {
append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)"
} }
if {[punk::lib::system::has_safeinterp_compile_bug]} { if {[punk::lib::system::has_tclbug_safeinterp_compile]} {
set indent " " set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n
append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n
append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75"
append warningblock [a] append warningblock [a]
} }
if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} {
set indent " "
append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n
append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n
append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2"
}
} }
set text "" set text ""

145
src/modules/punk/args-999999.0a1.0.tm

@ -201,6 +201,7 @@
#[para] packages used by punk::args #[para] packages used by punk::args
#[list_begin itemized] #[list_begin itemized]
package require Tcl 8.6- package require Tcl 8.6-
#optional? punk::trie
#*** !doctools #*** !doctools
#[item] [package {Tcl 8.6-}] #[item] [package {Tcl 8.6-}]
@ -293,6 +294,7 @@ tcl::namespace::eval punk::args {
-validate_without_ansi 0\ -validate_without_ansi 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\ -nocase 0\
-choiceprefix 1\
-multiple 0\ -multiple 0\
] ]
set valspec_defaults [tcl::dict::create\ set valspec_defaults [tcl::dict::create\
@ -301,8 +303,12 @@ tcl::namespace::eval punk::args {
-allow_ansi 1\ -allow_ansi 1\
-validate_without_ansi 0\ -validate_without_ansi 0\
-strip_ansi 0\ -strip_ansi 0\
-nocase 0\
-choiceprefix 1\
-multiple 0\ -multiple 0\
] ]
#we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices
#default to 1 for convenience
#checks with no default #checks with no default
#-minlen -maxlen -range #-minlen -maxlen -range
@ -415,11 +421,11 @@ tcl::namespace::eval punk::args {
-anyopts { -anyopts {
set opt_any $v set opt_any $v
} }
-minlen - -maxlen - -range - -choices - -choicelabels { -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix {
#review - only apply to certain types? #review - only apply to certain types?
tcl::dict::set optspec_defaults $k $v tcl::dict::set optspec_defaults $k $v
} }
-nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels - -nocase {
if {$v} { if {$v} {
tcl::dict::unset optspec_defaults $k tcl::dict::unset optspec_defaults $k
} }
@ -459,7 +465,7 @@ tcl::namespace::eval punk::args {
tcl::dict::set optspec_defaults $k $v tcl::dict::set optspec_defaults $k $v
} }
default { default {
set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels\ set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\
-nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\
} }
@ -479,7 +485,7 @@ tcl::namespace::eval punk::args {
-maxvalues { -maxvalues {
set val_max $v set val_max $v
} }
-minlen - -maxlen - -range - -choices - -choicelabels { -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase {
#review - only apply to certain types? #review - only apply to certain types?
tcl::dict::set valspec_defaults $k $v tcl::dict::set valspec_defaults $k $v
} }
@ -520,7 +526,7 @@ tcl::namespace::eval punk::args {
} }
default { default {
set known { -min -minvalues -max -maxvalues\ set known { -min -minvalues -max -maxvalues\
-minlen -maxlen -range -choices -choicelabels\ -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\
-nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\
-type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\
} }
@ -596,12 +602,12 @@ tcl::namespace::eval punk::args {
} }
} }
} }
-default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE {
#review -solo 1 vs -type none ? #review -solo 1 vs -type none ?
tcl::dict::set spec_merged $spec $specval tcl::dict::set spec_merged $spec $specval
} }
default { default {
set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help]
error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs"
} }
} }
@ -752,7 +758,28 @@ tcl::namespace::eval punk::args {
#set greencheck [a+ web-limegreen]\u2713[a] #set greencheck [a+ web-limegreen]\u2713[a]
set greencheck [a+ brightgreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a]
foreach arg [dict get $spec_dict opt_names] { if {![catch {package require punk::trie}]} {
set opt_names_display [list]
set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]]
set idents [dict get [$trie shortest_idents ""] scanned]
$trie destroy
set M "\x1b\[32m" ;#mark in green
set RST "\x1b\[m"
foreach c [dict get $spec_dict opt_names] {
set id [dict get $idents $c]
if {$id eq $c} {
lappend opt_names_display $M$c$RST
} else {
set idlen [string length $id]
lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]"
}
}
} else {
set opt_names_display [dict get $spec_dict opt_names]
}
foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] {
set arginfo [dict get $spec_dict arg_info $arg] set arginfo [dict get $spec_dict arg_info $arg]
if {[dict exists $arginfo -default]} { if {[dict exists $arginfo -default]} {
#set default $c_default[dict get $arginfo -default] #set default $c_default[dict get $arginfo -default]
@ -763,14 +790,47 @@ tcl::namespace::eval punk::args {
set help [punk::lib::dict_getdef $arginfo -help ""] set help [punk::lib::dict_getdef $arginfo -help ""]
if {[dict exists $arginfo -choices]} { if {[dict exists $arginfo -choices]} {
if {$help ne ""} {append help \n} if {$help ne ""} {append help \n}
append help "Choices: [dict get $arginfo -choices]" if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
} else {
set casemsg " (case sensitive)"
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
} else {
set prefixmsg ""
}
append help "Choices$prefixmsg$casemsg"
if {[catch {package require punk::trie}]} {
append help "\n " [join [dict get $arginfo -choices] "\n "]
} else {
if {[catch {
set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]]
set idents [dict get [$trie shortest_idents ""] scanned]
$trie destroy
set M "\x1b\[32m" ;#mark in green
set RST "\x1b\[m"
foreach c [dict get $arginfo -choices] {
set id [dict get $idents $c]
if {$id eq $c} {
append help "\n " "$M$c$RST"
} else {
set idlen [string length $id]
append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]"
}
}
} errM]} {
puts stderr "prefix marking failed\n$errM"
append help "\n " [join [dict get $arginfo -choices] "\n "]
}
}
} }
if {[punk::lib::dict_getdef $arginfo -multiple 0]} { if {[punk::lib::dict_getdef $arginfo -multiple 0]} {
set multiple $greencheck set multiple $greencheck
} else { } else {
set multiple "" set multiple ""
} }
$t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help]
if {$arg eq $badarg} { if {$arg eq $badarg} {
$t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg
} }
@ -785,7 +845,40 @@ tcl::namespace::eval punk::args {
set help [punk::lib::dict_getdef $arginfo -help ""] set help [punk::lib::dict_getdef $arginfo -help ""]
if {[dict exists $arginfo -choices]} { if {[dict exists $arginfo -choices]} {
if {$help ne ""} {append help \n} if {$help ne ""} {append help \n}
append help "Choices: [dict get $arginfo -choices]" if {[dict get $arginfo -nocase]} {
set casemsg " (case insensitive)"
} else {
set casemsg " (case sensitive)"
}
if {[dict get $arginfo -choiceprefix]} {
set prefixmsg " (choice prefix allowed)"
} else {
set prefixmsg ""
}
append help "Choices$prefixmsg$casemsg"
if {[catch {package require punk::trie}]} {
append help "\n " [join [dict get $arginfo -choices] "\n "]
} else {
if {[catch {
set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]]
set idents [dict get [$trie shortest_idents ""] scanned]
$trie destroy
set M "\x1b\[32m" ;#mark in green
set RST "\x1b\[m"
foreach c [dict get $arginfo -choices] {
set id [dict get $idents $c]
if {$id eq $c} {
append help "\n " "$M$c$RST"
} else {
set idlen [string length $id]
append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]"
}
}
} errM]} {
puts stderr "prefix marking failed\n$errM"
append help "\n " [join [dict get $arginfo -choices] "\n "]
}
}
} }
if {[punk::lib::dict_getdef $arginfo -multiple 0]} { if {[punk::lib::dict_getdef $arginfo -multiple 0]} {
set multiple $greencheck set multiple $greencheck
@ -1429,20 +1522,38 @@ tcl::namespace::eval punk::args {
} }
if {$has_choices} { if {$has_choices} {
#todo -choicelabels #todo -choicelabels
set choices [tcl::dict::get $thisarg -choices] set choices [tcl::dict::get $thisarg -choices]
set nocase [tcl::dict::get $thisarg -nocase] set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set nocase [tcl::dict::get $thisarg -nocase]
foreach e $vlist e_check $vlist_check { foreach e $vlist e_check $vlist_check {
if {$nocase} { if {$nocase} {
set casemsg "(case insensitive)" set casemsg " (case insensitive)"
set choices_test [tcl::string::tolower $choices] set choices_test [tcl::string::tolower $choices]
set v_test [tcl::string::tolower $e_check] set v_test [tcl::string::tolower $e_check]
} else { } else {
set casemsg "(case sensitive)" set casemsg " (case sensitive)"
set v_test $e_check set v_test $e_check
set choices_test $choices set choices_test $choices
} }
if {$v_test ni $choices_test} { set choice_ok 0
arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname if {$choiceprefix} {
if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} {
set choice_ok 1
#can we handle empty string as a choice? It should just work - REVIEW/test
set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list
if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} {
tcl::dict::set opts $argname $choice
} else {
tcl::dict::set values_dict $argname $choice
}
}
set prefixmsg " (or a unique prefix of a value)"
} else {
set prefixmsg ""
set choice_ok [expr {$v_test in $choices_test}]
}
if {!$choice_ok} {
arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname
} }
} }
} }

5
src/modules/punk/config-0.1.tm

@ -362,10 +362,11 @@ tcl::namespace::eval punk::config {
proc configure {args} { proc configure {args} {
set argd [punk::args::get_dict { set argd [punk::args::get_dict {
*values -min 1 -max 1
whichconfig -type string -choices {startup running} whichconfig -type string -choices {startup running stop}
} $args] } $args]
return "unimplemented - $argd"
} }
proc show {whichconfig {globfor *}} { proc show {whichconfig {globfor *}} {

160
src/modules/punk/du-999999.0a1.0.tm

@ -1065,56 +1065,65 @@ namespace eval punk::du {
#note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review).
#dotfiles aren't considered hidden on all platforms #dotfiles aren't considered hidden on all platforms
#some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context.
if {$opt_glob eq "*"} { if {"windows" eq $::tcl_platform(platform)} {
#Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' if {$opt_glob eq "*"} {
#set parent [lindex $folders $folderidx] #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] #set parent [lindex $folders $folderidx]
#set hdirs {} set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*]
set dirs [glob -nocomplain -dir $folderpath -types d * .*] set dirs [glob -nocomplain -dir $folderpath -types d * .*]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
#set hlinks {} set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?)
#set links [lsort -unique [concat $hlinks $links[unset links]]]
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*]
#set hfiles {}
set files [glob -nocomplain -dir $folderpath -types f * .*]
#set files {}
} else {
set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?) set files [glob -nocomplain -dir $folderpath -types f * .*]
} else {
set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
} else {
set hdirs {}
set hfiles {}
set hlinks {}
if {$opt_glob eq "*"} {
#Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
#set parent [lindex $folders $folderidx]
set dirs [glob -nocomplain -dir $folderpath -types d * .*]
set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
set files [glob -nocomplain -dir $folderpath -types f * .*]
} else {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
} }
#note struct::set difference produces unordered result #note struct::set difference produces unordered result
#struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!) #struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!)
#relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' #relying on struct::set to remove dupes is somewhat risky.
#It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes
#for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version
#remove links and . .. from directories, remove links from files #remove links and . .. from directories, remove links from files
#ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now. #ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now.
#struct::set will affect order: tcl vs critcl give different ordering! #struct::set will affect order: tcl vs critcl give different ordering!
set files [struct::set difference [concat $hfiles $files[unset files]] $links] set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links]
set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]]
#set links [lsort -unique [concat $links $hlinks]]
#---- #----
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
if {"windows" eq $::tcl_platform(platform)} { #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden
set flaggedhidden [concat $hdirs $hfiles $hlinks] #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden
} else {
#unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden
#this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden
set flaggedhidden {}
}
set vfsmounts [get_vfsmounts_in_folder $folderpath] set vfsmounts [get_vfsmounts_in_folder $folderpath]
@ -1223,21 +1232,21 @@ namespace eval punk::du {
#if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {} #if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {}
#zipfs files also reported as links by glob - review - should we preserve this in response? #todo - hidden? not returned in attributes on windows at least.
#zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate)
if {$opt_glob eq "*"} { if {$opt_glob eq "*"} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
#set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
set links [list]
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
} else { } else {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
#set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
set links [list]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
} }
#remove any links from our dirs and files collections #remove any links from our dirs and files collections
set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] #see du_dirlisting_generic re struct::set difference issues
set files [struct::set difference $files[unset files] $links] set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]]
set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
#nested vfs mount.. REVIEW - does anything need special handling? #nested vfs mount.. REVIEW - does anything need special handling?
@ -1300,34 +1309,63 @@ namespace eval punk::du {
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- ---
#at least some vfs on windows seem to support the -hidden attribute
#we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW
#The extra globs aren't nice - but hopefully the vfs is reasonably performant (?)
set errors [dict create] set errors [dict create]
if {$opt_glob eq "*"} { if {"windows" eq $::tcl_platform(platform)} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs if {$opt_glob eq "*"} {
#review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*]
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs?
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*]
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
} else {
set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob]
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
} else { } else {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] #we leave it to the ui on unix to classify dotfiles as hidden
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set hdirs {}
set files [glob -nocomplain -dir $folderpath -types f $opt_glob] set hfiles {}
set hlinks {}
if {$opt_glob eq "*"} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
#review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs?
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files
} else {
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
} }
#remove any links from our dirs and files collections #remove any links from our dirs and files collections
set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] #see du_dirlisting_generic re struct::set difference issues
set files [struct::set difference $files[unset files] $links] set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]]
set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
#nested vfs mount.. REVIEW - does anything need special handling? #nested vfs mount.. REVIEW - does anything need special handling?
set vfsmounts [get_vfsmounts_in_folder $folderpath] set vfsmounts [get_vfsmounts_in_folder $folderpath]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
set effective_opts $opts set effective_opts $opts
dict set effective_opts -with_times $timed_types dict set effective_opts -with_times $timed_types
dict set effective_opts -with_sizes $sized_types dict set effective_opts -with_sizes $sized_types
return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors]
} }
#we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files
#but we don't classify as such anyway. (leave for UI)
proc du_dirlisting_unix {folderpath args} { proc du_dirlisting_unix {folderpath args} {
set defaults [dict create\ set defaults [dict create\
-glob *\ -glob *\
@ -1379,6 +1417,9 @@ namespace eval punk::du {
} }
#this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows
#we don't classify anything as 'flaggedhidden' on unix.
#it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library
#This
if {$opt_glob eq "*"} { if {$opt_glob eq "*"} {
set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs
set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove
@ -1389,8 +1430,9 @@ namespace eval punk::du {
set files [glob -nocomplain -dir $folderpath -types f $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
} }
#remove any links from our dirs and files collections #remove any links from our dirs and files collections
set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] #see du_dirlisting_generic re struct::set difference issues
set files [struct::set difference $files[unset files] $links] set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]]
set files [punk::lib::struct_set_diff_unique $files[unset files] $links]
set vfsmounts [get_vfsmounts_in_folder $folderpath] set vfsmounts [get_vfsmounts_in_folder $folderpath]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
@ -1406,7 +1448,7 @@ namespace eval punk::du {
#return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types #return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types
proc du_get_metadata_lists {sized_types timed_types files dirs links} { proc du_get_metadata_lists {sized_types timed_types files dirs links} {
set meta_dict [dict create] set meta_dict [dict create]
set meta_types [concat $sized_types $timed_types] set meta_types [list {*}$sized_types {*}$timed_types]
#known tcl stat keys 2023 - review #known tcl stat keys 2023 - review
set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}]
#make sure we call file stat only once per item #make sure we call file stat only once per item
@ -1419,6 +1461,7 @@ namespace eval punk::du {
if {![catch {file stat $path arrstat} errM]} { if {![catch {file stat $path arrstat} errM]} {
dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]]
} else { } else {
puts stderr "du_get_metadata_lists: file stat $path error: $errM"
dict lappend errors $path "file stat error: $errM" dict lappend errors $path "file stat error: $errM"
dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict]
} }
@ -1437,6 +1480,9 @@ namespace eval punk::du {
if {$ft eq "f"} { if {$ft eq "f"} {
#subst with na if empty? #subst with na if empty?
lappend fsizes [dict get $pathinfo size] lappend fsizes [dict get $pathinfo size]
if {[dict get $pathinfo size] eq ""} {
puts stderr "du_get_metadata_lists: fsize $path is empty!"
}
} }
} }
if {$ft in $timed_types} { if {$ft in $timed_types} {
@ -1446,7 +1492,7 @@ namespace eval punk::du {
#todo - fix . The list lengths will presumably match but have empty values if failed to stat #todo - fix . The list lengths will presumably match but have empty values if failed to stat
if {"f" in $sized_types} { if {"f" in $sized_types} {
if {[llength $fsizes] ne [llength $files]} { if {[llength $fsizes] ne [llength $files]} {
dict lappend errors $folderpath "failed to retrieve all file sizes" dict lappend errors general "failed to retrieve all file sizes"
} }
} }
return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes] return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes]

1
src/modules/punk/fileline-999999.0a1.0.tm

@ -290,7 +290,6 @@ namespace eval punk::fileline::class {
-showconfig 0\ -showconfig 0\
-boundaryheader {Boundary %i% at %b%}\ -boundaryheader {Boundary %i% at %b%}\
] ]
set known_opts [dict keys $defaults]
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader {

169
src/modules/punk/lib-999999.0a1.0.tm

@ -339,6 +339,144 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency
# - 1 punk boot script
# - 2 packagetrace module
# - These should be updated to sync with this
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
proc tm_version_isvalid {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionpart $versionpart]]} {
return 1
} else {
return 0
}
}
proc tm_version_major {version} {
if {![tm_version_isvalid $version]} {
error "Invalid version '$version' is not a proper Tcl module version number"
}
set firstpart [lindex [split $version .] 0]
#check for a/b in first segment
if {[string is integer -strict $firstpart]} {
return $firstpart
}
if {[string first a $firstpart] > 0} {
return [lindex [split $firstpart a] 0]
}
if {[string first b $firstpart] > 0} {
return [lindex [split $firstpart b] 0]
}
error "tm_version_major unable to determine major version from version number '$version'"
}
proc tm_version_canonical {ver} {
#accepts a single valid version only - not a bounded or unbounded spec
if {![tm_version_isvalid $ver]} {
error "tm_version_canonical version '$ver' is not valid for a package version"
}
set parts [split $ver .]
set newparts [list]
foreach o $parts {
set trimmed [string trimleft $o 0]
set firstnonzero [string index $trimmed 0]
switch -exact -- $firstnonzero {
"" {
lappend newparts 0
}
a - b {
#e.g 000bnnnn -> bnnnnn
set tailtrimmed [string trimleft [string range $trimmed 1 end] 0]
if {$tailtrimmed eq ""} {
set tailtrimmed 0
}
lappend newparts 0$firstnonzero$tailtrimmed
}
default {
#digit
if {[string is integer -strict $trimmed]} {
#e.g 0100 -> 100
lappend newparts $trimmed
} else {
#e.g 0100b003 -> 100b003 (still need to process tail)
if {[set apos [string first a $trimmed]] > 0} {
set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits
set rhs [string trimleft $rhs 0]
if {$rhs eq ""} {
set rhs 0
}
lappend newparts ${lhs}a${rhs}
} elseif {[set bpos [string first b $trimmed]] > 0} {
set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch
set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits
set rhs [string trimleft $rhs 0]
if {$rhs eq ""} {
set rhs 0
}
lappend newparts ${lhs}b${rhs}
} else {
#assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b
error "tm_version_canonical error - trimfail - unexpected"
}
}
}
}
}
return [join $newparts .]
}
proc tm_version_required_canonical {versionspec} {
#also trim leading zero from any dottedpart?
#Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
#e.g 1.01 is equivalent to 1.1 and 01.001
#also 1b3 == 1b0003
if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version
set errmsg "tm_version_required_canonical - invalid version specification"
if {[string first - $versionspec] < 0} {
#no dash
#looks like a minbounded version (ie a single version with no dash) convert to min-max form
set from $versionspec
if {![tm_version_isvalid $from]} {
error "$errmsg '$versionpec'"
}
if {![catch {tm_version_major $from} majorv]} {
set from [tm_version_canonical $from]
return "${from}-[expr {$majorv +1}]"
} else {
error "$errmsg '$versionspec'"
}
} else {
# min- or min-max
#validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
set parts [split $versionspec -] ;#we expect only 2 parts
lassign $parts from to
if {![tm_version_isvalid $from]} {
error "$errmsg '$versionspec'"
}
set from [tm_version_canonical $from]
if {[llength $parts] == 2} {
if {$to ne ""} {
if {![tm_version_isvalid $to]} {
error "$errmsg '$versionspec'"
}
set to [tm_version_canonical $to]
return $from-$to
} else {
return $from-
}
} else {
error "$errmsg '$versionspec'"
}
error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point"
}
}
# end tm_version... functions
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# -- --- # -- ---
#https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists
#DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024
@ -1575,8 +1713,20 @@ namespace eval punk::lib {
lremove $fromlist {*}$doomed lremove $fromlist {*}$doomed
} }
#fix for tcl impl of struct::set::diff which doesn't dedupe
proc struct_set_diff_unique {A B} {
package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine.
if {[struct::set::Loaded] eq "tcl"} {
return [punk::lib::setdiff $A $B]
} else {
#use (presumably critcl) implementation for speed
return [struct::set difference $A $B]
}
}
#non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B
#consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024)
#also struct::set difference with critcl is faster #also struct::set difference with critcl is faster
proc setdiff {A B} { proc setdiff {A B} {
if {[llength $A] == 0} {return {}} if {[llength $A] == 0} {return {}}
@ -3032,6 +3182,11 @@ namespace eval punk::lib {
proc objclone {obj} { proc objclone {obj} {
append obj2 $obj {} append obj2 $obj {}
} }
proc set_clone {varname obj} {
#used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val]
append obj2 $obj {}
uplevel 1 [list set $varname $obj2]
}
@ -3175,7 +3330,7 @@ tcl::namespace::eval punk::lib::system {
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
#[list_begin definitions] #[list_begin definitions]
proc has_script_var_bug {} { proc has_tclbug_script_var {} {
set script {set j [list spud] ; list} set script {set j [list spud] ; list}
append script \n append script \n
uplevel #0 $script uplevel #0 $script
@ -3194,7 +3349,15 @@ tcl::namespace::eval punk::lib::system {
return false return false
} }
} }
proc has_safeinterp_compile_bug {{show 0}} {
proc has_tclbug_list_quoting_emptyjoin {} {
#https://core.tcl-lang.org/tcl/tktview/e38dce74e2
set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases
set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}"
return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug.
}
proc has_tclbug_safeinterp_compile {{show 0}} {
#ensemble calls within safe interp not compiled #ensemble calls within safe interp not compiled
namespace eval [namespace current]::testcompile { namespace eval [namespace current]::testcompile {
proc ensembletest {} {string index a 0} proc ensembletest {} {string index a 0}

25
src/modules/punk/mix/base-0.1.tm

@ -473,13 +473,26 @@ namespace eval punk::mix::base {
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names
zlib adler32 $data zlib adler32 $data
} }
#zlib crc vie file-slurp #zlib crc via file-slurp
proc cksum_crc_file {filename} { proc cksum_crc_file {filename} {
package require zlib package require zlib
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
zlib crc $data zlib crc $data
} }
proc cksum_md5_data {data} {
if {[package vsatisfies [package present md5] 2-]} {
return [md5::md5 -hex $data]
} else {
return [md5::md5 $data]
}
}
#fallback md5 via file-slurp - shouldn't be needed if have md5 2-
proc cksum_md5_file {filename} {
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename]
cksum_md5_data $data
}
#required to be able to accept relative paths #required to be able to accept relative paths
#for full cksum - using tar could reduce number of hashes to be made.. #for full cksum - using tar could reduce number of hashes to be made..
@ -624,7 +637,11 @@ namespace eval punk::mix::base {
} }
md5 { md5 {
package require md5 package require md5
set cksum_command [list md5::md5 -hex -file] if {[package vsatisfies [package present md5] 2- ] } {
set cksum_command [list md5::md5 -hex -file]
} else {
set cksum_comand [list cksum_md5_file]
}
} }
cksum { cksum {
package require cksum ;#tcllib package require cksum ;#tcllib
@ -637,7 +654,7 @@ namespace eval punk::mix::base {
set cksum_command [list cksum_adler32_file] set cksum_command [list cksum_adler32_file]
} }
sha3 - sha3-256 { sha3 - sha3-256 {
#todo - replace with something that doesn't call another process #todo - replace with something that doesn't call another process - only if tcllibc not available!
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}]
set cksum_command [list $sha3_implementation 256] set cksum_command [list $sha3_implementation 256]
} }
@ -684,7 +701,7 @@ namespace eval punk::mix::base {
set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
set tsstart [clock millis] set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... " puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
set tsend [clock millis] set tsend [clock millis]
set ms [expr {$tsend - $tsstart}] set ms [expr {$tsend - $tsstart}]

7
src/modules/punk/mix/commandset/doc-999999.0a1.0.tm

@ -271,7 +271,12 @@ namespace eval punk::mix::commandset::doc {
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation.
#review - if we're checking fname - should also test length of whole path and determine limits for tar #review - if we're checking fname - should also test length of whole path and determine limits for tar
package require md5 package require md5
set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man if {[package vsatisfies [package present md5] 2- ] } {
set md5opt "-hex"
} else {
set md5opt ""
}
set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man
puts stderr "WARNING - overlong file name - renaming $fullpath" puts stderr "WARNING - overlong file name - renaming $fullpath"
puts stderr " to [file dirname $fullpath]/$target_docname" puts stderr " to [file dirname $fullpath]/$target_docname"
} }

6
src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd

@ -417,9 +417,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;Hide {<#};Hide '@ Hide :exit_multishell;Hide {<#};Hide '@
namespace eval ::punk::multishell { namespace eval ::punk::multishell {
set last_script_root [file dirname [file normalize ${argv0}/__]] set last_script_root [file dirname [file normalize ${::argv0}/__]]
set last_script [file dirname [file normalize [info script]/__]] set last_script [file dirname [file normalize [info script]/__]]
if {[info exists argv0] && if {[info exists ::argv0] &&
$last_script eq $last_script_root $last_script eq $last_script_root
} { } {
set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode
@ -434,7 +434,7 @@ namespace eval ::punk::multishell {
if {![info exists ::punk::multishell::is_main($script_name)]} { if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated #e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]"
return 0 return 0
} }
return [set ::punk::multishell::is_main($script_name)] return [set ::punk::multishell::is_main($script_name)]

2
src/modules/punk/mix/util-999999.0a1.0.tm

@ -261,6 +261,8 @@ namespace eval punk::mix::util {
return return
} }
# review punk::lib::tm_version.. functions
proc is_valid_tm_version {versionpart} { proc is_valid_tm_version {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare' #Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionpart $versionpart]]} { if {![catch [list package vcompare $versionpart $versionpart]]} {

52
src/modules/punk/nav/fs-999999.0a1.0.tm

@ -821,9 +821,12 @@ tcl::namespace::eval punk::nav::fs {
set match_contents $opt_tailglob set match_contents $opt_tailglob
} }
} }
puts stdout "searchbase: $searchbase searchspec:$searchspec" #puts stdout "searchbase: $searchbase searchspec:$searchspec"
set in_vfs 0
#file attr //cookit:/ returns {-vfs 1 -handle {}}
#we will treat it differently for now - use generic handler REVIEW
set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit.
if {[llength [package provide vfs]]} { if {[llength [package provide vfs]]} {
foreach mount [vfs::filesystem info] { foreach mount [vfs::filesystem info] {
if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} {
@ -849,22 +852,45 @@ tcl::namespace::eval punk::nav::fs {
set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} else { } else {
set in_zipfs 0 set in_zipfs 0
if {[info commands ::tcl::zipfs::mount] ne ""} { set in_cookit 1
if {[string match //zipfs:/* $location]} { set in_other_pseudovol 1
set in_zipfs 1 switch -glob -- $location {
//zipfs:/* {
if {[info commands ::tcl::zipfs::mount] ne ""} {
set in_zipfs 1
}
}
//cookit:/* {
set in_cookit 1
}
default {
#handle 'other/unknown' that mounts at a volume-like path //pseudovol:/
if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} {
#pseudovol probably more than one char long
#we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name?
set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob)
} else {
#we could use 'file attr' here to test if {-vfs 1}
#but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems)
#instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume
}
} }
#dict for {zmount zpath} [zipfs mount] {
# if {[punk::mix::base::lib::path_a_atorbelow_b $location $zmount]} {
# set in_zipfs 1
# break
# }
#}
} }
if {$in_zipfs} { if {$in_zipfs} {
#relative vs absolute? review - cwd valid for //zipfs:/ ?? #relative vs absolute? review - cwd valid for //zipfs:/ ??
set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} elseif {$in_cookit} {
#seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/
#don't use twapi
#could possibly use du_dirlisting_tclvfs REVIEW
#files and folders are all returned with the -types hidden option for glob on windows
set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} elseif {$in_other} {
set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} else { } else {
set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times]
} }
} }

26
src/modules/punk/packagepreference-999999.0a1.0.tm

@ -155,18 +155,26 @@ tcl::namespace::eval punk::packagepreference {
if {[lindex $args 1] eq "-exact"} { if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2] set pkg [lindex $args 2]
set vwant [lindex $args 3] set vwant [lindex $args 3]
if {[set ver [package provide $pkg]] ne ""} { if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
if {$ver eq $vwant} { #although we could shortcircuit using vsatisfies to return the ver
return $vwant #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does.
} else { return [$COMMANDSTACKNEXT {*}$args]
#package already provided with a different version.. we will defer to underlying implementation to return the standard error
return [$COMMANDSTACKNEXT {*}$args] #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
} # return $ver
#} else {
# #package already provided with a different version.. we will defer to underlying implementation to return the standard error
# return [$COMMANDSTACKNEXT {*}$args]
#}
} }
} else { } else {
set pkg [lindex $args 1] set pkg [lindex $args 1]
if {[set ver [package provide $pkg]] ne ""} { set vwant [lindex $args 2]
return $ver if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} {
return [$COMMANDSTACKNEXT {*}$args]
#if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} {
# return $ver
#}
} }
} }
if {[regexp {[A-Z]} $pkg]} { if {[regexp {[A-Z]} $pkg]} {

31
src/modules/punk/repl-0.1.tm

@ -2062,6 +2062,10 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
#/scriptlib/tests/listrep_bug.tcl #/scriptlib/tests/listrep_bug.tcl
#after the uplevel #0 $commandstr call #after the uplevel #0 $commandstr call
# vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value
#review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer?
#probably just that the repl can't then be used to debug representation issues and possibly that the performance is not ideal for list pipeline commands(?)
#now that we eval in another thread and interp - we seem to lose the list rep anyway.
#(unless we also save the script in that interp too in a run_command_cache)
global run_command_string global run_command_string
set run_command_string "$commandstr\n" ;#add anything that won't affect script. set run_command_string "$commandstr\n" ;#add anything that won't affect script.
global run_command_cache global run_command_cache
@ -2151,7 +2155,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
#----------------------------------------- #-----------------------------------------
#list/string-rep bug workaround part 2 #list/string-rep bug workaround part 2
#todo - set flag based on punk::lib::system::has_script_var_bug #todo - set flag based on punk::lib::system::has_tclbug_script_var
lappend run_command_cache $run_command_string lappend run_command_cache $run_command_string
#puts stderr "run_command_string rep: [rep $run_command_string]" #puts stderr "run_command_string rep: [rep $run_command_string]"
if {[llength $run_command_cache] > 2000} { if {[llength $run_command_cache] > 2000} {
@ -2576,15 +2580,15 @@ namespace eval repl {
set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread) set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread)
set codethread_mutex [thread::mutex create] set codethread_mutex [thread::mutex create]
thread::send $codethread [string map [list %args% [list $opts]\ thread::send $codethread [string map [list %args% [list $opts]\
%argv0% [list $::argv0]\ %argv0% [list $::argv0]\
%argv% [list $::argv]\ %argv% [list $::argv]\
%argc% [list $::argc]\ %argc% [list $::argc]\
%replthread% [thread::id]\ %replthread% [thread::id]\
%replthread_cond% $codethread_cond\ %replthread_cond% $codethread_cond\
%replthread_interp% [list $opt_callback_interp]\ %replthread_interp% [list $opt_callback_interp]\
%tmlist% [list [tcl::tm::list]]\ %tmlist% [list [tcl::tm::list]]\
%autopath% [list $::auto_path]\ %autopath% [list $::auto_path]\
] { ] {
set ::argv0 %argv0% set ::argv0 %argv0%
set ::argv %argv% set ::argv %argv%
@ -2699,8 +2703,10 @@ namespace eval repl {
#todo - add/remove shellfilter stacked ansiwrap #todo - add/remove shellfilter stacked ansiwrap
} }
proc mode args { proc mode args {
thread::send %replthread% [list punk::console::mode {*}$args] #with tsv::set console is_raw we don't need to call mode in both the replthread and the codethread
# REVIEW - call in local interp? how about if codethread is safe interp?
#interp eval code [list ::punk::console::mode {*}$args] #interp eval code [list ::punk::console::mode {*}$args]
thread::send %replthread% [list punk::console::mode {*}$args]
} }
proc cmdtype cmd { proc cmdtype cmd {
code invokehidden tcl:info:cmdtype $cmd code invokehidden tcl:info:cmdtype $cmd
@ -2831,6 +2837,7 @@ namespace eval repl {
code alias ::md5::md5 ::repl::interphelpers::md5 code alias ::md5::md5 ::repl::interphelpers::md5
code alias exit ::repl::interphelpers::quit code alias exit ::repl::interphelpers::quit
} elseif {$safe == 2} { } elseif {$safe == 2} {
#safebase
safe::interpCreate code -nested 1 safe::interpCreate code -nested 1
#safe::setLogCmd ::repl::interpextras::safe_msg ;#using setLogcmd early will show the auto_path notice - which is *verbose* #safe::setLogCmd ::repl::interpextras::safe_msg ;#using setLogcmd early will show the auto_path notice - which is *verbose*
#while it may conceivably be useful in debugging safe itself - auto_path and tcl::tm::list can be inspected to show these values in the safe interp itself anyway - so early logging is of limited utility here. #while it may conceivably be useful in debugging safe itself - auto_path and tcl::tm::list can be inspected to show these values in the safe interp itself anyway - so early logging is of limited utility here.
@ -2906,6 +2913,7 @@ namespace eval repl {
namespace eval ::codeinterp { namespace eval ::codeinterp {
variable errstack {} variable errstack {}
variable outstack {} variable outstack {}
variable run_command_cache
} }
# -- --- # -- ---
@ -2936,7 +2944,6 @@ namespace eval repl {
#catch {package require packageTrace} #catch {package require packageTrace}
package require punk package require punk
package require shellrun package require shellrun
package require shellfilter package require shellfilter
set running_config $::punk::config::running set running_config $::punk::config::running
if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} {

24
src/modules/punk/repl/codethread-999999.0a1.0.tm

@ -20,12 +20,12 @@
#*** !doctools #*** !doctools
#[manpage_begin shellspy_module_punk::repl::codethread 0 999999.0a1.0] #[manpage_begin shellspy_module_punk::repl::codethread 0 999999.0a1.0]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}] #[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}]
#[require punk::repl::codethread] #[require punk::repl::codethread]
#[keywords module] #[keywords module repl]
#[description] #[description]
#[para] - #[para] This is part of the infrastructure required for the punk::repl to operate
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -131,11 +131,14 @@ tcl::namespace::eval punk::repl::codethread {
# return "ok" # return "ok"
#} #}
variable run_command_cache
proc is_running {} { proc is_running {} {
variable running variable running
return $running return $running
} }
proc runscript {script} { proc runscript {script} {
#puts stderr "->runscript" #puts stderr "->runscript"
variable replthread_cond variable replthread_cond
variable output_stdout "" variable output_stdout ""
@ -169,9 +172,18 @@ tcl::namespace::eval punk::repl::codethread {
#set errhandle [shellfilter::stack::item_tophandle stderr] #set errhandle [shellfilter::stack::item_tophandle stderr]
#interp transfer "" $errhandle code #interp transfer "" $errhandle code
set scope [interp eval code [list set ::punk::ns::ns_current]]
set status [catch { set status [catch {
interp eval code [list tcl::namespace::inscope $scope $script] #shennanigans to keep compiled script around after call.
#otherwise when $script goes out of scope - internal rep of vars set in script changes.
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible.
interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone
interp eval code {
lappend ::codeinterp::run_command_cache $::codeinterp::clonescript
if {[llength $::codeinterp::run_command_cache] > 2000} {
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache]
}
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript
}
} result] } result]

5
src/modules/punk/repo-999999.0a1.0.tm

@ -27,6 +27,11 @@
# #
# path/repo functions # path/repo functions
# #
#REVIEW punk::repo required early by punk boot script to find projectdir
#todo - split off basic find_project chain of functions to a smaller package and import as necessary here
#Then we can reduce early dependencies in punk boot
if {$::tcl_platform(platform) eq "windows"} { if {$::tcl_platform(platform) eq "windows"} {
package require punk::winpath package require punk::winpath
} else { } else {

600
src/modules/punk/trie-999999.0a1.0.tm

@ -0,0 +1,600 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-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) CMcC 2010
#
# @@ Meta Begin
# Application punk::trie 999999.0a1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::trie 0 999999.0a1.0]
#[copyright "2010"]
#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}]
#[require punk::trie]
#[keywords module datastructure trie]
#[description] tcl trie implementation courtesy of CmcC (tcl wiki)
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::trie
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::trie
#[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 punk::trie::class {
#*** !doctools
#[subsection {Namespace punk::trie::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 punk::trie {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
proc Dolog {lvl txt} {
#return "$lvl -- $txt"
#logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'"
puts stderr $msg
}
package require logger
logger::initNamespace ::punk::trie
foreach lvl [logger::levels] {
interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl
log::logproc $lvl ::punk::trie::Log_$lvl
}
#namespace path ::punk::trie::log
#[para] class definitions
if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} {
#*** !doctools
#[list_begin enumerated]
oo::class create [tcl::namespace::current]::trieclass {
variable trie id
method matches {t what} {
#*** !doctools
#[call class::trieclass [method matches] [arg t] [arg what]]
#[para] search for longest prefix, return matching prefix, element and suffix
set matches {}
set wlen [string length $what]
foreach k [lsort -decreasing -dictionary [dict keys $t]] {
set klen [string length $k]
set match ""
for {set i 0} {$i < $klen
&& $i < $wlen
&& [string index $k $i] eq [string index $what $i]
} {incr i} {
append match [string index $k $i]
}
if {$match ne ""} {
lappend matches $match $k
}
}
#Debug.trie {matches: $what -> $matches}
::punk::trie::log::debug {matches: $what -> $matches}
if {[dict size $matches]} {
# find the longest matching prefix
set match [lindex [lsort -dictionary [dict keys $matches]] end]
set mel [dict get $matches $match]
set suffix [string range $what [string length $match] end]
return [list $match $mel $suffix]
} else {
return {} ;# no matches
}
}
# return next unique id if there's no proffered value
method id {value} {
if {$value} {
return $value
} else {
return [incr id]
}
}
# insert an element with a given optional value into trie
# along path given by $args (no need to specify)
method insert {what {value 0} args} {
if {[llength $args]} {
set t [dict get $trie {*}$args]
} else {
set t $trie
}
if {[dict exists $t $what]} {
#Debug.trie {$what is an exact match on path ($args $what)}
::punk::trie::log::debug {$what is an exact match on path ($args $what)}
if {[catch {dict size [dict get $trie {*}$args $what]} size]} {
# the match is a leaf - we're done
} else {
# the match is a dict - we have to add a null
dict set trie {*}$args $what "" [my id $value]
}
return ;# exact match - no change
}
# search for longest prefix
set match [my matches $t $what]
if {![llength $match]} {
;# no matching prefix - new element
#Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)}
::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)}
dict set trie {*}$args $what [my id $value]
return
}
lassign $match match mel suffix ;# prefix, element of match, suffix
if {$match ne $mel} {
# the matching element shares a prefix, but has a variant suffix
# it must be split
#Debug.trie {splitting '$mel' along '$match'}
::punk::trie::log::debug {splitting '$mel' along '$match'}
set melC [dict get $t $mel]
dict unset trie {*}$args $mel
dict set trie {*}$args $match [string range $mel [string length $match] end] $melC
}
if {[catch {dict size [dict get $trie {*}$args $match]} size]} {
# the match is a leaf - must be split
if {$match eq $mel} {
# the matching element shares a prefix, but has a variant suffix
# it must be split
#Debug.trie {splitting '$mel' along '$match'}
::punk::trie::log::debug {splitting '$mel' along '$match'}
set melC [dict get $t $mel]
dict unset trie {*}$args $mel
dict set trie {*}$args $match "" $melC
}
#Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'}
::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'}
set melid [dict get $t $mel]
dict set trie {*}$args $match $suffix [my id $value]
} else {
# it's a dict - keep searching
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)}
::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)}
my insert $suffix $value {*}$args $match
}
return
}
# find a path matching an element $what
# if the element's not found, return the nearest path
method find_path {what args} {
if {[llength $args]} {
set t [dict get $trie {*}$args]
} else {
set t $trie
}
if {[dict exists $t $what]} {
#Debug.trie {$what is an exact match on path ($args $what)}
return [list {*}$args $what] ;# exact match - no change
}
# search for longest prefix
set match [my matches $t $what]
if {![llength $match]} {
return $args
}
lassign $match match mel suffix ;# prefix, element of match, suffix
if {$match ne $mel} {
# the matching element shares a prefix, but has a variant suffix
# no match
return $args
}
if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} {
# got to a non-matching leaf - no match
return $args
} else {
# it's a dict - keep searching
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)}
return [my find_path $suffix {*}$args $match]
}
}
# given a trie, which may have been modified by deletion,
# optimize it by removing empty nodes and coalescing singleton nodes
method optimize {args} {
if {[llength $args]} {
set t [dict get $trie {*}$args]
} else {
set t $trie
}
if {[catch {dict size $t} size]} {
#Debug.trie {optimize leaf '$t' along '$args'}
::punk::trie::log::debug {optimize leaf '$t' along '$args'}
# leaf - leave it
} else {
switch -- $size {
0 {
#Debug.trie {optimize empty dict ($t) along '$args'}
::punk::trie::log::debug {optimize empty dict ($t) along '$args'}
if {[llength $args]} {
dict unset trie {*}$args
}
}
1 {
#Debug.trie {optimize singleton dict ($t) along '$args'}
::punk::trie::log::debug {optimize singleton dict ($t) along '$args'}
lassign $t k v
if {[llength $args]} {
dict unset trie {*}$args
}
append args $k
if {[llength $v]} {
dict set trie {*}$args $v
}
my optimize {*}$args
}
default {
#Debug.trie {optimize dict ($t) along '$args'}
::punk::trie::log::debug {optimize dict ($t) along '$args'}
dict for {k v} $t {
my optimize {*}$args $k
}
}
}
}
}
# delete element $what from trie
method delete {what} {
set path [my find_path $what]
if {[join $path ""] eq $what} {
#Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]}
if {[catch {dict size [dict get $trie {*}$path]} size]} {
# got to a matching leaf - delete it
dict unset trie {*}$path
set path [lrange $path 0 end-1]
} else {
dict unset trie {*}$path ""
}
my optimize ;# remove empty and singleton elements
} else {
# nothing to delete, guess we're done
}
}
# find the value of element $what in trie,
# error if not found
method find_or_error {what} {
set path [my find_path $what]
if {[join $path ""] eq $what} {
if {[catch {dict size [dict get $trie {*}$path]} size]} {
# got to a matching leaf - done
return [dict get $trie {*}$path]
} else {
#JMN - what could be an exact match for a path, but not be in the trie itself
if {[dict exists $trie {*}$path ""]} {
return [dict get $trie {*}$path ""]
} else {
::punk::trie::log::debug {'$what' matches a path but is not a leaf}
error "'$what' not found"
}
}
} else {
error "'$what' not found"
}
}
#JMN - renamed original find to find_or_error
#prefer not to catch on result - but test for -1
method find {what} {
set path [my find_path $what]
if {[join $path ""] eq $what} {
#presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep
if {[catch {dict size [dict get $trie {*}$path]} size]} {
# got to a matching leaf - done
return [dict get $trie {*}$path]
} else {
#JMN - what could be an exact match for a path, but not be in the trie itself
if {[dict exists $trie {*}$path ""]} {
return [dict get $trie {*}$path ""]
} else {
::punk::trie::log::debug {'$what' matches a path but is not a leaf}
return -1
}
}
} else {
return -1
}
}
# dump the trie as a string
method dump {} {
return $trie
}
# return a string rep of the trie sorted in dict order
method order {{t {}}} {
if {![llength $t]} {
set t $trie
} elseif {[llength $t] == 1} {
return $t
}
set acc {}
foreach key [lsort -dictionary [dict keys $t]] {
lappend acc $key [my order [dict get $t $key]]
}
return $acc
}
# return the trie as a dict of names with values
method flatten {{t {}} {prefix ""}} {
if {![llength $t]} {
set t $trie
} elseif {[llength $t] == 1} {
return [list $prefix $t]
}
set acc {}
foreach key [dict keys $t] {
lappend acc {*}[my flatten [dict get $t $key] $prefix$key]
}
return $acc
}
#shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match
#ie if a stored word is a prefix of any other words - it must be fully specified to identify itself.
#JMN - REVIEW - better algorithms?
#caller having retained all members can avoid flatten call
#by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned.
#when all 'which' members are in the tree - scanning stops when they're all found
# - and a dict containing result and scanned keys is returned
# - result contains a dict with keys for each which member
# - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length)
method shortest_idents {which {allmembers {}}} {
set t $trie
if {![llength $allmembers]} {
set members [dict keys [my flatten]]
} else {
set members $allmembers
}
set len_members [lmap m $members {list [string length $m] $m}]
set longestfirst [lsort -index 0 -integer -decreasing $len_members]
set longestfirst [lmap v $longestfirst {lindex $v 1}]
set taken [dict create]
set scanned [dict create]
set result [dict create] ;#words in our which list - if found
foreach w $longestfirst {
set path [my find_path $w]
if {[dict exists $taken $w]} {
#whole word - no unique prefix
dict set scanned $w $w
if {$w in $which} {
#puts stderr "$w -> $w"
dict set result $w $w
if {[dict size $result] == [llength $which]} {
return [dict create result $result scanned $scanned]
}
}
continue
}
set acc ""
foreach p [lrange $path 0 end-1] {
dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present
}
append acc [string index [lindex $path end] 0]
dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary
if {$w in $which} {
#puts stderr "$w -> $acc"
dict set result $w $acc
if {[dict size $result] == [llength $which]} {
return [dict create result $result scanned $scanned]
}
}
}
return [dict create result $result scanned $scanned]
}
# overwrite the trie
method set {t} {
set trie $t
}
constructor {args} {
set trie {}
set id 0
foreach a $args {
my insert $a
}
}
}
set testlist [list blah x black blacken]
proc test1 {} {
#JMN
#test that find_or_error of a path that isn't stored as a value returns an appropriate error
#(used to report couldn't find dict key "")
set t [punk::trie::trieclass new blah x black blacken]
if {[catch {$t find_or_error bla} errM]} {
puts stderr "should be error indicating 'bla' not found"
puts stderr "err during $t find bla\n$errM"
}
return $t
}
# 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 ---}]
}
#*** !doctools
#[subsection {Namespace punk::trie}]
#[para] Core API functions for punk::trie
#[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 punk::trie ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::trie::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::trie::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 punk::trie::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::trie::system {
#*** !doctools
#[subsection {Namespace punk::trie::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::trie [tcl::namespace::eval punk::trie {
variable pkg punk::trie
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/trie-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

8
src/modules/textblock-999999.0a1.0.tm

@ -5280,7 +5280,7 @@ tcl::namespace::eval textblock {
It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj"
*values -min 1 -max 1 *values -min 1 -max 1
frametype -help "name from the predefined frametypes:<ftlist> frametype -help "name from the predefined frametypes:<ftlist>
or an adhoc or an adhoc "
}] }]
append spec \n "frametype -help \"A predefined \"" append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args punk::args::get_dict $spec $args
@ -6804,7 +6804,11 @@ tcl::namespace::eval textblock {
if {$use_md5} { if {$use_md5} {
#package require md5 ;#already required at package load #package require md5 ;#already required at package load
set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review if {[package vsatisfies [package present md5] 2- ] } {
set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review
} else {
set hash [md5::md5 [encoding convertto utf-8 $hashables]]
}
} else { } else {
set hash $hashables set hash $hashables
} }

Loading…
Cancel
Save