Browse Source

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

master
Julian Noble 4 months 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 \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}] }]
set argd [punk::args::get_dict $argspecs $args] 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] 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. #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 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 *}} { proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::aliases $glob
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} { proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::alias $aliasorglob {*}$args
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]
}
} }
#pipeline-toys - put in lib/scriptlib? #pipeline-toys - put in lib/scriptlib?
##geometric mean ##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i| #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 {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| 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 #functions must be in export list of their source namespace
set aliases [tcl::dict::create\ set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\ tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\ list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\ lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force] 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 variable aliases
if {!$opt_force} { set existing [list]
set existing [list] set conflicts [list]
set conflicts [list] foreach {a cmd} $aliases {
foreach {a cmd} $aliases { if {[tcl::info::commands ::$a] ne ""} {
if {[tcl::info::commands ::$a] ne ""} { lappend existing $a
lappend existing $a set existing_alias [interp alias "" $a]
if {[llength $cmd] > 1} { if {$existing_alias ne ""} {
#use alias mechanism set existing_target $existing_alias
set existing_target [interp alias "" $a] if {[string match $ignore_pattern $existing_target]} {
} else { #don't consider it a conflict - will use ignore_aliases to exclude it below
#using namespace import lappend ignore_aliases $a
#check origin continue
set existing_target [tcl::namespace::origin $cmd]
} }
if {$existing_target ne $cmd} { } else {
#command exists in global ns but doesn't match our defined aliases/imports if {[catch {tcl::namespace::origin $a} existing_command]} {
lappend conflicts $a 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 set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases { dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd" #puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} { if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd interp alias {} $a {} {*}$cmd
} else { } else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
} }
} }
#tcl::namespace::delete $tempns #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 { set argd [punk::args::get_dict {
-offset -default 0 -offset -default 0
} $args] } $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 #*** !doctools
#[list_begin definitions] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] 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 # Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency # - 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 { lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n -joinchar -default \n
*values -min 1 -max 1 *values -min 1 -max 1
} $args]] opts values } $args]] leaders opts values
puts "opts:$opts" puts "opts:$opts"
puts "values:$values" puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] 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 { lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1 *opts -any 1
-block -default {} -block -default {}
} $args]] opts valuedict } $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $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 module -type string
}] }]
set argd [punk::args::get_dict $argspecs $args] 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 module [dict get $values module]
#set opts [dict merge $defaults $args] #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 *values -min 0 -max -1
} }
set argd [punk::args::get_dict $argspecs $args] 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_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes] 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 # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0 *opts -any 0
-searchbase -default "" -searchbase -default ""
-tailglob -default "\uFFFF" -tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string *values -min 0 -max -1 -type string
} }
set argd [punk::args::get_dict $argspecs $args] 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] set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict *values -min 1 -max -1 -type dict
} }
set argd [punk::args::get_dict $argspecs $args] 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] 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::lib
package require punk::args 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_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp 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 #leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} { proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body return $body
} }
proc nseval {fqns script} { proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} { if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace" 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::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} { if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns] append body \n [nseval_script $fqns]
proc $cmd {script} $body proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6 debug.punk.ns.compile {proc $cmd} 2
} }
tailcall $cmd $script 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 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 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 #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 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 cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {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 cmdwidest4 [pipedata [list {*}$elements4 ""] {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 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 displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]] set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1 *values -min 1 -max 1
sourcepattern -type string -optional 0 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 sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $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 *values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1 tailglobs -multiple 1
} $args] } $args]
lassign [dict values $argd] opts values lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values] set tailglobs [dict values $values]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] 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 { tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1 variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create] 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. proc enable {} {
# each tag will use it's own thread to write to the configured log target variable is_enabled
proc open {tag {settingsdict {}}} { set is_enabled 1
upvar ::shellfilter::sources sourcelist #'tag' is an identifier for the log source.
package require shellthread # each tag will use it's own thread to write to the configured log target
if {![dict exists $settingsdict -tag]} { proc ::shellfilter::log::open {tag {settingsdict {}}} {
tcl::dict::set settingsdict -tag $tag upvar ::shellfilter::sources sourcelist
} else { if {![dict exists $settingsdict -tag]} {
#review tcl::dict::set settingsdict -tag $tag
if {$tag ne [tcl::dict::get $settingsdict -tag]} { } else {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" #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} { 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 proc ::shellfilter::log::write {tag msg} {
} upvar ::shellfilter::sources sourcelist
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written variable allow_adhoc_tags
proc write_sync {tag msg} { if {!$allow_adhoc_tags} {
shellthread::manager::write_log $tag $msg -async 0 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"
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 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 #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 { namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere #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" set tag "SHELLFILTER::STACK"
#JMN - load from config #JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514} #::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" ::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack { foreach tf $stack {
::shellfilter::log::write $tag " $tf" ::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 package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. #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 package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict { lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 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 blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1 *values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\ frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary." -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 corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj 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) 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. 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 size -default 1 -type integer
} }
proc gcross {args} { 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 \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}] }]
set argd [punk::args::get_dict $argspecs $args] 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] 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. #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 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 *}} { proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::aliases $glob
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} { proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::alias $aliasorglob {*}$args
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]
}
} }
#pipeline-toys - put in lib/scriptlib? #pipeline-toys - put in lib/scriptlib?
##geometric mean ##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i| #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 {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| 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 #functions must be in export list of their source namespace
set aliases [tcl::dict::create\ set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\ tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\ list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\ lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force] 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 variable aliases
if {!$opt_force} { set existing [list]
set existing [list] set conflicts [list]
set conflicts [list] foreach {a cmd} $aliases {
foreach {a cmd} $aliases { if {[tcl::info::commands ::$a] ne ""} {
if {[tcl::info::commands ::$a] ne ""} { lappend existing $a
lappend existing $a set existing_alias [interp alias "" $a]
if {[llength $cmd] > 1} { if {$existing_alias ne ""} {
#use alias mechanism set existing_target $existing_alias
set existing_target [interp alias "" $a] if {[string match $ignore_pattern $existing_target]} {
} else { #don't consider it a conflict - will use ignore_aliases to exclude it below
#using namespace import lappend ignore_aliases $a
#check origin continue
set existing_target [tcl::namespace::origin $cmd]
} }
if {$existing_target ne $cmd} { } else {
#command exists in global ns but doesn't match our defined aliases/imports if {[catch {tcl::namespace::origin $a} existing_command]} {
lappend conflicts $a 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 set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases { dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd" #puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} { if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd interp alias {} $a {} {*}$cmd
} else { } else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
} }
} }
#tcl::namespace::delete $tempns #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 { set argd [punk::args::get_dict {
-offset -default 0 -offset -default 0
} $args] } $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 #*** !doctools
#[list_begin definitions] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] 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 # Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency # - 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 { lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n -joinchar -default \n
*values -min 1 -max 1 *values -min 1 -max 1
} $args]] opts values } $args]] leaders opts values
puts "opts:$opts" puts "opts:$opts"
puts "values:$values" puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] 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 { lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1 *opts -any 1
-block -default {} -block -default {}
} $args]] opts valuedict } $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $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 module -type string
}] }]
set argd [punk::args::get_dict $argspecs $args] 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 module [dict get $values module]
#set opts [dict merge $defaults $args] #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 *values -min 0 -max -1
} }
set argd [punk::args::get_dict $argspecs $args] 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_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes] 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 # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0 *opts -any 0
-searchbase -default "" -searchbase -default ""
-tailglob -default "\uFFFF" -tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string *values -min 0 -max -1 -type string
} }
set argd [punk::args::get_dict $argspecs $args] 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] set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict *values -min 1 -max -1 -type dict
} }
set argd [punk::args::get_dict $argspecs $args] 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] 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::lib
package require punk::args 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_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp 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 #leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} { proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body return $body
} }
proc nseval {fqns script} { proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} { if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace" 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::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} { if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns] append body \n [nseval_script $fqns]
proc $cmd {script} $body proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6 debug.punk.ns.compile {proc $cmd} 2
} }
tailcall $cmd $script 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 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 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 #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 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 cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {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 cmdwidest4 [pipedata [list {*}$elements4 ""] {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 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 displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]] set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1 *values -min 1 -max 1
sourcepattern -type string -optional 0 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 sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $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 *values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1 tailglobs -multiple 1
} $args] } $args]
lassign [dict values $argd] opts values lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values] set tailglobs [dict values $values]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] 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 { tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1 variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create] 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. proc enable {} {
# each tag will use it's own thread to write to the configured log target variable is_enabled
proc open {tag {settingsdict {}}} { set is_enabled 1
upvar ::shellfilter::sources sourcelist #'tag' is an identifier for the log source.
package require shellthread # each tag will use it's own thread to write to the configured log target
if {![dict exists $settingsdict -tag]} { proc ::shellfilter::log::open {tag {settingsdict {}}} {
tcl::dict::set settingsdict -tag $tag upvar ::shellfilter::sources sourcelist
} else { if {![dict exists $settingsdict -tag]} {
#review tcl::dict::set settingsdict -tag $tag
if {$tag ne [tcl::dict::get $settingsdict -tag]} { } else {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" #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} { 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 proc ::shellfilter::log::write {tag msg} {
} upvar ::shellfilter::sources sourcelist
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written variable allow_adhoc_tags
proc write_sync {tag msg} { if {!$allow_adhoc_tags} {
shellthread::manager::write_log $tag $msg -async 0 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"
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 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 #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 { namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere #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" set tag "SHELLFILTER::STACK"
#JMN - load from config #JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514} #::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" ::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack { foreach tf $stack {
::shellfilter::log::write $tag " $tf" ::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 package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. #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 package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict { lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 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 blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1 *values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\ frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary." -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 corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj 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) 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. 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 size -default 1 -type integer
} }
proc gcross {args} { 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 \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}] }]
set argd [punk::args::get_dict $argspecs $args] 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] 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. #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 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 *}} { proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::aliases $glob
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} { proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::alias $aliasorglob {*}$args
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]
}
} }
#pipeline-toys - put in lib/scriptlib? #pipeline-toys - put in lib/scriptlib?
##geometric mean ##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i| #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 {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| 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 #functions must be in export list of their source namespace
set aliases [tcl::dict::create\ set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\ tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\ list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\ lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force] 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 variable aliases
if {!$opt_force} { set existing [list]
set existing [list] set conflicts [list]
set conflicts [list] foreach {a cmd} $aliases {
foreach {a cmd} $aliases { if {[tcl::info::commands ::$a] ne ""} {
if {[tcl::info::commands ::$a] ne ""} { lappend existing $a
lappend existing $a set existing_alias [interp alias "" $a]
if {[llength $cmd] > 1} { if {$existing_alias ne ""} {
#use alias mechanism set existing_target $existing_alias
set existing_target [interp alias "" $a] if {[string match $ignore_pattern $existing_target]} {
} else { #don't consider it a conflict - will use ignore_aliases to exclude it below
#using namespace import lappend ignore_aliases $a
#check origin continue
set existing_target [tcl::namespace::origin $cmd]
} }
if {$existing_target ne $cmd} { } else {
#command exists in global ns but doesn't match our defined aliases/imports if {[catch {tcl::namespace::origin $a} existing_command]} {
lappend conflicts $a 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 set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases { dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd" #puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} { if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd interp alias {} $a {} {*}$cmd
} else { } else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
} }
} }
#tcl::namespace::delete $tempns #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 { set argd [punk::args::get_dict {
-offset -default 0 -offset -default 0
} $args] } $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 #*** !doctools
#[list_begin definitions] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] 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 # Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency # - 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 { lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n -joinchar -default \n
*values -min 1 -max 1 *values -min 1 -max 1
} $args]] opts values } $args]] leaders opts values
puts "opts:$opts" puts "opts:$opts"
puts "values:$values" puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] 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 { lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1 *opts -any 1
-block -default {} -block -default {}
} $args]] opts valuedict } $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $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 module -type string
}] }]
set argd [punk::args::get_dict $argspecs $args] 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 module [dict get $values module]
#set opts [dict merge $defaults $args] #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 *values -min 0 -max -1
} }
set argd [punk::args::get_dict $argspecs $args] 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_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes] 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 # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0 *opts -any 0
-searchbase -default "" -searchbase -default ""
-tailglob -default "\uFFFF" -tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string *values -min 0 -max -1 -type string
} }
set argd [punk::args::get_dict $argspecs $args] 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] set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict *values -min 1 -max -1 -type dict
} }
set argd [punk::args::get_dict $argspecs $args] 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] 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::lib
package require punk::args 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_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp 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 #leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} { proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body return $body
} }
proc nseval {fqns script} { proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} { if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace" 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::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} { if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns] append body \n [nseval_script $fqns]
proc $cmd {script} $body proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6 debug.punk.ns.compile {proc $cmd} 2
} }
tailcall $cmd $script 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 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 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 #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 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 cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {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 cmdwidest4 [pipedata [list {*}$elements4 ""] {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 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 displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]] set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1 *values -min 1 -max 1
sourcepattern -type string -optional 0 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 sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $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 *values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1 tailglobs -multiple 1
} $args] } $args]
lassign [dict values $argd] opts values lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values] set tailglobs [dict values $values]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] 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 { tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1 variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create] 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. proc enable {} {
# each tag will use it's own thread to write to the configured log target variable is_enabled
proc open {tag {settingsdict {}}} { set is_enabled 1
upvar ::shellfilter::sources sourcelist #'tag' is an identifier for the log source.
package require shellthread # each tag will use it's own thread to write to the configured log target
if {![dict exists $settingsdict -tag]} { proc ::shellfilter::log::open {tag {settingsdict {}}} {
tcl::dict::set settingsdict -tag $tag upvar ::shellfilter::sources sourcelist
} else { if {![dict exists $settingsdict -tag]} {
#review tcl::dict::set settingsdict -tag $tag
if {$tag ne [tcl::dict::get $settingsdict -tag]} { } else {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" #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} { 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 proc ::shellfilter::log::write {tag msg} {
} upvar ::shellfilter::sources sourcelist
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written variable allow_adhoc_tags
proc write_sync {tag msg} { if {!$allow_adhoc_tags} {
shellthread::manager::write_log $tag $msg -async 0 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"
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 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 #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 { namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere #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" set tag "SHELLFILTER::STACK"
#JMN - load from config #JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514} #::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" ::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack { foreach tf $stack {
::shellfilter::log::write $tag " $tf" ::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 package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. #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 package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict { lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 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 blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1 *values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\ frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary." -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 corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj 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) 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. 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 size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {

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

@ -6976,7 +6976,7 @@ namespace eval punk {
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
}] }]
set argd [punk::args::get_dict $argspecs $args] 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] 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. #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 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 *}} { proc aliases {{glob *}} {
set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::aliases $glob
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} { proc alias {{aliasorglob ""} args} {
set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command tailcall punk::lib::alias $aliasorglob {*}$args
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]
}
} }
#pipeline-toys - put in lib/scriptlib? #pipeline-toys - put in lib/scriptlib?
##geometric mean ##geometric mean
#alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** <i| #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 {} help {} punk::help
interp alias {} aliases {} punk::aliases
interp alias {} alias {} punk::alias
interp alias {} treemore {} punk::xmore tree interp alias {} treemore {} punk::xmore tree
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| 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 #functions must be in export list of their source namespace
set aliases [tcl::dict::create\ set aliases [tcl::dict::create\
aliases ::punk::lib::aliases\
alias ::punk::lib::alias\
tstr ::punk::lib::tstr\ tstr ::punk::lib::tstr\
list_as_lines ::punk::lib::list_as_lines\ list_as_lines ::punk::lib::list_as_lines\
lines_as_list ::punk::lib::lines_as_list\ lines_as_list ::punk::lib::lines_as_list\
@ -155,34 +157,48 @@ tcl::namespace::eval punk::aliascore {
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set opt_force [dict get $opts -force] 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 variable aliases
if {!$opt_force} { set existing [list]
set existing [list] set conflicts [list]
set conflicts [list] foreach {a cmd} $aliases {
foreach {a cmd} $aliases { if {[tcl::info::commands ::$a] ne ""} {
if {[tcl::info::commands ::$a] ne ""} { lappend existing $a
lappend existing $a set existing_alias [interp alias "" $a]
if {[llength $cmd] > 1} { if {$existing_alias ne ""} {
#use alias mechanism set existing_target $existing_alias
set existing_target [interp alias "" $a] if {[string match $ignore_pattern $existing_target]} {
} else { #don't consider it a conflict - will use ignore_aliases to exclude it below
#using namespace import lappend ignore_aliases $a
#check origin continue
set existing_target [tcl::namespace::origin $cmd]
} }
if {$existing_target ne $cmd} { } else {
#command exists in global ns but doesn't match our defined aliases/imports if {[catch {tcl::namespace::origin $a} existing_command]} {
lappend conflicts $a 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 set tempns ::temp_[info cmdcount] ;#temp ns for renames
dict for {a cmd} $aliases { dict for {a cmd} $aliases {
#puts "aliascore $a -> $cmd" #puts "aliascore $a -> $cmd"
if {$a in $ignore_aliases} {
continue
}
if {[llength $cmd] > 1} { if {[llength $cmd] > 1} {
interp alias {} $a {} {*}$cmd interp alias {} $a {} {*}$cmd
} else { } else {
@ -205,7 +221,7 @@ tcl::namespace::eval punk::aliascore {
} }
} }
#tcl::namespace::delete $tempns #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 { set argd [punk::args::get_dict {
-offset -default 0 -offset -default 0
} $args] } $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 #*** !doctools
#[list_begin definitions] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"
interp alias {} lremove {} ::punk::lib::compat::lremove interp alias {} lremove {} ::punk::lib::compat::lremove
@ -393,6 +396,80 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] 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 # Maintenance - This is the primary source for tm_version... functions
# - certain packages script require these but without package dependency # - 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 { lassign [tcl::dict::values [punk::args::get_dict {
-joinchar -default \n -joinchar -default \n
*values -min 1 -max 1 *values -min 1 -max 1
} $args]] opts values } $args]] leaders opts values
puts "opts:$opts" puts "opts:$opts"
puts "values:$values" puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] 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 { lassign [tcl::dict::values [punk::args::get_dict {
*opts -any 1 *opts -any 1
-block -default {} -block -default {}
} $args]] opts valuedict } $args]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $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 module -type string
}] }]
set argd [punk::args::get_dict $argspecs $args] 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 module [dict get $values module]
#set opts [dict merge $defaults $args] #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 *values -min 0 -max -1
} }
set argd [punk::args::get_dict $argspecs $args] 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_stripbase [dict get $opts -stripbase]
set opt_formatsizes [dict get $opts -formatsizes] 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 # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argspecs {
*id punk::nav::fs::dirfiles_dict
*opts -any 0 *opts -any 0
-searchbase -default "" -searchbase -default ""
-tailglob -default "\uFFFF" -tailglob -default "\uFFFF"
@ -735,7 +736,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 0 -max -1 -type string *values -min 0 -max -1 -type string
} }
set argd [punk::args::get_dict $argspecs $args] 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] set searchspecs [dict values $vals]
#puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stderr "searchspecs: $searchspecs [llength $searchspecs]"
@ -1000,7 +1001,7 @@ tcl::namespace::eval punk::nav::fs {
*values -min 1 -max -1 -type dict *values -min 1 -max -1 -type dict
} }
set argd [punk::args::get_dict $argspecs $args] 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] 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::lib
package require punk::args 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_current "::"
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns
namespace export nsjoin nsprefix nstail nsparts nseval nsimport_noclobber corp 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 #leading colon makes it hard (impossible?) to call directly if not within the namespace
proc ns/ {v {ns_or_glob ""} args} { proc ns/ {v {ns_or_glob ""} args} {
@ -200,16 +206,17 @@ tcl::namespace::eval punk::ns {
return $body return $body
} }
proc nseval {fqns script} { proc nseval {fqns script} {
#create one proc for each fully qualified namespace to evaluate script
if {![string match ::* $fqns]} { if {![string match ::* $fqns]} {
error "nseval only accepts a fully qualified namespace" 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::pipecmds::nseval_$loc
set cmd ::punk_dynamic::ns::eval-$loc set cmd ::punk::ns::evaluator::eval-$loc
if {$cmd ni [info commands $cmd]} { if {$cmd ni [info commands $cmd]} {
append body \n [nseval_script $fqns] append body \n [nseval_script $fqns]
proc $cmd {script} $body proc $cmd {script} $body
debug.punk.pipe.compile {proc $cmd} 6 debug.punk.ns.compile {proc $cmd} 2
} }
tailcall $cmd $script 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 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 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 #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 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 cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {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 cmdwidest4 [pipedata [list {*}$elements4 ""] {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 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 displaylist [list]
set col1 [string repeat " " [expr {$chwidest1 + 8}]] set col1 [string repeat " " [expr {$chwidest1 + 8}]]
@ -1875,7 +1891,7 @@ tcl::namespace::eval punk::ns {
*values -min 1 -max 1 *values -min 1 -max 1
sourcepattern -type string -optional 0 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 sourcepattern [dict get $values sourcepattern]
set source_ns [tcl::namespace::qualifiers $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 *values -min 0 -max -1 -optional 1 -type string
tailglobs -multiple 1 tailglobs -multiple 1
} $args] } $args]
lassign [dict values $argd] opts values lassign [dict values $argd] leaders opts values
set tailglobs [dict values $values] set tailglobs [dict values $values]
# -- --- --- --- --- --- --- # -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] 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 ::argc 0
set ::argv {} set ::argv {}
set ::auto_path %autopath% set ::auto_path %autopath%
#puts stdout "safe interp" #puts stdout "safebase interp"
#flush stdout #flush stdout
namespace eval ::codeinterp { namespace eval ::codeinterp {
variable errstack {} variable errstack {}
@ -2879,6 +2879,17 @@ namespace eval repl {
} else { } else {
interp share {} [shellfilter::stack::item_tophandle stderr] code 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 #work around bug in safe base which won't load Tcl libs that have deeper nesting
#(also affects tcllib page/plugins folder) #(also affects tcllib page/plugins folder)
set termversions [package versions term] 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 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 #review - exit should do something slightly different
# see ::safe::interpDelete # see ::safe::interpDelete
code alias exit ::repl::interphelpers::quit code alias exit ::repl::interphelpers::quit
code alias ::md5::md5 ::repl::interphelpers::md5 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] interp eval code [list package provide md5 $md5version]
} else { } else {
interp create code 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 { tcl::namespace::eval shellfilter::log {
variable allow_adhoc_tags 1 variable allow_adhoc_tags 1
variable open_logs [tcl::dict::create] 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. proc enable {} {
# each tag will use it's own thread to write to the configured log target variable is_enabled
proc open {tag {settingsdict {}}} { set is_enabled 1
upvar ::shellfilter::sources sourcelist #'tag' is an identifier for the log source.
package require shellthread # each tag will use it's own thread to write to the configured log target
if {![dict exists $settingsdict -tag]} { proc ::shellfilter::log::open {tag {settingsdict {}}} {
tcl::dict::set settingsdict -tag $tag upvar ::shellfilter::sources sourcelist
} else { if {![dict exists $settingsdict -tag]} {
#review tcl::dict::set settingsdict -tag $tag
if {$tag ne [tcl::dict::get $settingsdict -tag]} { } else {
error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" #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} { 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 proc ::shellfilter::log::write {tag msg} {
} upvar ::shellfilter::sources sourcelist
#write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written variable allow_adhoc_tags
proc write_sync {tag msg} { if {!$allow_adhoc_tags} {
shellthread::manager::write_log $tag $msg -async 0 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"
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 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 #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 { namespace eval shellfilter::pipe {
#write channel for program. workerthread reads other end of fifo2 and writes data somewhere #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" set tag "SHELLFILTER::STACK"
#JMN - load from config #JMN - load from config
#::shellfilter::log::open $tag {-syslog 127.0.0.1:514} #::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" ::shellfilter::log::write $tag "transform stack for $pipename $args"
foreach tf $stack { foreach tf $stack {
::shellfilter::log::write $tag " $tf" ::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 package require overtype
#safebase interps as at 2024-08 can't access deeper paths - even though they are below the supposed safe list. #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 package require textutil
@ -5182,7 +5189,7 @@ tcl::namespace::eval textblock {
lassign [punk::args::get_dict { lassign [punk::args::get_dict {
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 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 blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5844,7 +5851,7 @@ tcl::namespace::eval textblock {
*values -min 1 *values -min 1
frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\ frametype -choices "<ftlist>" -choiceprefix 0 -choicerestricted 0 -type dict\
-help "name from the predefined frametypes or an adhoc dictionary." -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 corner noncorner top bottom vertical horizontal left right
hl hlt hlb vsl vll vlr tlc trc blc brc hltj hlbj vllj vlrj 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) 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. 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 size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {

Loading…
Cancel
Save