Browse Source

update bootsupport,vfs,project_layouts for punk::args and punk::safe

master
Julian Noble 2 days ago
parent
commit
e85481ad8c
  1. 76
      src/bootsupport/modules/punk-0.1.tm
  2. 56
      src/bootsupport/modules/punk/aliascore-0.1.0.tm
  3. 868
      src/bootsupport/modules/punk/args-0.1.0.tm
  4. 2
      src/bootsupport/modules/punk/fileline-0.1.0.tm
  5. 81
      src/bootsupport/modules/punk/lib-0.1.1.tm
  6. 2
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  7. 7
      src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  8. 40
      src/bootsupport/modules/punk/ns-0.1.0.tm
  9. 2
      src/bootsupport/modules/punk/path-0.1.0.tm
  10. 98
      src/bootsupport/modules/shellfilter-0.1.9.tm
  11. 15
      src/bootsupport/modules/textblock-0.1.2.tm
  12. 76
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  13. 56
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  14. 868
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  15. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm
  16. 81
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  17. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  18. 7
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  19. 40
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  20. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  21. 98
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm
  22. 15
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm
  23. 76
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  24. 56
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  25. 868
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm
  26. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm
  27. 81
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  28. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  29. 7
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  30. 40
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  31. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  32. 98
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm
  33. 15
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm
  34. 76
      src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
  35. 56
      src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm
  36. 868
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm
  37. 2
      src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm
  38. 81
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm
  39. 2
      src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm
  40. 7
      src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm
  41. 40
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  42. 2
      src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm
  43. 17
      src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm
  44. 1491
      src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm
  45. 98
      src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm
  46. 181
      src/vfs/_vfscommon.vfs/modules/termscheme-0.1.0.tm
  47. 15
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm

76
src/bootsupport/modules/punk-0.1.tm

@ -6976,7 +6976,7 @@ namespace eval punk {
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
# -- --- --- --- --- ---
@ -7560,80 +7560,14 @@ namespace eval punk {
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it.
interp alias {} mode {} punk::mode
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
tailcall punk::lib::aliases $glob
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
tailcall punk::lib::alias $aliasorglob {*}$args
}
#pipeline-toys - put in lib/scriptlib?
##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i|
@ -7669,8 +7603,6 @@ namespace eval punk {
interp alias {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|

56
src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -105,6 +105,8 @@ tcl::namespace::eval punk::aliascore {
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
#we never override existing aliases to ::repl::interp* even if -force = 1
#(these are our safebase aliases)
set ignore_pattern "::repl::interp*"
set ignore_aliases [list]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
set existing_alias [interp alias "" $a]
if {$existing_alias ne ""} {
set existing_target $existing_alias
if {[string match $ignore_pattern $existing_target]} {
#don't consider it a conflict - will use ignore_aliases to exclude it below
lappend ignore_aliases $a
continue
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
} else {
if {[catch {tcl::namespace::origin $a} existing_command]} {
set existing_command ""
}
set existing_target $existing_command
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
if {!$opt_force && [llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts]
}

868
src/bootsupport/modules/punk/args-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1556,7 +1556,7 @@ namespace eval punk::fileline::lib {
set argd [punk::args::get_dict {
-offset -default 0
} $args]
lassign [dict values $argd] opts remainingargs
lassign [dict values $argd] leaders opts remainingargs
}

81
src/bootsupport/modules/punk/lib-0.1.1.tm

@ -211,6 +211,9 @@ tcl::namespace::eval punk::lib::compat {
#*** !doctools
#[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency
@ -2894,7 +2971,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n
*values -min 1 -max 1
} $args]] opts values
} $args]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
@ -2936,7 +3013,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1
-block -default {}
} $args]] opts valuedict
} $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
}

2
src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -153,7 +153,7 @@ namespace eval punk::mix::commandset::module {
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]

7
src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -643,7 +643,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values_dict
lassign [dict values $argd] leaders opts values_dict
set opt_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes]
@ -726,6 +726,7 @@ tcl::namespace::eval punk::nav::fs {
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} {
set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set list_of_dicts [dict values $vals]

40
src/bootsupport/modules/punk/ns-0.1.0.tm

@ -20,8 +20,8 @@
package require punk::lib
package require punk::args
tcl::namespace::eval ::punk_dynamic::ns {
tcl::namespace::eval ::punk::ns::evaluator {
#eval-_NS_xxx_NS_etc procs
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -29,6 +29,12 @@ tcl::namespace::eval punk::ns {
variable ns_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp
catch {
package require debug
debug define punk.ns.compile
#debug on punk.ns.compile
#debug level punk.ns.compile 3
}
#leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body
}
proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace"
}
set loc [string map {:: _sep_} $fqns]
set loc [string map {:: _NS_} $fqns]
#set cmd ::punk::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc
set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns]
proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6
debug.punk.ns.compile {proc $cmd} 2
}
tailcall $cmd $script
}
@ -800,14 +807,23 @@ tcl::namespace::eval punk::ns {
set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
#set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}]
set chwidest1 [tcl::mathfunc::max {*}$lenlist1]
#set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]]
#wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed
set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
#set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]]
set displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1
sourcepattern -type string -optional 0
}
lassign [dict values [punk::args::get_dict $argspecs $args]] opts values
lassign [dict values [punk::args::get_dict $argspecs $args]] leaders opts values
set sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $sourcepattern]

2
src/bootsupport/modules/punk/path-0.1.0.tm

@ -662,7 +662,7 @@ namespace eval punk::path {
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]

98
src/bootsupport/modules/shellfilter-0.1.9.tm

@ -13,46 +13,60 @@
tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create]
variable is_enabled 0
proc disable {} {
variable is_enabled
set is_enabled 0
proc ::shellfilter::log::open {tag settingsdict} {}
proc ::shellfilter::log::write {tag msg} {}
proc ::shellfilter::log::write_sync {tag msg} {}
proc ::shellfilter::log::close {tag} {}
}
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
package require shellthread
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
proc enable {} {
variable is_enabled
set is_enabled 1
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc ::shellfilter::log::open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
}
}
}
if {$tag ni $sourcelist} {
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
proc write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
proc ::shellfilter::log::write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
}
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc ::shellfilter::log::write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc ::shellfilter::log::close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
}
#review
@ -73,6 +87,12 @@ tcl::namespace::eval shellfilter::log {
}
}
}
if {[catch {package require shellthread}]} {
shellfilter::log::disable
} else {
shellfilter::log::enable
}
}
namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere
@ -1594,7 +1614,13 @@ namespace eval shellfilter::stack {
set tag "SHELLFILTER::STACK"
#JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514}
::shellfilter::log::open $tag {-syslog ""}
if {[catch {
::shellfilter::log::open $tag {-syslog ""}
} err]} {
#e.g safebase interp can't load required modules such as shellthread (or Thread)
puts stderr "shellfilter::show_pipeline cannot open log"
return
}
::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack {
::shellfilter::log::write $tag " $tf"

15
src/bootsupport/modules/textblock-0.1.2.tm

@ -62,7 +62,14 @@ catch {package require patternpunk}
package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list.
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
if {[catch {
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
} errM]} {
#catch this too in case stderr not available
catch {
puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM"
}
}
package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _o opts _v values
} $args] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks]
set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj
}\
@ -8110,7 +8117,7 @@ tcl::namespace::eval textblock {
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors)
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used.
"
*values -min 1 -max 1
*values -min 0 -max 1
size -default 1 -type integer
}
proc gcross {args} {

76
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm

@ -6976,7 +6976,7 @@ namespace eval punk {
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
# -- --- --- --- --- ---
@ -7560,80 +7560,14 @@ namespace eval punk {
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it.
interp alias {} mode {} punk::mode
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
tailcall punk::lib::aliases $glob
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
tailcall punk::lib::alias $aliasorglob {*}$args
}
#pipeline-toys - put in lib/scriptlib?
##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i|
@ -7669,8 +7603,6 @@ namespace eval punk {
interp alias {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|

56
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -105,6 +105,8 @@ tcl::namespace::eval punk::aliascore {
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
#we never override existing aliases to ::repl::interp* even if -force = 1
#(these are our safebase aliases)
set ignore_pattern "::repl::interp*"
set ignore_aliases [list]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
set existing_alias [interp alias "" $a]
if {$existing_alias ne ""} {
set existing_target $existing_alias
if {[string match $ignore_pattern $existing_target]} {
#don't consider it a conflict - will use ignore_aliases to exclude it below
lappend ignore_aliases $a
continue
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
} else {
if {[catch {tcl::namespace::origin $a} existing_command]} {
set existing_command ""
}
set existing_target $existing_command
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
if {!$opt_force && [llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts]
}

868
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1556,7 +1556,7 @@ namespace eval punk::fileline::lib {
set argd [punk::args::get_dict {
-offset -default 0
} $args]
lassign [dict values $argd] opts remainingargs
lassign [dict values $argd] leaders opts remainingargs
}

81
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -211,6 +211,9 @@ tcl::namespace::eval punk::lib::compat {
#*** !doctools
#[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency
@ -2894,7 +2971,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n
*values -min 1 -max 1
} $args]] opts values
} $args]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
@ -2936,7 +3013,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1
-block -default {}
} $args]] opts valuedict
} $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
}

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -153,7 +153,7 @@ namespace eval punk::mix::commandset::module {
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]

7
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -643,7 +643,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values_dict
lassign [dict values $argd] leaders opts values_dict
set opt_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes]
@ -726,6 +726,7 @@ tcl::namespace::eval punk::nav::fs {
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} {
set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set list_of_dicts [dict values $vals]

40
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -20,8 +20,8 @@
package require punk::lib
package require punk::args
tcl::namespace::eval ::punk_dynamic::ns {
tcl::namespace::eval ::punk::ns::evaluator {
#eval-_NS_xxx_NS_etc procs
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -29,6 +29,12 @@ tcl::namespace::eval punk::ns {
variable ns_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp
catch {
package require debug
debug define punk.ns.compile
#debug on punk.ns.compile
#debug level punk.ns.compile 3
}
#leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body
}
proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace"
}
set loc [string map {:: _sep_} $fqns]
set loc [string map {:: _NS_} $fqns]
#set cmd ::punk::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc
set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns]
proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6
debug.punk.ns.compile {proc $cmd} 2
}
tailcall $cmd $script
}
@ -800,14 +807,23 @@ tcl::namespace::eval punk::ns {
set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
#set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}]
set chwidest1 [tcl::mathfunc::max {*}$lenlist1]
#set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]]
#wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed
set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
#set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]]
set displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1
sourcepattern -type string -optional 0
}
lassign [dict values [punk::args::get_dict $argspecs $args]] opts values
lassign [dict values [punk::args::get_dict $argspecs $args]] leaders opts values
set sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $sourcepattern]

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -662,7 +662,7 @@ namespace eval punk::path {
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]

98
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm

@ -13,46 +13,60 @@
tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create]
variable is_enabled 0
proc disable {} {
variable is_enabled
set is_enabled 0
proc ::shellfilter::log::open {tag settingsdict} {}
proc ::shellfilter::log::write {tag msg} {}
proc ::shellfilter::log::write_sync {tag msg} {}
proc ::shellfilter::log::close {tag} {}
}
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
package require shellthread
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
proc enable {} {
variable is_enabled
set is_enabled 1
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc ::shellfilter::log::open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
}
}
}
if {$tag ni $sourcelist} {
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
proc write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
proc ::shellfilter::log::write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
}
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc ::shellfilter::log::write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc ::shellfilter::log::close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
}
#review
@ -73,6 +87,12 @@ tcl::namespace::eval shellfilter::log {
}
}
}
if {[catch {package require shellthread}]} {
shellfilter::log::disable
} else {
shellfilter::log::enable
}
}
namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere
@ -1594,7 +1614,13 @@ namespace eval shellfilter::stack {
set tag "SHELLFILTER::STACK"
#JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514}
::shellfilter::log::open $tag {-syslog ""}
if {[catch {
::shellfilter::log::open $tag {-syslog ""}
} err]} {
#e.g safebase interp can't load required modules such as shellthread (or Thread)
puts stderr "shellfilter::show_pipeline cannot open log"
return
}
::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack {
::shellfilter::log::write $tag " $tf"

15
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm

@ -62,7 +62,14 @@ catch {package require patternpunk}
package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list.
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
if {[catch {
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
} errM]} {
#catch this too in case stderr not available
catch {
puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM"
}
}
package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _o opts _v values
} $args] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks]
set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj
}\
@ -8110,7 +8117,7 @@ tcl::namespace::eval textblock {
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors)
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used.
"
*values -min 1 -max 1
*values -min 0 -max 1
size -default 1 -type integer
}
proc gcross {args} {

76
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm

@ -6976,7 +6976,7 @@ namespace eval punk {
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
# -- --- --- --- --- ---
@ -7560,80 +7560,14 @@ namespace eval punk {
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it.
interp alias {} mode {} punk::mode
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
tailcall punk::lib::aliases $glob
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
tailcall punk::lib::alias $aliasorglob {*}$args
}
#pipeline-toys - put in lib/scriptlib?
##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i|
@ -7669,8 +7603,6 @@ namespace eval punk {
interp alias {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|

56
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -105,6 +105,8 @@ tcl::namespace::eval punk::aliascore {
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
#we never override existing aliases to ::repl::interp* even if -force = 1
#(these are our safebase aliases)
set ignore_pattern "::repl::interp*"
set ignore_aliases [list]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
set existing_alias [interp alias "" $a]
if {$existing_alias ne ""} {
set existing_target $existing_alias
if {[string match $ignore_pattern $existing_target]} {
#don't consider it a conflict - will use ignore_aliases to exclude it below
lappend ignore_aliases $a
continue
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
} else {
if {[catch {tcl::namespace::origin $a} existing_command]} {
set existing_command ""
}
set existing_target $existing_command
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
if {!$opt_force && [llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts]
}

868
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1556,7 +1556,7 @@ namespace eval punk::fileline::lib {
set argd [punk::args::get_dict {
-offset -default 0
} $args]
lassign [dict values $argd] opts remainingargs
lassign [dict values $argd] leaders opts remainingargs
}

81
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -211,6 +211,9 @@ tcl::namespace::eval punk::lib::compat {
#*** !doctools
#[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency
@ -2894,7 +2971,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n
*values -min 1 -max 1
} $args]] opts values
} $args]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
@ -2936,7 +3013,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1
-block -default {}
} $args]] opts valuedict
} $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
}

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -153,7 +153,7 @@ namespace eval punk::mix::commandset::module {
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]

7
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -643,7 +643,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values_dict
lassign [dict values $argd] leaders opts values_dict
set opt_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes]
@ -726,6 +726,7 @@ tcl::namespace::eval punk::nav::fs {
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} {
set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set list_of_dicts [dict values $vals]

40
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -20,8 +20,8 @@
package require punk::lib
package require punk::args
tcl::namespace::eval ::punk_dynamic::ns {
tcl::namespace::eval ::punk::ns::evaluator {
#eval-_NS_xxx_NS_etc procs
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -29,6 +29,12 @@ tcl::namespace::eval punk::ns {
variable ns_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp
catch {
package require debug
debug define punk.ns.compile
#debug on punk.ns.compile
#debug level punk.ns.compile 3
}
#leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body
}
proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace"
}
set loc [string map {:: _sep_} $fqns]
set loc [string map {:: _NS_} $fqns]
#set cmd ::punk::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc
set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns]
proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6
debug.punk.ns.compile {proc $cmd} 2
}
tailcall $cmd $script
}
@ -800,14 +807,23 @@ tcl::namespace::eval punk::ns {
set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
#set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}]
set chwidest1 [tcl::mathfunc::max {*}$lenlist1]
#set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]]
#wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed
set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
#set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]]
set displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1
sourcepattern -type string -optional 0
}
lassign [dict values [punk::args::get_dict $argspecs $args]] opts values
lassign [dict values [punk::args::get_dict $argspecs $args]] leaders opts values
set sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $sourcepattern]

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -662,7 +662,7 @@ namespace eval punk::path {
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]

98
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/shellfilter-0.1.9.tm

@ -13,46 +13,60 @@
tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create]
variable is_enabled 0
proc disable {} {
variable is_enabled
set is_enabled 0
proc ::shellfilter::log::open {tag settingsdict} {}
proc ::shellfilter::log::write {tag msg} {}
proc ::shellfilter::log::write_sync {tag msg} {}
proc ::shellfilter::log::close {tag} {}
}
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
package require shellthread
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
proc enable {} {
variable is_enabled
set is_enabled 1
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc ::shellfilter::log::open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
}
}
}
if {$tag ni $sourcelist} {
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
proc write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
proc ::shellfilter::log::write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
}
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc ::shellfilter::log::write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc ::shellfilter::log::close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
}
#review
@ -73,6 +87,12 @@ tcl::namespace::eval shellfilter::log {
}
}
}
if {[catch {package require shellthread}]} {
shellfilter::log::disable
} else {
shellfilter::log::enable
}
}
namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere
@ -1594,7 +1614,13 @@ namespace eval shellfilter::stack {
set tag "SHELLFILTER::STACK"
#JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514}
::shellfilter::log::open $tag {-syslog ""}
if {[catch {
::shellfilter::log::open $tag {-syslog ""}
} err]} {
#e.g safebase interp can't load required modules such as shellthread (or Thread)
puts stderr "shellfilter::show_pipeline cannot open log"
return
}
::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack {
::shellfilter::log::write $tag " $tf"

15
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm

@ -62,7 +62,14 @@ catch {package require patternpunk}
package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list.
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
if {[catch {
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
} errM]} {
#catch this too in case stderr not available
catch {
puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM"
}
}
package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _o opts _v values
} $args] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks]
set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj
}\
@ -8110,7 +8117,7 @@ tcl::namespace::eval textblock {
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors)
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used.
"
*values -min 1 -max 1
*values -min 0 -max 1
size -default 1 -type integer
}
proc gcross {args} {

76
src/vfs/_vfscommon.vfs/modules/punk-0.1.tm

@ -6976,7 +6976,7 @@ namespace eval punk {
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
# -- --- --- --- --- ---
@ -7560,80 +7560,14 @@ namespace eval punk {
#this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it.
interp alias {} mode {} punk::mode
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
tailcall punk::lib::aliases $glob
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
tailcall punk::lib::alias $aliasorglob {*}$args
}
#pipeline-toys - put in lib/scriptlib?
##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i|
@ -7669,8 +7603,6 @@ namespace eval punk {
interp alias {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|

56
src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm

@ -105,6 +105,8 @@ tcl::namespace::eval punk::aliascore {
#functions must be in export list of their source namespace
set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force]
#we never override existing aliases to ::repl::interp* even if -force = 1
#(these are our safebase aliases)
set ignore_pattern "::repl::interp*"
set ignore_aliases [list]
variable aliases
if {!$opt_force} {
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
if {[llength $cmd] > 1} {
#use alias mechanism
set existing_target [interp alias "" $a]
} else {
#using namespace import
#check origin
set existing_target [tcl::namespace::origin $cmd]
set existing [list]
set conflicts [list]
foreach {a cmd} $aliases {
if {[tcl::info::commands ::$a] ne ""} {
lappend existing $a
set existing_alias [interp alias "" $a]
if {$existing_alias ne ""} {
set existing_target $existing_alias
if {[string match $ignore_pattern $existing_target]} {
#don't consider it a conflict - will use ignore_aliases to exclude it below
lappend ignore_aliases $a
continue
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
} else {
if {[catch {tcl::namespace::origin $a} existing_command]} {
set existing_command ""
}
set existing_target $existing_command
}
if {$existing_target ne $cmd} {
#command exists in global ns but doesn't match our defined aliases/imports
lappend conflicts $a
}
}
if {[llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
}
if {!$opt_force && [llength $conflicts]} {
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts"
}
set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd
} else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
}
}
#tcl::namespace::delete $tempns
return [dict keys $aliases]
return [dict create aliases [dict keys $aliases] unchanged $ignore_aliases changed $conflicts]
}

868
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm

File diff suppressed because it is too large Load Diff

2
src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm

@ -1556,7 +1556,7 @@ namespace eval punk::fileline::lib {
set argd [punk::args::get_dict {
-offset -default 0
} $args]
lassign [dict values $argd] opts remainingargs
lassign [dict values $argd] leaders opts remainingargs
}

81
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm

@ -211,6 +211,9 @@ tcl::namespace::eval punk::lib::compat {
#*** !doctools
#[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}]
}
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed)
proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
set ns_mapped [string map {:: \uFFFF} $ns]
#puts stderr "aliases ns: $ns_mapped"
set segments [split $ns_mapped \uFFFF] ;#include empty string before leading ::
if {![string length [lindex $segments end]]} {
#special case for :: only include leading segment rather thatn {} {}
set segments [lrange $segments 0 end-1]
}
set segcount [llength $segments] ;#only match number of segments matching current ns
set all_aliases [interp aliases {}]
set matched [list]
foreach a $all_aliases {
#normalize with leading ::
if {![string match ::* $a]} {
set abs ::$a
} else {
set abs $a
}
set asegs [split [string map {:: \uFFFF} $abs] \uFFFF]
set acount [llength $asegs]
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments"
if {[expr {$acount - 1}] == $segcount} {
if {[lrange $asegs 0 end-1] eq $segments} {
if {[string match $glob [lindex $asegs end]]} {
#report this alias in the current namespace - even though there may be no matching command
lappend matched $a ;#add raw alias token which may or may not have leading ::
}
}
}
}
#set matched_abs [lsearch -all -inline $all_aliases $glob]
return $matched
}
proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command
if {[llength $args]} {
if {$aliasorglob in [interp aliases ""]} {
set existing [interp alias "" $aliasorglob]
puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)"
}
if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} {
#use empty string/whitespace as intention to delete alias
return [interp alias "" $aliasorglob ""]
}
return [interp alias "" $aliasorglob "" {*}$args]
} else {
if {![string length $aliasorglob]} {
set aliaslist [punk::lib::aliases]
puts -nonewline stderr $aliaslist
return
}
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias
set target [interp alias "" $aliasorglob]
if {[llength $target]} {
return $target
}
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} {
set aliaslist [punk::lib::aliases $aliasorglob]
puts -nonewline stderr $aliaslist
return
}
return [list]
}
}
# == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == ==
# Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency
@ -2894,7 +2971,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n
*values -min 1 -max 1
} $args]] opts values
} $args]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
@ -2936,7 +3013,7 @@ namespace eval punk::lib {
lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1
-block -default {}
} $args]] opts valuedict
} $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
}

2
src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm

@ -153,7 +153,7 @@ namespace eval punk::mix::commandset::module {
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]

7
src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm

@ -643,7 +643,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values_dict
lassign [dict values $argd] leaders opts values_dict
set opt_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes]
@ -726,6 +726,7 @@ tcl::namespace::eval punk::nav::fs {
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} {
set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts vals
lassign [dict values $argd] leaders opts vals
set list_of_dicts [dict values $vals]

40
src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm

@ -20,8 +20,8 @@
package require punk::lib
package require punk::args
tcl::namespace::eval ::punk_dynamic::ns {
tcl::namespace::eval ::punk::ns::evaluator {
#eval-_NS_xxx_NS_etc procs
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -29,6 +29,12 @@ tcl::namespace::eval punk::ns {
variable ns_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp
catch {
package require debug
debug define punk.ns.compile
#debug on punk.ns.compile
#debug level punk.ns.compile 3
}
#leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body
}
proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace"
}
set loc [string map {:: _sep_} $fqns]
set loc [string map {:: _NS_} $fqns]
#set cmd ::punk::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc
set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns]
proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6
debug.punk.ns.compile {proc $cmd} 2
}
tailcall $cmd $script
}
@ -800,14 +807,23 @@ tcl::namespace::eval punk::ns {
set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
#set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}]
set chwidest1 [tcl::mathfunc::max {*}$lenlist1]
#set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}]
set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]]
#wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed
set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
#set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]]
#set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}]
set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]]
set displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1
sourcepattern -type string -optional 0
}
lassign [dict values [punk::args::get_dict $argspecs $args]] opts values
lassign [dict values [punk::args::get_dict $argspecs $args]] leaders opts values
set sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $sourcepattern]

2
src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm

@ -662,7 +662,7 @@ namespace eval punk::path {
*values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1
} $args]
lassign [dict values $argd] opts values
lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]

17
src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.tm

@ -2857,7 +2857,7 @@ namespace eval repl {
set ::argc 0
set ::argv {}
set ::auto_path %autopath%
#puts stdout "safe interp"
#puts stdout "safebase interp"
#flush stdout
namespace eval ::codeinterp {
variable errstack {}
@ -2879,6 +2879,17 @@ namespace eval repl {
} else {
interp share {} [shellfilter::stack::item_tophandle stderr] code
}
interp eval code {
package require punk::lib
package require textblock ;#may fail to load term::ansi::code::macros - (only required for altg)
}
#JMN
interp eval code {
package require shellfilter
}
#work around bug in safe base which won't load Tcl libs that have deeper nesting
#(also affects tcllib page/plugins folder)
set termversions [package versions term]
@ -2896,13 +2907,15 @@ namespace eval repl {
}
#code invokehidden source c:/repo/jn/shellspy/modules/punk/lib-0.1.1.tm
code alias detok ::safe::DetokPath code
code alias detok ::safe::DetokPath code ;#temp - this violates the point of the {$p(:X:)} paths
#review - exit should do something slightly different
# see ::safe::interpDelete
code alias exit ::repl::interphelpers::quit
code alias ::md5::md5 ::repl::interphelpers::md5
code alias ::fconfigure ::fconfigure ;#needed for shellfilter
code alias ::file ::file
interp eval code [list package provide md5 $md5version]
} else {
interp create code

1491
src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm

File diff suppressed because it is too large Load Diff

98
src/vfs/_vfscommon.vfs/modules/shellfilter-0.1.9.tm

@ -13,46 +13,60 @@
tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create]
variable is_enabled 0
proc disable {} {
variable is_enabled
set is_enabled 0
proc ::shellfilter::log::open {tag settingsdict} {}
proc ::shellfilter::log::write {tag msg} {}
proc ::shellfilter::log::write_sync {tag msg} {}
proc ::shellfilter::log::close {tag} {}
}
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
package require shellthread
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
proc enable {} {
variable is_enabled
set is_enabled 1
#'tag' is an identifier for the log source.
# each tag will use it's own thread to write to the configured log target
proc ::shellfilter::log::open {tag {settingsdict {}}} {
upvar ::shellfilter::sources sourcelist
if {![dict exists $settingsdict -tag]} {
tcl::dict::set settingsdict -tag $tag
} else {
#review
if {$tag ne [tcl::dict::get $settingsdict -tag]} {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value"
}
}
}
if {$tag ni $sourcelist} {
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
proc write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
lappend sourcelist $tag
}
#note new_worker
set worker_tid [shellthread::manager::new_worker $tag $settingsdict]
#puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid"
return $worker_tid
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
proc ::shellfilter::log::write {tag msg} {
upvar ::shellfilter::sources sourcelist
variable allow_adhoc_tags
if {!$allow_adhoc_tags} {
if {$tag ni $sourcelist} {
error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag <settings>, and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags"
}
}
shellthread::manager::write_log $tag $msg
}
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written
proc ::shellfilter::log::write_sync {tag msg} {
shellthread::manager::write_log $tag $msg -async 0
}
proc ::shellfilter::log::close {tag} {
#shellthread::manager::close_worker $tag
shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed
}
}
#review
@ -73,6 +87,12 @@ tcl::namespace::eval shellfilter::log {
}
}
}
if {[catch {package require shellthread}]} {
shellfilter::log::disable
} else {
shellfilter::log::enable
}
}
namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere
@ -1594,7 +1614,13 @@ namespace eval shellfilter::stack {
set tag "SHELLFILTER::STACK"
#JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514}
::shellfilter::log::open $tag {-syslog ""}
if {[catch {
::shellfilter::log::open $tag {-syslog ""}
} err]} {
#e.g safebase interp can't load required modules such as shellthread (or Thread)
puts stderr "shellfilter::show_pipeline cannot open log"
return
}
::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack {
::shellfilter::log::write $tag " $tf"

181
src/vfs/_vfscommon.vfs/modules/termscheme-0.1.0.tm

@ -0,0 +1,181 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <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) 2024
#
# @@ Meta Begin
# Application termscheme 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_termscheme 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require termscheme]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of termscheme
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by termscheme
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval termscheme::class {
#*** !doctools
#[subsection {Namespace termscheme::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval termscheme {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace termscheme}]
#[para] Core API functions for termscheme
#[list_begin definitions]
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace termscheme ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval termscheme::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace termscheme::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace termscheme::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval termscheme::system {
#*** !doctools
#[subsection {Namespace termscheme::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide termscheme [tcl::namespace::eval termscheme {
variable pkg termscheme
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

15
src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm

@ -62,7 +62,14 @@ catch {package require patternpunk}
package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list.
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
if {[catch {
package require term::ansi::code::macros ;#required for frame if old ansi g0 used - review - make package optional?
} errM]} {
#catch this too in case stderr not available
catch {
puts stderr "textblock package failed to load term::ansi::code::macros with error: $errM"
}
}
package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer
blocks -type string -multiple 1
} $args] _o opts _v values
} $args] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks]
set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary."
memberglob -type globstring -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices {
corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj
}\
@ -8110,7 +8117,7 @@ tcl::namespace::eval textblock {
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors)
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used.
"
*values -min 1 -max 1
*values -min 0 -max 1
size -default 1 -type integer
}
proc gcross {args} {

Loading…
Cancel
Save