#set s [list uplevel 1 [concat $rhs $segment_members_filled]]
if {![info exists pscript]} {
upvar ::_pipescript pscript
@ -4972,6 +4976,7 @@ namespace eval punk {
}
}
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 [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]]
@ -7321,16 +7326,22 @@ namespace eval punk {
if {$topic in [list tcl]} {
if {[punk::lib::system::has_script_var_bug]} {
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)"
if {[punk::lib::system::has_tclbug_script_var]} {
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 " "
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
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set nocase [tcl::dict::get $thisarg -nocase]
foreach e $vlist e_check $vlist_check {
if {$nocase} {
set casemsg "(case insensitive)"
set casemsg "(case insensitive)"
set choices_test [tcl::string::tolower $choices]
set v_test [tcl::string::tolower $e_check]
} else {
set casemsg "(case sensitive)"
set casemsg "(case sensitive)"
set v_test $e_check
set choices_test $choices
}
if {$v_test ni $choices_test} {
arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname
set choice_ok 0
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
#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
#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 {"windows" eq $::tcl_platform(platform)} {
if {$opt_glob eq "*"} {
#Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
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 links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?)
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]
}
}
#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!)
#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
#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!
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
if {"windows" eq $::tcl_platform(platform)} {
set flaggedhidden [concat $hdirs $hfiles $hlinks]
} else {
set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
#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]
#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
}
#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
#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
proc setdiff {A B} {
if {[llength $A] == 0} {return {}}
@ -2387,7 +2537,7 @@ namespace eval punk::lib {
set stdin_state [fconfigure stdin]
if {[catch {
package require punk::console
set console_raw [set ::punk::console::is_raw]
set console_raw [tsv::get console is_raw]
} err_console]} {
#assume normal line mode
set console_raw 0
@ -3032,6 +3182,11 @@ namespace eval punk::lib {
proc objclone {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]
#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
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 " to [file dirname $fullpath]/$target_docname"
#set s [list uplevel 1 [concat $rhs $segment_members_filled]]
if {![info exists pscript]} {
upvar ::_pipescript pscript
@ -4972,6 +4976,7 @@ namespace eval punk {
}
}
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 [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]]
@ -7321,16 +7326,22 @@ namespace eval punk {
if {$topic in [list tcl]} {
if {[punk::lib::system::has_script_var_bug]} {
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)"
if {[punk::lib::system::has_tclbug_script_var]} {
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 " "
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
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
set nocase [tcl::dict::get $thisarg -nocase]
foreach e $vlist e_check $vlist_check {
if {$nocase} {
set casemsg "(case insensitive)"
set casemsg "(case insensitive)"
set choices_test [tcl::string::tolower $choices]
set v_test [tcl::string::tolower $e_check]
} else {
set casemsg "(case sensitive)"
set casemsg "(case sensitive)"
set v_test $e_check
set choices_test $choices
}
if {$v_test ni $choices_test} {
arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname
set choice_ok 0
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
#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
#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 {"windows" eq $::tcl_platform(platform)} {
if {$opt_glob eq "*"} {
#Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink'
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 links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?)
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]
}
}
#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!)
#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
#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!
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links]
if {"windows" eq $::tcl_platform(platform)} {
set flaggedhidden [concat $hdirs $hfiles $hlinks]
} else {
set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks]
#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]
#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
}
#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
#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
proc setdiff {A B} {
if {[llength $A] == 0} {return {}}
@ -2387,7 +2537,7 @@ namespace eval punk::lib {
set stdin_state [fconfigure stdin]
if {[catch {
package require punk::console
set console_raw [set ::punk::console::is_raw]
set console_raw [tsv::get console is_raw]
} err_console]} {
#assume normal line mode
set console_raw 0
@ -3032,6 +3182,11 @@ namespace eval punk::lib {
proc objclone {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]
#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
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 " to [file dirname $fullpath]/$target_docname"
