Browse Source

bootsupport commandstack punk::packagepreference

master
Julian Noble 3 months ago
parent
commit
6e38d4cf54
  1. 512
      src/bootsupport/modules/commandstack-0.3.tm
  2. 20
      src/bootsupport/modules/include_modules.config
  3. 267
      src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  4. 512
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm
  5. 20
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config
  6. 267
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  7. 512
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm
  8. 20
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config
  9. 267
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  10. 283
      src/vendormodules/commandstack-0.2.tm
  11. 7
      src/vendormodules/include_modules.config
  12. 218
      src/vfs/_vfscommon/modules/commandstack-0.1.tm
  13. 283
      src/vfs/_vfscommon/modules/commandstack-0.2.tm
  14. 58
      src/vfs/_vfscommon/modules/punk/mix/cli-0.3.1.tm

512
src/bootsupport/modules/commandstack-0.3.tm

@ -0,0 +1,512 @@
#JMN 2021 - Public Domain
#cooperative command renaming
#
# REVIEW 2024 - code was originally for specific use in packageTrace
# - code should be reviewed for more generic utility.
# - API is obscure and undocumented.
# - unclear if intention was only for builtins
# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename
#changes:
#2024
# - mungecommand to support namespaced commands
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
#strive for no other package dependencies here.
namespace eval commandstack {
variable all_stacks
variable debug
set debug 0
variable known_renamers [list ::packagetrace ::packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
}
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTOR {command} {
#assert - command has already been resolved to a namespace ie fully qualified
if {[llength [info procs $command]]} {
#look for *IMPLEMENTOR_*!
set prefix IMPLEMENTOR_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
if {[info commands tcl::info::cmdtype] ne ""} {
#tcl9 and maybe some tcl 8.7s ?
switch -- [tcl::info::cmdtype $command] {
native {
return builtin
}
default {
return undetermined
}
}
} else {
return undetermined
}
}
}
}
namespace eval commandstack::renamed_commands {}
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place
namespace eval commandstack {
namespace export {[a-z]*}
proc help {} {
return {
}
}
proc debug {{on_off {}}} {
variable debug
if {$on_off eq ""} {
return $debug
} else {
if {[string is boolean -strict $debug]} {
set debug [expr {$on_off && 1}]
return $debug
}
}
}
proc get_stack {command} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc get_next_command {command renamer tokenid} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
}
} else {
return $command
}
}
proc basecall {command args} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {[llength $stack]} {
set rec1 [lindex $stack 0]
tailcall [dict get $rec1 implementation] {*}$args
} else {
tailcall $command {*}$args
}
} else {
tailcall $command {*}$args
}
}
#review.
#<renamer> defaults to calling namespace - but can be arbitrary string
proc rename_command {args} {
#todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
# - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
#
if {[lindex $args 0] eq "-renamer"} {
set renamer [lindex $args 1]
set arglist [lrange $args 2 end]
} else {
set renamer ""
set arglist $args
}
if {[llength $arglist] != 3} {
error "commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody"
}
lassign $arglist command procargs procbody
set command [uplevel 1 [list namespace which $command]]
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
variable all_stacks
variable known_renamers
variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done.
if {$renamer eq ""} {
set renamer [uplevel 1 [list namespace current]]
}
if {$renamer ni $known_renamers} {
lappend known_renamers $renamer
dict set renamer_command_tokens [list $renamer $command] 0
}
#TODO - reduce emissions to stderr - flag for debug?
#e.g packageTrace and packageSuppress packages use this convention.
set nextinfo [uplevel 1 [list\
apply {{command renamer procbody} {
#todo - munge dash so we can make names in renamed_commands separable
# {- _dash_} ?
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
set do_rename 0
if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
#$command is not the standard builtin - something has replaced it, could be ourself.
set next_implementor [::commandstack::util::get_IMPLEMENTOR $command]
set munged_next_implementor [string map {:: _ns_} $next_implementor]
#if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it.
if {[dict exists $::commandstack::all_stacks $command]} {
set comstacks [dict get $::commandstack::all_stacks $command]
} else {
set comstacks [list]
}
set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer')
if {[llength $this_renamer_previous_entries]} {
if {$next_implementor eq $renamer} {
#previous renamer was us. Rather than assume our job is done.. compare the implementations
#don't rename if immediate predecessor is same code.
#set topstack [lindex $comstacks end]
#set next_impl [dict get $topstack implementation]
set current_body [info body $command]
lassign [commandstack::lib::split_body $current_body] _ current_code
set current_code [string trim $current_code]
set new_code [string trim $procbody]
if {$current_code eq $new_code} {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
puts stdout "----------"
puts stdout "$current_code"
puts stdout "----------"
puts stdout "$new_code"
puts stdout "----------"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} elseif {$next_implementor in $::commandstack::known_renamers} {
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {builtin}} {
#native/builtin could still have been renamed
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {unspecified undetermined}} {
#review - probably don't need a warning anyway
puts stderr "(commandstack::rename_command) WARNING - Something may have renamed the '$command' command. Attempting to cooperate.(untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set next_implementor original
#rename $command $next_target
set do_rename 1
}
#There are of course other ways in which $command may have been renamed - but we can't detect.
set token [list $command $renamer $tokenid]
return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename]
} } $command $renamer $procbody]
]
variable debug
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]"
}
}
#token is always first dict entry. (Value needs to be searched with lsearch -index 1 )
#renamer is always second dict entry (Value needs to be searched with lsearch -index 3)
set new_record [dict create\
token [dict get $nextinfo token]\
renamer $renamer\
next_implementor [dict get $nextinfo next_implementor]\
next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\
implementation [dict get $nextinfo next_target]\
]
if {![dict get $nextinfo do_rename]} {
#review
puts stderr "no rename performed"
return [dict create implementation ""]
}
catch {rename ::commandstack::temp::testproc ""}
set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] {
#IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% <procargs> <procbody> )
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
set COMMANDSTACKNEXT [%next_getter%]
#<commandstack_separator>#
}]
set final_procbody "$nextinit$procbody"
#build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command
#(e.g due to invalid argument specifiers)
proc ::commandstack::temp::testproc $procargs $final_procbody
uplevel 1 [list rename $command [dict get $nextinfo next_target]]
uplevel 1 [list rename ::commandstack::temp::testproc $command]
dict lappend all_stacks $command $new_record
return $new_record
}
#todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
#todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
#todo - removal of all entries pertaining to a particular renamer
#todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack?
#remove by token, or by commandname if called from same context as original rename_command
#If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed.
#A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
#similarly a nonexistant token or renamer will not remove anything and will just return the current stack
proc remove_rename {token_or_command} {
if {[llength $token_or_command] == 3} {
#is token
lassign $token_or_command command renamer tokenid
} elseif {[llength $token_or_command] == 2} {
#command and renamer only supplied
lassign $token_or_command command renamer
set tokenid ""
} elseif {[llength $token_or_command] == 1} {
#is command name only
set command $token_or_command
set renamer [uplevel 1 [list namespace current]]
set tokenid ""
}
set command [uplevel 1 [list namespace which $command]]
variable all_stacks
variable known_renamers
if {$renamer ni $known_renamers} {
error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {$tokenid ne ""} {
#token_or_command is a token as returned within the rename_command result dictionary
#search first dict value
set doomed_posn [lsearch -index 1 $stack $token_or_command]
} else {
#search second dict value
set matches [lsearch -all -index 3 $stack $renamer]
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
}
if {$doomed_posn ne "" && $doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record next_implementor] ne $renamer} {
puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record next_implementor [dict get $doomed_record next_implementor]
#don't update next_getter - it always refers to self
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
proc show_stack {{commandname_glob *}} {
variable all_stacks
if {[package provide punk::lib] ne ""} {
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
} else {
if {![regexp {[?*]} $commandname_glob]} {
#if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
}
set result ""
set matchedkeys [dict keys $all_stacks $commandname_glob]
#don't try to calculate widest on empty list
if {[llength $matchedkeys]} {
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
set indent [string repeat " " [expr {$widest + 3}]]
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
set padkey [string repeat " " 20]
foreach k $matchedkeys {
append result "$k = "
set i 0
foreach stackmember [dict get $all_stacks $k] {
if {$i > 0} {
append result "\n$indent"
}
append result [string range "$i " 0 4] " = "
set j 0
dict for {k v} $stackmember {
if {$j > 0} {
append result "\n$indent2"
}
set displaykey [string range "$k$padkey" 0 20]
append result "$displaykey = $v"
incr j
}
incr i
}
append result \n
}
}
return $result
}
}
#review
#document when this is to be called. Wiping stacks without undoing renames seems odd.
proc Delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
#review - document how/when to use. example? intention?
proc Rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}
}
namespace eval commandstack::lib {
proc splitx {str {regexp {[\t \r\n]+}}} {
#snarfed from tcllib textutil::splitx to avoid the dependency
# Bugfix 476988
if {[string length $str] == 0} {
return {}
}
if {[string length $regexp] == 0} {
return [::split $str ""]
}
if {[regexp $regexp {}]} {
return -code error "splitting on regexp \"$regexp\" would cause infinite loop"
}
set list {}
set start 0
while {[regexp -start $start -indices -- $regexp $str match submatch]} {
foreach {subStart subEnd} $submatch break
foreach {matchStart matchEnd} $match break
incr matchStart -1
incr matchEnd
lappend list [string range $str $start $matchStart]
if {$subStart >= $start} {
lappend list [string range $str $subStart $subEnd]
}
set start $matchEnd
}
lappend list [string range $str $start end]
return $list
}
proc split_body {procbody} {
set marker "#<commandstack_separator>#"
set header ""
set code ""
set found_marker 0
foreach ln [split $procbody \n] {
if {!$found_marker} {
if {[string trim $ln] eq $marker} {
set found_marker 1
} else {
append header $ln \n
}
} else {
append code $ln \n
}
}
if {$found_marker} {
return [list $header $code]
} else {
return [list "" $procbody]
}
}
}
package provide commandstack [namespace eval commandstack {
set version 0.3
}]

20
src/bootsupport/modules/include_modules.config

@ -4,14 +4,19 @@
#each entry - base module
set bootsupport_modules [list\
src/vendormodules commandstack\
src/vendormodules cksum\
src/vendormodules modpod\
src/vendormodules overtype\
src/vendormodules fauxlink\
src/vendormodules oolib\
src/vendormodules http\
src/vendormodules dictutils\
src/vendormodules fauxlink\
src/vendormodules fileutil\
src/vendormodules http\
src/vendormodules md5\
src/vendormodules modpod\
src/vendormodules oolib\
src/vendormodules overtype\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
src/vendormodules textutil::adjust\
src/vendormodules textutil::repeat\
src/vendormodules textutil::split\
@ -20,10 +25,6 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\
@ -57,6 +58,7 @@ set bootsupport_modules [list\
modules punk::ns\
modules punk::overlay\
modules punk::path\
modules punk::packagepreference\
modules punk::repo\
modules punk::tdl\
modules punk::zip\

267
src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -0,0 +1,267 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::packagepreference 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::packagepreference 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 punk::packagepreference]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::packagepreference
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::packagepreference
#[list_begin itemized]
package require Tcl 8.6-
package require commandstack
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {commandstack}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::packagepreference::class {
#*** !doctools
#[subsection {Namespace punk::packagepreference::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::packagepreference}]
#[para] Core API functions for punk::packagepreference
#[list_begin definitions]
proc uninstall {} {
#*** !doctools
#[call [fun uninstall]]
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called)
commandstack::remove_rename {::package punk::packagepreference}
}
proc install {} {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file)
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names.
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name)
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall
#todo - review/update commandstack package
#modern module/lib names should preferably be lower case
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9)
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable.
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase
#(also just overloading the package builtin comes at a cost!)
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem.
#(or in any environment where multiple versions of Tcl libraries may be available)
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file.
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective.
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} {
#::package override installed by punk::packagepreference::install
#return to previous 'package' implementation with: punk::packagepreference::uninstall
#uglier but faster than tcl::prefix::match in this instance
#maintenance - check no prefixes of require are added to builtin package command
switch -exact -- [lindex $args 0] {
r - re - req - requi - requir - require {
#puts "==>package $args"
#puts "==>[info level 1]"
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
set vwant [lindex $args 3]
if {[set ver [package provide $pkg]] ne ""} {
if {$ver eq $vwant} {
return $vwant
} else {
#package already provided with a different version.. we will defer to underlying implementation to return the standard error
return [$COMMANDSTACKNEXT {*}$args]
}
}
} else {
set pkg [lindex $args 1]
if {[set ver [package provide $pkg]] ne ""} {
return $ver
}
}
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
return [$COMMANDSTACKNEXT {*}$args]
} else {
return $v
}
} else {
return [$COMMANDSTACKNEXT {*}$args]
}
}
default {
return [$COMMANDSTACKNEXT {*}$args]
}
}
}]
if {[dict get $stackrecord implementation] ne ""} {
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command
puts stdout "punk::packagepreference renamed ::package to $impl"
} else {
puts stderr "punk::packagepreference failed to rename ::package"
}
#puts stdout [info body ::package]
}
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::packagepreference::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::packagepreference::system {
#*** !doctools
#[subsection {Namespace punk::packagepreference::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference {
variable pkg punk::packagepreference
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

512
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm

@ -0,0 +1,512 @@
#JMN 2021 - Public Domain
#cooperative command renaming
#
# REVIEW 2024 - code was originally for specific use in packageTrace
# - code should be reviewed for more generic utility.
# - API is obscure and undocumented.
# - unclear if intention was only for builtins
# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename
#changes:
#2024
# - mungecommand to support namespaced commands
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
#strive for no other package dependencies here.
namespace eval commandstack {
variable all_stacks
variable debug
set debug 0
variable known_renamers [list ::packagetrace ::packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
}
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTOR {command} {
#assert - command has already been resolved to a namespace ie fully qualified
if {[llength [info procs $command]]} {
#look for *IMPLEMENTOR_*!
set prefix IMPLEMENTOR_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
if {[info commands tcl::info::cmdtype] ne ""} {
#tcl9 and maybe some tcl 8.7s ?
switch -- [tcl::info::cmdtype $command] {
native {
return builtin
}
default {
return undetermined
}
}
} else {
return undetermined
}
}
}
}
namespace eval commandstack::renamed_commands {}
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place
namespace eval commandstack {
namespace export {[a-z]*}
proc help {} {
return {
}
}
proc debug {{on_off {}}} {
variable debug
if {$on_off eq ""} {
return $debug
} else {
if {[string is boolean -strict $debug]} {
set debug [expr {$on_off && 1}]
return $debug
}
}
}
proc get_stack {command} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc get_next_command {command renamer tokenid} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
}
} else {
return $command
}
}
proc basecall {command args} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {[llength $stack]} {
set rec1 [lindex $stack 0]
tailcall [dict get $rec1 implementation] {*}$args
} else {
tailcall $command {*}$args
}
} else {
tailcall $command {*}$args
}
}
#review.
#<renamer> defaults to calling namespace - but can be arbitrary string
proc rename_command {args} {
#todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
# - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
#
if {[lindex $args 0] eq "-renamer"} {
set renamer [lindex $args 1]
set arglist [lrange $args 2 end]
} else {
set renamer ""
set arglist $args
}
if {[llength $arglist] != 3} {
error "commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody"
}
lassign $arglist command procargs procbody
set command [uplevel 1 [list namespace which $command]]
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
variable all_stacks
variable known_renamers
variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done.
if {$renamer eq ""} {
set renamer [uplevel 1 [list namespace current]]
}
if {$renamer ni $known_renamers} {
lappend known_renamers $renamer
dict set renamer_command_tokens [list $renamer $command] 0
}
#TODO - reduce emissions to stderr - flag for debug?
#e.g packageTrace and packageSuppress packages use this convention.
set nextinfo [uplevel 1 [list\
apply {{command renamer procbody} {
#todo - munge dash so we can make names in renamed_commands separable
# {- _dash_} ?
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
set do_rename 0
if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
#$command is not the standard builtin - something has replaced it, could be ourself.
set next_implementor [::commandstack::util::get_IMPLEMENTOR $command]
set munged_next_implementor [string map {:: _ns_} $next_implementor]
#if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it.
if {[dict exists $::commandstack::all_stacks $command]} {
set comstacks [dict get $::commandstack::all_stacks $command]
} else {
set comstacks [list]
}
set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer')
if {[llength $this_renamer_previous_entries]} {
if {$next_implementor eq $renamer} {
#previous renamer was us. Rather than assume our job is done.. compare the implementations
#don't rename if immediate predecessor is same code.
#set topstack [lindex $comstacks end]
#set next_impl [dict get $topstack implementation]
set current_body [info body $command]
lassign [commandstack::lib::split_body $current_body] _ current_code
set current_code [string trim $current_code]
set new_code [string trim $procbody]
if {$current_code eq $new_code} {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
puts stdout "----------"
puts stdout "$current_code"
puts stdout "----------"
puts stdout "$new_code"
puts stdout "----------"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} elseif {$next_implementor in $::commandstack::known_renamers} {
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {builtin}} {
#native/builtin could still have been renamed
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {unspecified undetermined}} {
#review - probably don't need a warning anyway
puts stderr "(commandstack::rename_command) WARNING - Something may have renamed the '$command' command. Attempting to cooperate.(untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set next_implementor original
#rename $command $next_target
set do_rename 1
}
#There are of course other ways in which $command may have been renamed - but we can't detect.
set token [list $command $renamer $tokenid]
return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename]
} } $command $renamer $procbody]
]
variable debug
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]"
}
}
#token is always first dict entry. (Value needs to be searched with lsearch -index 1 )
#renamer is always second dict entry (Value needs to be searched with lsearch -index 3)
set new_record [dict create\
token [dict get $nextinfo token]\
renamer $renamer\
next_implementor [dict get $nextinfo next_implementor]\
next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\
implementation [dict get $nextinfo next_target]\
]
if {![dict get $nextinfo do_rename]} {
#review
puts stderr "no rename performed"
return [dict create implementation ""]
}
catch {rename ::commandstack::temp::testproc ""}
set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] {
#IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% <procargs> <procbody> )
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
set COMMANDSTACKNEXT [%next_getter%]
#<commandstack_separator>#
}]
set final_procbody "$nextinit$procbody"
#build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command
#(e.g due to invalid argument specifiers)
proc ::commandstack::temp::testproc $procargs $final_procbody
uplevel 1 [list rename $command [dict get $nextinfo next_target]]
uplevel 1 [list rename ::commandstack::temp::testproc $command]
dict lappend all_stacks $command $new_record
return $new_record
}
#todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
#todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
#todo - removal of all entries pertaining to a particular renamer
#todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack?
#remove by token, or by commandname if called from same context as original rename_command
#If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed.
#A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
#similarly a nonexistant token or renamer will not remove anything and will just return the current stack
proc remove_rename {token_or_command} {
if {[llength $token_or_command] == 3} {
#is token
lassign $token_or_command command renamer tokenid
} elseif {[llength $token_or_command] == 2} {
#command and renamer only supplied
lassign $token_or_command command renamer
set tokenid ""
} elseif {[llength $token_or_command] == 1} {
#is command name only
set command $token_or_command
set renamer [uplevel 1 [list namespace current]]
set tokenid ""
}
set command [uplevel 1 [list namespace which $command]]
variable all_stacks
variable known_renamers
if {$renamer ni $known_renamers} {
error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {$tokenid ne ""} {
#token_or_command is a token as returned within the rename_command result dictionary
#search first dict value
set doomed_posn [lsearch -index 1 $stack $token_or_command]
} else {
#search second dict value
set matches [lsearch -all -index 3 $stack $renamer]
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
}
if {$doomed_posn ne "" && $doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record next_implementor] ne $renamer} {
puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record next_implementor [dict get $doomed_record next_implementor]
#don't update next_getter - it always refers to self
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
proc show_stack {{commandname_glob *}} {
variable all_stacks
if {[package provide punk::lib] ne ""} {
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
} else {
if {![regexp {[?*]} $commandname_glob]} {
#if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
}
set result ""
set matchedkeys [dict keys $all_stacks $commandname_glob]
#don't try to calculate widest on empty list
if {[llength $matchedkeys]} {
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
set indent [string repeat " " [expr {$widest + 3}]]
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
set padkey [string repeat " " 20]
foreach k $matchedkeys {
append result "$k = "
set i 0
foreach stackmember [dict get $all_stacks $k] {
if {$i > 0} {
append result "\n$indent"
}
append result [string range "$i " 0 4] " = "
set j 0
dict for {k v} $stackmember {
if {$j > 0} {
append result "\n$indent2"
}
set displaykey [string range "$k$padkey" 0 20]
append result "$displaykey = $v"
incr j
}
incr i
}
append result \n
}
}
return $result
}
}
#review
#document when this is to be called. Wiping stacks without undoing renames seems odd.
proc Delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
#review - document how/when to use. example? intention?
proc Rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}
}
namespace eval commandstack::lib {
proc splitx {str {regexp {[\t \r\n]+}}} {
#snarfed from tcllib textutil::splitx to avoid the dependency
# Bugfix 476988
if {[string length $str] == 0} {
return {}
}
if {[string length $regexp] == 0} {
return [::split $str ""]
}
if {[regexp $regexp {}]} {
return -code error "splitting on regexp \"$regexp\" would cause infinite loop"
}
set list {}
set start 0
while {[regexp -start $start -indices -- $regexp $str match submatch]} {
foreach {subStart subEnd} $submatch break
foreach {matchStart matchEnd} $match break
incr matchStart -1
incr matchEnd
lappend list [string range $str $start $matchStart]
if {$subStart >= $start} {
lappend list [string range $str $subStart $subEnd]
}
set start $matchEnd
}
lappend list [string range $str $start end]
return $list
}
proc split_body {procbody} {
set marker "#<commandstack_separator>#"
set header ""
set code ""
set found_marker 0
foreach ln [split $procbody \n] {
if {!$found_marker} {
if {[string trim $ln] eq $marker} {
set found_marker 1
} else {
append header $ln \n
}
} else {
append code $ln \n
}
}
if {$found_marker} {
return [list $header $code]
} else {
return [list "" $procbody]
}
}
}
package provide commandstack [namespace eval commandstack {
set version 0.3
}]

20
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config

@ -4,14 +4,19 @@
#each entry - base module
set bootsupport_modules [list\
src/vendormodules commandstack\
src/vendormodules cksum\
src/vendormodules modpod\
src/vendormodules overtype\
src/vendormodules fauxlink\
src/vendormodules oolib\
src/vendormodules http\
src/vendormodules dictutils\
src/vendormodules fauxlink\
src/vendormodules fileutil\
src/vendormodules http\
src/vendormodules md5\
src/vendormodules modpod\
src/vendormodules oolib\
src/vendormodules overtype\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
src/vendormodules textutil::adjust\
src/vendormodules textutil::repeat\
src/vendormodules textutil::split\
@ -20,10 +25,6 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\
@ -57,6 +58,7 @@ set bootsupport_modules [list\
modules punk::ns\
modules punk::overlay\
modules punk::path\
modules punk::packagepreference\
modules punk::repo\
modules punk::tdl\
modules punk::zip\

267
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -0,0 +1,267 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::packagepreference 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::packagepreference 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 punk::packagepreference]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::packagepreference
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::packagepreference
#[list_begin itemized]
package require Tcl 8.6-
package require commandstack
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {commandstack}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::packagepreference::class {
#*** !doctools
#[subsection {Namespace punk::packagepreference::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::packagepreference}]
#[para] Core API functions for punk::packagepreference
#[list_begin definitions]
proc uninstall {} {
#*** !doctools
#[call [fun uninstall]]
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called)
commandstack::remove_rename {::package punk::packagepreference}
}
proc install {} {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file)
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names.
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name)
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall
#todo - review/update commandstack package
#modern module/lib names should preferably be lower case
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9)
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable.
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase
#(also just overloading the package builtin comes at a cost!)
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem.
#(or in any environment where multiple versions of Tcl libraries may be available)
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file.
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective.
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} {
#::package override installed by punk::packagepreference::install
#return to previous 'package' implementation with: punk::packagepreference::uninstall
#uglier but faster than tcl::prefix::match in this instance
#maintenance - check no prefixes of require are added to builtin package command
switch -exact -- [lindex $args 0] {
r - re - req - requi - requir - require {
#puts "==>package $args"
#puts "==>[info level 1]"
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
set vwant [lindex $args 3]
if {[set ver [package provide $pkg]] ne ""} {
if {$ver eq $vwant} {
return $vwant
} else {
#package already provided with a different version.. we will defer to underlying implementation to return the standard error
return [$COMMANDSTACKNEXT {*}$args]
}
}
} else {
set pkg [lindex $args 1]
if {[set ver [package provide $pkg]] ne ""} {
return $ver
}
}
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
return [$COMMANDSTACKNEXT {*}$args]
} else {
return $v
}
} else {
return [$COMMANDSTACKNEXT {*}$args]
}
}
default {
return [$COMMANDSTACKNEXT {*}$args]
}
}
}]
if {[dict get $stackrecord implementation] ne ""} {
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command
puts stdout "punk::packagepreference renamed ::package to $impl"
} else {
puts stderr "punk::packagepreference failed to rename ::package"
}
#puts stdout [info body ::package]
}
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::packagepreference::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::packagepreference::system {
#*** !doctools
#[subsection {Namespace punk::packagepreference::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference {
variable pkg punk::packagepreference
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

512
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm

@ -0,0 +1,512 @@
#JMN 2021 - Public Domain
#cooperative command renaming
#
# REVIEW 2024 - code was originally for specific use in packageTrace
# - code should be reviewed for more generic utility.
# - API is obscure and undocumented.
# - unclear if intention was only for builtins
# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamer>' for delegating to command as it was prior to rename
#changes:
#2024
# - mungecommand to support namespaced commands
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
#strive for no other package dependencies here.
namespace eval commandstack {
variable all_stacks
variable debug
set debug 0
variable known_renamers [list ::packagetrace ::packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
}
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTOR {command} {
#assert - command has already been resolved to a namespace ie fully qualified
if {[llength [info procs $command]]} {
#look for *IMPLEMENTOR_*!
set prefix IMPLEMENTOR_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
if {[info commands tcl::info::cmdtype] ne ""} {
#tcl9 and maybe some tcl 8.7s ?
switch -- [tcl::info::cmdtype $command] {
native {
return builtin
}
default {
return undetermined
}
}
} else {
return undetermined
}
}
}
}
namespace eval commandstack::renamed_commands {}
namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place
namespace eval commandstack {
namespace export {[a-z]*}
proc help {} {
return {
}
}
proc debug {{on_off {}}} {
variable debug
if {$on_off eq ""} {
return $debug
} else {
if {[string is boolean -strict $debug]} {
set debug [expr {$on_off && 1}]
return $debug
}
}
}
proc get_stack {command} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc get_next_command {command renamer tokenid} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid"
}
} else {
return $command
}
}
proc basecall {command args} {
variable all_stacks
set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {[llength $stack]} {
set rec1 [lindex $stack 0]
tailcall [dict get $rec1 implementation] {*}$args
} else {
tailcall $command {*}$args
}
} else {
tailcall $command {*}$args
}
}
#review.
#<renamer> defaults to calling namespace - but can be arbitrary string
proc rename_command {args} {
#todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames
# - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack
#
if {[lindex $args 0] eq "-renamer"} {
set renamer [lindex $args 1]
set arglist [lrange $args 2 end]
} else {
set renamer ""
set arglist $args
}
if {[llength $arglist] != 3} {
error "commandstack::rename_command usage: rename_command ?-renamer <string>? command procargs procbody"
}
lassign $arglist command procargs procbody
set command [uplevel 1 [list namespace which $command]]
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
variable all_stacks
variable known_renamers
variable renamer_command_tokens ;#monotonically increasing int per <mungedrenamer>::<mungedcommand> representing number of renames ever done.
if {$renamer eq ""} {
set renamer [uplevel 1 [list namespace current]]
}
if {$renamer ni $known_renamers} {
lappend known_renamers $renamer
dict set renamer_command_tokens [list $renamer $command] 0
}
#TODO - reduce emissions to stderr - flag for debug?
#e.g packageTrace and packageSuppress packages use this convention.
set nextinfo [uplevel 1 [list\
apply {{command renamer procbody} {
#todo - munge dash so we can make names in renamed_commands separable
# {- _dash_} ?
set mungedcommand [string map {:: _ns_} $command]
set mungedrenamer [string map {:: _ns_} $renamer]
set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1]
set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
set do_rename 0
if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
#$command is not the standard builtin - something has replaced it, could be ourself.
set next_implementor [::commandstack::util::get_IMPLEMENTOR $command]
set munged_next_implementor [string map {:: _ns_} $next_implementor]
#if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it.
if {[dict exists $::commandstack::all_stacks $command]} {
set comstacks [dict get $::commandstack::all_stacks $command]
} else {
set comstacks [list]
}
set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer')
if {[llength $this_renamer_previous_entries]} {
if {$next_implementor eq $renamer} {
#previous renamer was us. Rather than assume our job is done.. compare the implementations
#don't rename if immediate predecessor is same code.
#set topstack [lindex $comstacks end]
#set next_impl [dict get $topstack implementation]
set current_body [info body $command]
lassign [commandstack::lib::split_body $current_body] _ current_code
set current_code [string trim $current_code]
set new_code [string trim $procbody]
if {$current_code eq $new_code} {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename."
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding."
puts stdout "----------"
puts stdout "$current_code"
puts stdout "----------"
puts stdout "$new_code"
puts stdout "----------"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} elseif {$next_implementor in $::commandstack::known_renamers} {
set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {builtin}} {
#native/builtin could still have been renamed
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} elseif {$next_implementor in {unspecified undetermined}} {
#review - probably don't need a warning anyway
puts stderr "(commandstack::rename_command) WARNING - Something may have renamed the '$command' command. Attempting to cooperate.(untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)"
set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid
set do_rename 1
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set next_implementor original
#rename $command $next_target
set do_rename 1
}
#There are of course other ways in which $command may have been renamed - but we can't detect.
set token [list $command $renamer $tokenid]
return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename]
} } $command $renamer $procbody]
]
variable debug
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]"
}
}
#token is always first dict entry. (Value needs to be searched with lsearch -index 1 )
#renamer is always second dict entry (Value needs to be searched with lsearch -index 3)
set new_record [dict create\
token [dict get $nextinfo token]\
renamer $renamer\
next_implementor [dict get $nextinfo next_implementor]\
next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\
implementation [dict get $nextinfo next_target]\
]
if {![dict get $nextinfo do_rename]} {
#review
puts stderr "no rename performed"
return [dict create implementation ""]
}
catch {rename ::commandstack::temp::testproc ""}
set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] {
#IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% <procargs> <procbody> )
set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc.
set COMMANDSTACKNEXT [%next_getter%]
#<commandstack_separator>#
}]
set final_procbody "$nextinit$procbody"
#build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command
#(e.g due to invalid argument specifiers)
proc ::commandstack::temp::testproc $procargs $final_procbody
uplevel 1 [list rename $command [dict get $nextinfo next_target]]
uplevel 1 [list rename ::commandstack::temp::testproc $command]
dict lappend all_stacks $command $new_record
return $new_record
}
#todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer
#todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost
#todo - removal of all entries pertaining to a particular renamer
#todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack?
#remove by token, or by commandname if called from same context as original rename_command
#If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed.
#A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything.
#similarly a nonexistant token or renamer will not remove anything and will just return the current stack
proc remove_rename {token_or_command} {
if {[llength $token_or_command] == 3} {
#is token
lassign $token_or_command command renamer tokenid
} elseif {[llength $token_or_command] == 2} {
#command and renamer only supplied
lassign $token_or_command command renamer
set tokenid ""
} elseif {[llength $token_or_command] == 1} {
#is command name only
set command $token_or_command
set renamer [uplevel 1 [list namespace current]]
set tokenid ""
}
set command [uplevel 1 [list namespace which $command]]
variable all_stacks
variable known_renamers
if {$renamer ni $known_renamers} {
error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or {<command> <renamer>}"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
if {$tokenid ne ""} {
#token_or_command is a token as returned within the rename_command result dictionary
#search first dict value
set doomed_posn [lsearch -index 1 $stack $token_or_command]
} else {
#search second dict value
set matches [lsearch -all -index 3 $stack $renamer]
set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer
}
if {$doomed_posn ne "" && $doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record next_implementor] ne $renamer} {
puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record next_implementor [dict get $doomed_record next_implementor]
#don't update next_getter - it always refers to self
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
proc show_stack {{commandname_glob *}} {
variable all_stacks
if {[package provide punk::lib] ne ""} {
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
} else {
if {![regexp {[?*]} $commandname_glob]} {
#if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace
set commandname_glob [uplevel 1 [list namespace which $commandname_glob]]
}
set result ""
set matchedkeys [dict keys $all_stacks $commandname_glob]
#don't try to calculate widest on empty list
if {[llength $matchedkeys]} {
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
set indent [string repeat " " [expr {$widest + 3}]]
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
set padkey [string repeat " " 20]
foreach k $matchedkeys {
append result "$k = "
set i 0
foreach stackmember [dict get $all_stacks $k] {
if {$i > 0} {
append result "\n$indent"
}
append result [string range "$i " 0 4] " = "
set j 0
dict for {k v} $stackmember {
if {$j > 0} {
append result "\n$indent2"
}
set displaykey [string range "$k$padkey" 0 20]
append result "$displaykey = $v"
incr j
}
incr i
}
append result \n
}
}
return $result
}
}
#review
#document when this is to be called. Wiping stacks without undoing renames seems odd.
proc Delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
#review - document how/when to use. example? intention?
proc Rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}
}
namespace eval commandstack::lib {
proc splitx {str {regexp {[\t \r\n]+}}} {
#snarfed from tcllib textutil::splitx to avoid the dependency
# Bugfix 476988
if {[string length $str] == 0} {
return {}
}
if {[string length $regexp] == 0} {
return [::split $str ""]
}
if {[regexp $regexp {}]} {
return -code error "splitting on regexp \"$regexp\" would cause infinite loop"
}
set list {}
set start 0
while {[regexp -start $start -indices -- $regexp $str match submatch]} {
foreach {subStart subEnd} $submatch break
foreach {matchStart matchEnd} $match break
incr matchStart -1
incr matchEnd
lappend list [string range $str $start $matchStart]
if {$subStart >= $start} {
lappend list [string range $str $subStart $subEnd]
}
set start $matchEnd
}
lappend list [string range $str $start end]
return $list
}
proc split_body {procbody} {
set marker "#<commandstack_separator>#"
set header ""
set code ""
set found_marker 0
foreach ln [split $procbody \n] {
if {!$found_marker} {
if {[string trim $ln] eq $marker} {
set found_marker 1
} else {
append header $ln \n
}
} else {
append code $ln \n
}
}
if {$found_marker} {
return [list $header $code]
} else {
return [list "" $procbody]
}
}
}
package provide commandstack [namespace eval commandstack {
set version 0.3
}]

20
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config

@ -4,14 +4,19 @@
#each entry - base module
set bootsupport_modules [list\
src/vendormodules commandstack\
src/vendormodules cksum\
src/vendormodules modpod\
src/vendormodules overtype\
src/vendormodules fauxlink\
src/vendormodules oolib\
src/vendormodules http\
src/vendormodules dictutils\
src/vendormodules fauxlink\
src/vendormodules fileutil\
src/vendormodules http\
src/vendormodules md5\
src/vendormodules modpod\
src/vendormodules oolib\
src/vendormodules overtype\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
src/vendormodules textutil::adjust\
src/vendormodules textutil::repeat\
src/vendormodules textutil::split\
@ -20,10 +25,6 @@ set bootsupport_modules [list\
src/vendormodules textutil::trim\
src/vendormodules textutil::wcswidth\
src/vendormodules uuid\
src/vendormodules md5\
src/vendormodules sha1\
src/vendormodules tomlish\
src/vendormodules test::tomlish\
modules punkcheck\
modules natsort\
modules punk::ansi\
@ -57,6 +58,7 @@ set bootsupport_modules [list\
modules punk::ns\
modules punk::overlay\
modules punk::path\
modules punk::packagepreference\
modules punk::repo\
modules punk::tdl\
modules punk::zip\

267
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm

@ -0,0 +1,267 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application punk::packagepreference 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::packagepreference 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 punk::packagepreference]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::packagepreference
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::packagepreference
#[list_begin itemized]
package require Tcl 8.6-
package require commandstack
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {commandstack}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::packagepreference::class {
#*** !doctools
#[subsection {Namespace punk::packagepreference::class}]
#[para] class definitions
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
#}
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::packagepreference}]
#[para] Core API functions for punk::packagepreference
#[list_begin definitions]
proc uninstall {} {
#*** !doctools
#[call [fun uninstall]]
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called)
commandstack::remove_rename {::package punk::packagepreference}
}
proc install {} {
#*** !doctools
#[call [fun install]]
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase.
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names"
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file)
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names.
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name)
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall
#todo - review/update commandstack package
#modern module/lib names should preferably be lower case
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9)
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable.
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase
#(also just overloading the package builtin comes at a cost!)
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem.
#(or in any environment where multiple versions of Tcl libraries may be available)
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file.
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective.
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} {
#::package override installed by punk::packagepreference::install
#return to previous 'package' implementation with: punk::packagepreference::uninstall
#uglier but faster than tcl::prefix::match in this instance
#maintenance - check no prefixes of require are added to builtin package command
switch -exact -- [lindex $args 0] {
r - re - req - requi - requir - require {
#puts "==>package $args"
#puts "==>[info level 1]"
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase
#(e.g we will still need to handle things like: package provide Tcl 8.6)
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase
if {[lindex $args 1] eq "-exact"} {
set pkg [lindex $args 2]
set vwant [lindex $args 3]
if {[set ver [package provide $pkg]] ne ""} {
if {$ver eq $vwant} {
return $vwant
} else {
#package already provided with a different version.. we will defer to underlying implementation to return the standard error
return [$COMMANDSTACKNEXT {*}$args]
}
}
} else {
set pkg [lindex $args 1]
if {[set ver [package provide $pkg]] ne ""} {
return $ver
}
}
if {[regexp {[A-Z]} $pkg]} {
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation
if {[catch {$COMMANDSTACKNEXT {*}[string tolower $args]} v]} {
return [$COMMANDSTACKNEXT {*}$args]
} else {
return $v
}
} else {
return [$COMMANDSTACKNEXT {*}$args]
}
}
default {
return [$COMMANDSTACKNEXT {*}$args]
}
}
}]
if {[dict get $stackrecord implementation] ne ""} {
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command
puts stdout "punk::packagepreference renamed ::package to $impl"
} else {
puts stderr "punk::packagepreference failed to rename ::package"
}
#puts stdout [info body ::package]
}
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1
# #[para] Arguments:
# # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n.
# # [list_end]
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::packagepreference::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::packagepreference::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::packagepreference::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::packagepreference::system {
#*** !doctools
#[subsection {Namespace punk::packagepreference::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference {
variable pkg punk::packagepreference
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

283
src/vendormodules/commandstack-0.2.tm

@ -1,283 +0,0 @@
#JMN 2021 - Public Domain
#cooperative command renaming
#
# REVIEW 2024 - code was originally for specific use in packageTrace
# - code should be reviewed for more generic utility.
# - API is obscure and undocumented.
# - unclear if intention was only for builtins
# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamingpkg>' for delegating to command as it was prior to rename
#changes:
#2024
# - mungecommand to support namespaced commands
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
namespace eval commandstack {
variable all_stacks
variable known_packages [list packageTrace packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
}
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTORPACKAGE_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTORPACKAGE {command} {
if {[llength [uplevel 1 [list info procs $command]]]} {
#look for *IMPLEMENTORPACKAGE_*!
set prefix IMPLEMENTORPACKAGE_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
return undetermined
}
}
}
namespace eval commandstack::renamed_commands {}
proc commandstack::help {} {
return {
}
}
proc commandstack::get_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the calling_package originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc commandstack::get_next_command {command calling_package} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack $calling_package]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command'"
}
} else {
return $command
}
}
namespace eval commandstack::work {}
#review.
#Does <responsible_package> even really need to be a package? Is it it intended to somehow automatically call remove_renaming_package e.g with package forget or unload?
#currently it checks 'package names' - but <responsible_package> could perhaps be changed to be an arbitrary string representing the renamer?
proc commandstack::rename_command {command {renamer {}} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
if {$responsible_package in [package names]} {
lappend known_packages $responsible_package
} else {
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names"
}
}
#shift it to the work namespace so we don't pollute global ns
#review - why? presumably due to use of uplevel 1 script below.
#alternatively we could string-map the script being uplevelled, or use apply?
set mungedcommand [string map {:: _ns_} $command]
#e.g packageTrace and packageSuppress packages use this convention.
set next_target ::commandstack::renamed_commands::_originalcommand_${mungedcommand} ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
uplevel 1 {
apply {{command next_target} {
if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself.
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $command]
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it.
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} {
#it was us. Assume our job is done.
#review - same responsible_package can never do multiple rename_command calls for one command? Probably an unlikely requirement (?)
return
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} {
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} {
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set ::commandstack::work::implementor_package original
rename $::commandstack::work::command $::commandstack::work::next_target
}
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect.
} } $command $next_target
}
set debug 1
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to $::commandstack::work::next_target"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to $::commandstack::work::next_target"
}
}
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 )
set new_record [dict create\
responsible_package $responsible_package\
implementor_package $::commandstack::work::implementor_package\
next [list ::commandstack::get_next_command $command $responsible_package]\
implementation $::commandstack::work::next_target\
]
#review - implementor_package better described as next_implementor ??
dict lappend all_stacks $command $new_record
return $new_record
}
proc commandstack::remove_renaming_package {command responsible_package} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set doomed_posn [lsearch -index 1 $stack $responsible_package]
if {$doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record implementor_package] ne $responsible_package} {
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package]
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
#review
#document when this is to be called. Wiping stacks without undoing renames seems odd.
proc commandstack::delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
#review - document how/when to use. example? intention?
proc commandstack::rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}
proc commandstack::show_stack {{commandname_glob *}} {
variable all_stacks
if {[package provide punk::lib] ne ""} {
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
} else {
set result ""
set matchedkeys [dict keys $all_stacks $commandname_glob]
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
set indent [string repeat " " $widest+3]
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
foreach k $matchedkeys {
append result "$k = "
set i 0
foreach stackmember [dict get $all_stacks $k] {
if {$i > 0} {
append result "\n$indent"
}
append result [string range "$i " 0 4] " = "
set j 0
dict for {k v} $stackmember {
if {$j > 0} {
append result "\n$indent2"
}
append result "$k = $v"
incr j
}
incr i
}
append result \n
}
return $result
}
}
package provide commandstack [namespace eval commandstack {
set version 0.2
}]

7
src/vendormodules/include_modules.config

@ -1,15 +1,14 @@
set local_modules [list\
c:/repo/nonexistant/tclmodules/blah/modules blah\
c:/repo/jn/tclmodules/overtype/modules overtype\
c:/repo/jn/tclmodules/fauxlink/modules fauxlink\
c:/repo/jn/tclmodules/gridplus/modules gridplus\
c:/repo/jn/tclmodules/modpod/modules modpod\
c:/repo/jn/tclmodules/overtype/modules overtype\
c:/repo/jn/tclmodules/packageTest/modules packageTest\
c:/repo/jn/tclmodules/gridplus/modules gridplus\
c:/repo/jn/tclmodules/tablelist/modules tablelist\
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\
c:/repo/jn/tclmodules/tomlish/modules tomlish\
c:/repo/jn/tclmodules/overtype/modules overtype\
c:/repo/jn/tclmodules/fauxlink/modules fauxlink\
]
set fossil_modules [dict create\

218
src/vfs/_vfscommon/modules/commandstack-0.1.tm

@ -1,218 +0,0 @@
#JMN 2021 - Public Domain
#
#
#changes:
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
package provide commandstack [namespace eval commandstack {
variable all_stacks
variable known_packages [list packageTrace packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
set version 0.1
}]
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we can't require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTORPACKAGE_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTORPACKAGE {command} {
if {[llength [uplevel 1 [list info procs $command]]]} {
#look for *IMPLEMENTORPACKAGE_*!
set prefix IMPLEMENTORPACKAGE_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
return undetermined
}
}
}
namespace eval commandstack::renamed_commands {}
proc commandstack::help {} {
return {
}
}
proc commandstack::get_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the calling_package originally renamed it, or the implementation it now points to.
proc commandstack::get_next_command {command calling_package} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack $calling_package]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command'"
}
} else {
return $command
}
}
namespace eval commandstack::work {}
proc commandstack::rename_command {command responsible_package} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
if {$responsible_package in [package names]} {
lappend known_packages $responsible_package
} else {
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names"
}
}
#shift it to the work namespace so we don't pollute global ns
set ::commandstack::work::responsible_package $responsible_package
set ::commandstack::work::command $command
#e.g packageTrace and packageSuppress packages use this convention.
set ::commandstack::work::next_target ::commandstack::renamed_commands::_originalcommand_package ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
uplevel 1 {
if {[llength [info procs $::commandstack::work::command]] || [llength [info commands $::commandstack::work::next_target]]} {
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself.
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $::commandstack::work::command]
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it.
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} {
#it was us. Assume our job is done.
return
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} {
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} {
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::command}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
}
} else {
#_originalcommand_package
#assume builtin/original
set ::commandstack::work::implementor_package original
rename $::commandstack::work::command $::commandstack::work::next_target
}
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect.
}
set debug 1
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command $command. (previous renames: [llength $stack]). Renaming to $::commandstack::work::next_target"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command $command. Renaming to $::commandstack::work::next_target"
}
}
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 )
set new_record [list responsible_package $responsible_package implementor_package $::commandstack::work::implementor_package implementation $::commandstack::work::next_target ]
dict lappend all_stacks $command $new_record
return $new_record
}
proc commandstack::remove_renaming_package {command responsible_package} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set doomed_posn [lsearch -index 1 $stack $responsible_package]
if {$doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record implementor_package] ne $responsible_package} {
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package]
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
proc commandstack::delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
proc commandstack::rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}

283
src/vfs/_vfscommon/modules/commandstack-0.2.tm

@ -1,283 +0,0 @@
#JMN 2021 - Public Domain
#cooperative command renaming
#
# REVIEW 2024 - code was originally for specific use in packageTrace
# - code should be reviewed for more generic utility.
# - API is obscure and undocumented.
# - unclear if intention was only for builtins
# - consider use of newer 'info cmdtype' - (but need also support for safe interps)
# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack.
# - document that replacement command should use 'commandstack::get_next_command <cmd> <renamingpkg>' for delegating to command as it was prior to rename
#changes:
#2024
# - mungecommand to support namespaced commands
# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_<mungedcommand>
#2021-09-18
# - initial version
# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command
# - They need to be able to load and unload in any order.
#
namespace eval commandstack {
variable all_stacks
variable known_packages [list packageTrace packageSuppress]
if {![info exists all_stacks]} {
#don't wipe it
set all_stacks [dict create]
}
}
namespace eval commandstack::util {
#note - we can't use something like md5 to ID proc body text because we don't want to require additional packages.
#We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace
#A magic comment was chosen as the identifying method.
#The string IMPLEMENTORPACKAGE_*! is searched for where the text between _ and ! is the name of the package that implemented the proc.
#return unspecified if the command is a proc with a body but no magic comment ID
#return unknown if the command doesn't have a proc body to analyze
#otherwise return the package name identified in the magic comment
proc get_IMPLEMENTORPACKAGE {command} {
if {[llength [uplevel 1 [list info procs $command]]]} {
#look for *IMPLEMENTORPACKAGE_*!
set prefix IMPLEMENTORPACKAGE_
set suffix "!"
set body [uplevel 1 [list info body $command]]
if {[string match "*$prefix*$suffix*" $body]} {
set prefixposn [string first "$prefix" $body]
set pkgposn [expr {$prefixposn + [string length $prefix]}]
#set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]]
set suffixposn [string first $suffix $body $pkgposn]
return [string range $body $pkgposn $suffixposn-1]
} else {
return unspecified
}
} else {
return undetermined
}
}
}
namespace eval commandstack::renamed_commands {}
proc commandstack::help {} {
return {
}
}
proc commandstack::get_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command]
} else {
return [list]
}
}
#get the implementation to which the calling_package originally renamed it, or the implementation it now points to.
#review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs?
#e.g if renaming builtin 'package' - this command is generally called 'a lot'
proc commandstack::get_next_command {command calling_package} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set posn [lsearch -index 1 $stack $calling_package]
if {$posn > -1} {
set record [lindex $stack $posn]
return [dict get $record implementation]
} else {
error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command'"
}
} else {
return $command
}
}
namespace eval commandstack::work {}
#review.
#Does <responsible_package> even really need to be a package? Is it it intended to somehow automatically call remove_renaming_package e.g with package forget or unload?
#currently it checks 'package names' - but <responsible_package> could perhaps be changed to be an arbitrary string representing the renamer?
proc commandstack::rename_command {command {renamer {}} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
if {$responsible_package in [package names]} {
lappend known_packages $responsible_package
} else {
error "(commandstack::rename_command) ERROR: package '$responsible_package' not in package names"
}
}
#shift it to the work namespace so we don't pollute global ns
#review - why? presumably due to use of uplevel 1 script below.
#alternatively we could string-map the script being uplevelled, or use apply?
set mungedcommand [string map {:: _ns_} $command]
#e.g packageTrace and packageSuppress packages use this convention.
set next_target ::commandstack::renamed_commands::_originalcommand_${mungedcommand} ;#default is to assume we are the only one playing around with it, but we'll check for known associates too.
uplevel 1 {
apply {{command next_target} {
if {[llength [info procs $command]] || [llength [info commands $next_target]]} {
#$::commandstack::work::command is not the standard builtin - something has replaced it, could be ourself.
set ::commandstack::work::implementor_package [::commandstack::util::get_IMPLEMENTORPACKAGE $command]
#if undetermined/unspecified it could be the latest responsible_package on the stack - but we can't know for sure something else didn't rename it.
if {$::commandstack::work::implementor_package eq $::commandstack::work::responsible_package} {
#it was us. Assume our job is done.
#review - same responsible_package can never do multiple rename_command calls for one command? Probably an unlikely requirement (?)
return
} elseif {$::commandstack::work::implementor_package in $::commandstack::known_packages} {
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} elseif {$::commandstack::work::implementor_package in {unspecified undetermined}} {
puts stderr "(commandstack::rename_command) WARNING - Something has renamed the '$::commandstack::work::command' command. Attempting to cooperate.(untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
} else {
puts stderr "(commandstack::rename_command) Warning - pkg:'$::commandstack::work::implementor_package' has renamed the '$::commandstack::work::command' command. Attempting to cooperate. (untested)"
set ::commandstack::work::next_target ::commandstack::renamed_commands::_renamedcommand_${::commandstack::work::mungedcommand}_${::commandstack::work::implementor_package}_version
rename $::commandstack::work::command $::commandstack::work::next_target
}
} else {
#_originalcommand_<mungedcommand>
#assume builtin/original
set ::commandstack::work::implementor_package original
rename $::commandstack::work::command $::commandstack::work::next_target
}
#There are of course other ways in which $::commandstack::work::command may have been renamed - but we can't detect.
} } $command $next_target
}
set debug 1
if $debug {
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to $::commandstack::work::next_target"
} else {
#assume this is the original
puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to $::commandstack::work::next_target"
}
}
#responsible_package is always first element. (Needs to be searched with lsearch -index 1 )
set new_record [dict create\
responsible_package $responsible_package\
implementor_package $::commandstack::work::implementor_package\
next [list ::commandstack::get_next_command $command $responsible_package]\
implementation $::commandstack::work::next_target\
]
#review - implementor_package better described as next_implementor ??
dict lappend all_stacks $command $new_record
return $new_record
}
proc commandstack::remove_renaming_package {command responsible_package} {
variable all_stacks
variable known_packages
if {$responsible_package ni $known_packages} {
error "(commandstack::remove_renaming_package) ERROR: package $responsible_package not in list of known_packages '$known_packages'"
}
if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command]
set doomed_posn [lsearch -index 1 $stack $responsible_package]
if {$doomed_posn > -1} {
set doomed_record [lindex $stack $doomed_posn]
if {[llength $stack] == ($doomed_posn + 1)} {
#last on stack - put the implemenation from the doomed_record back as the actual command
uplevel #0 [list rename $command ""]
uplevel #0 [list rename [dict get $doomed_record implementation] $command]
} elseif {[llength $stack] > ($doomed_posn + 1)} {
#there is at least one more record on the stack - rewrite it to point where the doomed_record pointed
set rewrite_posn [expr {$doomed_posn + 1}]
set rewrite_record [lindex $stack $rewrite_posn]
if {[dict get $rewrite_record implementor_package] ne $responsible_package} {
puts stderr "(commandstack::remove_renaming_package) WARNING: next record on the commandstack didn't record $responsible_package as the implementor_package - not deleting implementation [dict get $rewrite_record implementation]"
} else {
uplevel #0 [list rename [dict get $rewrite_record implementation] ""]
}
dict set rewrite_record implementor_package [dict get $doomed_record implementor_package]
dict set rewrite_record implementation [dict get $doomed_record implementation]
lset stack $rewrite_posn $rewrite_record
dict set all_stacks $command $stack
}
set stack [lreplace $stack $doomed_posn $doomed_posn]
dict set all_stacks $command $stack
}
return $stack
}
return [list]
}
#review
#document when this is to be called. Wiping stacks without undoing renames seems odd.
proc commandstack::delete_stack {command} {
variable all_stacks
if {[dict exists $all_stacks $command]} {
dict unset all_stacks $command
return 1
} else {
return 1
}
}
#can be used to temporarily put a stack aside - should manually rename back when done.
#review - document how/when to use. example? intention?
proc commandstack::rename_stack {oldname newname} {
variable all_stacks
if {[dict exists $all_stacks $oldname]} {
if {[dict exists $all_stacks $newname]} {
error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack"
} else {
#set stackval [dict get $all_stacks $oldname]
#dict unset all_stacks $oldname
#dict set all_stacks $newname $stackval
dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0]
}
}
}
proc commandstack::show_stack {{commandname_glob *}} {
variable all_stacks
if {[package provide punk::lib] ne ""} {
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*]
} else {
set result ""
set matchedkeys [dict keys $all_stacks $commandname_glob]
set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]]
set indent [string repeat " " $widest+3]
set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide
foreach k $matchedkeys {
append result "$k = "
set i 0
foreach stackmember [dict get $all_stacks $k] {
if {$i > 0} {
append result "\n$indent"
}
append result [string range "$i " 0 4] " = "
set j 0
dict for {k v} $stackmember {
if {$j > 0} {
append result "\n$indent2"
}
append result "$k = $v"
incr j
}
incr i
}
append result \n
}
return $result
}
}
package provide commandstack [namespace eval commandstack {
set version 0.2
}]

58
src/vfs/_vfscommon/modules/punk/mix/cli-0.3.1.tm

@ -615,6 +615,8 @@ namespace eval punk::mix::cli {
-glob *\
-max_depth 100\
]
set had_error 0
# -max_depth -1 for no limit
set build_installername pods_in_$current_source_dir
set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck]
@ -668,7 +670,6 @@ namespace eval punk::mix::cli {
close $fdout
}
#delete and regenerate zip and modpod stubbed zip
set had_error 0
set notes [list]
if {[catch {
file delete $buildfolder/$basename-$module_build_version.zip
@ -704,8 +705,8 @@ namespace eval punk::mix::cli {
modpod::lib::make_zip_modpod $zipfile $modulefile
} else {
#TODO - review punk::zip::mkzip and/or external zip to provide a fallback?
set had_err 1
lappend notest "zipfs_unavailable"
set had_error 1
lappend notes "zipfs_unavailable"
puts stderr "WARNING: zipfs unavailable can't build $modulefile"
}
@ -730,28 +731,37 @@ namespace eval punk::mix::cli {
$build_event destroy
$build_installer destroy
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm
$event targetset_addsource $modulefile
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
$event targetset_started
# -- --- --- --- --- ---
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
lappend module_list $modulefile
file copy -force $modulefile $target_module_dir
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
} else {
puts -nonewline stderr "."
set did_skip 1
if {$is_interesting} {
puts stderr "$modulefile [$event targetset_source_changes]"
#JMN - review
if {!$had_error} {
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm
$event targetset_addsource $modulefile
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
$event targetset_started
# -- --- --- --- --- ---
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
lappend module_list $modulefile
if {[catch {
file copy -force $modulefile $target_module_dir
} errMsg]} {
puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir"
$event targetset_end FAILED -note "could not copy $modulefile"
} else {
puts stderr "Copied zip modpod module $modulefile to $target_module_dir"
# -- --- --- --- --- ---
$event targetset_end OK -note "zip modpod"
}
} else {
puts -nonewline stderr "."
set did_skip 1
if {$is_interesting} {
puts stderr "$modulefile [$event targetset_source_changes]"
}
$event targetset_end SKIPPED
}
$event targetset_end SKIPPED
}
}
tarjar {

Loading…
Cancel
Save