154 changed files with 5114 additions and 196713 deletions
@ -1,112 +0,0 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
@ -1,259 +0,0 @@
|
||||
|
||||
# Tcl parser for optional arguments in function calls and |
||||
# commandline arguments |
||||
# |
||||
# (c) 2001 Bastien Chevreux |
||||
|
||||
# Index of exported commands |
||||
# - argp::registerArgs |
||||
# - argp::setArgDefaults |
||||
# - argp::setArgsNeeded |
||||
# - argp::parseArgs |
||||
|
||||
# Internal commands |
||||
# - argp::CheckValues |
||||
|
||||
# See end of file for an example on how to use |
||||
|
||||
package provide argp 0.2 |
||||
|
||||
namespace eval argp { |
||||
variable Optstore |
||||
variable Opttypes { |
||||
boolean integer double string |
||||
} |
||||
|
||||
namespace export {[a-z]*} |
||||
} |
||||
|
||||
|
||||
proc argp::registerArgs { func arglist } { |
||||
variable Opttypes |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
#puts $parentns |
||||
#puts $caller |
||||
#puts $cmangled |
||||
|
||||
set Optstore(keys,$cmangled) {} |
||||
set Optstore(deflist,$cmangled) {} |
||||
set Optstore(argneeded,$cmangled) {} |
||||
|
||||
foreach arg $arglist { |
||||
foreach {opt type default allowed} $arg { |
||||
set optindex [lsearch -glob $Opttypes $type*] |
||||
if { $optindex < 0} { |
||||
return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]" |
||||
} |
||||
set type [lindex $Opttypes $optindex] |
||||
|
||||
lappend Optstore(keys,$cmangled) $opt |
||||
set Optstore(type,$opt,$cmangled) $type |
||||
set Optstore(default,$opt,$cmangled) $default |
||||
set Optstore(allowed,$opt,$cmangled) $allowed |
||||
lappend Optstore(deflist,$cmangled) $opt $default |
||||
} |
||||
} |
||||
|
||||
if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} { |
||||
return -code error "Error in declaration of optional arguments.\n$res" |
||||
} |
||||
} |
||||
|
||||
proc argp::setArgDefaults { func arglist } { |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
set Optstore(deflist,$cmangled) {} |
||||
foreach {opt default} $arglist { |
||||
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
set Optstore(default,$opt,$cmangled) $default |
||||
} |
||||
|
||||
# set the new defaultlist |
||||
foreach opt $Optstore(keys,$cmangled) { |
||||
lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled) |
||||
} |
||||
} |
||||
|
||||
proc argp::setArgsNeeded { func arglist } { |
||||
variable Optstore |
||||
|
||||
set parentns [string range [uplevel 1 [list namespace current]] 2 end] |
||||
if { $parentns != "" } { |
||||
append caller $parentns :: $func |
||||
} else { |
||||
set caller $func |
||||
} |
||||
set cmangled [string map {:: _} $caller] |
||||
|
||||
#append caller $parentns :: $func |
||||
#set cmangled ${parentns}_$func |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
|
||||
set Optstore(argneeded,$cmangled) {} |
||||
foreach opt $arglist { |
||||
if {![info exists Optstore(default,$opt,$cmangled)]} { |
||||
return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
lappend Optstore(argneeded,$cmangled) $opt |
||||
} |
||||
} |
||||
|
||||
|
||||
proc argp::parseArgs { args } { |
||||
variable Optstore |
||||
|
||||
if {[llength $args] == 0} { |
||||
upvar args a opts o |
||||
} else { |
||||
upvar args a [lindex $args 0] o |
||||
} |
||||
|
||||
if { [ catch { set caller [lindex [info level -1] 0]}]} { |
||||
set caller "main program" |
||||
set cmangled "" |
||||
} else { |
||||
set cmangled [string map {:: _} $caller] |
||||
} |
||||
|
||||
if {![info exists Optstore(deflist,$cmangled)]} { |
||||
return -code error "Arguments for $caller not registered yet." |
||||
} |
||||
|
||||
# set the defaults |
||||
array set o $Optstore(deflist,$cmangled) |
||||
|
||||
# but unset the needed arguments |
||||
foreach key $Optstore(argneeded,$cmangled) { |
||||
catch { unset o($key) } |
||||
} |
||||
|
||||
foreach {key val} $a { |
||||
if {![info exists Optstore(type,$key,$cmangled)]} { |
||||
return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)" |
||||
} |
||||
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||
boolean - |
||||
integer { |
||||
if { $val == "" } { |
||||
return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value." |
||||
} |
||||
if { ![string is $Optstore(type,$key,$cmangled) $val]} { |
||||
return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value." |
||||
} |
||||
} |
||||
double { |
||||
if { $val == "" } { |
||||
return -code error "$caller, $key empty string is not double value." |
||||
} |
||||
if { ![string is double $val]} { |
||||
return -code error "$caller, $key $val is not double value." |
||||
} |
||||
if { [string is integer $val]} { |
||||
set val [expr {$val + .0}] |
||||
} |
||||
} |
||||
default { |
||||
} |
||||
} |
||||
set o($key) $val |
||||
} |
||||
|
||||
foreach key $Optstore(argneeded,$cmangled) { |
||||
if {![info exists o($key)]} { |
||||
return -code error "$caller, needed argument $key was not given." |
||||
} |
||||
} |
||||
|
||||
if { [catch { CheckValues $caller $cmangled [array get o]} err]} { |
||||
return -code error $err |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
|
||||
proc argp::CheckValues { caller cmangled checklist } { |
||||
variable Optstore |
||||
|
||||
#puts "Checking $checklist" |
||||
|
||||
foreach {key val} $checklist { |
||||
if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } { |
||||
switch -exact -- $Optstore(type,$key,$cmangled) { |
||||
string { |
||||
if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} { |
||||
return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)" |
||||
} |
||||
} |
||||
double - |
||||
integer { |
||||
set found 0 |
||||
foreach range $Optstore(allowed,$key,$cmangled) { |
||||
if {[llength $range] == 1} { |
||||
if { $val == [lindex $range 0] } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} elseif {[llength $range] == 2} { |
||||
set low [lindex $range 0] |
||||
set high [lindex $range 1] |
||||
|
||||
if { ![string is integer $low] \ |
||||
&& [string compare "-" $low] != 0} { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not \u00b4-\u00b4: $range" |
||||
} |
||||
if { ![string is integer $high] \ |
||||
&& [string compare "+" $high] != 0} { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not \u00b4+\u00b4: $range" |
||||
} |
||||
if {[string compare "-" $low] == 0} { |
||||
if { [string compare "+" $high] == 0 \ |
||||
|| $val <= $high } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
if { $val >= $low } { |
||||
if {[string compare "+" $high] == 0 \ |
||||
|| $val <= $high } { |
||||
set found 1 |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range" |
||||
} |
||||
} |
||||
if { $found == 0 } { |
||||
return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
@ -1,601 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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) Julian Noble 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application argparsingtest 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_argparsingtest 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 argparsingtest] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of argparsingtest |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by argparsingtest |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
package require struct::set |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::class}] |
||||
#[para] class definitions |
||||
if {[info commands [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 |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest}] |
||||
#[para] Core API functions for argparsingtest |
||||
#[list_begin definitions] |
||||
|
||||
proc test1_ni {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
if {$k ni [dict keys $defaults]} { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
proc test1_switchmerge {args} { |
||||
set defaults [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 {} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
} |
||||
#if we need to loop to test arg validity anyway - then dict set as we go is slightly faster than a dict merge at the end |
||||
proc test1_switch {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
variable switchopts |
||||
set switchopts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
#slightly slower than just creating the dict within the proc |
||||
proc test1_switch_nsvar {args} { |
||||
variable switchopts |
||||
set opts $switchopts |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-return - -show_edge - -show_seps - -frametype - -x - -y - -z - -1 - -2 - -3 { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_switch2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
set switches [lmap v [dict keys $opts] {list $v -}] |
||||
set switches [concat {*}$switches] |
||||
set switches [lrange $switches 0 end-1] |
||||
foreach {k v} $args { |
||||
switch -- $k\ |
||||
{*}$switches { |
||||
dict set opts $k $v |
||||
}\ |
||||
default { |
||||
error "unrecognised option '$k'. Known options [dict keys $opts]" |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix option $k" {-return -frametype -show_edge -show_seps -x -y -z -1 -2 -3} $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
proc test1_prefix2 {args} { |
||||
set opts [dict create\ |
||||
-return string\ |
||||
-frametype \uFFEF\ |
||||
-show_edge \uFFEF\ |
||||
-show_seps \uFFEF\ |
||||
-x ""\ |
||||
-y b\ |
||||
-z c\ |
||||
-1 1\ |
||||
-2 2\ |
||||
-3 3\ |
||||
] |
||||
if {[llength $args]} { |
||||
set knownflags [dict keys $opts] |
||||
} |
||||
foreach {k v} $args { |
||||
dict set opts [tcl::prefix::match -message "test1_prefix2 option $k" $knownflags $k] $v |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags |
||||
proc test1_punkargs {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::argparsingtest::test1_punkargs |
||||
@cmd -name argtest4 -help "test of punk::args::parse comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
}] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::test1_punkargs_by_id |
||||
@cmd -name argtest4 -help "test of punk::args::parse comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values |
||||
} |
||||
proc test1_punkargs_by_id {args} { |
||||
set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::argparsingtest::test1_punkargs2 |
||||
@cmd -name argtest4 -help "test of punk::args::parse comparative performance" |
||||
@leaders -min 0 -max 0 |
||||
@opts -anyopts 0 |
||||
-return -default string -type string |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean |
||||
-2 -default 2 -type integer |
||||
-3 -default 3 -type integer |
||||
@values -min 0 -max 0 |
||||
} |
||||
proc test1_punkargs2 {args} { |
||||
set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
|
||||
proc test1_punkargs_validate_ansistripped {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped |
||||
@cmd -name argtest4 -help "test of punk::args::parse comparative performance" |
||||
@opts -anyopts 0 |
||||
-return -default string -type string -choices {string object} -help "return type" |
||||
-frametype -default \uFFEF -type string |
||||
-show_edge -default \uFFEF -type string |
||||
-show_seps -default \uFFEF -type string |
||||
-join -type none -multiple 1 |
||||
-x -default "" -type string |
||||
-y -default b -type string |
||||
-z -default c -type string |
||||
-1 -default 1 -type boolean -validate_ansistripped true |
||||
-2 -default 2 -type integer -validate_ansistripped true |
||||
-3 -default 3 -type integer -validate_ansistripped true |
||||
@values |
||||
}] |
||||
return [tcl::dict::get $argd opts] |
||||
} |
||||
|
||||
package require opt |
||||
variable optlist |
||||
tcl::OptProc test1_opt { |
||||
{-return string "return type"} |
||||
{-frametype \uFFEF "type of frame"} |
||||
{-show_edge \uFFEF "show table outer borders"} |
||||
{-show_seps \uFFEF "show separators"} |
||||
{-join "solo option"} |
||||
{-x "" "x val"} |
||||
{-y b "y val"} |
||||
{-z c "z val"} |
||||
{-1 1 "1val"} |
||||
{-2 -int 2 "2val"} |
||||
{-3 -int 3 "3val"} |
||||
} { |
||||
set opts [dict create] |
||||
foreach v [info locals] { |
||||
dict set opts $v [set $v] |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
package require cmdline |
||||
#cmdline::getoptions is much faster than typedGetoptions |
||||
proc test1_cmdline_untyped {args} { |
||||
set cmdlineopts_untyped { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.arg 1 "arg 1"} |
||||
{2.arg 2 "arg 2"} |
||||
{3.arg 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] |
||||
} |
||||
proc test1_cmdline_typed {args} { |
||||
set cmdlineopts_typed { |
||||
{return.arg "string" "return val"} |
||||
{frametype.arg \uFFEF "frame type"} |
||||
{show_edge.arg \uFFEF "show table borders"} |
||||
{show_seps.arg \uFFEF "show table seps"} |
||||
{join "join the things"} |
||||
{x.arg "" "arg x"} |
||||
{y.arg b "arg y"} |
||||
{z.arg c "arg z"} |
||||
{1.boolean 1 "arg 1"} |
||||
{2.integer 2 "arg 2"} |
||||
{3.integer 3 "arg 3"} |
||||
} |
||||
|
||||
set usage "usage etc" |
||||
return [::cmdline::typedGetoptions args $cmdlineopts_typed $usage] |
||||
} |
||||
|
||||
catch { |
||||
package require argp |
||||
argp::registerArgs test1_argp { |
||||
{ -return string "string" } |
||||
{ -frametype string \uFFEF } |
||||
{ -show_edge string \uFFEF } |
||||
{ -show_seps string \uFFEF } |
||||
{ -x string "" } |
||||
{ -y string b } |
||||
{ -z string c } |
||||
{ -1 boolean 1 } |
||||
{ -2 integer 2 } |
||||
{ -3 integer 3 } |
||||
} |
||||
} |
||||
proc test1_argp {args} { |
||||
argp::parseArgs opts |
||||
return [array get opts] |
||||
} |
||||
|
||||
package require tepam |
||||
tepam::procedure {test1_tepam} { |
||||
-args { |
||||
{-return -type string -default string} |
||||
{-frametype -type string -default \uFFEF} |
||||
{-show_edge -type string -default \uFFEF} |
||||
{-show_seps -type string -default \uFFEF} |
||||
{-join -type none -multiple} |
||||
{-x -type string -default ""} |
||||
{-y -type string -default b} |
||||
{-z -type string -default c} |
||||
{-1 -type boolean -default 1} |
||||
{-2 -type integer -default 2} |
||||
{-3 -type integer -default 3} |
||||
} |
||||
} { |
||||
return [dict create return $return frametype $frametype show_edge $show_edge show_seps $show_seps x $x y $y z $z 1 $1 2 $2 3 $3 join $join] |
||||
} |
||||
|
||||
#multiline values use first line of each record to determine amount of indent to trim |
||||
proc test_multiline {args} { |
||||
set t3 [textblock::frame t3] |
||||
set argd [punk::args::parse $args withdef [subst { |
||||
-template1 -default { |
||||
****** |
||||
* t1 * |
||||
****** |
||||
} |
||||
-template2 -default { ------ |
||||
****** |
||||
* t2 * |
||||
******} |
||||
-template3 -default {$t3} |
||||
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately |
||||
-template3b -default { |
||||
$t3 |
||||
----------------- |
||||
$t3 |
||||
abc\ndef |
||||
} |
||||
-template4 -default "****** |
||||
* t4 * |
||||
******" |
||||
-template5 -default " |
||||
|
||||
|
||||
" |
||||
-flag -default 0 -type boolean |
||||
}]] |
||||
return $argd |
||||
} |
||||
proc test_multiline2 {args} { |
||||
set t3 [textblock::frame t3] |
||||
set argd [punk::args::parse $args withdef { |
||||
-template1 -default { |
||||
****** |
||||
* t1 * |
||||
****** |
||||
} |
||||
-template2 -default { ------ |
||||
****** |
||||
* t2 * |
||||
******} |
||||
-template3 -default {$t3} |
||||
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately |
||||
-template3b -default { |
||||
${$t3} |
||||
----------------- |
||||
${$t3} |
||||
abc\ndef |
||||
} |
||||
-template4 -default "****** |
||||
* t4 * |
||||
******" |
||||
-template5 -default " |
||||
a |
||||
${$t3} |
||||
c |
||||
" |
||||
-flag -default 0 -type boolean |
||||
}] |
||||
return $argd |
||||
} |
||||
|
||||
#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 argparsingtest ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval argparsingtest::lib { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::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 argparsingtest::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval argparsingtest::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace argparsingtest::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide argparsingtest [namespace eval argparsingtest { |
||||
variable pkg argparsingtest |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,200 +0,0 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5-; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -1,933 +0,0 @@
|
||||
# cmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing command line |
||||
# arguments that are processed by our various applications. |
||||
# It also includes a utility routine to determine the |
||||
# application name for use in command line errors. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.5- |
||||
package provide cmdline 1.5.2 |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||
getKnownOptions usage |
||||
} |
||||
|
||||
# ::cmdline::getopt -- |
||||
# |
||||
# The cmdline::getopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getopt function returns 1 if an option was found, 0 if no more |
||||
# options were found, and -1 if an error occurred. |
||||
|
||||
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
set result [getKnownOpt argsList $optstring option value] |
||||
|
||||
if {$result < 0} { |
||||
# Collapse unknown-option error into any-other-error result. |
||||
set result -1 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getKnownOpt -- |
||||
# |
||||
# The cmdline::getKnownOpt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. Note that |
||||
# unknown options and the args that follow them are |
||||
# left in this list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getKnownOpt function returns 1 if an option was found, |
||||
# 0 if no more options were found, -1 if an unknown option was |
||||
# encountered, and -2 if any other error occurred. |
||||
|
||||
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
# default settings for a normal return |
||||
set value "" |
||||
set option "" |
||||
set result 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
"--*" - |
||||
"-*" { |
||||
set option [string range $arg 1 end] |
||||
if {[string equal [string range $option 0 0] "-"]} { |
||||
set option [string range $arg 2 end] |
||||
} |
||||
|
||||
# support for format: [-]-option=value |
||||
set idx [string first "=" $option 1] |
||||
if {$idx != -1} { |
||||
set _val [string range $option [expr {$idx+1}] end] |
||||
set option [string range $option 0 [expr {$idx-1}]] |
||||
} |
||||
|
||||
if {[lsearch -exact $optstring $option] != -1} { |
||||
# Booleans are set to 1 when present |
||||
set value 1 |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
if {[info exists _val]} { |
||||
set value $_val |
||||
} elseif {[llength $argsList]} { |
||||
set value [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set value "Option \"$option\" requires an argument" |
||||
set result -2 |
||||
} |
||||
} else { |
||||
# Unknown option. |
||||
set value "Illegal option \"-$option\"" |
||||
set result -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed flags if an incorrect flag is specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# (where flag takes no argument) |
||||
# flag comment |
||||
# |
||||
# (or where flag takes an argument) |
||||
# flag default comment |
||||
# |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getopt argv $opts opt arg]]} { |
||||
if {$err < 0} { |
||||
set result(?) "" |
||||
break |
||||
} |
||||
set result($opt) $arg |
||||
} |
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::getKnownOptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This ignores unknown flags, but generates |
||||
# an error message that lists the correct usage if a known option |
||||
# is used incorrectly. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. This |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
# As we encounter them, keep the unknown options and their |
||||
# arguments in this list. Before we return from this procedure, |
||||
# we'll prepend these args to the argList so that the application |
||||
# doesn't lose them. |
||||
|
||||
set unknownOptions [list] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||
if {$err == -1} { |
||||
# Unknown option. |
||||
|
||||
# Skip over any non-option items that follow it. |
||||
# For now, add them to the list of unknownOptions. |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
while {([llength $argv] != 0) \ |
||||
&& ![string match "-*" [lindex $argv 0]]} { |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
} |
||||
} elseif {$err == -2} { |
||||
set result(?) "" |
||||
break |
||||
} else { |
||||
set result($opt) $arg |
||||
} |
||||
} |
||||
|
||||
# Before returning, prepend the any unknown args back onto the |
||||
# argList so that the application doesn't lose them. |
||||
set argv [concat $unknownOptions $argv] |
||||
|
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::GetOptionDefaults -- |
||||
# |
||||
# This internal procedure processes the option list (that was passed to |
||||
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||
# for each option in the option list, the value of which is the option's |
||||
# default value. |
||||
# |
||||
# Arguments: |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# defaultArrayVar The name of the array in which to put argument defaults. |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||
upvar 1 $defaultArrayVar result |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Need to hide this from the usage display and getopt |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
|
||||
# Set defaults for those that take values. |
||||
|
||||
set default [lindex $opt 1] |
||||
set result($name) $default |
||||
} else { |
||||
# The default for booleans is false |
||||
set result($name) 0 |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
# ::cmdline::usage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::getoptions |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
append name " value" |
||||
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||
} else { |
||||
set desc "[lindex $opt 1]" |
||||
} |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||
lappend lines $name $desc |
||||
} |
||||
foreach {name desc} $lines { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::getfiles -- |
||||
# |
||||
# Given a list of file arguments from the command line, compute |
||||
# the set of valid files. On windows, file globbing is performed |
||||
# on each argument. On Unix, only file existence is tested. If |
||||
# a file argument produces no valid files, a warning is optionally |
||||
# generated. |
||||
# |
||||
# This code also uses the full path for each file. If not |
||||
# given it prepends [pwd] to the filename. This ensures that |
||||
# these files will never conflict with files in our zip file. |
||||
# |
||||
# Arguments: |
||||
# patterns The file patterns specified by the user. |
||||
# quiet If this flag is set, no warnings will be generated. |
||||
# |
||||
# Results: |
||||
# Returns the list of files that match the input patterns. |
||||
|
||||
proc ::cmdline::getfiles {patterns quiet} { |
||||
set result {} |
||||
if {$::tcl_platform(platform) == "windows"} { |
||||
foreach pattern $patterns { |
||||
set pat [file join $pattern] |
||||
set files [glob -nocomplain -- $pat] |
||||
if {$files == {}} { |
||||
if {! $quiet} { |
||||
puts stdout "warning: no files match \"$pattern\"" |
||||
} |
||||
} else { |
||||
foreach file $files { |
||||
lappend result $file |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set result $patterns |
||||
} |
||||
set files {} |
||||
foreach file $result { |
||||
# Make file an absolute path so that we will never conflict |
||||
# with files that might be contained in our zip file. |
||||
set fullPath [file join [pwd] $file] |
||||
|
||||
if {[file isfile $fullPath]} { |
||||
lappend files $fullPath |
||||
} elseif {! $quiet} { |
||||
puts stdout "warning: no files match \"$file\"" |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
# ::cmdline::getArgv0 -- |
||||
# |
||||
# This command returns the "sanitized" version of argv0. It will strip |
||||
# off the leading path and remove the ".bin" extensions that our apps |
||||
# use because they must be wrapped by a shell script. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# The application name that can be used in error messages. |
||||
|
||||
proc ::cmdline::getArgv0 {} { |
||||
global argv0 |
||||
|
||||
set name [file tail $argv0] |
||||
return [file rootname $name] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# Now the typed versions of the above commands. |
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# typedCmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing typed command |
||||
# line arguments that may be processed by various applications. |
||||
# |
||||
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export typedGetopt typedGetoptions typedUsage |
||||
|
||||
# variable cmdline::charclasses -- |
||||
# |
||||
# Create regexp list of allowable character classes |
||||
# from "string is" error message. |
||||
# |
||||
# Results: |
||||
# String of character class names separated by "|" characters. |
||||
|
||||
variable charclasses |
||||
#checker exclude badKey |
||||
catch {string is . .} charclasses |
||||
variable dummy |
||||
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||
unset dummy |
||||
} |
||||
|
||||
# ::cmdline::typedGetopt -- |
||||
# |
||||
# The cmdline::typedGetopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to a list of args this command will process the |
||||
# first argument and return info on how to proceed. In addition, |
||||
# you may specify a type for the argument to each option. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you want to process. |
||||
# If options are found, the arg list is modified |
||||
# and the processed arguments are removed from the |
||||
# start of the list. |
||||
# |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".xxx", where |
||||
# xxx is any valid character class to the tcl |
||||
# command "string is", then typedGetopt routine will |
||||
# use the next argument as a typed argument to the |
||||
# option. The argument must match the specified |
||||
# character classes (e.g. integer, double, boolean, |
||||
# xdigit, etc.). Alternatively, you may specify |
||||
# ".arg" for an untyped argument. |
||||
# |
||||
# optVar Upon success, the variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .xxx extension). If |
||||
# typedGetopt fails the variable is set to the empty |
||||
# string. SOMETIMES! Different for each -value! |
||||
# |
||||
# argVar Upon success, the variable pointed to by argVar |
||||
# contains the argument for the specified option. |
||||
# If typedGetopt fails, the variable is filled with |
||||
# an error message. |
||||
# |
||||
# Argument type syntax: |
||||
# Option that takes no argument. |
||||
# foo |
||||
# |
||||
# Option that takes a typeless argument. |
||||
# foo.arg |
||||
# |
||||
# Option that takes a typed argument. Allowable types are all |
||||
# valid character classes to the tcl command "string is". |
||||
# Currently must be one of alnum, alpha, ascii, control, |
||||
# boolean, digit, double, false, graph, integer, lower, print, |
||||
# punct, space, true, upper, wordchar, or xdigit. |
||||
# foo.double |
||||
# |
||||
# Option that takes an argument from a list. |
||||
# foo.(bar|blat) |
||||
# |
||||
# Argument quantifier syntax: |
||||
# Option that takes an optional argument. |
||||
# foo.arg? |
||||
# |
||||
# Option that takes a list of arguments terminated by "--". |
||||
# foo.arg+ |
||||
# |
||||
# Option that takes an optional list of arguments terminated by "--". |
||||
# foo.arg* |
||||
# |
||||
# Argument quantifiers work on all argument types, so, for |
||||
# example, the following is a valid option specification. |
||||
# foo.(bar|blat|blah)? |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options may be specified on the command line using a unique, |
||||
# shortened version of the option name. Given that program foo |
||||
# has an option list of {bar.alpha blah.arg blat.double}, |
||||
# "foo -b fob" returns an error, but "foo -ba fob" |
||||
# successfully returns {bar fob} |
||||
# |
||||
# Results: |
||||
# The typedGetopt function returns one of the following: |
||||
# 1 a valid option was found |
||||
# 0 no more options found to process |
||||
# -1 invalid option |
||||
# -2 missing argument to a valid option |
||||
# -3 argument to a valid option does not match type |
||||
# |
||||
# Known Bugs: |
||||
# When using options which include special glob characters, |
||||
# you must use the exact option. Abbreviating it can cause |
||||
# an error in the "cmdline::prefixSearch" procedure. |
||||
|
||||
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||
variable charclasses |
||||
|
||||
upvar $argvVar argsList |
||||
|
||||
upvar $optVar retvar |
||||
upvar $argVar optarg |
||||
|
||||
# default settings for a normal return |
||||
set optarg "" |
||||
set retvar "" |
||||
set retval 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
"-*" { |
||||
# Create list of options without their argument extensions |
||||
|
||||
set optstr "" |
||||
foreach str $optstring { |
||||
lappend optstr [file rootname $str] |
||||
} |
||||
|
||||
set _opt [string range $arg 1 end] |
||||
|
||||
set i [prefixSearch $optstr [file rootname $_opt]] |
||||
if {$i != -1} { |
||||
set opt [lindex $optstring $i] |
||||
|
||||
set quantifier "none" |
||||
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||
set opt [string range $opt 0 end-1] |
||||
} |
||||
|
||||
if {[string first . $opt] == -1} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||
if {[string equal arg $charclass]} { |
||||
set type arg |
||||
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||
set type class |
||||
} else { |
||||
set type oneof |
||||
} |
||||
|
||||
set argsList [lrange $argsList 1 end] |
||||
set opt [file rootname $opt] |
||||
|
||||
while {1} { |
||||
if {[llength $argsList] == 0 |
||||
|| [string equal "--" [lindex $argsList 0]]} { |
||||
if {[string equal "--" [lindex $argsList 0]]} { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set optarg "" |
||||
} elseif {$quantifier == "+"} { |
||||
set retvar $opt |
||||
if {[llength $optarg] < 1} { |
||||
set retval -2 |
||||
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||
} else { |
||||
set retval 1 |
||||
} |
||||
} elseif {$quantifier == "*"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
} else { |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -2 |
||||
} |
||||
set quantifier "" |
||||
} elseif {($type == "arg") |
||||
|| (($type == "oneof") |
||||
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||
|| (($type == "class") |
||||
&& [string is $charclass [lindex $argsList 0]])} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
lappend optarg [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -3 |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set optarg "" |
||||
} |
||||
set quantifier "" |
||||
} |
||||
if {![regexp -- {[+*]} $quantifier]} { |
||||
break; |
||||
} |
||||
} |
||||
} else { |
||||
Error \ |
||||
"Illegal option type specification: must be one of $charclasses" \ |
||||
BAD OPTION TYPE |
||||
} |
||||
} else { |
||||
set optarg "Illegal option -- $_opt" |
||||
set retvar $_opt |
||||
set retval -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $retval |
||||
} |
||||
|
||||
# ::cmdline::typedGetoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed options if an incorrect option is |
||||
# specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# |
||||
# option default comment |
||||
# |
||||
# Options formatting is as described for the optstring |
||||
# argument of typedGetopt. Default is for optionally |
||||
# specifying a default value. Comment is for optionally |
||||
# specifying a comment for the usage display. The |
||||
# options "--", "-help", and "-?" are automatically included |
||||
# in optlist. |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options formatting and syntax is as described in typedGetopt. |
||||
# There are two additional suffixes that may be applied when |
||||
# passing options to typedGetoptions. |
||||
# |
||||
# You may add ".multi" as a suffix to any option. For options |
||||
# that take an argument, this means that the option may be used |
||||
# more than once on the command line and that each additional |
||||
# argument will be appended to a list, which is then returned |
||||
# to the application. |
||||
# foo.double.multi |
||||
# |
||||
# If a non-argument option is specified as ".multi", it is |
||||
# toggled on and off for each time it is used on the command |
||||
# line. |
||||
# foo.multi |
||||
# |
||||
# If an option specification does not contain the ".multi" |
||||
# suffix, it is not an error to use an option more than once. |
||||
# In this case, the behavior for options with arguments is that |
||||
# the last argument is the one that will be returned. For |
||||
# options that do not take arguments, using them more than once |
||||
# has no additional effect. |
||||
# |
||||
# Options may also be hidden from the usage display by |
||||
# appending the suffix ".secret" to any option specification. |
||||
# Please note that the ".secret" suffix must be the last suffix, |
||||
# after any argument type specification and ".multi" suffix. |
||||
# foo.xdigit.multi.secret |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||
variable charclasses |
||||
|
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
} |
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
|
||||
regsub -- {\..*$} $name {} temp |
||||
set multi($temp) 1 |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||
# Set defaults for those that take values. |
||||
# Booleans are set just by being present, or not |
||||
|
||||
set dflt [lindex $opt 1] |
||||
if {$dflt != {}} { |
||||
set defaults($name) $dflt |
||||
} |
||||
} |
||||
} |
||||
set argc [llength $argv] |
||||
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||
if {$err == 1} { |
||||
if {[info exists result($opt)] |
||||
&& [info exists multi($opt)]} { |
||||
# Toggle boolean options or append new arguments |
||||
|
||||
if {$arg == ""} { |
||||
unset result($opt) |
||||
} else { |
||||
set result($opt) "$result($opt) $arg" |
||||
} |
||||
} else { |
||||
set result($opt) "$arg" |
||||
} |
||||
} elseif {($err == -1) || ($err == -3)} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
} |
||||
if {[info exists result(?)] || [info exists result(help)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
foreach {opt dflt} [array get defaults] { |
||||
if {![info exists result($opt)]} { |
||||
set result($opt) $dflt |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::typedUsage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags, |
||||
# type of argument taken (if any), default value (if any), |
||||
# and an optional description. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::typedGetoptions |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||
variable charclasses |
||||
|
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
|
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Display something about multiple options |
||||
} |
||||
|
||||
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||
} { |
||||
regsub -- "\\..+\$" $name {} name |
||||
append name " $charclass" |
||||
set desc [lindex $opt 2] |
||||
set default [lindex $opt 1] |
||||
if {$default != ""} { |
||||
append desc " <$default>" |
||||
} |
||||
} else { |
||||
set desc [lindex $opt 1] |
||||
} |
||||
lappend accum $name $desc |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||
} |
||||
foreach {name desc} $accum { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::prefixSearch -- |
||||
# |
||||
# Search a Tcl list for a pattern; searches first for an exact match, |
||||
# and if that fails, for a unique prefix that matches the pattern |
||||
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||
# |
||||
# Arguments: |
||||
# list list of words |
||||
# pattern word to search for |
||||
# |
||||
# Results: |
||||
# Index of found word is returned. If no exact match or |
||||
# unique short version is found then -1 is returned. |
||||
|
||||
proc ::cmdline::prefixSearch {list pattern} { |
||||
# Check for an exact match |
||||
|
||||
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||
return $pos |
||||
} |
||||
|
||||
# Check for a unique short version |
||||
|
||||
set slist [lsort $list] |
||||
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||
# What if there is nothing for the check variable? |
||||
|
||||
set check [lindex $slist [expr {$pos + 1}]] |
||||
if {[string first $pattern $check] != 0} { |
||||
return [::lsearch -exact $list [lindex $slist $pos]] |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
# ::cmdline::Error -- |
||||
# |
||||
# Internal helper to throw errors with a proper error-code attached. |
||||
# |
||||
# Arguments: |
||||
# message text of the error message to throw. |
||||
# args additional parts of the error code to use, |
||||
# with CMDLINE as basic prefix added by this command. |
||||
# |
||||
# Results: |
||||
# An error is thrown, always. |
||||
|
||||
proc ::cmdline::Error {message args} { |
||||
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||
} |
||||
@ -1,518 +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> <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 |
||||
if {$command eq ""} { |
||||
return $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] |
||||
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>} |
||||
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." |
||||
puts stderr [::commandstack::show_stack $command] |
||||
} 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)" |
||||
puts stderr |
||||
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}} { |
||||
#could be a standard tcl proc, or from application or package |
||||
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 {![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]] |
||||
} |
||||
if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { |
||||
#punk pipeline also needed for patterns |
||||
return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] |
||||
} else { |
||||
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 |
||||
}] |
||||
|
||||
|
||||
@ -1,306 +0,0 @@
|
||||
# Debug - a debug narrative logger. |
||||
# -- Colin McCormack / originally Wub server utilities |
||||
# |
||||
# Debugging areas of interest are represented by 'tokens' which have |
||||
# independantly settable levels of interest (an integer, higher is more detailed) |
||||
# |
||||
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||
# caller's scope if and only if the current level of interest matches or exceeds |
||||
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||
# complex narrative in code without unnecessarily evaluating it. |
||||
# |
||||
# TODO: potentially different streams for different areas of interest. |
||||
# (currently only stderr is used. there is some complexity in efficient |
||||
# cross-threaded streams.) |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::debug { |
||||
namespace export -clear \ |
||||
define on off prefix suffix header trailer \ |
||||
names 2array level setting parray pdict \ |
||||
nl tab hexl |
||||
namespace ensemble create -subcommands {} |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API & Implementation |
||||
|
||||
proc ::debug::noop {args} {} |
||||
|
||||
proc ::debug::debug {tag message {level 1}} { |
||||
variable detail |
||||
if {$detail($tag) < $level} { |
||||
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||
return |
||||
} |
||||
|
||||
variable prefix |
||||
variable suffix |
||||
variable header |
||||
variable trailer |
||||
variable fds |
||||
|
||||
if {[info exists fds($tag)]} { |
||||
set fd $fds($tag) |
||||
} else { |
||||
set fd stderr |
||||
} |
||||
|
||||
# Assemble the shown text from the user message and the various |
||||
# prefixes and suffices (global + per-tag). |
||||
|
||||
set themessage "" |
||||
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||
append themessage $message |
||||
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||
|
||||
# Resolve variables references and command invokations embedded |
||||
# into the message with plain text. |
||||
set code [catch { |
||||
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||
} __ eo] |
||||
|
||||
# And dump an internal error if that resolution failed. |
||||
if {$code} { |
||||
if {[catch { |
||||
set caller [info level -1] |
||||
}]} { set caller GLOBAL } |
||||
if {[string length $caller] >= 1000} { |
||||
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||
} |
||||
foreach line [split $caller \n] { |
||||
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||
} |
||||
return |
||||
} |
||||
|
||||
# From here we have a good message to show. We only shorten it a |
||||
# bit if its a bit excessive in size. |
||||
|
||||
if {[string length $smessage] > 4096} { |
||||
set head [string range $smessage 0 2048] |
||||
set tail [string range $smessage end-2048 end] |
||||
set smessage "${head}...(truncated)...$tail" |
||||
} |
||||
|
||||
foreach line [split $smessage \n] { |
||||
puts $fd "$sheader$tag | $line$strailer" |
||||
} |
||||
return |
||||
} |
||||
|
||||
# names - return names of debug tags |
||||
proc ::debug::names {} { |
||||
variable detail |
||||
return [lsort [array names detail]] |
||||
} |
||||
|
||||
proc ::debug::2array {} { |
||||
variable detail |
||||
set result {} |
||||
foreach n [lsort [array names detail]] { |
||||
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||
lappend result $n $detail($n) |
||||
} else { |
||||
lappend result $n -$detail($n) |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# level - set level and fd for tag |
||||
proc ::debug::level {tag {level ""} {fd {}}} { |
||||
variable detail |
||||
# TODO: Force level >=0. |
||||
if {$level ne ""} { |
||||
set detail($tag) $level |
||||
} |
||||
|
||||
if {![info exists detail($tag)]} { |
||||
set detail($tag) 1 |
||||
} |
||||
|
||||
variable fds |
||||
if {$fd ne {}} { |
||||
set fds($tag) $fd |
||||
} |
||||
|
||||
return $detail($tag) |
||||
} |
||||
|
||||
proc ::debug::header {text} { variable header $text } |
||||
proc ::debug::trailer {text} { variable trailer $text } |
||||
|
||||
proc ::debug::define {tag} { |
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
# Set a prefix/suffix to use for tag. |
||||
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||
# This works because colon (:) is an illegal character for user-specified tags. |
||||
|
||||
proc ::debug::prefix {tag {theprefix {}}} { |
||||
variable prefix |
||||
set prefix($tag) $theprefix |
||||
|
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
proc ::debug::suffix {tag {theprefix {}}} { |
||||
variable suffix |
||||
set suffix($tag) $theprefix |
||||
|
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
# turn on debugging for tag |
||||
proc ::debug::on {tag {level ""} {fd {}}} { |
||||
variable active |
||||
set active($tag) 1 |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::debug $tag |
||||
return |
||||
} |
||||
|
||||
# turn off debugging for tag |
||||
proc ::debug::off {tag {level ""} {fd {}}} { |
||||
variable active |
||||
set active($tag) 1 |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::noop |
||||
return |
||||
} |
||||
|
||||
proc ::debug::setting {args} { |
||||
if {[llength $args] == 1} { |
||||
set args [lindex $args 0] |
||||
} |
||||
set fd stderr |
||||
if {[llength $args] % 2} { |
||||
set fd [lindex $args end] |
||||
set args [lrange $args 0 end-1] |
||||
} |
||||
foreach {tag level} $args { |
||||
if {$level > 0} { |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::debug $tag |
||||
} else { |
||||
level $tag [expr {-$level}] $fd |
||||
interp alias {} debug.$tag {} ::debug::noop |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Convenience commands. |
||||
# Format arrays and dicts as multi-line message. |
||||
# Insert newlines and tabs. |
||||
|
||||
proc ::debug::nl {} { return \n } |
||||
proc ::debug::tab {} { return \t } |
||||
|
||||
proc ::debug::parray {a {pattern *}} { |
||||
upvar 1 $a array |
||||
if {![array exists array]} { |
||||
error "\"$a\" isn't an array" |
||||
} |
||||
pdict [array get array] $pattern |
||||
} |
||||
|
||||
proc ::debug::pdict {dict {pattern *}} { |
||||
set maxl 0 |
||||
set names [lsort -dict [dict keys $dict $pattern]] |
||||
foreach name $names { |
||||
if {[string length $name] > $maxl} { |
||||
set maxl [string length $name] |
||||
} |
||||
} |
||||
set maxl [expr {$maxl + 2}] |
||||
set lines {} |
||||
foreach name $names { |
||||
set nameString [format (%s) $name] |
||||
lappend lines [format "%-*s = %s" \ |
||||
$maxl $nameString \ |
||||
[dict get $dict $name]] |
||||
} |
||||
return [join $lines \n] |
||||
} |
||||
|
||||
proc ::debug::hexl {data {prefix {}}} { |
||||
set r {} |
||||
|
||||
# Convert the data to hex and to characters. |
||||
binary scan $data H*@0a* hexa asciia |
||||
|
||||
# Replace non-printing characters in the data with dots. |
||||
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||
|
||||
# Pad with spaces to a full multiple of 32/16. |
||||
set n [expr {[string length $hexa] % 32}] |
||||
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||
#puts "pad H [expr {32-$n}]" |
||||
|
||||
set n [expr {[string length $asciia] % 32}] |
||||
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||
#puts "pad A [expr {32-$n}]" |
||||
|
||||
# Reassemble formatted, in groups of 16 bytes/characters. |
||||
# The hex part is handled in groups of 32 nibbles. |
||||
set addr 0 |
||||
while {[string length $hexa]} { |
||||
# Get front group of 16 bytes each. |
||||
set hex [string range $hexa 0 31] |
||||
set ascii [string range $asciia 0 15] |
||||
# Prep for next iteration |
||||
set hexa [string range $hexa 32 end] |
||||
set asciia [string range $asciia 16 end] |
||||
|
||||
# Convert the hex to pairs of hex digits |
||||
regsub -all -- {..} $hex {& } hex |
||||
|
||||
# Add the hex and latin-1 data to the result buffer |
||||
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||
incr addr 16 |
||||
} |
||||
|
||||
# And done |
||||
return $r |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
namespace eval debug { |
||||
variable detail ; # map: TAG -> level of interest |
||||
variable prefix ; # map: TAG -> message prefix to use |
||||
variable suffix ; # map: TAG -> message suffix to use |
||||
variable fds ; # map: TAG -> handle of open channel to log to. |
||||
variable header {} ; # per-line heading, subst'ed |
||||
variable trailer {} ; # per-line ending, subst'ed |
||||
|
||||
# Notes: |
||||
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||
# the global message prefix / suffix. |
||||
# - prefix and suffix are applied per message. |
||||
# - header and trailer are per line. And should not generate multiple lines! |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide debug 1.0.6 |
||||
return |
||||
@ -1,366 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application dictn 0.1.2 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval dictn { |
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
} |
||||
|
||||
|
||||
## ::dictn::append |
||||
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||
# %set list {a b {c d}} |
||||
# %append list x |
||||
# a b {c d}x |
||||
# IOW - don't do that unless you really know that's what you want. |
||||
# |
||||
proc ::dictn::append {dictvar path {value {}}} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict append $dictvar $path $value] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set str [dict get $dvar {*}$path] |
||||
append str $val |
||||
dict set dvar {*}$path $str |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::create {args} { |
||||
::set data {} |
||||
foreach {path val} $args { |
||||
dict set data {*}$path $val |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
proc ::dictn::exists {dictval path} { |
||||
return [dict exists $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::filter {dictval path filterType args} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict filter $sub $filterType {*}$args |
||||
} |
||||
|
||||
proc ::dictn::for {keyvalvars dictval path body} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict for $keyvalvars $sub $body |
||||
} |
||||
|
||||
proc ::dictn::get {dictval {path {}}} { |
||||
return [dict get $dictval {*}$path] |
||||
} |
||||
|
||||
|
||||
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||
#tcl 9+ |
||||
proc ::dictn::getdef {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} else { |
||||
#tcl < 9 |
||||
proc ::dictn::getdef {dictval path default} { |
||||
if {[tcl::dict::exists $dictval {*}$path]} { |
||||
return [tcl::dict::get $dictval {*}$path] |
||||
} else { |
||||
return $default |
||||
} |
||||
} |
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
if {[tcl::dict::exists $dictval {*}$path]} { |
||||
return [tcl::dict::get $dictval {*}$path] |
||||
} else { |
||||
return $default |
||||
} |
||||
} |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
if {![dict exists $dvar {*}$path]} { |
||||
::set val 0 |
||||
} else { |
||||
::set val [dict get $dvar {*}$path] |
||||
} |
||||
::set newval [expr {$val + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::info {dictval {path {}}} { |
||||
if {![string length $path]} { |
||||
return [dict info $dictval] |
||||
} else { |
||||
::set sub [dict get $dictval {*}$path] |
||||
return [dict info $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict keys $sub $glob] |
||||
} else { |
||||
return [dict keys $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::lappend {dictvar path args} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set list [dict get $dvar {*}$path] |
||||
::lappend list {*}$args |
||||
dict set dvar {*}$path $list |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::merge {args} { |
||||
error "nested merge not yet supported" |
||||
} |
||||
|
||||
#dictn remove dictionaryValue ?path ...? |
||||
proc ::dictn::remove {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||
|
||||
foreach path $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict remove $sub [lindex $path end]] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
if {[llength $basic]} { |
||||
return [dict remove $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::replace {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||
|
||||
foreach {path val} $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path $val |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict replace $sub [lindex $path end] $val] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[llength $basic]} { |
||||
return [dict replace $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::set {dictvar path newval} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict set dvar {*}$path $newval] |
||||
} |
||||
|
||||
proc ::dictn::size {dictval {path {}}} { |
||||
return [dict size [dict get $dictval {*}$path]] |
||||
} |
||||
|
||||
proc ::dictn::unset {dictvar path} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict unset dvar {*}$path |
||||
} |
||||
|
||||
proc ::dictn::update {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
uplevel 1 [list set $var [dict get $dvar $path]] |
||||
} |
||||
} |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
upvar 1 $var $var |
||||
if {![::info exists $var]} { |
||||
uplevel 1 [list dict unset $dictvar {*}$path] |
||||
} else { |
||||
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#an experiment. |
||||
proc ::dictn::Applyupdate {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set headscript "" |
||||
::set i 0 |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||
::lappend arglist $var |
||||
::lappend vallist [dict get $dvar {*}$path] |
||||
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||
::append headscript \n |
||||
::incr i |
||||
} |
||||
} |
||||
|
||||
::set body $headscript\r\n$body |
||||
|
||||
puts stderr "BODY: $body" |
||||
|
||||
#set result [apply [list args $body] {*}$vallist] |
||||
catch {apply [list args $body] {*}$vallist} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||
dict set dvar {*}$path [::set $var] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict values $sub $glob] |
||||
} else { |
||||
return [dict values $sub] |
||||
} |
||||
} |
||||
|
||||
# Standard form: |
||||
#'dictn with dictVariable path body' |
||||
# |
||||
# Extended form: |
||||
#'dictn with dictVariable path arrayVariable body' |
||||
# |
||||
proc ::dictn::with {dictvar path args} { |
||||
if {[llength $args] == 1} { |
||||
::set body [lindex $args 0] |
||||
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
::lassign $args arrayname body |
||||
|
||||
upvar 1 $arrayname arr |
||||
array set arr [dict get $dvar {*}$path] |
||||
::set prevkeys [array names arr] |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
|
||||
foreach k $prevkeys { |
||||
if {![::info exists arr($k)]} { |
||||
dict unset $dvar {*}$path $k |
||||
} |
||||
} |
||||
foreach k [array names arr] { |
||||
dict set $dvar {*}$path $k $arr($k) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide dictn [namespace eval dictn { |
||||
variable version |
||||
::set version 0.1.2 |
||||
}] |
||||
return |
||||
@ -1,145 +0,0 @@
|
||||
# dictutils.tcl -- |
||||
# |
||||
# Various dictionary utilities. |
||||
# |
||||
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
||||
# |
||||
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
||||
# |
||||
|
||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||
|
||||
package require Tcl 8.6- |
||||
package provide dictutils 0.2.1 |
||||
|
||||
namespace eval dictutils { |
||||
namespace export equal apply capture witharray nlappend |
||||
namespace ensemble create |
||||
|
||||
# dictutils witharray dictVar arrayVar script -- |
||||
# |
||||
# Unpacks the elements of the dictionary in dictVar into the array |
||||
# variable arrayVar and then evaluates the script. If the script |
||||
# completes with an ok, return or continue status, then the result is copied |
||||
# back into the dictionary variable, otherwise it is discarded. A |
||||
# [break] can be used to explicitly abort the transaction. |
||||
# |
||||
proc witharray {dictVar arrayVar script} { |
||||
upvar 1 $dictVar dict $arrayVar array |
||||
array set array $dict |
||||
try { uplevel 1 $script |
||||
} on break {} { # Discard the result |
||||
} on continue result - on ok result { |
||||
set dict [array get array] ;# commit changes |
||||
return $result |
||||
} on return {result opts} { |
||||
set dict [array get array] ;# commit changes |
||||
dict incr opts -level ;# remove this proc from level |
||||
return -options $opts $result |
||||
} |
||||
# All other cases will discard the changes and propagage |
||||
} |
||||
|
||||
# dictutils equal equalp d1 d2 -- |
||||
# |
||||
# Compare two dictionaries for equality. Two dictionaries are equal |
||||
# if they (a) have the same keys, (b) the corresponding values for |
||||
# each key in the two dictionaries are equal when compared using the |
||||
# equality predicate, equalp (passed as an argument). The equality |
||||
# predicate is invoked with the key and the two values from each |
||||
# dictionary as arguments. |
||||
# |
||||
proc equal {equalp d1 d2} { |
||||
if {[dict size $d1] != [dict size $d2]} { return 0 } |
||||
dict for {k v} $d1 { |
||||
if {![dict exists $d2 $k]} { return 0 } |
||||
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
||||
# |
||||
# A combination of *dict with* and *apply*, this procedure creates a |
||||
# new procedure scope populated with the values in the dictionary |
||||
# variable. It then applies the lambdaTerm (anonymous procedure) in |
||||
# this new scope. If the procedure completes normally, then any |
||||
# changes made to variables in the dictionary are reflected back to |
||||
# the dictionary variable, otherwise they are ignored. This provides |
||||
# a transaction-style semantics whereby atomic updates to a |
||||
# dictionary can be performed. This procedure can also be useful for |
||||
# implementing a variety of control constructs, such as mutable |
||||
# closures. |
||||
# |
||||
proc apply {dictVar lambdaExpr args} { |
||||
upvar 1 $dictVar dict |
||||
set env $dict ;# copy |
||||
lassign $lambdaExpr params body ns |
||||
if {$ns eq ""} { set ns "::" } |
||||
set body [format { |
||||
upvar 1 env __env__ |
||||
dict with __env__ %s |
||||
} [list $body]] |
||||
set lambdaExpr [list $params $body $ns] |
||||
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
||||
if {$rc == 0} { |
||||
# Copy back any updates |
||||
set dict $env |
||||
} |
||||
return -options $opts $ret |
||||
} |
||||
|
||||
# capture ?level? ?exclude? ?include? -- |
||||
# |
||||
# Captures a snapshot of the current (scalar) variable bindings at |
||||
# $level on the stack into a dictionary environment. This dictionary |
||||
# can later be used with *dictutils apply* to partially restore the |
||||
# scope, creating a first approximation of closures. The *level* |
||||
# argument should be of the forms accepted by *uplevel* and |
||||
# designates which level to capture. It defaults to 1 as in uplevel. |
||||
# The *exclude* argument specifies an optional list of literal |
||||
# variable names to avoid when performing the capture. No variables |
||||
# matching any item in this list will be captured. The *include* |
||||
# argument can be used to specify a list of glob patterns of |
||||
# variables to capture. Only variables matching one of these |
||||
# patterns are captured. The default is a single pattern "*", for |
||||
# capturing all visible variables (as determined by *info vars*). |
||||
# |
||||
proc capture {{level 1} {exclude {}} {include {*}}} { |
||||
if {[string is integer $level]} { incr level } |
||||
set env [dict create] |
||||
foreach pattern $include { |
||||
foreach name [uplevel $level [list info vars $pattern]] { |
||||
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
||||
upvar $level $name value |
||||
catch { dict set env $name $value } ;# no arrays |
||||
} |
||||
} |
||||
return $env |
||||
} |
||||
|
||||
# nlappend dictVar keyList ?value ...? |
||||
# |
||||
# Append zero or more elements to the list value stored in the given |
||||
# dictionary at the path of keys specified in $keyList. If $keyList |
||||
# specifies a non-existent path of keys, nlappend will behave as if |
||||
# the path mapped to an empty list. |
||||
# |
||||
proc nlappend {dictvar keylist args} { |
||||
upvar 1 $dictvar dict |
||||
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
||||
set list [dict get $dict {*}$keylist] |
||||
} |
||||
lappend list {*}$args |
||||
dict set dict {*}$keylist $list |
||||
} |
||||
|
||||
# invoke cmd args... -- |
||||
# |
||||
# Helper procedure to invoke a callback command with arguments at |
||||
# the global scope. The helper ensures that proper quotation is |
||||
# used. The command is expected to be a list, e.g. {string equal}. |
||||
# |
||||
proc invoke {cmd args} { uplevel #0 $cmd $args } |
||||
|
||||
} |
||||
@ -1,568 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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 fauxlink 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] |
||||
#[copyright "2024"] |
||||
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||
#[require fauxlink] |
||||
#[keywords symlink faux fake shortcut toml] |
||||
#[description] |
||||
#[para] A cross platform shortcut/symlink alternative. |
||||
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||
#[para] archiving and packaging systems. |
||||
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||
#[para] format of name <nominalname>#<encodedtarget>.fauxlink |
||||
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||
#[para] The file extension must be .fauxlink or .fxlnk |
||||
#[para] The + symbol substitutes for forward-slashes. |
||||
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||
#[para] We deliberately treat higher % sequences literally. |
||||
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls. |
||||
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||
#[para] file%23A.txt#..+file%23A.txt.fauxlink |
||||
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink |
||||
#[para] The <nominalname> can be unrelated to the actual target |
||||
#[para] e.g datafile.dat#..+file%23A.txt.fauxlink |
||||
#[para] This system has no filesystem support - and must be completely application driven. |
||||
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||
#[para] with custom data being under a single application-chosen table name |
||||
#[para] The toplevel Toml table [lb]fauxlink[rb] is reserved for core extensions to this system. |
||||
#[para] Aside from the 2 used for delimiting (+ #) |
||||
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||
#[para] e.g space and tab are required to be %20 %09 |
||||
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||
#[para] Control characters and other punctuation is optional to encode. |
||||
#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. |
||||
#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX |
||||
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||
# |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||
#Using fauxlink - a link would be: |
||||
# "my-program-files#++server+c+Program%20Files.fauxlink" |
||||
#If we needed the old-style literal %20 it would become |
||||
# "my-program-files#++server+c+Program%2520Files.fauxlink" |
||||
# |
||||
# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) |
||||
# e.g |
||||
# pfiles#file%3a++++localhost+c+Program%2520files |
||||
# The browser will work with literal spaces too though - so it could just as well be: |
||||
# pfiles#file%3a++++localhost+c+Program%20files |
||||
#windows may default to using explorer.exe instead of a browser for file:// urls though |
||||
#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? |
||||
#in a .url shortcut either literal space or %20 will work ie %xx values are decoded |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of fauxlink |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by fauxlink |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval fauxlink::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace fauxlink::class}] |
||||
#[para] class definitions |
||||
if {[info commands [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 |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval fauxlink { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
#todo - enforce utf-8 |
||||
|
||||
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||
|
||||
|
||||
variable encode_map |
||||
variable decode_map |
||||
#most filesystems don't allow NULL - map to empty string |
||||
|
||||
#Make sure % is not in encode_map |
||||
set encode_map [dict create\ |
||||
\x00 ""\ |
||||
{ } %20\ |
||||
\t %09\ |
||||
+ %2B\ |
||||
# %23\ |
||||
* %2A\ |
||||
? %3F\ |
||||
\\ %5C\ |
||||
/ %2F\ |
||||
| %7C\ |
||||
: %3A\ |
||||
{;} %3B\ |
||||
{"} %22\ |
||||
< %3C\ |
||||
> %3E\ |
||||
] |
||||
#above have some overlap with ctrl codes below. |
||||
#no big deal as it's a dict |
||||
|
||||
#must_encode |
||||
# + # * ? \ / | : ; " < > <sp> \t |
||||
# also NUL to empty string |
||||
|
||||
# also ctrl chars 01 to 1F (1..31) |
||||
for {set i 1} {$i < 32} {incr i} { |
||||
set ch [format %c $i] |
||||
set enc "%[format %02X $i]" |
||||
set enc_lower [string tolower $enc] |
||||
dict set encode_map $ch $enc |
||||
dict set decode_map $enc $ch |
||||
dict set decode_map $enc_lower $ch |
||||
} |
||||
|
||||
variable must_encode |
||||
set must_encode [dict keys $encode_map] |
||||
|
||||
|
||||
#if they are in |
||||
|
||||
#decode map doesn't include |
||||
# %00 (nul) |
||||
# %2F "/" |
||||
# %2f "/" |
||||
# %7f (del) |
||||
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||
# |
||||
set decode_map [dict merge $decode_map [dict create\ |
||||
%09 \t\ |
||||
%20 { }\ |
||||
%21 "!"\ |
||||
%22 {"}\ |
||||
%23 "#"\ |
||||
%24 "$"\ |
||||
%25 "%"\ |
||||
%26 "&"\ |
||||
%27 "'"\ |
||||
%28 "("\ |
||||
%29 ")"\ |
||||
%2A "*"\ |
||||
%2a "*"\ |
||||
%2B "+"\ |
||||
%2b "+"\ |
||||
%2C ","\ |
||||
%2c ","\ |
||||
%2D "-"\ |
||||
%2d "-"\ |
||||
%2E "."\ |
||||
%2e "."\ |
||||
%3A ":"\ |
||||
%3a ":"\ |
||||
%3B {;}\ |
||||
%3b {;}\ |
||||
%3D "="\ |
||||
%3C "<"\ |
||||
%3c "<"\ |
||||
%3d "="\ |
||||
%3E ">"\ |
||||
%3e ">"\ |
||||
%3F "?"\ |
||||
%3f "?"\ |
||||
%40 "@"\ |
||||
%5B "\["\ |
||||
%5b "\["\ |
||||
%5C "\\"\ |
||||
%5c "\\"\ |
||||
%5D "\]"\ |
||||
%5d "\]"\ |
||||
%5E "^"\ |
||||
%5e "^"\ |
||||
%60 "`"\ |
||||
%7B "{"\ |
||||
%7b "{"\ |
||||
%7C "|"\ |
||||
%7c "|"\ |
||||
%7D "}"\ |
||||
%7d "}"\ |
||||
%7E "~"\ |
||||
%7e "~"\ |
||||
]] |
||||
#Don't go above 7f |
||||
#if we want to specify p |
||||
|
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace fauxlink}] |
||||
#[para] Core API functions for fauxlink |
||||
#[list_begin definitions] |
||||
proc Segment_mustencode_check {str} { |
||||
variable decode_map |
||||
variable encode_map ;#must_encode |
||||
set idx 0 |
||||
set err "" |
||||
foreach ch [split $str ""] { |
||||
if {[dict exists $encode_map $ch]} { |
||||
set enc [dict get $encode_map $ch] |
||||
if {[dict exists $decode_map $enc]} { |
||||
append err " char $idx should be encoded as $enc" \n |
||||
} else { |
||||
append err " no %xx encoding available. Use %UXX if really required" \n |
||||
} |
||||
} |
||||
incr idx |
||||
} |
||||
return $err ;#empty string if ok |
||||
} |
||||
|
||||
proc resolve {link} { |
||||
variable decode_map |
||||
variable encode_map |
||||
variable must_encode |
||||
set ftail [file tail $link] |
||||
set extension_name [string range [file extension $ftail] 1 end] |
||||
if {$extension_name ni [list fxlnk fauxlink]} { |
||||
set is_fauxlink 0 |
||||
#we'll process anyway - but return the result wrapped |
||||
#This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent |
||||
#(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens |
||||
# to have # characters in it) |
||||
#It also means if someone really wants to use the fauxlink semantics on a different file type |
||||
# - they can - but just have to access the results differently and take that (minor) risk. |
||||
#error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||
set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate" |
||||
} else { |
||||
set is_fauxlink 1 |
||||
set err_extra "" |
||||
} |
||||
set linkspec [file rootname $ftail] |
||||
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||
if {[tcl::string::first # $linkspec] < 0} { |
||||
set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" |
||||
append err $err_extra |
||||
error $err |
||||
} |
||||
#The 1st 2 parts of split on # are name and target file/dir |
||||
#If there are only 3 parts the 3rd part is a comment and there are no 'tags' |
||||
#if there are 4 parts - the 3rd part is a tagset where each tag begins with @ |
||||
#and each subsequent part is a comment. Empty comments are stripped from the comments list |
||||
#A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ |
||||
#e.g name.txt#path#@tag1@tag2#test###.fauxlink |
||||
#has a name, a target, 2 tags and one comment |
||||
|
||||
#check namespec already has required chars encoded |
||||
set segments [split $linkspec #] |
||||
lassign $segments namespec targetspec |
||||
#puts stderr "-->namespec $namespec" |
||||
set nametest [tcl::string::map $encode_map $namespec] |
||||
#puts stderr "-->nametest $nametest" |
||||
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||
set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" |
||||
append err [Segment_mustencode_check $namespec] |
||||
append err $err_extra |
||||
error $err |
||||
} |
||||
#see comments below regarding 2 rounds and ordering. |
||||
set name [decode_unicode_escapes $namespec] |
||||
set name [tcl::string::map $decode_map $name] |
||||
#puts stderr "-->name: $name" |
||||
|
||||
set targetsegment [split $targetspec +] |
||||
#check each + delimited part of targetspec already has required chars encoded |
||||
set pp 0 ;#pathpart index |
||||
set targetpath_parts [list] |
||||
foreach pathpart $targetsegment { |
||||
set targettest [tcl::string::map $encode_map $pathpart] |
||||
if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { |
||||
set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" |
||||
append err [Segment_mustencode_check $pathpart] |
||||
append err $err_extra |
||||
error $err |
||||
} |
||||
#2 rounds of substitution is possibly asking for trouble.. |
||||
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||
#so it's not so much about what can be encoded, |
||||
# - but it makes it harder to reason about for users |
||||
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||
# the double sub would make it %UXXX -> somechar anyway. |
||||
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||
set pathpart [decode_unicode_escapes $pathpart] |
||||
set pathpart [tcl::string::map $decode_map $pathpart] |
||||
lappend targetpath_parts $pathpart |
||||
|
||||
incr pp |
||||
} |
||||
set targetpath [join $targetpath_parts /] |
||||
if {$name eq ""} { |
||||
set name [lindex $targetpath_parts end] |
||||
} |
||||
#we do the same encoding checks on tags and comments to increase chances of portability |
||||
set tags [list] |
||||
set comments [list] |
||||
switch -- [llength $segments] { |
||||
2 { |
||||
#no tags or comments |
||||
} |
||||
3 { |
||||
#only 3 sections - last is comment - even if looks like tags |
||||
#to make the 3rd part a tagset, an extra # would be needed |
||||
set comments [list [lindex $segments 2]] |
||||
} |
||||
default { |
||||
set tagset [lindex $segments 2] |
||||
if {$tagset eq ""} { |
||||
#ok - no tags |
||||
} else { |
||||
if {[string first @ $tagset] != 0} { |
||||
set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" |
||||
append err \n " - must begin with @" |
||||
append err $err_extra |
||||
error $err |
||||
} else { |
||||
set tagset [string range $tagset 1 end] |
||||
set rawtags [split $tagset @] |
||||
set tags [list] |
||||
foreach t $rawtags { |
||||
if {$t eq ""} { |
||||
lappend tags "" |
||||
} else { |
||||
set tagtest [tcl::string::map $encode_map $t] |
||||
if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { |
||||
set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" |
||||
append err [Segment_mustencode_check $t] |
||||
append err $err_extra |
||||
error $err |
||||
} |
||||
lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set rawcomments [lrange $segments 3 end] |
||||
#set comments [lsearch -all -inline -not $comments ""] |
||||
set comments [list] |
||||
foreach c $rawcomments { |
||||
if {$c eq ""} {continue} |
||||
set commenttest [tcl::string::map $encode_map $c] |
||||
if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { |
||||
set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" |
||||
append err [Segment_mustencode_check $c] |
||||
append err $err_extra |
||||
error $err |
||||
} |
||||
lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] |
||||
} |
||||
} |
||||
} |
||||
|
||||
set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] |
||||
if {$is_fauxlink} { |
||||
#standard .fxlnk or .fauxlink |
||||
return $data |
||||
} else { |
||||
#custom extension - or called in error on wrong type of file but happened to parse. |
||||
#see comments at top regarding is_fauxlink |
||||
#make sure no keys in common at top level. |
||||
return [dict create\ |
||||
linktype $extension_name\ |
||||
note "nonstandard extension returning nonstandard dict with result in data key"\ |
||||
data $data\ |
||||
] |
||||
} |
||||
} |
||||
variable map |
||||
|
||||
#default exclusion of / (%U2f and equivs) |
||||
#this would allow obfuscation of intention - when we have + for that anyway |
||||
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||
variable map |
||||
set ucstart [string first %U $str 0] |
||||
if {$ucstart < 0} { |
||||
return $str |
||||
} |
||||
set max 8 |
||||
set map [list] |
||||
set strend [expr {[string length $str]-1}] |
||||
while {$ucstart >= 0} { |
||||
set s $ucstart |
||||
set i [expr {$s +2}] ;#skip the %U |
||||
set hex "" |
||||
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||
set in [string index $str $i] |
||||
if {[tcl::string::is xdigit -strict $in]} { |
||||
append hex $in |
||||
} else { |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$hex ne ""} { |
||||
incr i -1 |
||||
lappend map $s $i $hex |
||||
} |
||||
set ucstart [tcl::string::first %U $str $i] |
||||
} |
||||
set out "" |
||||
set lastidx -1 |
||||
set e 0 |
||||
foreach {s e hex} $map { |
||||
append out [string range $str $lastidx+1 $s-1] |
||||
set sub [format %c 0x$hex] |
||||
if {$sub in $exclusions} { |
||||
append out %U$hex ;#put it back |
||||
} else { |
||||
append out $sub |
||||
} |
||||
set lastidx $e |
||||
} |
||||
if {$e < [tcl::string::length $str]-1} { |
||||
append out [string range $str $e+1 end] |
||||
} |
||||
return $out |
||||
} |
||||
proc link_as {name target} { |
||||
|
||||
} |
||||
|
||||
#proc sample1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of sample1 |
||||
# return "ok" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval fauxlink::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval fauxlink::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace fauxlink::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide fauxlink [namespace eval fauxlink { |
||||
variable pkg fauxlink |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,325 +0,0 @@
|
||||
package provide funcl [namespace eval funcl { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
#funcl = function list (nested call structure) |
||||
# |
||||
#a basic functional composition o combinator |
||||
#o(f,g)(x) == f(g(x)) |
||||
|
||||
namespace eval funcl { |
||||
|
||||
#from punk::pipe |
||||
proc arg_is_script_shaped {arg} { |
||||
if {[string first " " $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[string first \n $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[string first ";" $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[string first \t $arg] >= 0} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
|
||||
proc o args { |
||||
set closing [string repeat {]} [expr [llength $args]-1]] |
||||
set body "[join $args { [}] \$data $closing" |
||||
return $body |
||||
} |
||||
|
||||
proc o_ args { |
||||
set body "" |
||||
set tails [lrepeat [llength $args] ""] |
||||
puts stdout "tails: $tails" |
||||
|
||||
set end [lindex $args end] |
||||
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||
set endfunc [string map "<end> $end" {uplevel 1 [list if 1 <end> ]}] |
||||
} else { |
||||
set endfunc $end |
||||
} |
||||
if {[llength $args] == 1} { |
||||
return $endfunc |
||||
} |
||||
|
||||
set wrap { [} |
||||
append wrap $endfunc |
||||
append wrap { ]} |
||||
|
||||
set i 0 |
||||
foreach cmdlist [lrange $args 0 end-1] { |
||||
set is_script 0 |
||||
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||
set is_script 1 |
||||
set script [lindex $cmdlist 0] |
||||
} |
||||
set t "" |
||||
if {$i > 0} { |
||||
append body { [} |
||||
} |
||||
set posn [lsearch $cmdlist _] |
||||
if {$posn <= 0} { |
||||
append body $cmdlist |
||||
if {$i == ([llength $args]-2)} { |
||||
append body " $wrap" |
||||
} |
||||
#if {$i == [expr {[llength $args] -2}]} { |
||||
# #append body " \$data" |
||||
# append body " $wrap" |
||||
#} |
||||
if {$i > 0} { |
||||
set t {]} |
||||
} |
||||
} else { |
||||
append body [lrange $cmdlist 0 $posn-1] |
||||
if {$i == ([llength $args] -2)} { |
||||
#append body " \$data" |
||||
append body " $wrap" |
||||
} |
||||
set t [lrange $cmdlist $posn+1 end] |
||||
if {$i > 0} { |
||||
append t { ]} |
||||
} |
||||
} |
||||
lset tails $i $t |
||||
incr i |
||||
} |
||||
append body [join [lreverse $tails] " "] |
||||
puts stdout "tails: $tails" |
||||
|
||||
return $body |
||||
} |
||||
|
||||
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
||||
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
||||
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
||||
# what type indicates running subtrees in parallel vs sequentially? |
||||
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
||||
# |
||||
# |
||||
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
||||
# also accept/return a call - return empty list if passed a call |
||||
proc next_funcl {funcl_or_tree} { |
||||
if {[lindex $funcl_or_tree 0] eq "_call"} { |
||||
return [list] |
||||
} |
||||
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
||||
set funcl $funcl_or_tree |
||||
} else { |
||||
error "funcltree not implemented" |
||||
} |
||||
|
||||
|
||||
set count [lindex $funcl 1] |
||||
if {$count == 0} { |
||||
#null funcl.. what is it? metadata/placeholder? |
||||
return $funcl |
||||
} |
||||
set indices [lrange $funcl 2 [expr {1 + $count}]] |
||||
set i 0 |
||||
foreach idx $indices { |
||||
if {$i > 0} { |
||||
#todo - return a funcltree |
||||
error "multi funcl not implemented" |
||||
} |
||||
set next [lindex $funcl $idx] |
||||
incr i |
||||
} |
||||
|
||||
return $next |
||||
|
||||
} |
||||
|
||||
#convert a funcl to a tcl script |
||||
proc funcl_script {funcl} { |
||||
if {![llength $funcl]} { |
||||
return "" |
||||
} |
||||
set body "" |
||||
set tails [list] |
||||
|
||||
set type [lindex $funcl 0] |
||||
if {$type ni [list "_fn" "_call"]} { |
||||
#todo - handle funcltree |
||||
error "type $type not implemented" |
||||
} |
||||
|
||||
|
||||
#only count of 1 with index 3 supported(?) |
||||
if {$type eq "_call"} { |
||||
#leaf |
||||
set cmdlist [lindex $funcl 3] |
||||
return $cmdlist |
||||
} |
||||
|
||||
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
||||
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
||||
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
||||
# ie multiple tail parts |
||||
set count [lindex $funcl 1] |
||||
|
||||
if {$count == 1} { |
||||
set idx [lindex $funcl 2] |
||||
if {$idx == 3} { |
||||
set cmdlist_pre [list] |
||||
} else { |
||||
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||
} |
||||
append body $cmdlist_pre |
||||
set t [lrange $funcl $idx+1 end] |
||||
lappend tails $t |
||||
} else { |
||||
#?? |
||||
error "funcl_script branching not yet supported" |
||||
} |
||||
|
||||
|
||||
set get_next 1 |
||||
set i 1 |
||||
while {$get_next} { |
||||
set funcl [next_funcl $funcl] |
||||
if {![llength $funcl]} { |
||||
set get_next 0 |
||||
} |
||||
lassign $funcl type count idx ;#todo support count > 1 |
||||
if {$type eq "_call"} { |
||||
set get_next 0 |
||||
} |
||||
set t "" |
||||
if {$type eq "_call"} { |
||||
append body { [} |
||||
append body [lindex $funcl $idx] |
||||
append body { ]} |
||||
} else { |
||||
append body { [} |
||||
if {$idx == 3} { |
||||
set cmdlist_pre [list] |
||||
} else { |
||||
set cmdlist_pre [lrange $funcl 3 $idx-1] |
||||
} |
||||
append body $cmdlist_pre |
||||
set t [lrange $funcl $idx+1 end] |
||||
lappend tails $t |
||||
lappend tails { ]} |
||||
} |
||||
incr i |
||||
} |
||||
append body [join [lreverse $tails] " "] |
||||
#puts stdout "tails: $tails" |
||||
|
||||
return $body |
||||
} |
||||
|
||||
|
||||
interp alias "" o_of "" funcl::o_of_n 1 |
||||
|
||||
#o_of_n |
||||
#tcl list rep o combinator |
||||
# |
||||
# can take lists of ordinary commandlists, scripts and funcls |
||||
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
||||
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
||||
# |
||||
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
||||
#last n args are passed to the prior function |
||||
#e.g for n=1 f a b = f(a(b)) |
||||
#e.g for n=2, e f a b = e(f(a b)) |
||||
proc o_of_n {n args} { |
||||
puts stdout "o_of_n '$args'" |
||||
if {$n != 1} { |
||||
error "o_of_n only implemented for 1 sub-funcl" |
||||
} |
||||
set comp [list] ;#composition list |
||||
set end [lindex $args end] |
||||
if {[lindex $end 0] in {_fn _call}]} { |
||||
#is_funcl |
||||
set endfunc [lindex $args end] |
||||
} else { |
||||
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
||||
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
||||
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
||||
} else { |
||||
set endfunc [list _call 1 3 [list {*}$end]] |
||||
} |
||||
} |
||||
|
||||
if {[llength $args] == 1} { |
||||
return $endfunc |
||||
} |
||||
set comp $endfunc |
||||
set revlist [lreverse [lrange $args 0 end-1]] |
||||
foreach cmdlist $revlist { |
||||
puts stderr "o_of_n >>-- $cmdlist" |
||||
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
||||
set is_script 1 |
||||
set script [lindex $cmdlist 0] |
||||
set arglist [list data] |
||||
|
||||
set comp [list _fn 1 6 call_script $script $arglist $comp] |
||||
} else { |
||||
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
||||
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
||||
} |
||||
} |
||||
return $comp |
||||
} |
||||
proc call_script {script argnames args} { |
||||
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
||||
} |
||||
proc funcl_script_test {scr} { |
||||
do_funcl_script_test $scr |
||||
} |
||||
proc do_funcl_script_test {scr} { |
||||
#set j "in do_funcl_script_test" |
||||
#set data "xxx" |
||||
#puts '$scr' |
||||
if 1 $scr |
||||
} |
||||
|
||||
#standard o_ with no script-handling |
||||
proc o_plain args { |
||||
set body "" |
||||
set i 0 |
||||
set tails [lrepeat [llength $args] ""] |
||||
#puts stdout "tails: $tails" |
||||
foreach cmdlist $args { |
||||
set t "" |
||||
if {$i > 0} { |
||||
append body { [} |
||||
} |
||||
set posn [lsearch $cmdlist _] |
||||
if {$posn <= 0} { |
||||
append body $cmdlist |
||||
if {$i == ([llength $args] -1)} { |
||||
append body " \$data" |
||||
} |
||||
if {$i > 0} { |
||||
set t {]} |
||||
} |
||||
} else { |
||||
append body [lrange $cmdlist 0 $posn-1] |
||||
if {$i == ([llength $args] -1)} { |
||||
append body " \$data" |
||||
} |
||||
set t [lrange $cmdlist $posn+1 end] |
||||
if {$i > 0} { |
||||
append t { ]} |
||||
} |
||||
} |
||||
lset tails $i $t |
||||
incr i |
||||
} |
||||
append body [join [lreverse $tails] " "] |
||||
#puts stdout "tails: $tails" |
||||
|
||||
return $body |
||||
} |
||||
#timings suggest no faster to split out the first item from the cmdlist loop |
||||
} |
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,739 +0,0 @@
|
||||
# md5.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" |
||||
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" |
||||
# |
||||
# This is an implementation of MD5 based upon the example code given in |
||||
# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas |
||||
# from the earlier tcllib md5 version by Don Libes. |
||||
# |
||||
# This implementation permits incremental updating of the hash and |
||||
# provides support for external compiled implementations either using |
||||
# critcl (md5c) or Trf. |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.2-; # tcl minimum version |
||||
|
||||
namespace eval ::md5 { |
||||
variable accel |
||||
array set accel {critcl 0 cryptkit 0 trf 0} |
||||
|
||||
namespace export md5 hmac MD5Init MD5Update MD5Final |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 0 |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# MD5Init -- |
||||
# |
||||
# Create and initialize an MD5 state variable. This will be |
||||
# cleaned up when we call MD5Final |
||||
# |
||||
proc ::md5::MD5Init {} { |
||||
variable accel |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
|
||||
# RFC1321:3.3 - Initialize MD5 state structure |
||||
array set state \ |
||||
[list \ |
||||
A [expr {0x67452301}] \ |
||||
B [expr {0xefcdab89}] \ |
||||
C [expr {0x98badcfe}] \ |
||||
D [expr {0x10325476}] \ |
||||
n 0 i "" ] |
||||
if {$accel(cryptkit)} { |
||||
cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5 |
||||
} elseif {$accel(trf)} { |
||||
set s {} |
||||
switch -exact -- $::tcl_platform(platform) { |
||||
windows { set s [open NUL w] } |
||||
unix { set s [open /dev/null w] } |
||||
} |
||||
if {$s != {}} { |
||||
fconfigure $s -translation binary -buffering none |
||||
::md5 -attach $s -mode write \ |
||||
-read-type variable \ |
||||
-read-destination [subst $token](trfread) \ |
||||
-write-type variable \ |
||||
-write-destination [subst $token](trfwrite) |
||||
array set state [list trfread 0 trfwrite 0 trf $s] |
||||
} |
||||
} |
||||
return $token |
||||
} |
||||
|
||||
# MD5Update -- |
||||
# |
||||
# This is called to add more data into the hash. You may call this |
||||
# as many times as you require. Note that passing in "ABC" is equivalent |
||||
# to passing these letters in as separate calls -- hence this proc |
||||
# permits hashing of chunked data |
||||
# |
||||
# If we have a C-based implementation available, then we will use |
||||
# it here in preference to the pure-Tcl implementation. |
||||
# |
||||
proc ::md5::MD5Update {token data} { |
||||
variable accel |
||||
upvar #0 $token state |
||||
|
||||
if {$accel(critcl)} { |
||||
if {[info exists state(md5c)]} { |
||||
set state(md5c) [md5c $data $state(md5c)] |
||||
} else { |
||||
set state(md5c) [md5c $data] |
||||
} |
||||
return |
||||
} elseif {[info exists state(ckctx)]} { |
||||
if {[string length $data] > 0} { |
||||
cryptkit::cryptEncrypt $state(ckctx) $data |
||||
} |
||||
return |
||||
} elseif {[info exists state(trf)]} { |
||||
puts -nonewline $state(trf) $data |
||||
return |
||||
} |
||||
|
||||
# Update the state values |
||||
incr state(n) [string length $data] |
||||
append state(i) $data |
||||
|
||||
# Calculate the hash for any complete blocks |
||||
set len [string length $state(i)] |
||||
for {set n 0} {($n + 64) <= $len} {} { |
||||
MD5Hash $token [string range $state(i) $n [incr n 64]] |
||||
} |
||||
|
||||
# Adjust the state for the blocks completed. |
||||
set state(i) [string range $state(i) $n end] |
||||
return |
||||
} |
||||
|
||||
# MD5Final -- |
||||
# |
||||
# This procedure is used to close the current hash and returns the |
||||
# hash data. Once this procedure has been called the hash context |
||||
# is freed and cannot be used again. |
||||
# |
||||
# Note that the output is 128 bits represented as binary data. |
||||
# |
||||
proc ::md5::MD5Final {token} { |
||||
upvar #0 $token state |
||||
|
||||
# Check for either of the C-compiled versions. |
||||
if {[info exists state(md5c)]} { |
||||
set r $state(md5c) |
||||
unset state |
||||
return $r |
||||
} elseif {[info exists state(ckctx)]} { |
||||
cryptkit::cryptEncrypt $state(ckctx) "" |
||||
cryptkit::cryptGetAttributeString $state(ckctx) \ |
||||
CRYPT_CTXINFO_HASHVALUE r 16 |
||||
cryptkit::cryptDestroyContext $state(ckctx) |
||||
# If nothing was hashed, we get no r variable set! |
||||
if {[info exists r]} { |
||||
unset state |
||||
return $r |
||||
} |
||||
} elseif {[info exists state(trf)]} { |
||||
close $state(trf) |
||||
set r $state(trfwrite) |
||||
unset state |
||||
return $r |
||||
} |
||||
|
||||
# RFC1321:3.1 - Padding |
||||
# |
||||
set len [string length $state(i)] |
||||
set pad [expr {56 - ($len % 64)}] |
||||
if {$len % 64 > 56} { |
||||
incr pad 64 |
||||
} |
||||
if {$pad == 0} { |
||||
incr pad 64 |
||||
} |
||||
|
||||
#puts "P $pad|bits=[expr {8 * $state(n)}]" |
||||
|
||||
append state(i) [binary format a$pad \x80] |
||||
|
||||
# RFC1321:3.2 - Append length in bits as little-endian wide int. |
||||
append state(i) [binary format ii [expr {8 * $state(n)}] 0] |
||||
|
||||
#puts DATA=[Hex $state(i)]([string length $state(i)]) |
||||
|
||||
# Calculate the hash for the remaining block. |
||||
set len [string length $state(i)] |
||||
for {set n 0} {($n + 64) <= $len} {} { |
||||
MD5Hash $token [string range $state(i) $n [incr n 64]] |
||||
} |
||||
|
||||
#puts md5-post__________________________________________ |
||||
#parray ::${token} |
||||
|
||||
# RFC1321:3.5 - Output |
||||
set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)] |
||||
unset state |
||||
|
||||
#puts HASH=[Hex $r] |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# HMAC Hashed Message Authentication (RFC 2104) |
||||
# |
||||
# hmac = H(K xor opad, H(K xor ipad, text)) |
||||
# |
||||
|
||||
# HMACInit -- |
||||
# |
||||
# This is equivalent to the MD5Init procedure except that a key is |
||||
# added into the algorithm |
||||
# |
||||
proc ::md5::HMACInit {K} { |
||||
|
||||
# Key K is adjusted to be 64 bytes long. If K is larger, then use |
||||
# the MD5 digest of K and pad this instead. |
||||
set len [string length $K] |
||||
if {$len > 64} { |
||||
set tok [MD5Init] |
||||
MD5Update $tok $K |
||||
set K [MD5Final $tok] |
||||
set len [string length $K] |
||||
} |
||||
set pad [expr {64 - $len}] |
||||
append K [string repeat \0 $pad] |
||||
|
||||
# Cacluate the padding buffers. |
||||
set Ki {} |
||||
set Ko {} |
||||
binary scan $K i16 Ks |
||||
foreach k $Ks { |
||||
append Ki [binary format i [expr {$k ^ 0x36363636}]] |
||||
append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] |
||||
} |
||||
|
||||
set tok [MD5Init] |
||||
MD5Update $tok $Ki; # initialize with the inner pad |
||||
|
||||
# preserve the Ko value for the final stage. |
||||
# FRINK: nocheck |
||||
set [subst $tok](Ko) $Ko |
||||
|
||||
return $tok |
||||
} |
||||
|
||||
# HMACUpdate -- |
||||
# |
||||
# Identical to calling MD5Update |
||||
# |
||||
proc ::md5::HMACUpdate {token data} { |
||||
MD5Update $token $data |
||||
return |
||||
} |
||||
|
||||
# HMACFinal -- |
||||
# |
||||
# This is equivalent to the MD5Final procedure. The hash context is |
||||
# closed and the binary representation of the hash result is returned. |
||||
# |
||||
proc ::md5::HMACFinal {token} { |
||||
upvar #0 $token state |
||||
|
||||
set tok [MD5Init]; # init the outer hashing function |
||||
MD5Update $tok $state(Ko); # prepare with the outer pad. |
||||
MD5Update $tok [MD5Final $token]; # hash the inner result |
||||
return [MD5Final $tok] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Description: |
||||
# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but |
||||
# includes an extra round and a set of constant modifiers throughout. |
||||
# |
||||
# Note: |
||||
# This function body is substituted later on to inline some of the |
||||
# procedures and to make is a bit more comprehensible. |
||||
# |
||||
set ::md5::MD5Hash_body { |
||||
variable $token |
||||
upvar 0 $token state |
||||
|
||||
#puts TR__=[Hex $msg]([string length $msg]) |
||||
|
||||
# RFC1321:3.4 - Process Message in 16-Word Blocks |
||||
binary scan $msg i* blocks |
||||
foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks { |
||||
#puts BL |
||||
|
||||
set A $state(A) |
||||
set B $state(B) |
||||
set C $state(C) |
||||
set D $state(D) |
||||
|
||||
# Round 1 |
||||
# Let [abcd k s i] denote the operation |
||||
# a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). |
||||
# Do the following 16 operations. |
||||
# [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] |
||||
set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}] |
||||
set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}] |
||||
set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}] |
||||
set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}] |
||||
# [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] |
||||
set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}] |
||||
set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}] |
||||
set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}] |
||||
set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}] |
||||
# [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] |
||||
set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}] |
||||
set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}] |
||||
set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}] |
||||
set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}] |
||||
# [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] |
||||
set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}] |
||||
set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}] |
||||
set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}] |
||||
set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}] |
||||
|
||||
# Round 2. |
||||
# Let [abcd k s i] denote the operation |
||||
# a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s) |
||||
# Do the following 16 operations. |
||||
# [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] |
||||
set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}] |
||||
set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}] |
||||
set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}] |
||||
set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}] |
||||
# [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] |
||||
set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}] |
||||
set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}] |
||||
set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}] |
||||
set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}] |
||||
# [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] |
||||
set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}] |
||||
set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}] |
||||
set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}] |
||||
set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}] |
||||
# [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] |
||||
set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}] |
||||
set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}] |
||||
set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}] |
||||
set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}] |
||||
|
||||
# Round 3. |
||||
# Let [abcd k s i] denote the operation |
||||
# a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s) |
||||
# Do the following 16 operations. |
||||
# [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] |
||||
set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}] |
||||
set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}] |
||||
set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}] |
||||
set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}] |
||||
# [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] |
||||
set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}] |
||||
set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}] |
||||
set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}] |
||||
set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}] |
||||
# [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] |
||||
set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}] |
||||
set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}] |
||||
set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}] |
||||
set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}] |
||||
# [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] |
||||
set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}] |
||||
set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}] |
||||
set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}] |
||||
set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}] |
||||
|
||||
# Round 4. |
||||
# Let [abcd k s i] denote the operation |
||||
# a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s) |
||||
# Do the following 16 operations. |
||||
# [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] |
||||
set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}] |
||||
set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}] |
||||
set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}] |
||||
set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}] |
||||
# [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] |
||||
set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}] |
||||
set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}] |
||||
set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}] |
||||
set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}] |
||||
# [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] |
||||
set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}] |
||||
set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}] |
||||
set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}] |
||||
set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}] |
||||
# [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] |
||||
set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}] |
||||
set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}] |
||||
set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}] |
||||
set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}] |
||||
|
||||
# Then perform the following additions. (That is, increment each |
||||
# of the four registers by the value it had before this block |
||||
# was started.) |
||||
incr state(A) $A |
||||
incr state(B) $B |
||||
incr state(C) $C |
||||
incr state(D) $D |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} |
||||
proc ::md5::bytes {v} { |
||||
#format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] |
||||
format %c%c%c%c \ |
||||
[expr {0xFF & $v}] \ |
||||
[expr {(0xFF00 & $v) >> 8}] \ |
||||
[expr {(0xFF0000 & $v) >> 16}] \ |
||||
[expr {((0xFF000000 & $v) >> 24) & 0xFF}] |
||||
} |
||||
|
||||
# 32bit rotate-left |
||||
proc ::md5::<<< {v n} { |
||||
return [expr {((($v << $n) \ |
||||
| (($v >> (32 - $n)) \ |
||||
& (0x7FFFFFFF >> (31 - $n))))) \ |
||||
& 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# Convert our <<< pseudo-operator into a procedure call. |
||||
regsub -all -line \ |
||||
{\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \ |
||||
$::md5::MD5Hash_body \ |
||||
{[expr {int(\1 + [<<< [expr {\2}] \3])}]} \ |
||||
::md5::MD5Hash_body |
||||
|
||||
# RFC1321:3.4 - function F |
||||
proc ::md5::F {X Y Z} { |
||||
return [expr {($X & $Y) | ((~$X) & $Z)}] |
||||
} |
||||
|
||||
# Inline the F function |
||||
regsub -all -line \ |
||||
{\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||
$::md5::MD5Hash_body \ |
||||
{( (\1 \& \2) | ((~\1) \& \3) )} \ |
||||
::md5::MD5Hash_body |
||||
|
||||
# RFC1321:3.4 - function G |
||||
proc ::md5::G {X Y Z} { |
||||
return [expr {(($X & $Z) | ($Y & (~$Z)))}] |
||||
} |
||||
|
||||
# Inline the G function |
||||
regsub -all -line \ |
||||
{\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||
$::md5::MD5Hash_body \ |
||||
{(((\1 \& \3) | (\2 \& (~\3))))} \ |
||||
::md5::MD5Hash_body |
||||
|
||||
# RFC1321:3.4 - function H |
||||
proc ::md5::H {X Y Z} { |
||||
return [expr {$X ^ $Y ^ $Z}] |
||||
} |
||||
|
||||
# Inline the H function |
||||
regsub -all -line \ |
||||
{\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||
$::md5::MD5Hash_body \ |
||||
{(\1 ^ \2 ^ \3)} \ |
||||
::md5::MD5Hash_body |
||||
|
||||
# RFC1321:3.4 - function I |
||||
proc ::md5::I {X Y Z} { |
||||
return [expr {$Y ^ ($X | (~$Z))}] |
||||
} |
||||
|
||||
# Inline the I function |
||||
regsub -all -line \ |
||||
{\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||
$::md5::MD5Hash_body \ |
||||
{(\2 ^ (\1 | (~\3)))} \ |
||||
::md5::MD5Hash_body |
||||
|
||||
|
||||
# RFC 1321:3.4 step 4: inline the set of constant modifiers. |
||||
namespace eval md5 { |
||||
variable tName |
||||
variable tVal |
||||
variable map |
||||
foreach tName { |
||||
T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 |
||||
T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 |
||||
T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 |
||||
T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 |
||||
T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 |
||||
T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 |
||||
T61 T62 T63 T64 |
||||
} tVal { |
||||
0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee |
||||
0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 |
||||
0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be |
||||
0x6b901122 0xfd987193 0xa679438e 0x49b40821 |
||||
|
||||
0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa |
||||
0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 |
||||
0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed |
||||
0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a |
||||
|
||||
0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c |
||||
0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 |
||||
0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 |
||||
0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 |
||||
|
||||
0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 |
||||
0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 |
||||
0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 |
||||
0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 |
||||
} { |
||||
lappend map \$$tName $tVal |
||||
} |
||||
set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body] |
||||
unset map tName tVal |
||||
} |
||||
|
||||
# Define the MD5 hashing procedure with inline functions. |
||||
proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body |
||||
unset ::md5::MD5Hash_body |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
if {[package provide Trf] != {}} { |
||||
interp alias {} ::md5::Hex {} ::hex -mode encode -- |
||||
} else { |
||||
proc ::md5::Hex {data} { |
||||
binary scan $data H* result |
||||
return [string toupper $result] |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::md5::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}] |
||||
|| ![catch {package require md5c}]} { |
||||
set r [expr {[info commands ::md5::md5c] != {}}] |
||||
} |
||||
} |
||||
cryptkit { |
||||
if {![catch {package require cryptkit}]} { |
||||
set r [expr {![catch {cryptkit::cryptInit}]}] |
||||
} |
||||
} |
||||
trf { |
||||
if {![catch {package require Trf}]} { |
||||
set r [expr {![catch {::md5 aa} msg]}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Description: |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::md5::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# fileevent handler for chunked file hashing. |
||||
# |
||||
proc ::md5::Chunk {token channel {chunksize 4096}} { |
||||
upvar #0 $token state |
||||
|
||||
if {[eof $channel]} { |
||||
fileevent $channel readable {} |
||||
set state(reading) 0 |
||||
} |
||||
|
||||
MD5Update $token [read $channel $chunksize] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::md5::md5 {args} { |
||||
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-hex { set opts(-hex) 1 } |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-channel { set opts(-channel) [Pop args 1] } |
||||
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args; break } |
||||
set err [join [lsort [array names opts]] ", "] |
||||
return -code error "bad option $option:\ |
||||
must be one of $err\nlen: [llength $args]" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args:\ |
||||
should be \"md5 ?-hex? -filename file | string\"" |
||||
} |
||||
set tok [MD5Init] |
||||
|
||||
#puts md5_______________________________________________ |
||||
#parray ::${tok} |
||||
|
||||
#puts IN=(([lindex $args 0])) |
||||
MD5Update $tok [lindex $args 0] |
||||
|
||||
#puts md5-final_________________________________________ |
||||
#parray ::${tok} |
||||
|
||||
set r [MD5Final $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [MD5Init] |
||||
# FRINK: nocheck |
||||
set [subst $tok](reading) 1 |
||||
fileevent $opts(-channel) readable \ |
||||
[list [namespace origin Chunk] \ |
||||
$tok $opts(-channel) $opts(-chunksize)] |
||||
vwait [subst $tok](reading) |
||||
set r [MD5Final $tok] |
||||
|
||||
# If we opened the channel - we should close it too. |
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
if {$opts(-hex)} { |
||||
set r [Hex $r] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::md5::hmac {args} { |
||||
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-key { set opts(-key) [Pop args 1] } |
||||
-hex { set opts(-hex) 1 } |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-channel { set opts(-channel) [Pop args 1] } |
||||
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args; break } |
||||
set err [join [lsort [array names opts]] ", "] |
||||
return -code error "bad option $option:\ |
||||
must be one of $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {![info exists opts(-key)]} { |
||||
return -code error "wrong # args:\ |
||||
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args:\ |
||||
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||
} |
||||
set tok [HMACInit $opts(-key)] |
||||
HMACUpdate $tok [lindex $args 0] |
||||
set r [HMACFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [HMACInit $opts(-key)] |
||||
# FRINK: nocheck |
||||
set [subst $tok](reading) 1 |
||||
fileevent $opts(-channel) readable \ |
||||
[list [namespace origin Chunk] \ |
||||
$tok $opts(-channel) $opts(-chunksize)] |
||||
vwait [subst $tok](reading) |
||||
set r [HMACFinal $tok] |
||||
|
||||
# If we opened the channel - we should close it too. |
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
if {$opts(-hex)} { |
||||
set r [Hex $r] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::md5 { |
||||
variable e |
||||
foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } } |
||||
unset e |
||||
} |
||||
|
||||
package provide md5 2.0.8 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,709 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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 modpod 0.1.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require modpod] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of modpod |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by modpod |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require struct::set ;#review |
||||
package require punk::lib |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::class}] |
||||
#[para] class definitions |
||||
if {[info commands [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 |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
|
||||
variable connected |
||||
if {![info exists connected(to)]} { |
||||
set connected(to) list |
||||
} |
||||
variable modpodscript |
||||
set modpodscript [info script] |
||||
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||
set connected(self) [file dirname $modpodscript] |
||||
} else { |
||||
#expecting a .tm |
||||
set connected(self) $modpodscript |
||||
} |
||||
variable loadables [info sharedlibextension] |
||||
variable sourceables {.tcl .tk} ;# .tm ? |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace modpod}] |
||||
#[para] Core API functions for modpod |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of sample1 |
||||
# return "ok" |
||||
#} |
||||
|
||||
#old tar connect mechanism - review - not needed? |
||||
proc connect {args} { |
||||
puts stderr "modpod::connect--->>$args" |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::connect |
||||
-type -default "" |
||||
@values -min 1 -max 1 |
||||
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||
}] |
||||
catch { |
||||
punk::lib::showdict $argd ;#heavy dependencies |
||||
} |
||||
set opt_path [dict get $argd values path] |
||||
variable connected |
||||
set original_connectpath $opt_path |
||||
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||
|
||||
if {$modpodpath in $connected(to)} { |
||||
return [dict create ok ALREADY_CONNECTED] |
||||
} |
||||
lappend connected(to) $modpodpath |
||||
|
||||
set connected(connectpath,$opt_path) $original_connectpath |
||||
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||
|
||||
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||
set connected(startdata,$modpodpath) -1 |
||||
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||
set connected(fh,$modpodpath) "" |
||||
|
||||
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||
set connected(type,$modpodpath) "unwrapped" |
||||
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||
|
||||
} else { |
||||
#connect to .tm but may still be unwrapped version available |
||||
lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||
set this_pkg_tm_folder [file dirname $modpodpath] |
||||
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||
#Not directly connected to unwrapped version - but may still be redirected there |
||||
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||
if {[file exists $unwrappedFolder]} { |
||||
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||
set con(type,$modpodpath) "modpod-redirecting" |
||||
} |
||||
} |
||||
|
||||
} |
||||
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||
set connected(tmfile,$modpodpath) |
||||
set tail_segments [list] |
||||
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||
} else { |
||||
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||
} |
||||
|
||||
switch -exact -- $connected(type,$modpodpath) { |
||||
"modpod-redirecting" { |
||||
#redirect to the unwrapped version |
||||
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||
|
||||
} |
||||
"unwrapped" { |
||||
if {[info commands ::thread::id] ne ""} { |
||||
set from [pid],[thread::id] |
||||
} else { |
||||
set from [pid] |
||||
} |
||||
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||
return [list ok ""] |
||||
} |
||||
default { |
||||
#autodetect .tm - zip/tar ? |
||||
#todo - use vfs ? |
||||
|
||||
#connect to tarball - start at 1st header |
||||
set connected(startdata,$modpodpath) 0 |
||||
set fh [open $modpodpath r] |
||||
set connected(fh,$modpodpath) $fh |
||||
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||
|
||||
if {$connected(startdata,$modpodpath) >= 0} { |
||||
#verify we have a valid tar header |
||||
if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} { |
||||
seek $fh $connected(startdata,$modpodpath) start |
||||
return [list ok $fh] |
||||
} else { |
||||
#error "cannot verify tar header" |
||||
#try zipfs |
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
|
||||
} |
||||
} |
||||
} |
||||
lpop connected(to) end |
||||
set connected(startdata,$modpodpath) -1 |
||||
unset connected(fh,$modpodpath) |
||||
catch {close $fh} |
||||
return [dict create err {Does not appear to be a valid modpod}] |
||||
} |
||||
} |
||||
} |
||||
proc disconnect {{modpod ""}} { |
||||
variable connected |
||||
if {![llength $connected(to)]} { |
||||
return 0 |
||||
} |
||||
if {$modpod eq ""} { |
||||
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||
set modpod [lindex $connected(to) end] |
||||
} |
||||
|
||||
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||
return 0 |
||||
} |
||||
if {[string length $connected(fh,$modpod)]} { |
||||
close $connected(fh,$modpod) |
||||
} |
||||
array unset connected *,$modpod |
||||
set connected(to) [lreplace $connected(to) $posn $posn] |
||||
return 1 |
||||
} |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::get |
||||
-from -default "" -help "path to pod" |
||||
@values -min 1 -max 1 |
||||
filename |
||||
}] |
||||
set frompod [dict get $argd opts -from] |
||||
set filename [dict get $argd values filename] |
||||
|
||||
variable connected |
||||
#//review |
||||
set modpod [::modpod::system::connect_if_not $frompod] |
||||
set fh $connected(fh,$modpod) |
||||
if {$connected(type,$modpod) eq "unwrapped"} { |
||||
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||
if {[string range $filename 0 0 eq "/"]} { |
||||
#absolute path (?) |
||||
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||
} else { |
||||
#relative path - use #modpod-xxx as base |
||||
set path [file join $connected(location,$modpod) $filename] |
||||
} |
||||
set fd [open $path r] |
||||
#utf-8? |
||||
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||
} else { |
||||
#read from vfs |
||||
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval modpod::lib { |
||||
namespace export {[a-z]*}; # Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::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 |
||||
#} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#zipfile is a pure zip at this point - ie no script/exe header |
||||
proc make_zip_modpod {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::modpod::lib::make_zip_modpod |
||||
-offsettype -default "archive" -choices {archive file} -help\ |
||||
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||
@values -min 2 -max 2 |
||||
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||
}] |
||||
set zipfile [dict get $argd values zipfile] |
||||
set outfile [dict get $argd values outfile] |
||||
set opt_offsettype [dict get $argd opts -offsettype] |
||||
|
||||
|
||||
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||
if {[catch {file normalize [info script]} modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||
} |
||||
if {$modfile eq "" || ![file exists $modfile]} { |
||||
error "modpod zip stub error. Unable to determine module path" |
||||
} |
||||
set moddir [file dirname $modfile] |
||||
set mod_and_ver [file rootname [file tail $modfile]] |
||||
lassign [split $mod_and_ver -] moduletail version |
||||
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
||||
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#determine module namespace so we can mount appropriately |
||||
proc intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
if {[llength $B] > [llength $A]} { |
||||
set res $A |
||||
set A $B |
||||
set B $res |
||||
} |
||||
set res {} |
||||
foreach x $A {set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||
foreach lc_mpath $lcase_modulepaths { |
||||
set mpath_segments [file split $lc_mpath] |
||||
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||
break |
||||
} |
||||
} |
||||
if {[llength $tail_segments]} { |
||||
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||
} else { |
||||
set fullpackage $moduletail |
||||
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||
} |
||||
|
||||
if {[info commands tcl::zipfs::mount] ne ""} { |
||||
#argument order changed to be consistent with vfs::zip::Mount etc |
||||
#early versions: zipfs::Mount mountpoint zipname |
||||
#since 2023-09: zipfs::Mount zipname mountpoint |
||||
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||
#This is presumably related to // being interpreted as a network path |
||||
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||
if {[catch { |
||||
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||
tcl::zipfs::mount $modfile $mount_at |
||||
} errM]} { |
||||
#try old api |
||||
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||
} |
||||
} |
||||
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} else { |
||||
#fallback to slower vfs::zip |
||||
#NB. We don't create the intermediate dirs - but the mount still works |
||||
if {![file exists $moddir/$mount_at]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||
error $msg |
||||
} else { |
||||
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $moddir/$mount_at |
||||
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||
} |
||||
} |
||||
} |
||||
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
} |
||||
#zipped data follows |
||||
}] |
||||
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||
|
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval modpod::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace modpod::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#deflate,store only supported |
||||
|
||||
#zipfile here is plain zip - no script/exe prefix part. |
||||
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||
set inzip [open $zipfile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set stuboffset [tell $out] |
||||
lappend report "stub size: $stuboffset" |
||||
fcopy $inzip $out |
||||
close $inzip |
||||
|
||||
set size [tell $out] |
||||
lappend report "modpod::system::make_mountable_zip" |
||||
lappend report "tmfile : [file tail $outfile]" |
||||
lappend report "output size : $size" |
||||
lappend report "offsettype : $offsettype" |
||||
|
||||
if {$offsettype eq "file"} { |
||||
#make zip offsets relative to start of whole file including prepended script. |
||||
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||
#not editable by 7z,nanazip,peazip |
||||
|
||||
#we aren't adding any new files/folders so we can edit the offsets in place |
||||
|
||||
#Now seek in $out to find the end of directory signature: |
||||
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||
if {$size < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$size - 65559}] |
||||
} |
||||
seek $out $tailsearch_start |
||||
set data [read $out] |
||||
#EOCD - End of Central Directory record |
||||
#PK\5\6 |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||
#set start_of_end [expr {$start_of_end + $seek}] |
||||
#incr start_of_end $seek |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
|
||||
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
lappend report "End of central directory: [array get eocd]" |
||||
seek $out [expr {$filerelative_eocd_posn+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||
flush $out |
||||
|
||||
seek $out $filerelative_eocd_posn |
||||
set end_of_ctrl_dir [read $out] |
||||
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
|
||||
# 0x06054b50 - end of central dir signature |
||||
puts stderr "$end_of_ctrl_dir" |
||||
puts stderr "comment_len: $eocd(comment_len)" |
||||
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||
lappend report "New dir offset: $eocd(diroffset)" |
||||
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||
} |
||||
|
||||
seek $out $eocd(diroffset) |
||||
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||
set current_file [tell $out] |
||||
set fileheader [read $out 46] |
||||
puts -------------- |
||||
puts [ansistring VIEW -lf 1 $fileheader] |
||||
puts -------------- |
||||
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
|
||||
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
set ::last_header $fileheader |
||||
|
||||
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||
puts "ver: $x(version)" |
||||
puts "method: $x(method)" |
||||
|
||||
#PK\1\2 |
||||
#33639248 dec = 0x02014b50 - central directory file header signature |
||||
if { $x(sig) != 33639248 } { |
||||
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||
} |
||||
|
||||
foreach size $x(lengths) var {filename extrafield comment} { |
||||
if { $size > 0 } { |
||||
set x($var) [read $out $size] |
||||
} else { |
||||
set x($var) "" |
||||
} |
||||
} |
||||
set next_file [tell $out] |
||||
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||
|
||||
seek $out [expr {$current_file+42}] |
||||
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $stuboffset" |
||||
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||
lappend report "new $x(offset)" |
||||
|
||||
seek $out $next_file |
||||
} |
||||
} |
||||
|
||||
close $out |
||||
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||
#don't fall over just because of that |
||||
catch { |
||||
punk::lib::showdict -roottype list -chan stderr $report |
||||
} |
||||
#puts [join $report \n] |
||||
return |
||||
} |
||||
|
||||
proc connect_if_not {{podpath ""}} { |
||||
upvar ::modpod::connected connected |
||||
set podpath [::modpod::system::normalize $podpath] |
||||
set docon 0 |
||||
if {![llength $connected(to)]} { |
||||
if {![string length $podpath]} { |
||||
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||
} else { |
||||
set docon 1 |
||||
} |
||||
} else { |
||||
if {![string length $podpath]} { |
||||
set podpath [lindex $connected(to) end] |
||||
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||
} else { |
||||
if {$podpath ni $connected(to)} { |
||||
set docon 1 |
||||
} |
||||
} |
||||
} |
||||
if {$docon} { |
||||
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||
} else { |
||||
return $podpath |
||||
} |
||||
} |
||||
#we were already connected |
||||
return $podpath |
||||
} |
||||
|
||||
proc myversion {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||
} |
||||
set fname [file tail [file rootname [file normalize $script]]] |
||||
set scriptdir [file dirname $script] |
||||
|
||||
if {![string match "#modpod-*" $fname]} { |
||||
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||
} else { |
||||
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||
if {![string length $version]} { |
||||
#try again on the name of the containing folder |
||||
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||
#todo - proper walk up the directory tree |
||||
if {![string length $version]} { |
||||
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||
} |
||||
} |
||||
} |
||||
|
||||
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||
return $version |
||||
} |
||||
|
||||
proc myname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||
} |
||||
return $connected(fullpackage,$script) |
||||
} |
||||
proc myfullname {} { |
||||
upvar ::modpod::connected connected |
||||
set script [info script] |
||||
#set script [::tarjar::normalize $script] |
||||
set script [file normalize $script] |
||||
if {![string length $script]} { |
||||
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||
} |
||||
return $::tarjar::connected(fullpackage,$script) |
||||
} |
||||
proc normalize {path} { |
||||
#newer versions of Tcl don't do tilde sub |
||||
|
||||
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||
set path [file normalize $path] |
||||
#set path [string tolower $path] ;#must do this after file normalize |
||||
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide modpod [namespace eval modpod { |
||||
variable pkg modpod |
||||
variable version |
||||
set version 0.1.3 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,201 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||
#method alias {newAlias existingKeyOrAlias} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,645 +0,0 @@
|
||||
package provide patterncmd [namespace eval patterncmd { |
||||
variable version |
||||
|
||||
set version 1.2.4 |
||||
}] |
||||
|
||||
|
||||
namespace eval pattern { |
||||
variable idCounter 1 ;#used by pattern::uniqueKey |
||||
|
||||
namespace eval cmd { |
||||
namespace eval util { |
||||
package require overtype |
||||
variable colwidths_lib [dict create] |
||||
variable colwidths_lib_default 15 |
||||
|
||||
dict set colwidths_lib "library" [list ch " " num 21 head "|" tail ""] |
||||
dict set colwidths_lib "version" [list ch " " num 7 head "|" tail ""] |
||||
dict set colwidths_lib "type" [list ch " " num 9 head "|" tail ""] |
||||
dict set colwidths_lib "note" [list ch " " num 31 head "|" tail "|"] |
||||
|
||||
proc colhead {type args} { |
||||
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||
set line "" |
||||
foreach colname [dict keys $colwidths] { |
||||
append line "[col $type $colname [string totitle $colname] {*}$args]" |
||||
} |
||||
return $line |
||||
} |
||||
proc colbreak {type} { |
||||
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||
set line "" |
||||
foreach colname [dict keys $colwidths] { |
||||
append line "[col $type $colname {} -backchar - -headoverridechar + -tailoverridechar +]" |
||||
} |
||||
return $line |
||||
} |
||||
proc col {type col val args} { |
||||
# args -head bool -tail bool ? |
||||
#---------------------------------------------------------------------------- |
||||
set known_opts [list -backchar -headchar -tailchar -headoverridechar -tailoverridechar -justify] |
||||
dict set default -backchar "" |
||||
dict set default -headchar "" |
||||
dict set default -tailchar "" |
||||
dict set default -headoverridechar "" |
||||
dict set default -tailoverridechar "" |
||||
dict set default -justify "left" |
||||
if {([llength $args] % 2) != 0} { |
||||
error "(pattern::cmd::util::col) ERROR: uneven options supplied - must be of form '-option value' " |
||||
} |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "((pattern::cmd::util::col) ERROR: option '$k' not in known options: '$known_opts'" |
||||
} |
||||
} |
||||
set opts [dict merge $default $args] |
||||
set backchar [dict get $opts -backchar] |
||||
set headchar [dict get $opts -headchar] |
||||
set tailchar [dict get $opts -tailchar] |
||||
set headoverridechar [dict get $opts -headoverridechar] |
||||
set tailoverridechar [dict get $opts -tailoverridechar] |
||||
set justify [dict get $opts -justify] |
||||
#---------------------------------------------------------------------------- |
||||
|
||||
|
||||
|
||||
upvar #0 ::pattern::cmd::util::colwidths_$type colwidths |
||||
#calculate headwidths |
||||
set headwidth 0 |
||||
set tailwidth 0 |
||||
foreach {key def} $colwidths { |
||||
set thisheadlen [string length [dict get $def head]] |
||||
if {$thisheadlen > $headwidth} { |
||||
set headwidth $thisheadlen |
||||
} |
||||
set thistaillen [string length [dict get $def tail]] |
||||
if {$thistaillen > $tailwidth} { |
||||
set tailwidth $thistaillen |
||||
} |
||||
} |
||||
|
||||
|
||||
set spec [dict get $colwidths $col] |
||||
if {[string length $backchar]} { |
||||
set ch $backchar |
||||
} else { |
||||
set ch [dict get $spec ch] |
||||
} |
||||
set num [dict get $spec num] |
||||
set headchar [dict get $spec head] |
||||
set tailchar [dict get $spec tail] |
||||
|
||||
if {[string length $headchar]} { |
||||
set headchar $headchar |
||||
} |
||||
if {[string length $tailchar]} { |
||||
set tailchar $tailchar |
||||
} |
||||
#overrides only apply if the head/tail has a length |
||||
if {[string length $headchar]} { |
||||
if {[string length $headoverridechar]} { |
||||
set headchar $headoverridechar |
||||
} |
||||
} |
||||
if {[string length $tailchar]} { |
||||
if {[string length $tailoverridechar]} { |
||||
set tailchar $tailoverridechar |
||||
} |
||||
} |
||||
set head [string repeat $headchar $headwidth] |
||||
set tail [string repeat $tailchar $tailwidth] |
||||
|
||||
set base [string repeat $ch [expr {$headwidth + $num + $tailwidth}]] |
||||
if {$justify eq "left"} { |
||||
set left_done [overtype::left $base "$head$val"] |
||||
return [overtype::right $left_done "$tail"] |
||||
} elseif {$justify in {centre center}} { |
||||
set mid_done [overtype::centre $base $val] |
||||
set left_mid_done [overtype::left $mid_done $head] |
||||
return [overtype::right $left_mid_done $tail] |
||||
} else { |
||||
set right_done [overtype::right $base "$val$tail"] |
||||
return [overtype::left $right_done $head] |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#package require pattern |
||||
|
||||
proc ::pattern::libs {} { |
||||
set libs [list \ |
||||
pattern {-type core -note "alternative:pattern2"}\ |
||||
pattern2 {-type core -note "alternative:pattern"}\ |
||||
patterncmd {-type core}\ |
||||
metaface {-type core}\ |
||||
patternpredator2 {-type core}\ |
||||
patterndispatcher {-type core}\ |
||||
patternlib {-type core}\ |
||||
patterncipher {-type optional -note optional}\ |
||||
] |
||||
|
||||
|
||||
|
||||
package require overtype |
||||
set result "" |
||||
|
||||
append result "[cmd::util::colbreak lib]\n" |
||||
append result "[cmd::util::colhead lib -justify centre]\n" |
||||
append result "[cmd::util::colbreak lib]\n" |
||||
foreach libname [dict keys $libs] { |
||||
set libinfo [dict get $libs $libname] |
||||
|
||||
append result [cmd::util::col lib library $libname] |
||||
if {[catch [list package present $libname] ver]} { |
||||
append result [cmd::util::col lib version "N/A"] |
||||
} else { |
||||
append result [cmd::util::col lib version $ver] |
||||
} |
||||
append result [cmd::util::col lib type [dict get $libinfo -type]] |
||||
|
||||
if {[dict exists $libinfo -note]} { |
||||
set note [dict get $libinfo -note] |
||||
} else { |
||||
set note "" |
||||
} |
||||
append result [cmd::util::col lib note $note] |
||||
append result "\n" |
||||
} |
||||
append result "[cmd::util::colbreak lib]\n" |
||||
return $result |
||||
} |
||||
|
||||
proc ::pattern::record {recname fields} { |
||||
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||
} |
||||
|
||||
set index -1 |
||||
set accessor [list ::apply { |
||||
{index rec args} |
||||
{ |
||||
if {[llength $args] == 0} { |
||||
return [lindex $rec $index] |
||||
} |
||||
if {[llength $args] == 1} { |
||||
return [lreplace $rec $index $index [lindex $args 0]] |
||||
} |
||||
error "Invalid number of arguments." |
||||
} |
||||
|
||||
}] |
||||
|
||||
set map {} |
||||
foreach field $fields { |
||||
dict set map $field [linsert $accessor end [incr index]] |
||||
} |
||||
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||
} |
||||
proc ::pattern::record2 {recname fields} { |
||||
if {[uplevel 1 [list namespace which $recname]] ne ""} { |
||||
error "(pattern::record) Can't create command '$recname': A command of that name already exists" |
||||
} |
||||
|
||||
set index -1 |
||||
set accessor [list ::apply] |
||||
|
||||
set template { |
||||
{rec args} |
||||
{ |
||||
if {[llength $args] == 0} { |
||||
return [lindex $rec %idx%] |
||||
} |
||||
if {[llength $args] == 1} { |
||||
return [lreplace $rec %idx% %idx% [lindex $args 0]] |
||||
} |
||||
error "Invalid number of arguments." |
||||
} |
||||
} |
||||
|
||||
set map {} |
||||
foreach field $fields { |
||||
set body [string map [list %idx% [incr index]] $template] |
||||
dict set map $field [list ::apply $body] |
||||
} |
||||
uplevel 1 [list namespace ensemble create -command $recname -map $map -parameters rec] |
||||
} |
||||
|
||||
proc ::argstest {args} { |
||||
package require cmdline |
||||
|
||||
} |
||||
|
||||
proc ::pattern::objects {} { |
||||
set result [::list] |
||||
|
||||
foreach ns [namespace children ::pp] { |
||||
#lappend result [::list [namespace tail $ns] [set ${ns}::(self)]] |
||||
set ch [namespace tail $ns] |
||||
if {[string range $ch 0 2] eq "Obj"} { |
||||
set OID [string range $ch 3 end] ;#OID need not be digits (!?) |
||||
lappend result [::list $OID [list OID $OID object_command [set pp::${ch}::v_object_command] usedby [array names ${ns}::_iface::o_usedby]]] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
|
||||
proc ::pattern::name {num} { |
||||
#!todo - fix |
||||
#set ::p::${num}::(self) |
||||
|
||||
lassign [interp alias {} ::p::$num] _predator info |
||||
if {![string length $_predator$info]} { |
||||
error "No object found for num:$num (no interp alias for ::p::$num)" |
||||
} |
||||
set invocants [dict get $info i] |
||||
set invocants_with_role_this [dict get $invocants this] |
||||
set invocant_this [lindex $invocants_with_role_this 0] |
||||
|
||||
|
||||
#lassign $invocant_this id info |
||||
#set map [dict get $info map] |
||||
#set fields [lindex $map 0] |
||||
lassign $invocant_this _id _ns _defaultmethod name _etc |
||||
return $name |
||||
} |
||||
|
||||
|
||||
proc ::pattern::with {cmd script} { |
||||
foreach c [info commands ::p::-1::*] { |
||||
interp alias {} [namespace tail $c] {} $c $cmd |
||||
} |
||||
interp alias {} . {} $cmd . |
||||
interp alias {} .. {} $cmd .. |
||||
|
||||
return [uplevel 1 $script] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#system diagnostics etc |
||||
|
||||
proc ::pattern::varspace_list {IID} { |
||||
namespace upvar ::p::${IID}::_iface o_varspace o_varspace o_variables o_variables |
||||
|
||||
set varspaces [list] |
||||
dict for {vname vdef} $o_variables { |
||||
set vs [dict get $vdef varspace] |
||||
if {$vs ni $varspaces} { |
||||
lappend varspaces $vs |
||||
} |
||||
} |
||||
if {$o_varspace ni $varspaces} { |
||||
lappend varspaces $o_varspace |
||||
} |
||||
return $varspaces |
||||
} |
||||
|
||||
proc ::pattern::check_interfaces {} { |
||||
foreach ns [namespace children ::p] { |
||||
set IID [namespace tail $ns] |
||||
if {[string is digit $IID]} { |
||||
foreach ref [array names ${ns}::_iface::o_usedby] { |
||||
set OID [string range $ref 1 end] |
||||
if {![namespace exists ::p::${OID}::_iface]} { |
||||
puts -nonewline stdout "\r\nPROBLEM!!!!!!!!! nonexistant/invalid object $OID referenced by Interface $IID\r\n" |
||||
} else { |
||||
puts -nonewline stdout . |
||||
} |
||||
|
||||
|
||||
#if {![info exists ::p::${OID}::(self)]} { |
||||
# puts "PROBLEM!!!!!!!!! nonexistant object $OID referenced by Interface $IID" |
||||
#} |
||||
} |
||||
} |
||||
} |
||||
puts -nonewline stdout "\r\n" |
||||
} |
||||
|
||||
|
||||
#from: http://wiki.tcl.tk/8766 (Introspection on aliases) |
||||
#usedby: metaface-1.1.6+ |
||||
#required because aliases can be renamed. |
||||
#A renamed alias will still return it's target with 'interp alias {} oldname' |
||||
# - so given newname - we require which_alias to return the same info. |
||||
proc ::pattern::which_alias {cmd} { |
||||
uplevel 1 [list ::trace add execution $cmd enterstep ::error] |
||||
catch {uplevel 1 $cmd} res |
||||
uplevel 1 [list ::trace remove execution $cmd enterstep ::error] |
||||
#puts stdout "which_alias $cmd returning '$res'" |
||||
return $res |
||||
} |
||||
# [info args] like proc following an alias recursivly until it reaches |
||||
# the proc it originates from or cannot determine it. |
||||
# accounts for default parameters set by interp alias |
||||
# |
||||
|
||||
|
||||
|
||||
proc ::pattern::aliasargs {cmd} { |
||||
set orig $cmd |
||||
|
||||
set defaultargs [list] |
||||
|
||||
# loop until error or return occurs |
||||
while {1} { |
||||
# is it a proc already? |
||||
if {[string equal [info procs $cmd] $cmd]} { |
||||
set result [info args $cmd] |
||||
# strip off the interp set default args |
||||
return [lrange $result [llength $defaultargs] end] |
||||
} |
||||
# is it a built in or extension command we can get no args for? |
||||
if {![string equal [info commands $cmd] $cmd]} { |
||||
error "\"$orig\" isn't a procedure" |
||||
} |
||||
|
||||
# catch bogus cmd names |
||||
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||
error "\"$orig\" isn't a procedure or alias or command" |
||||
} |
||||
#set cmd [lindex $alias 0] |
||||
if {[llength $alias]>1} { |
||||
set cmd [lindex $alias 0] |
||||
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||
} else { |
||||
set cmd $alias |
||||
} |
||||
} else { |
||||
|
||||
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||
# check if it is aliased in from another interpreter |
||||
if {[catch {interp target {} $cmd} msg]} { |
||||
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||
} |
||||
if {$msg != {} } { |
||||
error "Not recursing into slave interpreter \"$msg\".\ |
||||
\"$orig\" could not be resolved." |
||||
} |
||||
# check if defaults are set for the alias |
||||
if {[llength $cmdargs]>1} { |
||||
set cmd [lindex $cmdargs 0] |
||||
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||
} else { |
||||
set cmd $cmdargs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc ::pattern::aliasbody {cmd} { |
||||
set orig $cmd |
||||
|
||||
set defaultargs [list] |
||||
|
||||
# loop until error or return occurs |
||||
while {1} { |
||||
# is it a proc already? |
||||
if {[string equal [info procs $cmd] $cmd]} { |
||||
set result [info body $cmd] |
||||
# strip off the interp set default args |
||||
return $result |
||||
#return [lrange $result [llength $defaultargs] end] |
||||
} |
||||
# is it a built in or extension command we can get no args for? |
||||
if {![string equal [info commands $cmd] $cmd]} { |
||||
error "\"$orig\" isn't a procedure" |
||||
} |
||||
|
||||
# catch bogus cmd names |
||||
if {[lsearch [interp aliases {}] $cmd]==-1} { |
||||
if {[catch {::pattern::which_alias $cmd} alias]} { |
||||
error "\"$orig\" isn't a procedure or alias or command" |
||||
} |
||||
#set cmd [lindex $alias 0] |
||||
if {[llength $alias]>1} { |
||||
set cmd [lindex $alias 0] |
||||
set defaultargs [concat [lrange $alias 1 end] $defaultargs] |
||||
} else { |
||||
set cmd $alias |
||||
} |
||||
} else { |
||||
|
||||
if {[llength [set cmdargs [interp alias {} $cmd]]]>0} { |
||||
# check if it is aliased in from another interpreter |
||||
if {[catch {interp target {} $cmd} msg]} { |
||||
error "Cannot resolve \"$orig\", alias leads to another interpreter." |
||||
} |
||||
if {$msg != {} } { |
||||
error "Not recursing into slave interpreter \"$msg\".\ |
||||
\"$orig\" could not be resolved." |
||||
} |
||||
# check if defaults are set for the alias |
||||
if {[llength $cmdargs]>1} { |
||||
set cmd [lindex $cmdargs 0] |
||||
set defaultargs [concat [lrange $cmdargs 1 end] $defaultargs] |
||||
} else { |
||||
set cmd $cmdargs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc ::pattern::uniqueKey2 {} { |
||||
#!todo - something else?? |
||||
return [clock seconds]-[incr ::pattern::idCounter] |
||||
} |
||||
|
||||
#used by patternlib package |
||||
proc ::pattern::uniqueKey {} { |
||||
return [incr ::pattern::idCounter] |
||||
#uuid with tcllibc is about 30us compared with 2us |
||||
# for large datasets, e.g about 100K inserts this would be pretty noticable! |
||||
#!todo - uuid pool with background thread to repopulate when idle? |
||||
#return [uuid::uuid generate] |
||||
} |
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------------------------------------------------------------------- |
||||
|
||||
proc ::pattern::test1 {} { |
||||
set msg "OK" |
||||
|
||||
puts stderr "next line should say:'--- saystuff:$msg" |
||||
::>pattern .. Create ::>thing |
||||
|
||||
::>thing .. PatternMethod saystuff args { |
||||
puts stderr "--- saystuff: $args" |
||||
} |
||||
::>thing .. Create ::>jjj |
||||
|
||||
::>jjj . saystuff $msg |
||||
::>jjj .. Destroy |
||||
::>thing .. Destroy |
||||
} |
||||
|
||||
proc ::pattern::test2 {} { |
||||
set msg "OK" |
||||
|
||||
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||
::>pattern .. Create ::>thing |
||||
|
||||
::>thing .. PatternProperty stuff $msg |
||||
|
||||
::>thing .. Create ::>jjj |
||||
|
||||
puts stderr "--- property 'stuff' value:[::>jjj . stuff]" |
||||
::>jjj .. Destroy |
||||
::>thing .. Destroy |
||||
} |
||||
|
||||
proc ::pattern::test3 {} { |
||||
set msg "OK" |
||||
|
||||
puts stderr "next line should say:'--- property 'stuff' value:$msg" |
||||
::>pattern .. Create ::>thing |
||||
|
||||
::>thing .. Property stuff $msg |
||||
|
||||
puts stderr "--- property 'stuff' value:[::>thing . stuff]" |
||||
::>thing .. Destroy |
||||
} |
||||
|
||||
#--------------------------------- |
||||
#unknown/obsolete |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#proc ::p::internals::showargs {args {ch stdout}} {puts $ch $args} |
||||
if {0} { |
||||
proc ::p::internals::new_interface {{usedbylist {}}} { |
||||
set OID [incr ::p::ID] |
||||
::p::internals::new_object ::p::ifaces::>$OID "" $OID |
||||
puts "obsolete >> new_interface created object $OID" |
||||
foreach usedby $usedbylist { |
||||
set ::p::${OID}::_iface::o_usedby(i$usedby) 1 |
||||
} |
||||
set ::p::${OID}::_iface::o_varspace "" ;#default varspace is the object's namespace. (varspace is absolute if it has leading :: , otherwise it's a relative namespace below the object's namespace) |
||||
#NOTE - o_varspace is only the default varspace for when new methods/properties are added. |
||||
# it is possible to create some methods/props with one varspace value, then create more methods/props with a different varspace value. |
||||
|
||||
set ::p::${OID}::_iface::o_constructor [list] |
||||
set ::p::${OID}::_iface::o_variables [list] |
||||
set ::p::${OID}::_iface::o_properties [dict create] |
||||
set ::p::${OID}::_iface::o_methods [dict create] |
||||
array set ::p::${OID}::_iface::o_definition [list] |
||||
set ::p::${OID}::_iface::o_open 1 ;#open for extending |
||||
return $OID |
||||
} |
||||
|
||||
|
||||
#temporary way to get OID - assumes single 'this' invocant |
||||
#!todo - make generic. |
||||
proc ::pattern::get_oid {_ID_} { |
||||
#puts stderr "#* get_oid: [lindex [dict get $_ID_ i this] 0 0]" |
||||
return [lindex [dict get $_ID_ i this] 0 0] |
||||
|
||||
#set invocants [dict get $_ID_ i] |
||||
#set invocant_roles [dict keys $invocants] |
||||
#set role_members [dict get $invocants this] |
||||
##set this_invocant [lindex $role_members 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
#set this_invocant [lindex [dict get $_ID_ i this] 0] ; |
||||
#lassign $this_invocant OID this_info |
||||
# |
||||
#return $OID |
||||
} |
||||
|
||||
#compile the uncompiled level1 interface |
||||
#assert: no more than one uncompiled interface present at level1 |
||||
proc ::p::meta::PatternCompile {self} { |
||||
???? |
||||
|
||||
upvar #0 $self SELFMAP |
||||
set ID [lindex $SELFMAP 0 0] |
||||
|
||||
set patterns [lindex $SELFMAP 1 1] ;#list of level1 interfaces |
||||
|
||||
set iid -1 |
||||
foreach i $patterns { |
||||
if {[set ::p::${i}::_iface::o_open]} { |
||||
set iid $i ;#found it |
||||
break |
||||
} |
||||
} |
||||
|
||||
if {$iid > -1} { |
||||
#!todo |
||||
|
||||
::p::compile_interface $iid |
||||
set ::p::${iid}::_iface::o_open 0 |
||||
} else { |
||||
#no uncompiled interface present at level 1. Do nothing. |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::p::meta::Def {self} { |
||||
error ::p::meta::Def |
||||
|
||||
upvar #0 $self SELFMAP |
||||
set self_ID [lindex $SELFMAP 0 0] |
||||
set IFID [lindex $SELFMAP 1 0 end] |
||||
|
||||
set maxc1 0 |
||||
set maxc2 0 |
||||
|
||||
set arrName ::p::${IFID}:: |
||||
|
||||
upvar #0 $arrName state |
||||
|
||||
array set methods {} |
||||
|
||||
foreach nm [array names state] { |
||||
if {[regexp {^m-1,name,(.+)} $nm _match mname]} { |
||||
set methods($mname) [set state($nm)] |
||||
|
||||
if {[string length $mname] > $maxc1} { |
||||
set maxc1 [string length $mname] |
||||
} |
||||
if {[string length [set state($nm)]] > $maxc2} { |
||||
set maxc2 [string length [set state($nm)]] |
||||
} |
||||
} |
||||
} |
||||
set bg1 [string repeat " " [expr {$maxc1 + 2}]] |
||||
set bg2 [string repeat " " [expr {$maxc2 + 2}]] |
||||
|
||||
|
||||
set r {} |
||||
foreach nm [lsort -dictionary [array names methods]] { |
||||
set arglist $state(m-1,args,$nm) |
||||
append r "[overtype::left $bg1 $nm] : [overtype::left $bg2 $methods($nm)] [::list $arglist]\n" |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -1,754 +0,0 @@
|
||||
package provide patternpredator2 1.2.4 |
||||
|
||||
proc ::p::internals::jaws {OID _ID_ args} { |
||||
#puts stderr ">>>(patternpredator2 lib)jaws called with _ID_:$_ID_ args: $args" |
||||
#set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||
|
||||
yield |
||||
set w 1 |
||||
|
||||
set stack [list] |
||||
set wordcount [llength $args] |
||||
set terminals [list . .. , # @ !] ;#tokens which require the current stack to be evaluated first |
||||
set unsupported 0 |
||||
set operator "" |
||||
set operator_prev "" ;#used only by argprotect to revert to previous operator |
||||
|
||||
|
||||
if {$OID ne "null"} { |
||||
#!DO NOT use upvar here for MAP! (calling set on a MAP in another iteration/call will overwrite a map for another object!) |
||||
#upvar #0 ::p::${OID}::_meta::map MAP |
||||
set MAP [set ::p::${OID}::_meta::map] |
||||
} else { |
||||
# error "jaws - OID = 'null' ???" |
||||
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] ;#MAP taken from _ID_ will be missing 'interfaces' key |
||||
} |
||||
set invocantdata [dict get $MAP invocantdata] |
||||
lassign $invocantdata OID alias default_method object_command wrapped |
||||
|
||||
set finished_args 0 ;#whether we've completely processed all args in the while loop and therefor don't need to peform the final word processing code |
||||
|
||||
#don't use 'foreach word $args' - we sometimes need to backtrack a little by manipulating $w |
||||
while {$w < $wordcount} { |
||||
set word [lindex $args [expr {$w -1}]] |
||||
#puts stdout "w:$w word:$word stack:$stack" |
||||
|
||||
if {$operator eq "argprotect"} { |
||||
set operator $operator_prev |
||||
lappend stack $word |
||||
incr w |
||||
} else { |
||||
if {[llength $stack]} { |
||||
if {$word in $terminals} { |
||||
set reduction [list 0 $_ID_ {*}$stack ] |
||||
#puts stderr ">>>jaws yielding value: $reduction triggered by word $word in position:$w" |
||||
|
||||
|
||||
set _ID_ [yield $reduction] |
||||
set stack [list] |
||||
#set OID [::pattern::get_oid $_ID_] |
||||
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||
|
||||
if {$OID ne "null"} { |
||||
set MAP [set ::p::${OID}::_meta::map] ;#Do not use upvar here! |
||||
} else { |
||||
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces [list level0 {} level1 {}]] |
||||
#puts stderr "WARNING REVIEW: jaws-branch - leave empty??????" |
||||
} |
||||
|
||||
#review - 2018. switched to _ID_ instead of MAP |
||||
lassign [lindex [dict get $_ID_ i this] 0] OID alias default_method object_command |
||||
#lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||
|
||||
|
||||
#puts stdout "---->>> yielded _ID_: $_ID_ OID:$OID alias:$alias default_method:$default_method object_command:$object_command" |
||||
set operator $word |
||||
#don't incr w |
||||
#incr w |
||||
} else { |
||||
if {$operator eq "argprotect"} { |
||||
set operator $operator_prev |
||||
set operator_prev "" |
||||
lappend stack $word |
||||
} else { |
||||
#only look for leading argprotect chacter (-) if we're not already in argprotect mode |
||||
if {$word eq "--"} { |
||||
set operator_prev $operator |
||||
set operator "argprotect" |
||||
#Don't add the plain argprotector to the stack |
||||
} elseif {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set operator_prev $operator |
||||
set operator "argprotect" |
||||
lappend stack $word |
||||
} else { |
||||
lappend stack $word |
||||
} |
||||
} |
||||
|
||||
|
||||
incr w |
||||
} |
||||
} else { |
||||
#no stack |
||||
switch -- $word {.} { |
||||
|
||||
if {$OID ne "null"} { |
||||
#we know next word is a property or method of a pattern object |
||||
incr w |
||||
set nextword [lindex $args [expr {$w - 1}]] |
||||
set command ::p::${OID}::$nextword |
||||
set stack [list $command] ;#2018 j |
||||
set operator . |
||||
if {$w eq $wordcount} { |
||||
set finished_args 1 |
||||
} |
||||
} else { |
||||
# don't incr w |
||||
#set nextword [lindex $args [expr {$w - 1}]] |
||||
set command $object_command ;#taken from the MAP |
||||
set stack [list "_exec_" $command] |
||||
set operator . |
||||
} |
||||
|
||||
|
||||
} {..} { |
||||
incr w |
||||
set nextword [lindex $args [expr {$w -1}]] |
||||
set command ::p::-1::$nextword |
||||
#lappend stack $command ;#lappend a small number of items to an empty list is slower than just setting the list. |
||||
set stack [list $command] ;#faster, and intent is clearer than lappend. |
||||
set operator .. |
||||
if {$w eq $wordcount} { |
||||
set finished_args 1 |
||||
} |
||||
} {,} { |
||||
#puts stdout "Stackless comma!" |
||||
|
||||
|
||||
if {$OID ne "null"} { |
||||
set command ::p::${OID}::$default_method |
||||
} else { |
||||
set command [list $default_method $object_command] |
||||
#object_command in this instance presumably be a list and $default_method a list operation |
||||
#e.g "lindex {A B C}" |
||||
} |
||||
#lappend stack $command |
||||
set stack [list $command] |
||||
set operator , |
||||
} {--} { |
||||
set operator_prev $operator |
||||
set operator argprotect |
||||
#no stack - |
||||
} {!} { |
||||
set command $object_command |
||||
set stack [list "_exec_" $object_command] |
||||
#puts stdout "!!!! !!!! $stack" |
||||
set operator ! |
||||
} default { |
||||
if {$operator eq ""} { |
||||
if {$OID ne "null"} { |
||||
set command ::p::${OID}::$default_method |
||||
} else { |
||||
set command [list $default_method $object_command] |
||||
} |
||||
set stack [list $command] |
||||
set operator , |
||||
lappend stack $word |
||||
} else { |
||||
#no stack - so we don't expect to be in argprotect mode already. |
||||
if {[string match "-*" $word]} { |
||||
#argSafety operator (tokens that appear to be Tcl 'options' automatically 'protect' the subsequent argument) |
||||
set operator_prev $operator |
||||
set operator "argprotect" |
||||
lappend stack $word |
||||
} else { |
||||
lappend stack $word |
||||
} |
||||
|
||||
} |
||||
} |
||||
incr w |
||||
} |
||||
|
||||
} |
||||
} ;#end while |
||||
|
||||
#process final word outside of loop |
||||
#assert $w == $wordcount |
||||
#trailing operators or last argument |
||||
if {!$finished_args} { |
||||
set word [lindex $args [expr {$w -1}]] |
||||
if {$operator eq "argprotect"} { |
||||
set operator $operator_prev |
||||
set operator_prev "" |
||||
|
||||
lappend stack $word |
||||
incr w |
||||
} else { |
||||
|
||||
|
||||
switch -- $word {.} { |
||||
if {![llength $stack]} { |
||||
#set stack [list "_result_" [::p::internals::ref_to_object $_ID_]] |
||||
yieldto return [::p::internals::ref_to_object $_ID_] |
||||
error "assert: never gets here" |
||||
|
||||
} else { |
||||
#puts stdout "==== $stack" |
||||
#assert - whenever _ID_ changed in this proc - we have updated the $OID variable |
||||
yieldto return [::p::internals::ref_to_stack $OID $_ID_ $stack] |
||||
error "assert: never gets here" |
||||
} |
||||
set operator . |
||||
|
||||
} {..} { |
||||
#trailing .. after chained call e.g >x . item 0 .. |
||||
#puts stdout "$$$$$$$$$$$$ [list 0 $_ID_ {*}$stack] $$$$" |
||||
#set reduction [list 0 $_ID_ {*}$stack] |
||||
yieldto return [yield [list 0 $_ID_ {*}$stack]] |
||||
} {#} { |
||||
set unsupported 1 |
||||
} {,} { |
||||
set unsupported 1 |
||||
} {&} { |
||||
set unsupported 1 |
||||
} {@} { |
||||
set unsupported 1 |
||||
} {--} { |
||||
|
||||
#set reduction [list 0 $_ID_ {*}$stack[set stack [list]]] |
||||
#puts stdout " -> -> -> about to call yield $reduction <- <- <-" |
||||
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]] ] |
||||
#set OID [::pattern::get_oid $_ID_] |
||||
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||
|
||||
if {$OID ne "null"} { |
||||
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||
} else { |
||||
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}} ] |
||||
} |
||||
yieldto return $MAP |
||||
} {!} { |
||||
#error "untested branch" |
||||
set _ID_ [yield [list 0 $_ID_ {*}$stack[set stack [list]]]] |
||||
#set OID [::pattern::get_oid $_ID_] |
||||
set OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||
|
||||
if {$OID ne "null"} { |
||||
set MAP [set ::p::${OID}::_meta::map] ;#DO not use upvar here! |
||||
} else { |
||||
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] ] |
||||
} |
||||
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||
set command $object_command |
||||
set stack [list "_exec_" $command] |
||||
set operator ! |
||||
} default { |
||||
if {$operator eq ""} { |
||||
#error "untested branch" |
||||
lassign [dict get $MAP invocantdata] OID alias default_command object_command |
||||
#set command ::p::${OID}::item |
||||
set command ::p::${OID}::$default_command |
||||
lappend stack $command |
||||
set operator , |
||||
|
||||
} |
||||
#do not look for argprotect items here (e.g -option) as the final word can't be an argprotector anyway. |
||||
lappend stack $word |
||||
} |
||||
if {$unsupported} { |
||||
set unsupported 0 |
||||
error "trailing '$word' not supported" |
||||
|
||||
} |
||||
|
||||
#if {$operator eq ","} { |
||||
# incr wordcount 2 |
||||
# set stack [linsert $stack end-1 . item] |
||||
#} |
||||
incr w |
||||
} |
||||
} |
||||
|
||||
|
||||
#final = 1 |
||||
#puts stderr ">>>jaws final return value: [list 1 $_ID_ {*}$stack]" |
||||
|
||||
return [list 1 $_ID_ {*}$stack] |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing. directly after object |
||||
proc ::p::internals::ref_to_object {_ID_} { |
||||
set OID [lindex [dict get $_ID_ i this] 0 0] |
||||
upvar #0 ::p::${OID}::_meta::map MAP |
||||
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||
set refname ::p::${OID}::_ref::__OBJECT |
||||
|
||||
array set $refname [list] ;#important to initialise the variable as an array here - or initial read attempts on elements will not fire traces |
||||
|
||||
set traceCmd [list ::p::predator::object_read_trace $OID $_ID_] |
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
#puts stdout "adding read trace on variable '$refname' - traceCmd:'$traceCmd'" |
||||
trace add variable $refname {read} $traceCmd |
||||
} |
||||
set traceCmd [list ::p::predator::object_array_trace $OID $_ID_] |
||||
if {[list {array} $traceCmd] ni [trace info variable $refname]} { |
||||
trace add variable $refname {array} $traceCmd |
||||
} |
||||
|
||||
set traceCmd [list ::p::predator::object_write_trace $OID $_ID_] |
||||
if {[list {write} $traceCmd] ni [trace info variable $refname]} { |
||||
trace add variable $refname {write} $traceCmd |
||||
} |
||||
|
||||
set traceCmd [list ::p::predator::object_unset_trace $OID $_ID_] |
||||
if {[list {unset} $traceCmd] ni [trace info variable $refname]} { |
||||
trace add variable $refname {unset} $traceCmd |
||||
} |
||||
return $refname |
||||
} |
||||
|
||||
|
||||
proc ::p::internals::create_or_update_reference {OID _ID_ refname command} { |
||||
#if {[lindex $fullstack 0] eq "_exec_"} { |
||||
# #strip it. This instruction isn't relevant for a reference. |
||||
# set commandstack [lrange $fullstack 1 end] |
||||
#} else { |
||||
# set commandstack $fullstack |
||||
#} |
||||
#set argstack [lassign $commandstack command] |
||||
#set field [string map {> __OBJECT_} [namespace tail $command]] |
||||
|
||||
|
||||
|
||||
set reftail [namespace tail $refname] |
||||
set argstack [lassign [split $reftail +] field] |
||||
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||
|
||||
#puts stderr "refname:'$refname' command: $command field:$field" |
||||
|
||||
|
||||
if {$OID ne "null"} { |
||||
upvar #0 ::p::${OID}::_meta::map MAP |
||||
} else { |
||||
#set map [dict get [lindex [dict get $_ID_ i this] 0 1] map] |
||||
set MAP [list invocantdata [lindex [dict get $_ID_ i this] 0] interfaces {level0 {} level1 {}}] |
||||
} |
||||
lassign [dict get $MAP invocantdata] OID alias default_method object_command |
||||
|
||||
|
||||
|
||||
if {$OID ne "null"} { |
||||
interp alias {} $refname {} $command $_ID_ {*}$argstack |
||||
} else { |
||||
interp alias {} $refname {} $command {*}$argstack |
||||
} |
||||
|
||||
|
||||
#set iflist [lindex $map 1 0] |
||||
set iflist [dict get $MAP interfaces level0] |
||||
#set iflist [dict get $MAP interfaces level0] |
||||
set field_is_property_like 0 |
||||
foreach IFID [lreverse $iflist] { |
||||
#tcl (braced) expr has lazy evaluation for &&, || & ?: operators - so this should be reasonably efficient. |
||||
if {[llength [info commands ::p::${IFID}::_iface::(GET)$field]] || [llength [info commands ::p::${IFID}::_iface::(SET)$field]]} { |
||||
set field_is_property_like 1 |
||||
#There is a setter or getter (but not necessarily an entry in the o_properties dict) |
||||
break |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
#whether field is a property or a method - remove any commandrefMisuse_TraceHandler |
||||
foreach tinfo [trace info variable $refname] { |
||||
#puts "-->removing traces on $refname: $tinfo" |
||||
if {[lindex $tinfo 1 0] eq "::p::internals::commandrefMisuse_TraceHandler"} { |
||||
trace remove variable $refname {*}$tinfo |
||||
} |
||||
} |
||||
|
||||
if {$field_is_property_like} { |
||||
#property reference |
||||
|
||||
|
||||
set this_invocantdata [lindex [dict get $_ID_ i this] 0] |
||||
lassign $this_invocantdata OID _alias _defaultmethod object_command |
||||
#get fully qualified varspace |
||||
|
||||
# |
||||
set propdict [$object_command .. GetPropertyInfo $field] |
||||
if {[dict exist $propdict $field]} { |
||||
set field_is_a_property 1 |
||||
set propinfo [dict get $propdict $field] |
||||
set varspace [dict get $propinfo varspace] |
||||
if {$varspace eq ""} { |
||||
set full_varspace ::p::${OID} |
||||
} else { |
||||
if {[::string match "::*" $varspace]} { |
||||
set full_varspace $varspace |
||||
} else { |
||||
set full_varspace ::p::${OID}::$varspace |
||||
} |
||||
} |
||||
} else { |
||||
set field_is_a_property 0 |
||||
#no propertyinfo - this field was probably established as a PropertyRead and/or PropertyWrite without a Property |
||||
#this is ok - and we still set the trace infrastructure below (app may convert it to a normal Property later) |
||||
set full_varspace ::p::${OID} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#We only trace on entire property.. not array elements (if references existed to both the array and an element both traces would be fired -(entire array trace first)) |
||||
set Hndlr [::list ::p::predator::propvar_write_TraceHandler $OID $field] |
||||
if { [::list {write} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||
trace add variable ${full_varspace}::o_${field} {write} $Hndlr |
||||
} |
||||
set Hndlr [::list ::p::predator::propvar_unset_TraceHandler $OID $field] |
||||
if { [::list {unset} $Hndlr] ni [trace info variable ${full_varspace}::o_${field}]} { |
||||
trace add variable ${full_varspace}::o_${field} {unset} $Hndlr |
||||
} |
||||
|
||||
|
||||
#supply all data in easy-access form so that propref_trace_read is not doing any extra work. |
||||
set get_cmd ::p::${OID}::(GET)$field |
||||
set traceCmd [list ::p::predator::propref_trace_read $get_cmd $_ID_ $refname $field $argstack] |
||||
|
||||
if {[list {read} $traceCmd] ni [trace info variable $refname]} { |
||||
set fieldvarname ${full_varspace}::o_${field} |
||||
|
||||
|
||||
#synch the refvar with the real var if it exists |
||||
#catch {set $refname [$refname]} |
||||
if {[array exists $fieldvarname]} { |
||||
if {![llength $argstack]} { |
||||
#unindexed reference |
||||
array set $refname [array get $fieldvarname] |
||||
#upvar $fieldvarname $refname |
||||
} else { |
||||
set s0 [lindex $argstack 0] |
||||
#refs to nonexistant array members common? (catch vs 'info exists') |
||||
if {[info exists ${fieldvarname}($s0)]} { |
||||
set $refname [set ${fieldvarname}($s0)] |
||||
} |
||||
} |
||||
} else { |
||||
#refs to uninitialised props actually should be *very* common. |
||||
#If we use 'catch', it means retrieving refs to non-initialised props is slower. Fired catches can be relatively expensive. |
||||
#Because it's common to get a ref to uninitialised props (e.g for initial setting of their value) - we will use 'info exists' instead of catch. |
||||
|
||||
#set errorInfo_prev $::errorInfo ;#preserve errorInfo across catches! |
||||
|
||||
#puts stdout " ---->>!!! ref to uninitialised prop $field $argstack !!!<------" |
||||
|
||||
|
||||
if {![llength $argstack]} { |
||||
#catch {set $refname [set ::p::${OID}::o_$field]} |
||||
if {[info exists $fieldvarname]} { |
||||
set $refname [set $fieldvarname] |
||||
#upvar $fieldvarname $refname |
||||
} |
||||
} else { |
||||
if {[llength $argstack] == 1} { |
||||
#catch {set $refname [lindex [set ::p::${OID}::o_$field] [lindex $argstack 0]]} |
||||
if {[info exists $fieldvarname]} { |
||||
set $refname [lindex [set $fieldvarname] [lindex $argstack 0]] |
||||
} |
||||
|
||||
} else { |
||||
#catch {set $refname [lindex [set ::p::${OID}::o_$field] $argstack]} |
||||
if {[info exists $fieldvarname]} { |
||||
set $refname [lindex [set $fieldvarname] $argstack] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#! what if someone has put a trace on ::errorInfo?? |
||||
#set ::errorInfo $errorInfo_prev |
||||
} |
||||
trace add variable $refname {read} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::propref_trace_write $_ID_ $OID $full_varspace $refname] |
||||
trace add variable $refname {write} $traceCmd |
||||
|
||||
set traceCmd [list ::p::predator::propref_trace_unset $_ID_ $OID $refname] |
||||
trace add variable $refname {unset} $traceCmd |
||||
|
||||
|
||||
set traceCmd [list ::p::predator::propref_trace_array $_ID_ $OID $refname] |
||||
# puts "**************** installing array variable trace on ref:$refname - cmd:$traceCmd" |
||||
trace add variable $refname {array} $traceCmd |
||||
} |
||||
|
||||
} else { |
||||
#puts "$refname ====> adding refMisuse_traceHandler $alias $field" |
||||
#matching variable in order to detect attempted use as property and throw error |
||||
|
||||
#2018 |
||||
#Note that we are adding a trace on a variable (the refname) which does not exist. |
||||
#this is fine - except that the trace won't fire for attempt to write it as an array using syntax such as set $ref(someindex) |
||||
#we could set the ref to an empty array - but then we have to also undo this if a property with matching name is added |
||||
##array set $refname {} ;#empty array |
||||
# - the empty array would mean a slightly better error message when misusing a command ref as an array |
||||
#but this seems like a code complication for little benefit |
||||
#review |
||||
|
||||
trace add variable $refname {read write unset array} [list ::p::internals::commandrefMisuse_TraceHandler $OID $field] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#trailing. after command/property |
||||
proc ::p::internals::ref_to_stack {OID _ID_ fullstack} { |
||||
if {[lindex $fullstack 0] eq "_exec_"} { |
||||
#strip it. This instruction isn't relevant for a reference. |
||||
set commandstack [lrange $fullstack 1 end] |
||||
} else { |
||||
set commandstack $fullstack |
||||
} |
||||
set argstack [lassign $commandstack command] |
||||
set field [string map {> __OBJECT_} [namespace tail $command]] |
||||
|
||||
|
||||
#!todo? |
||||
# - make every object's OID unpredictable and sparse (UUID) and modify 'namespace child' etc to prevent iteration/inspection of ::p namespace. |
||||
# - this would only make sense for an environment where any meta methods taking a code body (e.g .. Method .. PatternMethod etc) are restricted. |
||||
|
||||
|
||||
#references created under ::p::${OID}::_ref are effectively inside a 'varspace' within the object itself. |
||||
# - this would in theory allow a set of interface functions on the object which have direct access to the reference variables. |
||||
|
||||
|
||||
set refname ::p::${OID}::_ref::[join [concat $field $argstack] +] |
||||
|
||||
if {[llength [info commands $refname]]} { |
||||
#todo - review - what if the field changed to/from a property/method? |
||||
#probably should fix that where such a change is made and leave this short circuit here to give reasonable performance for existing refs |
||||
return $refname |
||||
} |
||||
::p::internals::create_or_update_reference $OID $_ID_ $refname $command |
||||
return $refname |
||||
} |
||||
|
||||
|
||||
namespace eval pp { |
||||
variable operators [list .. . -- - & @ # , !] |
||||
variable operators_notin_args "" |
||||
foreach op $operators { |
||||
append operators_notin_args "({$op} ni \$args) && " |
||||
} |
||||
set operators_notin_args [string trimright $operators_notin_args " &"] ;#trim trailing spaces and ampersands |
||||
#set operators_notin_args {({.} ni $args) && ({,} ni $args) && ({..} ni $args)} |
||||
} |
||||
interp alias {} strmap {} string map ;#stop code editor from mono-colouring our big string mapped code blocks! |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# 2017 ::p::predator2 is the development version - intended for eventual use as the main dispatch mechanism. |
||||
#each map is a 2 element list of lists. |
||||
# form: {$commandinfo $interfaceinfo} |
||||
# commandinfo is of the form: {ID Namespace defaultmethod commandname _?} |
||||
|
||||
#2018 |
||||
#each map is a dict. |
||||
#form: {invocantdata {ID Namespace defaultmethod commandname _?} interfaces {level0 {} level1 {}}} |
||||
|
||||
|
||||
#OID = Object ID (integer for now - could in future be a uuid) |
||||
proc ::p::predator2 {_ID_ args} { |
||||
#puts stderr "predator2: _ID_:'$_ID_' args:'$args'" |
||||
#set invocants [dict get $_ID_ i] |
||||
#set invocant_roles [dict keys $invocants] |
||||
|
||||
#For now - we are 'this'-centric (single dispatch). todo - adapt for multiple roles, multimethods etc. |
||||
#set this_role_members [dict get $invocants this] |
||||
#set this_invocant [lindex [dict get $_ID_ i this] 0] ;#for the role 'this' we assume only one invocant in the list. |
||||
#lassign $this_invocant this_OID this_info_dict |
||||
|
||||
set this_OID [lindex [dict get $_ID_ i this] 0 0] ;#get_oid |
||||
|
||||
|
||||
set cheat 1 ;# |
||||
#------- |
||||
#Optimise the next most common use case. A single . followed by args which contain no other operators (non-chained call) |
||||
#(it should be functionally equivalent to remove this shortcut block) |
||||
if {$cheat} { |
||||
if { ([lindex $args 0] eq {.}) && ([llength $args] > 1) && ([llength [lsearch -all -inline $args .]] == 1) && ({,} ni $args) && ({..} ni $args) && ({--} ni $args) && ({!} ni $args)} { |
||||
|
||||
set remaining_args [lassign $args dot method_or_prop] |
||||
|
||||
#how will we do multiple apis? (separate interface stacks) apply? apply [list [list _ID_ {*}$arglist] ::p::${stackid?}::$method_or_prop ::p::${this_OID}] ??? |
||||
set command ::p::${this_OID}::$method_or_prop |
||||
#REVIEW! |
||||
#e.g what if the method is named "say hello" ?? (hint - it will break because we will look for 'say') |
||||
#if {[llength $command] > 1} { |
||||
# error "methods with spaces not included in test suites - todo fix!" |
||||
#} |
||||
#Dont use {*}$command - (so we can support methods with spaces) |
||||
#if {![llength [info commands $command]]} {} |
||||
if {[namespace which $command] eq ""} { |
||||
if {[namespace which ::p::${this_OID}::(UNKNOWN)] ne ""} { |
||||
#lset command 0 ::p::${this_OID}::(UNKNOWN) ;#seems wrong - command could have spaces |
||||
set command ::p::${this_OID}::(UNKNOWN) |
||||
#tailcall {*}$command $_ID_ $cmdname {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
tailcall $command $_ID_ $method_or_prop {*}[lrange $args 2 end] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "(::p::predator2) error running command:'$command' argstack:'[lrange $args 2 end]'\n - command not found and no 'unknown' handler" "method '$method_or_prop' not found" |
||||
} |
||||
} else { |
||||
#tailcall {*}$command $_ID_ {*}$remaining_args |
||||
tailcall $command $_ID_ {*}$remaining_args |
||||
} |
||||
} |
||||
} |
||||
#------------ |
||||
|
||||
|
||||
if {([llength $args] == 1) && ([lindex $args 0] eq "..")} { |
||||
return $_ID_ |
||||
} |
||||
|
||||
|
||||
#puts stderr "pattern::predator (test version) called with: _ID_:$_ID_ args:$args" |
||||
|
||||
|
||||
|
||||
#puts stderr "this_info_dict: $this_info_dict" |
||||
|
||||
|
||||
|
||||
|
||||
if {![llength $args]} { |
||||
#should return some sort of public info.. i.e probably not the ID which is an implementation detail |
||||
#return cmd |
||||
return [lindex [dict get [set ::p::${this_OID}::_meta::map] invocantdata] 0] ;#Object ID |
||||
|
||||
#return a dict keyed on object command name - (suitable as use for a .. Create 'target') |
||||
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method object_command wrapped |
||||
#return [list $object_command [list -id $this_OID ]] |
||||
} elseif {[llength $args] == 1} { |
||||
#short-circuit the single index case for speed. |
||||
if {[lindex $args 0] ni {.. . -- - & @ # , !}} { |
||||
#lassign [dict get [set ::p::${this_OID}::_meta::map] invocantdata] this_OID alias default_method |
||||
lassign [lindex [dict get $_ID_ i this] 0] this_OID alias default_method |
||||
|
||||
tailcall ::p::${this_OID}::$default_method $_ID_ [lindex $args 0] |
||||
} elseif {[lindex $args 0] eq {--}} { |
||||
|
||||
#!todo - we could hide the invocant by only allowing this call from certain uplevel procs.. |
||||
# - combined with using UUIDs for $OID, and a secured/removed metaface on the object |
||||
# - (and also hiding of [interp aliases] command so they can't iterate and examine all aliases) |
||||
# - this could effectively hide the object's namespaces,vars etc from the caller (?) |
||||
return [set ::p::${this_OID}::_meta::map] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#upvar ::p::coroutine_instance c ;#coroutine names must be unique per call to predator (not just per object - or we could get a clash during some cyclic calls) |
||||
#incr c |
||||
#set reduce ::p::reducer${this_OID}_$c |
||||
set reduce ::p::reducer${this_OID}_[incr ::p::coroutine_instance] |
||||
#puts stderr "..................creating reducer $reduce with args $this_OID _ID_ $args" |
||||
coroutine $reduce ::p::internals::jaws $this_OID $_ID_ {*}$args |
||||
|
||||
|
||||
set current_ID_ $_ID_ |
||||
|
||||
set final 0 |
||||
set result "" |
||||
while {$final == 0} { |
||||
#the argument given here to $reduce will be returned by 'yield' within the coroutine context (jaws) |
||||
set reduction_args [lassign [$reduce $current_ID_[set current_ID_ [list]] ] final current_ID_ command] |
||||
#puts stderr "..> final:$final current_ID_:'$current_ID_' command:'$command' reduction_args:'$reduction_args'" |
||||
#if {[string match *Destroy $command]} { |
||||
# puts stdout " calling Destroy reduction_args:'$reduction_args'" |
||||
#} |
||||
if {$final == 1} { |
||||
|
||||
if {[llength $command] == 1} { |
||||
if {$command eq "_exec_"} { |
||||
tailcall {*}$reduction_args |
||||
} |
||||
if {[llength [info commands $command]]} { |
||||
tailcall {*}$command $current_ID_ {*}$reduction_args |
||||
} |
||||
set cmdname [namespace tail $command] |
||||
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||
tailcall {*}$command $current_ID_ $cmdname {*}$reduction_args ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "1)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||
} |
||||
|
||||
} else { |
||||
#e.g lindex {a b c} |
||||
tailcall {*}$command {*}$reduction_args |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {[lindex $command 0] eq "_exec_"} { |
||||
set result [uplevel 1 [list {*}[lrange $command 1 end] {*}$reduction_args]] |
||||
|
||||
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {} ] |
||||
} else { |
||||
if {[llength $command] == 1} { |
||||
if {![llength [info commands $command]]} { |
||||
set cmdname [namespace tail $command] |
||||
set this_OID [lindex [dict get $current_ID_ i this] 0 0] |
||||
if {[llength [info commands ::p::${this_OID}::(UNKNOWN)]]} { |
||||
|
||||
lset command 0 ::p::${this_OID}::(UNKNOWN) |
||||
set result [uplevel 1 [list {*}$command $current_ID_ $cmdname {*}$reduction_args]] ;#delegate to UNKNOWN, along with original commandname as 1st arg. |
||||
} else { |
||||
return -code error -errorinfo "2)error running command:'$command' argstack:'$reduction_args'\n - command not found and no 'unknown' handler" "method '$cmdname' not found" |
||||
} |
||||
} else { |
||||
#set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||
set result [uplevel 1 [list {*}$command $current_ID_ {*}$reduction_args ]] |
||||
|
||||
} |
||||
} else { |
||||
set result [uplevel 1 [list {*}$command {*}$reduction_args]] |
||||
} |
||||
|
||||
if {[llength [info commands $result]]} { |
||||
if {([llength $result] == 1) && ([string first ">" [namespace tail $result]] == 0)} { |
||||
#looks like a pattern command |
||||
set current_ID_ [$result .. INVOCANTDATA] |
||||
|
||||
|
||||
#todo - determine if plain .. INVOCANTDATA is sufficient instead of .. UPDATEDINVOCANTDATA |
||||
#if {![catch {$result .. INVOCANTDATA} result_invocantdata]} { |
||||
# set current_ID_ $result_invocantdata |
||||
#} else { |
||||
# return -code error -errorinfo "3)error running command:'$command' argstack:'$reduction_args'\n - Failed to access result:'$result' as a pattern object." "Failed to access result:'$result' as a pattern object" |
||||
#} |
||||
} else { |
||||
#non-pattern command |
||||
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||
} |
||||
} else { |
||||
set current_ID_ [list i [list this [list [list "null" {} {lindex} $result {} ] ] ] context {}] |
||||
#!todo - allow further operations on non-command values. e.g dicts, lists & strings (treat strings as lists) |
||||
|
||||
} |
||||
} |
||||
|
||||
} |
||||
} |
||||
error "Assert: Shouldn't get here (end of ::p::predator2)" |
||||
#return $result |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,346 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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::aliascore 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::aliascore] |
||||
#[keywords module alias] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::aliascore |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::aliascore |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::aliascore::class { |
||||
# #*** !doctools |
||||
# #[subsection {Namespace punk::aliascore::class}] |
||||
# #[para] class definitions |
||||
# if {[info commands [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::aliascore { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable aliases |
||||
#use absolute ns ie must be prefixed with :: |
||||
#single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased |
||||
|
||||
#functions should generally be covered by one of the export patterns of their source namespace |
||||
# - if they are not - e.g (separately loaded ensemble command ?) |
||||
# the aliascore::init will temporarily extend the exports list to do the import, and then reset the exports to how they were. |
||||
set aliases [tcl::dict::create\ |
||||
val ::punk::pipe::val\ |
||||
aliases ::punk::lib::aliases\ |
||||
alias ::punk::lib::alias\ |
||||
tstr ::punk::lib::tstr\ |
||||
list_as_lines ::punk::lib::list_as_lines\ |
||||
lines_as_list ::punk::lib::lines_as_list\ |
||||
linelist ::punk::lib::linelist\ |
||||
linesort ::punk::lib::linesort\ |
||||
pdict ::punk::lib::pdict\ |
||||
plist {::punk::lib::pdict -roottype list}\ |
||||
showlist {::punk::lib::showdict -roottype list}\ |
||||
grepstr ::punk::grepstr\ |
||||
rehash ::punk::rehash\ |
||||
showdict ::punk::lib::showdict\ |
||||
ansistrip ::punk::ansi::ansistrip\ |
||||
stripansi ::punk::ansi::ansistrip\ |
||||
ansiwrap ::punk::ansi::ansiwrap\ |
||||
colour ::punk::console::colour\ |
||||
color ::punk::console::colour\ |
||||
ansi ::punk::console::ansi\ |
||||
a? ::punk::console::code_a?\ |
||||
A? {::punk::console::code_a? forcecolor}\ |
||||
a+ ::punk::console::code_a+\ |
||||
A+ {::punk::console::code_a+ forcecolour}\ |
||||
a ::punk::console::code_a\ |
||||
A {::punk::console::code_a forcecolour}\ |
||||
smcup ::punk::console::enable_alt_screen\ |
||||
rmcup ::punk::console::disable_alt_screen\ |
||||
config ::punk::config\ |
||||
s ::punk::ns::synopsis\ |
||||
eg ::punk::ns::eg\ |
||||
] |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::aliascore}] |
||||
#[para] Core API functions for punk::aliascore |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
proc _is_exported {ns cmd} { |
||||
set exports [::tcl::namespace::eval $ns [list namespace export]] |
||||
set is_exported 0 |
||||
foreach p $exports { |
||||
if {[string match $p $cmd]} { |
||||
set is_exported 1 |
||||
break |
||||
} |
||||
} |
||||
return $is_exported |
||||
} |
||||
|
||||
#_nsprefix accepts entire command - not just an existing namespace for which we want the parent |
||||
proc _nsprefix {{nspath {}}} { |
||||
#maintenance: from punk::ns::nsprefix - (without unnecessary nstail) |
||||
#normalize the common case of :::: |
||||
set nspath [string map {:::: ::} $nspath] |
||||
set rawprefix [string range $nspath 0 end-[string length [namespace tail $nspath]]] |
||||
if {$rawprefix eq "::"} { |
||||
return $rawprefix |
||||
} else { |
||||
if {[string match *:: $rawprefix]} { |
||||
return [string range $rawprefix 0 end-2] |
||||
} else { |
||||
return $rawprefix |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo - options as to whether we should raise an error if collisions found, undo aliases etc? |
||||
proc init {args} { |
||||
set defaults {-force 0} |
||||
set opts [dict merge $defaults $args] |
||||
set opt_force [dict get $opts -force] |
||||
|
||||
#we never override existing aliases to ::repl::interp* even if -force = 1 |
||||
#(these are our safebase aliases) |
||||
set ignore_pattern "::repl::interp*" |
||||
set ignore_aliases [list] |
||||
|
||||
variable aliases |
||||
set existing [list] |
||||
set conflicts [list] |
||||
foreach {a cmd} $aliases { |
||||
if {[tcl::info::commands ::$a] ne ""} { |
||||
lappend existing $a |
||||
set existing_alias [interp alias "" $a] |
||||
if {$existing_alias ne ""} { |
||||
set existing_target $existing_alias |
||||
if {[string match $ignore_pattern $existing_target]} { |
||||
#don't consider it a conflict - will use ignore_aliases to exclude it below |
||||
lappend ignore_aliases $a |
||||
continue |
||||
} |
||||
} else { |
||||
if {[catch {tcl::namespace::origin $a} existing_command]} { |
||||
set existing_command "" |
||||
} |
||||
set existing_target $existing_command |
||||
} |
||||
|
||||
if {$existing_target ne $cmd} { |
||||
#command exists in global ns but doesn't match our defined aliases/imports |
||||
lappend conflicts $a |
||||
} |
||||
} |
||||
} |
||||
if {!$opt_force && [llength $conflicts]} { |
||||
error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" |
||||
} |
||||
|
||||
set failed [list] |
||||
set tempns ::temp_[info cmdcount] ;#temp ns for renames |
||||
dict for {a cmd} $aliases { |
||||
#puts "aliascore $a -> $cmd" |
||||
if {$a in $ignore_aliases} { |
||||
continue |
||||
} |
||||
if {[llength $cmd] > 1} { |
||||
interp alias {} $a {} {*}$cmd |
||||
} else { |
||||
if {[tcl::info::commands $cmd] ne ""} { |
||||
#todo - ensure exported? noclobber? |
||||
set container_ns [_nsprefix $cmd] |
||||
set cmdtail [tcl::namespace::tail $cmd] |
||||
set was_exported 1 ;#assumption |
||||
if {![_is_exported $container_ns $cmdtail]} { |
||||
set was_exported 0 |
||||
set existing_exports [tcl::namespace::eval $container_ns [list ::namespace export]] |
||||
tcl::namespace::eval $container_ns [list ::namespace export $cmdtail] |
||||
} |
||||
if {[tcl::namespace::tail $a] eq $cmdtail} { |
||||
#puts stderr "importing $cmd" |
||||
try { |
||||
tcl::namespace::eval :: [list ::namespace import $cmd] |
||||
} trap {} {emsg eopts} { |
||||
lappend failed [list alias $a target $cmd errormsg $emsg] |
||||
} |
||||
} else { |
||||
#target command name differs from exported name |
||||
#e.g stripansi -> punk::ansi::ansistrip |
||||
#import and rename |
||||
#puts stderr "importing $cmd (with rename to ::$a)" |
||||
try { |
||||
tcl::namespace::eval $tempns [list ::namespace import $cmd] |
||||
} trap {} {emsg eopst} { |
||||
lappend failed [list alias $a target $cmd errormsg $emsg] |
||||
} |
||||
catch {rename ${tempns}::$cmdtail ::$a} |
||||
} |
||||
#restore original exports |
||||
if {!$was_exported} { |
||||
tcl::namespace::eval $container_ns [list ::namespace export -clear {*}$existing_exports] |
||||
} |
||||
} else { |
||||
interp alias {} $a {} {*}$cmd |
||||
} |
||||
} |
||||
} |
||||
#tcl::namespace::delete $tempns |
||||
return [dict create aliases [dict keys $aliases] existing $existing ignored $ignore_aliases changed $conflicts failed $failed] |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::aliascore ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#interp alias {} list_as_lines {} punk::lib::list_as_lines |
||||
#interp alias {} lines_as_list {} punk::lib::lines_as_list |
||||
#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review |
||||
#interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features |
||||
#interp alias {} linesort {} punk::lib::linesort |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::aliascore::lib { |
||||
namespace export {[a-z]*} ;# Convention: export all lowercase |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::aliascore::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::aliascore::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval punk::aliascore::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::aliascore::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::aliascore [namespace eval punk::aliascore { |
||||
variable pkg punk::aliascore |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,966 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application ::punk::ansi::colourmap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_::punk::ansi::colourmap 0 0.1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require ::punk::ansi::colourmap] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of ::punk::ansi::colourmap |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by ::punk::ansi::colourmap |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
tcl::namespace::eval ::punk::ansi::colourmap { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace ::punk::ansi::colourmap}] |
||||
#[para] Core API functions for ::punk::ansi::colourmap |
||||
#[list_begin definitions] |
||||
|
||||
variable PUNKARGS |
||||
|
||||
#---------------------------------------------- |
||||
#todo - document vars as part of package API |
||||
#- or provide a function to return varnames? |
||||
#- or wrap each in a function and see if any performance/memory impact? (readonly - so should just be a reference without any copying?) |
||||
#TK_colour_map |
||||
#TK_colour_map_lookup |
||||
#TK_colour_map_merge |
||||
#TK_colour_map_reverse |
||||
#---------------------------------------------- |
||||
|
||||
|
||||
|
||||
#significantly slower than tables - but here as a check/test |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::ansi::colourmap::get_rgb_using_tk |
||||
@cmd -name punk::ansi::colourmap::get_rgb_using_tk -help\ |
||||
"This function requires Tk to function, and will call |
||||
'package require tk' to load it. |
||||
The name argument accepts Tk colour names or hex values |
||||
in either #XXX or #XXXXXX format. |
||||
Tk colour names can be displayed using the command: |
||||
punk::ansi::a? tk ?glob..? |
||||
|
||||
get_rgb_using_tk returns a decimal rgb string delimited with dashes. |
||||
e.g |
||||
get_rgb_using_tk #FFF |
||||
255-255-255 |
||||
get_rgb_using_tk SlateBlue |
||||
106-90-205" |
||||
@leaders |
||||
name -type string|stringstartswith(#) |
||||
}] |
||||
proc get_rgb_using_tk {name} { |
||||
package require tk |
||||
#assuming 'winfo depth .' is always 32 ? |
||||
set RGB [winfo rgb . $name] |
||||
set rgb [lmap n $RGB {expr {$n / 256}}] |
||||
return [join $rgb -] |
||||
} |
||||
|
||||
variable TK_colour_map |
||||
tcl::dict::set TK_colour_map "alice blue" 240-248-255 |
||||
tcl::dict::set TK_colour_map AliceBlue 240-248-255 |
||||
tcl::dict::set TK_colour_map "antique white" 250-235-215 |
||||
tcl::dict::set TK_colour_map AntiqueWhite 250-235-215 |
||||
tcl::dict::set TK_colour_map AntiqueWhite1 255-239-219 |
||||
tcl::dict::set TK_colour_map AntiqueWhite2 238-223-204 |
||||
tcl::dict::set TK_colour_map AntiqueWhite3 205-192-176 |
||||
tcl::dict::set TK_colour_map AntiqueWhite4 139-131-120 |
||||
tcl::dict::set TK_colour_map aqua 0-255-255 |
||||
tcl::dict::set TK_colour_map aquamarine 127-255-212 |
||||
tcl::dict::set TK_colour_map aquamarine1 127-255-212 |
||||
tcl::dict::set TK_colour_map aquamarine2 118-238-198 |
||||
tcl::dict::set TK_colour_map aquamarine3 102-205-170 |
||||
tcl::dict::set TK_colour_map aquamarine4 69-139-16 |
||||
tcl::dict::set TK_colour_map azure 240-255-255 |
||||
tcl::dict::set TK_colour_map azure1 240-255-255 |
||||
tcl::dict::set TK_colour_map azure2 224-238-238 |
||||
tcl::dict::set TK_colour_map azure3 193-205-205 |
||||
tcl::dict::set TK_colour_map azure4 131-139-139 |
||||
tcl::dict::set TK_colour_map beige 245-245-220 |
||||
tcl::dict::set TK_colour_map bisque 255-228-196 |
||||
tcl::dict::set TK_colour_map bisque1 255-228-196 |
||||
tcl::dict::set TK_colour_map bisque2 238-213-183 |
||||
tcl::dict::set TK_colour_map bisque3 205-183-158 |
||||
tcl::dict::set TK_colour_map bisque4 139-125-107 |
||||
tcl::dict::set TK_colour_map black 0-0-0 |
||||
tcl::dict::set TK_colour_map "blanched almond" 255-235-205 |
||||
tcl::dict::set TK_colour_map BlanchedAlmond 255-235-205 |
||||
tcl::dict::set TK_colour_map blue 0-0-255 |
||||
tcl::dict::set TK_colour_map "blue violet" 138-43-226 |
||||
tcl::dict::set TK_colour_map blue1 0-0-255 |
||||
tcl::dict::set TK_colour_map blue2 0-0-238 |
||||
tcl::dict::set TK_colour_map blue3 0-0-205 |
||||
tcl::dict::set TK_colour_map blue4 0-0-139 |
||||
tcl::dict::set TK_colour_map BlueViolet 138-43-226 |
||||
tcl::dict::set TK_colour_map brown 165-42-42 |
||||
tcl::dict::set TK_colour_map brown1 255-64-64 |
||||
tcl::dict::set TK_colour_map brown2 238-59-59 |
||||
tcl::dict::set TK_colour_map brown3 205-51-51 |
||||
tcl::dict::set TK_colour_map brown4 139-35-35 |
||||
tcl::dict::set TK_colour_map burlywood 222-184-135 |
||||
tcl::dict::set TK_colour_map burlywood1 255-211-155 |
||||
tcl::dict::set TK_colour_map burlywood2 238-197-145 |
||||
tcl::dict::set TK_colour_map burlywood3 205-170-125 |
||||
tcl::dict::set TK_colour_map burlywood4 139-115-85 |
||||
tcl::dict::set TK_colour_map "cadet blue" 95-158-160 |
||||
tcl::dict::set TK_colour_map CadetBlue 95-158-160 |
||||
tcl::dict::set TK_colour_map CadetBlue1 152-245-255 |
||||
tcl::dict::set TK_colour_map CadetBlue2 142-229-238 |
||||
tcl::dict::set TK_colour_map CadetBlue3 122-197-205 |
||||
tcl::dict::set TK_colour_map CadetBlue4 83-134-139 |
||||
tcl::dict::set TK_colour_map chartreuse 127-255-0 |
||||
tcl::dict::set TK_colour_map chartreuse1 127-255-0 |
||||
tcl::dict::set TK_colour_map chartreuse2 118-238-0 |
||||
tcl::dict::set TK_colour_map chartreuse3 102-205-0 |
||||
tcl::dict::set TK_colour_map chartreuse4 69-139-0 |
||||
tcl::dict::set TK_colour_map chocolate 210-105-30 |
||||
tcl::dict::set TK_colour_map chocolate1 255-127-36 |
||||
tcl::dict::set TK_colour_map chocolate2 238-118-33 |
||||
tcl::dict::set TK_colour_map chocolate3 205-102-29 |
||||
tcl::dict::set TK_colour_map chocolate4 139-69-19 |
||||
tcl::dict::set TK_colour_map coral 255-127-80 |
||||
tcl::dict::set TK_colour_map coral1 255-114-86 |
||||
tcl::dict::set TK_colour_map coral2 238-106-80 |
||||
tcl::dict::set TK_colour_map coral3 205-91-69 |
||||
tcl::dict::set TK_colour_map coral4 139-62-47 |
||||
tcl::dict::set TK_colour_map "cornflower blue" 100-149-237 |
||||
tcl::dict::set TK_colour_map CornflowerBlue 100-149-237 |
||||
tcl::dict::set TK_colour_map cornsilk 255-248-220 |
||||
tcl::dict::set TK_colour_map cornsilk1 255-248-220 |
||||
tcl::dict::set TK_colour_map cornsilk2 238-232-205 |
||||
tcl::dict::set TK_colour_map cornsilk3 205-200-177 |
||||
tcl::dict::set TK_colour_map cornsilk4 139-136-120 |
||||
tcl::dict::set TK_colour_map crimson 220-20-60 |
||||
tcl::dict::set TK_colour_map cyan 0-255-255 |
||||
tcl::dict::set TK_colour_map cyan1 0-255-255 |
||||
tcl::dict::set TK_colour_map cyan2 0-238-238 |
||||
tcl::dict::set TK_colour_map cyan3 0-205-205 |
||||
tcl::dict::set TK_colour_map cyan4 0-139-139 |
||||
tcl::dict::set TK_colour_map "dark blue" 0-0-139 |
||||
tcl::dict::set TK_colour_map "dark cyan" 0-139-139 |
||||
tcl::dict::set TK_colour_map "dark goldenrod" 184-134-11 |
||||
tcl::dict::set TK_colour_map "dark gray" 169-169-169 |
||||
tcl::dict::set TK_colour_map "dark green" 0-100-0 |
||||
tcl::dict::set TK_colour_map "dark grey" 169-169-169 |
||||
tcl::dict::set TK_colour_map "dark khaki" 189-183-107 |
||||
tcl::dict::set TK_colour_map "dark magenta" 139-0-139 |
||||
tcl::dict::set TK_colour_map "dark olive green" 85-107-47 |
||||
tcl::dict::set TK_colour_map "dark orange" 255-140-0 |
||||
tcl::dict::set TK_colour_map "dark orchid" 153-50-204 |
||||
tcl::dict::set TK_colour_map "dark red" 139-0-0 |
||||
tcl::dict::set TK_colour_map "dark salmon" 233-150-122 |
||||
tcl::dict::set TK_colour_map "dark sea green" 143-188-143 |
||||
tcl::dict::set TK_colour_map "dark slate blue" 72-61-139 |
||||
tcl::dict::set TK_colour_map "dark slate gray" 47-79-79 |
||||
tcl::dict::set TK_colour_map "dark slate grey" 47-79-79 |
||||
tcl::dict::set TK_colour_map "dark turquoise" 0-206-209 |
||||
tcl::dict::set TK_colour_map "dark violet" 148-0-211 |
||||
tcl::dict::set TK_colour_map DarkBlue 0-0-139 |
||||
tcl::dict::set TK_colour_map DarkCyan 0-139-139 |
||||
tcl::dict::set TK_colour_map DarkGoldenrod 184-134-11 |
||||
tcl::dict::set TK_colour_map DarkGoldenrod1 255-185-15 |
||||
tcl::dict::set TK_colour_map DarkGoldenrod2 238-173-14 |
||||
tcl::dict::set TK_colour_map DarkGoldenrod3 205-149-12 |
||||
tcl::dict::set TK_colour_map DarkGoldenrod4 139-101-8 |
||||
tcl::dict::set TK_colour_map DarkGray 169-169-169 |
||||
tcl::dict::set TK_colour_map DarkGreen 0-100-0 |
||||
tcl::dict::set TK_colour_map DarkGrey 169-169-169 |
||||
tcl::dict::set TK_colour_map DarkKhaki 189-183-107 |
||||
tcl::dict::set TK_colour_map DarkMagenta 139-0-139 |
||||
tcl::dict::set TK_colour_map DarkOliveGreen 85-107-47 |
||||
tcl::dict::set TK_colour_map DarkOliveGreen1 202-255-112 |
||||
tcl::dict::set TK_colour_map DarkOliveGreen2 188-238-104 |
||||
tcl::dict::set TK_colour_map DarkOliveGreen3 162-205-90 |
||||
tcl::dict::set TK_colour_map DarkOliveGreen4 110-139-61 |
||||
tcl::dict::set TK_colour_map DarkOrange 255-140-0 |
||||
tcl::dict::set TK_colour_map DarkOrange1 255-127-0 |
||||
tcl::dict::set TK_colour_map DarkOrange2 238-118-0 |
||||
tcl::dict::set TK_colour_map DarkOrange3 205-102-0 |
||||
tcl::dict::set TK_colour_map DarkOrange4 139-69-0 |
||||
tcl::dict::set TK_colour_map DarkOrchid 153-50-204 |
||||
tcl::dict::set TK_colour_map DarkOrchid1 191-62-255 |
||||
tcl::dict::set TK_colour_map DarkOrchid2 178-58-238 |
||||
tcl::dict::set TK_colour_map DarkOrchid3 154-50-205 |
||||
tcl::dict::set TK_colour_map DarkOrchid4 104-34-139 |
||||
tcl::dict::set TK_colour_map DarkRed 139-0-0 |
||||
tcl::dict::set TK_colour_map DarkSalmon 233-150-122 |
||||
tcl::dict::set TK_colour_map DarkSeaGreen 43-188-143 |
||||
tcl::dict::set TK_colour_map DarkSeaGreen1 193-255-193 |
||||
tcl::dict::set TK_colour_map DarkSeaGreen2 180-238-180 |
||||
tcl::dict::set TK_colour_map DarkSeaGreen3 155-205-155 |
||||
tcl::dict::set TK_colour_map DarkSeaGreen4 105-139-105 |
||||
tcl::dict::set TK_colour_map DarkSlateBlue 72-61-139 |
||||
tcl::dict::set TK_colour_map DarkSlateGray 47-79-79 |
||||
tcl::dict::set TK_colour_map DarkSlateGray1 151-255-255 |
||||
tcl::dict::set TK_colour_map DarkSlateGray2 141-238-238 |
||||
tcl::dict::set TK_colour_map DarkSlateGray3 121-205-205 |
||||
tcl::dict::set TK_colour_map DarkSlateGray4 82-139-139 |
||||
tcl::dict::set TK_colour_map DarkSlateGrey 47-79-79 |
||||
tcl::dict::set TK_colour_map DarkTurquoise 0-206-209 |
||||
tcl::dict::set TK_colour_map DarkViolet 148-0-211 |
||||
tcl::dict::set TK_colour_map "deep pink" 255-20-147 |
||||
tcl::dict::set TK_colour_map "deep sky blue" 0-191-255 |
||||
tcl::dict::set TK_colour_map DeepPink 255-20-147 |
||||
tcl::dict::set TK_colour_map DeepPink1 255-20-147 |
||||
tcl::dict::set TK_colour_map DeepPink2 238-18-137 |
||||
tcl::dict::set TK_colour_map DeepPink3 205-16-118 |
||||
tcl::dict::set TK_colour_map DeepPink4 139-10-80 |
||||
tcl::dict::set TK_colour_map DeepSkyBlue 0-191-255 |
||||
tcl::dict::set TK_colour_map DeepSkyBlue1 0-191-255 |
||||
tcl::dict::set TK_colour_map DeepSkyBlue2 0-178-238 |
||||
tcl::dict::set TK_colour_map DeepSkyBlue3 0-154-205 |
||||
tcl::dict::set TK_colour_map DeepSkyBlue4 0-104-139 |
||||
tcl::dict::set TK_colour_map "dim gray" 105-105-105 |
||||
tcl::dict::set TK_colour_map "dim grey" 105-105-105 |
||||
tcl::dict::set TK_colour_map DimGray 105-105-105 |
||||
tcl::dict::set TK_colour_map DimGrey 105-105-105 |
||||
tcl::dict::set TK_colour_map "dodger blue" 30-144-255 |
||||
tcl::dict::set TK_colour_map DodgerBlue 30-144-255 |
||||
tcl::dict::set TK_colour_map DodgerBlue1 30-144-255 |
||||
tcl::dict::set TK_colour_map DodgerBlue2 28-134-238 |
||||
tcl::dict::set TK_colour_map DodgerBlue3 24-116-205 |
||||
tcl::dict::set TK_colour_map DodgerBlue4 16-78-139 |
||||
tcl::dict::set TK_colour_map firebrick 178-34-34 |
||||
tcl::dict::set TK_colour_map firebrick1 255-48-48 |
||||
tcl::dict::set TK_colour_map firebrick2 238-44-44 |
||||
tcl::dict::set TK_colour_map firebrick3 205-38-38 |
||||
tcl::dict::set TK_colour_map firebrick4 139-26-26 |
||||
tcl::dict::set TK_colour_map "floral white" 255-250-240 |
||||
tcl::dict::set TK_colour_map FloralWhite 255-250-240 |
||||
tcl::dict::set TK_colour_map "forest green" 34-139-34 |
||||
tcl::dict::set TK_colour_map ForestGreen 34-139-34 |
||||
tcl::dict::set TK_colour_map fuchsia 255-0-255 |
||||
tcl::dict::set TK_colour_map gainsboro 220-220-220 |
||||
tcl::dict::set TK_colour_map "ghost white" 248-248-255 |
||||
tcl::dict::set TK_colour_map GhostWhite 248-248-255 |
||||
tcl::dict::set TK_colour_map gold 255-215-0 |
||||
tcl::dict::set TK_colour_map gold1 255-215-0 |
||||
tcl::dict::set TK_colour_map gold2 238-201-0 |
||||
tcl::dict::set TK_colour_map gold3 205-173-0 |
||||
tcl::dict::set TK_colour_map gold4 139-117-0 |
||||
tcl::dict::set TK_colour_map goldenrod 218-165-32 |
||||
tcl::dict::set TK_colour_map goldenrod1 255-193-37 |
||||
tcl::dict::set TK_colour_map goldenrod2 238-180-34 |
||||
tcl::dict::set TK_colour_map goldenrod3 205-155-29 |
||||
tcl::dict::set TK_colour_map goldenrod4 139-105-20 |
||||
tcl::dict::set TK_colour_map gray 128-128-128 |
||||
tcl::dict::set TK_colour_map gray0 0-0-0 |
||||
tcl::dict::set TK_colour_map gray1 3-3-3 |
||||
tcl::dict::set TK_colour_map gray2 5-5-5 |
||||
tcl::dict::set TK_colour_map gray3 8-8-8 |
||||
tcl::dict::set TK_colour_map gray4 10-10-10 |
||||
tcl::dict::set TK_colour_map gray5 13-13-13 |
||||
tcl::dict::set TK_colour_map gray6 15-15-15 |
||||
tcl::dict::set TK_colour_map gray7 18-18-18 |
||||
tcl::dict::set TK_colour_map gray8 20-20-20 |
||||
tcl::dict::set TK_colour_map gray9 23-23-23 |
||||
tcl::dict::set TK_colour_map gray10 26-26-26 |
||||
tcl::dict::set TK_colour_map gray11 28-28-28 |
||||
tcl::dict::set TK_colour_map gray12 31-31-31 |
||||
tcl::dict::set TK_colour_map gray13 33-33-33 |
||||
tcl::dict::set TK_colour_map gray14 36-36-36 |
||||
tcl::dict::set TK_colour_map gray15 38-38-38 |
||||
tcl::dict::set TK_colour_map gray16 41-41-41 |
||||
tcl::dict::set TK_colour_map gray17 43-43-43 |
||||
tcl::dict::set TK_colour_map gray18 46-46-46 |
||||
tcl::dict::set TK_colour_map gray19 48-48-48 |
||||
tcl::dict::set TK_colour_map gray20 51-51-51 |
||||
tcl::dict::set TK_colour_map gray21 54-54-54 |
||||
tcl::dict::set TK_colour_map gray22 56-56-56 |
||||
tcl::dict::set TK_colour_map gray23 59-59-59 |
||||
tcl::dict::set TK_colour_map gray24 61-61-61 |
||||
tcl::dict::set TK_colour_map gray25 64-64-64 |
||||
tcl::dict::set TK_colour_map gray26 66-66-66 |
||||
tcl::dict::set TK_colour_map gray27 69-69-69 |
||||
tcl::dict::set TK_colour_map gray28 71-71-71 |
||||
tcl::dict::set TK_colour_map gray29 74-74-74 |
||||
tcl::dict::set TK_colour_map gray30 77-77-77 |
||||
tcl::dict::set TK_colour_map gray31 79-79-79 |
||||
tcl::dict::set TK_colour_map gray32 82-82-82 |
||||
tcl::dict::set TK_colour_map gray33 84-84-84 |
||||
tcl::dict::set TK_colour_map gray34 87-87-87 |
||||
tcl::dict::set TK_colour_map gray35 89-89-89 |
||||
tcl::dict::set TK_colour_map gray36 92-92-92 |
||||
tcl::dict::set TK_colour_map gray37 94-94-94 |
||||
tcl::dict::set TK_colour_map gray38 97-97-97 |
||||
tcl::dict::set TK_colour_map gray39 99-99-99 |
||||
tcl::dict::set TK_colour_map gray40 102-102-102 |
||||
tcl::dict::set TK_colour_map gray41 105-105-105 |
||||
tcl::dict::set TK_colour_map gray42 107-107-107 |
||||
tcl::dict::set TK_colour_map gray43 110-110-110 |
||||
tcl::dict::set TK_colour_map gray44 112-112-112 |
||||
tcl::dict::set TK_colour_map gray45 115-115-115 |
||||
tcl::dict::set TK_colour_map gray46 117-117-117 |
||||
tcl::dict::set TK_colour_map gray47 120-120-120 |
||||
tcl::dict::set TK_colour_map gray48 122-122-122 |
||||
tcl::dict::set TK_colour_map gray49 125-125-125 |
||||
tcl::dict::set TK_colour_map gray50 127-127-127 |
||||
tcl::dict::set TK_colour_map gray51 130-130-130 |
||||
tcl::dict::set TK_colour_map gray52 133-133-133 |
||||
tcl::dict::set TK_colour_map gray53 135-135-135 |
||||
tcl::dict::set TK_colour_map gray54 138-138-138 |
||||
tcl::dict::set TK_colour_map gray55 140-140-140 |
||||
tcl::dict::set TK_colour_map gray56 143-143-143 |
||||
tcl::dict::set TK_colour_map gray57 145-145-145 |
||||
tcl::dict::set TK_colour_map gray58 148-148-148 |
||||
tcl::dict::set TK_colour_map gray59 150-150-150 |
||||
tcl::dict::set TK_colour_map gray60 153-153-153 |
||||
tcl::dict::set TK_colour_map gray61 156-156-156 |
||||
tcl::dict::set TK_colour_map gray62 158-158-158 |
||||
tcl::dict::set TK_colour_map gray63 161-161-161 |
||||
tcl::dict::set TK_colour_map gray64 163-163-163 |
||||
tcl::dict::set TK_colour_map gray65 166-166-166 |
||||
tcl::dict::set TK_colour_map gray66 168-168-168 |
||||
tcl::dict::set TK_colour_map gray67 171-171-171 |
||||
tcl::dict::set TK_colour_map gray68 173-173-173 |
||||
tcl::dict::set TK_colour_map gray69 176-176-176 |
||||
tcl::dict::set TK_colour_map gray70 179-179-179 |
||||
tcl::dict::set TK_colour_map gray71 181-181-181 |
||||
tcl::dict::set TK_colour_map gray72 184-184-184 |
||||
tcl::dict::set TK_colour_map gray73 186-186-186 |
||||
tcl::dict::set TK_colour_map gray74 189-189-189 |
||||
tcl::dict::set TK_colour_map gray75 191-191-191 |
||||
tcl::dict::set TK_colour_map gray76 194-194-194 |
||||
tcl::dict::set TK_colour_map gray77 196-196-196 |
||||
tcl::dict::set TK_colour_map gray78 199-199-199 |
||||
tcl::dict::set TK_colour_map gray79 201-201-201 |
||||
tcl::dict::set TK_colour_map gray80 204-204-204 |
||||
tcl::dict::set TK_colour_map gray81 207-207-207 |
||||
tcl::dict::set TK_colour_map gray82 209-209-209 |
||||
tcl::dict::set TK_colour_map gray83 212-212-212 |
||||
tcl::dict::set TK_colour_map gray84 214-214-214 |
||||
tcl::dict::set TK_colour_map gray85 217-217-217 |
||||
tcl::dict::set TK_colour_map gray86 219-219-219 |
||||
tcl::dict::set TK_colour_map gray87 222-222-222 |
||||
tcl::dict::set TK_colour_map gray88 224-224-224 |
||||
tcl::dict::set TK_colour_map gray89 227-227-227 |
||||
tcl::dict::set TK_colour_map gray90 229-229-229 |
||||
tcl::dict::set TK_colour_map gray91 232-232-232 |
||||
tcl::dict::set TK_colour_map gray92 235-235-235 |
||||
tcl::dict::set TK_colour_map gray93 237-237-237 |
||||
tcl::dict::set TK_colour_map gray94 240-240-240 |
||||
tcl::dict::set TK_colour_map gray95 242-242-242 |
||||
tcl::dict::set TK_colour_map gray96 245-245-245 |
||||
tcl::dict::set TK_colour_map gray97 247-247-247 |
||||
tcl::dict::set TK_colour_map gray98 250-250-250 |
||||
tcl::dict::set TK_colour_map gray99 252-252-252 |
||||
tcl::dict::set TK_colour_map gray100 255-255-255 |
||||
tcl::dict::set TK_colour_map green 0-128-0 |
||||
tcl::dict::set TK_colour_map "green yellow" 173-255-47 |
||||
tcl::dict::set TK_colour_map green1 0-255-0 |
||||
tcl::dict::set TK_colour_map green2 0-238-0 |
||||
tcl::dict::set TK_colour_map green3 0-205-0 |
||||
tcl::dict::set TK_colour_map green4 0-139-0 |
||||
tcl::dict::set TK_colour_map GreenYellow 173-255-47 |
||||
tcl::dict::set TK_colour_map grey 128-128-128 |
||||
tcl::dict::set TK_colour_map grey0 0-0-0 |
||||
tcl::dict::set TK_colour_map grey1 3-3-3 |
||||
tcl::dict::set TK_colour_map grey2 5-5-5 |
||||
tcl::dict::set TK_colour_map grey3 8-8-8 |
||||
tcl::dict::set TK_colour_map grey4 10-10-10 |
||||
tcl::dict::set TK_colour_map grey5 13-13-13 |
||||
tcl::dict::set TK_colour_map grey6 15-15-15 |
||||
tcl::dict::set TK_colour_map grey7 18-18-18 |
||||
tcl::dict::set TK_colour_map grey8 20-20-20 |
||||
tcl::dict::set TK_colour_map grey9 23-23-23 |
||||
tcl::dict::set TK_colour_map grey10 26-26-26 |
||||
tcl::dict::set TK_colour_map grey11 28-28-28 |
||||
tcl::dict::set TK_colour_map grey12 31-31-31 |
||||
tcl::dict::set TK_colour_map grey13 33-33-33 |
||||
tcl::dict::set TK_colour_map grey14 36-36-36 |
||||
tcl::dict::set TK_colour_map grey15 38-38-38 |
||||
tcl::dict::set TK_colour_map grey16 41-41-41 |
||||
tcl::dict::set TK_colour_map grey17 43-43-43 |
||||
tcl::dict::set TK_colour_map grey18 46-46-46 |
||||
tcl::dict::set TK_colour_map grey19 48-48-48 |
||||
tcl::dict::set TK_colour_map grey20 51-51-51 |
||||
tcl::dict::set TK_colour_map grey21 54-54-54 |
||||
tcl::dict::set TK_colour_map grey22 56-56-56 |
||||
tcl::dict::set TK_colour_map grey23 59-59-59 |
||||
tcl::dict::set TK_colour_map grey24 61-61-61 |
||||
tcl::dict::set TK_colour_map grey25 64-64-64 |
||||
tcl::dict::set TK_colour_map grey26 66-66-66 |
||||
tcl::dict::set TK_colour_map grey27 69-69-69 |
||||
tcl::dict::set TK_colour_map grey28 71-71-71 |
||||
tcl::dict::set TK_colour_map grey29 74-74-74 |
||||
tcl::dict::set TK_colour_map grey30 77-77-77 |
||||
tcl::dict::set TK_colour_map grey31 79-79-79 |
||||
tcl::dict::set TK_colour_map grey32 82-82-82 |
||||
tcl::dict::set TK_colour_map grey33 84-84-84 |
||||
tcl::dict::set TK_colour_map grey34 87-87-87 |
||||
tcl::dict::set TK_colour_map grey35 89-89-89 |
||||
tcl::dict::set TK_colour_map grey36 92-92-92 |
||||
tcl::dict::set TK_colour_map grey37 94-94-94 |
||||
tcl::dict::set TK_colour_map grey38 97-97-97 |
||||
tcl::dict::set TK_colour_map grey39 99-99-99 |
||||
tcl::dict::set TK_colour_map grey40 102-102-102 |
||||
tcl::dict::set TK_colour_map grey41 105-105-105 |
||||
tcl::dict::set TK_colour_map grey42 107-107-107 |
||||
tcl::dict::set TK_colour_map grey43 110-110-110 |
||||
tcl::dict::set TK_colour_map grey44 112-112-112 |
||||
tcl::dict::set TK_colour_map grey45 115-115-115 |
||||
tcl::dict::set TK_colour_map grey46 117-117-117 |
||||
tcl::dict::set TK_colour_map grey47 120-120-120 |
||||
tcl::dict::set TK_colour_map grey48 122-122-122 |
||||
tcl::dict::set TK_colour_map grey49 125-125-125 |
||||
tcl::dict::set TK_colour_map grey50 127-127-127 |
||||
tcl::dict::set TK_colour_map grey51 130-130-130 |
||||
tcl::dict::set TK_colour_map grey52 133-133-133 |
||||
tcl::dict::set TK_colour_map grey53 135-135-135 |
||||
tcl::dict::set TK_colour_map grey54 138-138-138 |
||||
tcl::dict::set TK_colour_map grey55 140-140-140 |
||||
tcl::dict::set TK_colour_map grey56 143-143-143 |
||||
tcl::dict::set TK_colour_map grey57 145-145-145 |
||||
tcl::dict::set TK_colour_map grey58 148-148-148 |
||||
tcl::dict::set TK_colour_map grey59 150-150-150 |
||||
tcl::dict::set TK_colour_map grey60 153-153-153 |
||||
tcl::dict::set TK_colour_map grey61 156-156-156 |
||||
tcl::dict::set TK_colour_map grey62 158-158-158 |
||||
tcl::dict::set TK_colour_map grey63 161-161-161 |
||||
tcl::dict::set TK_colour_map grey64 163-163-163 |
||||
tcl::dict::set TK_colour_map grey65 166-166-166 |
||||
tcl::dict::set TK_colour_map grey66 168-168-168 |
||||
tcl::dict::set TK_colour_map grey67 171-171-171 |
||||
tcl::dict::set TK_colour_map grey68 173-173-173 |
||||
tcl::dict::set TK_colour_map grey69 176-176-176 |
||||
tcl::dict::set TK_colour_map grey70 179-179-179 |
||||
tcl::dict::set TK_colour_map grey71 181-181-181 |
||||
tcl::dict::set TK_colour_map grey72 184-184-184 |
||||
tcl::dict::set TK_colour_map grey73 186-186-186 |
||||
tcl::dict::set TK_colour_map grey74 189-189-189 |
||||
tcl::dict::set TK_colour_map grey75 191-191-191 |
||||
tcl::dict::set TK_colour_map grey76 194-194-194 |
||||
tcl::dict::set TK_colour_map grey77 196-196-196 |
||||
tcl::dict::set TK_colour_map grey78 199-199-199 |
||||
tcl::dict::set TK_colour_map grey79 201-201-201 |
||||
tcl::dict::set TK_colour_map grey80 204-204-204 |
||||
tcl::dict::set TK_colour_map grey81 207-207-207 |
||||
tcl::dict::set TK_colour_map grey82 209-209-209 |
||||
tcl::dict::set TK_colour_map grey83 212-212-212 |
||||
tcl::dict::set TK_colour_map grey84 214-214-214 |
||||
tcl::dict::set TK_colour_map grey85 217-217-217 |
||||
tcl::dict::set TK_colour_map grey86 219-219-219 |
||||
tcl::dict::set TK_colour_map grey87 222-222-222 |
||||
tcl::dict::set TK_colour_map grey88 224-224-224 |
||||
tcl::dict::set TK_colour_map grey89 227-227-227 |
||||
tcl::dict::set TK_colour_map grey90 229-229-229 |
||||
tcl::dict::set TK_colour_map grey91 232-232-232 |
||||
tcl::dict::set TK_colour_map grey92 235-235-235 |
||||
tcl::dict::set TK_colour_map grey93 237-237-237 |
||||
tcl::dict::set TK_colour_map grey94 240-240-240 |
||||
tcl::dict::set TK_colour_map grey95 242-242-242 |
||||
tcl::dict::set TK_colour_map grey96 245-245-245 |
||||
tcl::dict::set TK_colour_map grey97 247-247-247 |
||||
tcl::dict::set TK_colour_map grey98 250-250-250 |
||||
tcl::dict::set TK_colour_map grey99 252-252-252 |
||||
tcl::dict::set TK_colour_map grey100 255-255-255 |
||||
tcl::dict::set TK_colour_map honeydew 240-255-240 |
||||
tcl::dict::set TK_colour_map honeydew1 240-255-240 |
||||
tcl::dict::set TK_colour_map honeydew2 224-238-224 |
||||
tcl::dict::set TK_colour_map honeydew3 193-205-193 |
||||
tcl::dict::set TK_colour_map honeydew4 131-139-131 |
||||
tcl::dict::set TK_colour_map "hot pink" 255-105-180 |
||||
tcl::dict::set TK_colour_map HotPink 255-105-180 |
||||
tcl::dict::set TK_colour_map HotPink1 255-110-180 |
||||
tcl::dict::set TK_colour_map HotPink2 238-106-167 |
||||
tcl::dict::set TK_colour_map HotPink3 205-96-144 |
||||
tcl::dict::set TK_colour_map HotPink4 139-58-98 |
||||
tcl::dict::set TK_colour_map "indian red" 205-92-92 |
||||
tcl::dict::set TK_colour_map IndianRed 205-92-92 |
||||
tcl::dict::set TK_colour_map IndianRed1 255-106-106 |
||||
tcl::dict::set TK_colour_map IndianRed2 238-99-99 |
||||
tcl::dict::set TK_colour_map IndianRed3 205-85-85 |
||||
tcl::dict::set TK_colour_map IndianRed4 139-58-58 |
||||
tcl::dict::set TK_colour_map indigo 75-0-130 |
||||
tcl::dict::set TK_colour_map ivory 255-255-240 |
||||
tcl::dict::set TK_colour_map ivory1 255-255-240 |
||||
tcl::dict::set TK_colour_map ivory2 238-238-224 |
||||
tcl::dict::set TK_colour_map ivory3 205-205-193 |
||||
tcl::dict::set TK_colour_map ivory4 139-139-131 |
||||
tcl::dict::set TK_colour_map khaki 240-230-140 |
||||
tcl::dict::set TK_colour_map khaki1 255-246-143 |
||||
tcl::dict::set TK_colour_map khaki2 238-230-133 |
||||
tcl::dict::set TK_colour_map khaki3 205-198-115 |
||||
tcl::dict::set TK_colour_map khaki4 139-134-78 |
||||
tcl::dict::set TK_colour_map lavender 230-230-250 |
||||
tcl::dict::set TK_colour_map "lavender blush" 255-240-245 |
||||
tcl::dict::set TK_colour_map LavenderBlush 255-240-245 |
||||
tcl::dict::set TK_colour_map LavenderBlush1 255-240-245 |
||||
tcl::dict::set TK_colour_map LavenderBlush2 238-224-229 |
||||
tcl::dict::set TK_colour_map LavenderBlush3 205-193-197 |
||||
tcl::dict::set TK_colour_map LavenderBlush4 139-131-134 |
||||
tcl::dict::set TK_colour_map "lawn green" 124-252-0 |
||||
tcl::dict::set TK_colour_map LawnGreen 124-252-0 |
||||
tcl::dict::set TK_colour_map "lemon chiffon" 255-250-205 |
||||
tcl::dict::set TK_colour_map LemonChiffon 255-250-205 |
||||
tcl::dict::set TK_colour_map LemonChiffon1 255-250-205 |
||||
tcl::dict::set TK_colour_map LemonChiffon2 238-233-191 |
||||
tcl::dict::set TK_colour_map LemonChiffon3 205-201-165 |
||||
tcl::dict::set TK_colour_map LemonChiffon4 139-137-112 |
||||
tcl::dict::set TK_colour_map "light blue" 173-216-230 |
||||
tcl::dict::set TK_colour_map "light coral" 240-128-128 |
||||
tcl::dict::set TK_colour_map "light cyan" 224-255-255 |
||||
tcl::dict::set TK_colour_map "light goldenrod" 238-221-130 |
||||
tcl::dict::set TK_colour_map "light goldenrod yellow" 250-250-210 |
||||
tcl::dict::set TK_colour_map "light gray" 211-211-211 |
||||
tcl::dict::set TK_colour_map "light green" 144-238-144 |
||||
tcl::dict::set TK_colour_map "light grey" 211-211-211 |
||||
tcl::dict::set TK_colour_map "light pink" 255-182-193 |
||||
tcl::dict::set TK_colour_map "light salmon" 255-160-122 |
||||
tcl::dict::set TK_colour_map "light sea green" 32-178-170 |
||||
tcl::dict::set TK_colour_map "light sky blue" 135-206-250 |
||||
tcl::dict::set TK_colour_map "light slate blue" 132-112-255 |
||||
tcl::dict::set TK_colour_map "light slate gray" 119-136-153 |
||||
tcl::dict::set TK_colour_map "light slate grey" 119-136-153 |
||||
tcl::dict::set TK_colour_map "light steel blue" 176-196-222 |
||||
tcl::dict::set TK_colour_map "light yellow" 255-255-224 |
||||
tcl::dict::set TK_colour_map LightBlue 173-216-230 |
||||
tcl::dict::set TK_colour_map LightBlue1 191-239-255 |
||||
tcl::dict::set TK_colour_map LightBlue2 178-223-238 |
||||
tcl::dict::set TK_colour_map LightBlue3 154-192-205 |
||||
tcl::dict::set TK_colour_map LightBlue4 104-131-139 |
||||
tcl::dict::set TK_colour_map LightCoral 240-128-128 |
||||
tcl::dict::set TK_colour_map LightCyan 224-255-255 |
||||
tcl::dict::set TK_colour_map LightCyan1 224-255-255 |
||||
tcl::dict::set TK_colour_map LightCyan2 209-238-238 |
||||
tcl::dict::set TK_colour_map LightCyan3 180-205-205 |
||||
tcl::dict::set TK_colour_map LightCyan4 122-139-139 |
||||
tcl::dict::set TK_colour_map LightGoldenrod 238-221-130 |
||||
tcl::dict::set TK_colour_map LightGoldenrod1 255-236-139 |
||||
tcl::dict::set TK_colour_map LightGoldenrod2 238-220-130 |
||||
tcl::dict::set TK_colour_map LightGoldenrod3 205-190-112 |
||||
tcl::dict::set TK_colour_map LightGoldenrod4 139-129-76 |
||||
tcl::dict::set TK_colour_map LightGoldenrodYellow 250-250-210 |
||||
tcl::dict::set TK_colour_map LightGray 211-211-211 |
||||
tcl::dict::set TK_colour_map LightGreen 144-238-144 |
||||
tcl::dict::set TK_colour_map LightGrey 211-211-211 |
||||
tcl::dict::set TK_colour_map LightPink 255-182-193 |
||||
tcl::dict::set TK_colour_map LightPink1 255-174-185 |
||||
tcl::dict::set TK_colour_map LightPink2 238-162-173 |
||||
tcl::dict::set TK_colour_map LightPink3 205-140-149 |
||||
tcl::dict::set TK_colour_map LightPink4 139-95-101 |
||||
tcl::dict::set TK_colour_map LightSalmon 255-160-122 |
||||
tcl::dict::set TK_colour_map LightSalmon1 255-160-122 |
||||
tcl::dict::set TK_colour_map LightSalmon2 238-149-114 |
||||
tcl::dict::set TK_colour_map LightSalmon3 205-129-98 |
||||
tcl::dict::set TK_colour_map LightSalmon4 139-87-66 |
||||
tcl::dict::set TK_colour_map LightSeaGreen 32-178-170 |
||||
tcl::dict::set TK_colour_map LightSkyBlue 135-206-250 |
||||
tcl::dict::set TK_colour_map LightSkyBlue1 176-226-255 |
||||
tcl::dict::set TK_colour_map LightSkyBlue2 164-211-238 |
||||
tcl::dict::set TK_colour_map LightSkyBlue3 141-182-205 |
||||
tcl::dict::set TK_colour_map LightSkyBlue4 96-123-139 |
||||
tcl::dict::set TK_colour_map LightSlateBlue 132-112-255 |
||||
tcl::dict::set TK_colour_map LightSlateGray 119-136-153 |
||||
tcl::dict::set TK_colour_map LightSlateGrey 119-136-153 |
||||
tcl::dict::set TK_colour_map LightSteelBlue 176-196-222 |
||||
tcl::dict::set TK_colour_map LightSteelBlue1 202-225-255 |
||||
tcl::dict::set TK_colour_map LightSteelBlue2 188-210-238 |
||||
tcl::dict::set TK_colour_map LightSteelBlue3 162-181-205 |
||||
tcl::dict::set TK_colour_map LightSteelBlue4 110-123-139 |
||||
tcl::dict::set TK_colour_map LightYellow 255-255-224 |
||||
tcl::dict::set TK_colour_map LightYellow1 255-255-224 |
||||
tcl::dict::set TK_colour_map LightYellow2 238-238-209 |
||||
tcl::dict::set TK_colour_map LightYellow3 205-205-180 |
||||
tcl::dict::set TK_colour_map LightYellow4 139-139-122 |
||||
tcl::dict::set TK_colour_map lime 0-255-0 |
||||
tcl::dict::set TK_colour_map "lime green" 50-205-50 |
||||
tcl::dict::set TK_colour_map LimeGreen 50-205-50 |
||||
tcl::dict::set TK_colour_map linen 250-240-230 |
||||
tcl::dict::set TK_colour_map magenta 255-0-255 |
||||
tcl::dict::set TK_colour_map magenta1 255-0-255 |
||||
tcl::dict::set TK_colour_map magenta2 238-0-238 |
||||
tcl::dict::set TK_colour_map magenta3 205-0-205 |
||||
tcl::dict::set TK_colour_map magenta4 139-0-139 |
||||
tcl::dict::set TK_colour_map maroon 128-0-0 |
||||
tcl::dict::set TK_colour_map maroon1 255-52-179 |
||||
tcl::dict::set TK_colour_map maroon2 238-48-167 |
||||
tcl::dict::set TK_colour_map maroon3 205-41-144 |
||||
tcl::dict::set TK_colour_map maroon4 139-28-98 |
||||
tcl::dict::set TK_colour_map "medium aquamarine" 102-205-170 |
||||
tcl::dict::set TK_colour_map "medium blue" 0-0-205 |
||||
tcl::dict::set TK_colour_map "medium orchid" 186-85-211 |
||||
tcl::dict::set TK_colour_map "medium purple" 147-112-219 |
||||
tcl::dict::set TK_colour_map "medium sea green" 60-179-113 |
||||
tcl::dict::set TK_colour_map "medium slate blue" 123-104-238 |
||||
tcl::dict::set TK_colour_map "medium spring green" 0-250-154 |
||||
tcl::dict::set TK_colour_map "medium turquoise" 72-209-204 |
||||
tcl::dict::set TK_colour_map "medium violet red" 199-21-133 |
||||
tcl::dict::set TK_colour_map MediumAquamarine 102-205-170 |
||||
tcl::dict::set TK_colour_map MediumBlue 0-0-205 |
||||
tcl::dict::set TK_colour_map MediumOrchid 186-85-211 |
||||
tcl::dict::set TK_colour_map MediumOrchid1 224-102-255 |
||||
tcl::dict::set TK_colour_map MediumOrchid2 209-95-238 |
||||
tcl::dict::set TK_colour_map MediumOrchid3 180-82-205 |
||||
tcl::dict::set TK_colour_map MediumOrchid4 122-55-139 |
||||
tcl::dict::set TK_colour_map MediumPurple 147-112-219 |
||||
tcl::dict::set TK_colour_map MediumPurple1 171-130-255 |
||||
tcl::dict::set TK_colour_map MediumPurple2 159-121-238 |
||||
tcl::dict::set TK_colour_map MediumPurple3 137-104-205 |
||||
tcl::dict::set TK_colour_map MediumPurple4 93-71-139 |
||||
tcl::dict::set TK_colour_map MediumSeaGreen 60-179-113 |
||||
tcl::dict::set TK_colour_map MediumSlateBlue 123-104-238 |
||||
tcl::dict::set TK_colour_map MediumSpringGreen 0-250-154 |
||||
tcl::dict::set TK_colour_map MediumTurquoise 72-209-204 |
||||
tcl::dict::set TK_colour_map MediumVioletRed 199-21-133 |
||||
tcl::dict::set TK_colour_map "midnight blue" 25-25-112 |
||||
tcl::dict::set TK_colour_map MidnightBlue 25-25-112 |
||||
tcl::dict::set TK_colour_map "mint cream" 245-255-250 |
||||
tcl::dict::set TK_colour_map MintCream 245-255-250 |
||||
tcl::dict::set TK_colour_map "misty rose" 255-228-225 |
||||
tcl::dict::set TK_colour_map MistyRose 255-228-225 |
||||
tcl::dict::set TK_colour_map MistyRose1 255-228-225 |
||||
tcl::dict::set TK_colour_map MistyRose2 238-213-210 |
||||
tcl::dict::set TK_colour_map MistyRose3 205-183-181 |
||||
tcl::dict::set TK_colour_map MistyRose4 139-125-123 |
||||
tcl::dict::set TK_colour_map moccasin 255-228-181 |
||||
tcl::dict::set TK_colour_map "navajo white" 255-222-173 |
||||
tcl::dict::set TK_colour_map NavajoWhite 255-222-173 |
||||
tcl::dict::set TK_colour_map NavajoWhite1 255-222-173 |
||||
tcl::dict::set TK_colour_map NavajoWhite2 238-207-161 |
||||
tcl::dict::set TK_colour_map NavajoWhite3 205-179-139 |
||||
tcl::dict::set TK_colour_map NavajoWhite4 139-121-94 |
||||
tcl::dict::set TK_colour_map navy 0-0-128 |
||||
tcl::dict::set TK_colour_map "navy blue" 0-0-128 |
||||
tcl::dict::set TK_colour_map NavyBlue 0-0-128 |
||||
tcl::dict::set TK_colour_map "old lace" 253-245-230 |
||||
tcl::dict::set TK_colour_map OldLace 253-245-230 |
||||
tcl::dict::set TK_colour_map olive 128-128-0 |
||||
tcl::dict::set TK_colour_map "olive drab" 107-142-35 |
||||
tcl::dict::set TK_colour_map OliveDrab 107-142-35 |
||||
tcl::dict::set TK_colour_map OliveDrab1 192-255-62 |
||||
tcl::dict::set TK_colour_map OliveDrab2 179-238-58 |
||||
tcl::dict::set TK_colour_map OliveDrab3 154-205-50 |
||||
tcl::dict::set TK_colour_map OliveDrab4 105-139-34 |
||||
tcl::dict::set TK_colour_map orange 255-165-0 |
||||
tcl::dict::set TK_colour_map "orange red" 255-69-0 |
||||
tcl::dict::set TK_colour_map orange1 255-165-0 |
||||
tcl::dict::set TK_colour_map orange2 238-154-0 |
||||
tcl::dict::set TK_colour_map orange3 205-133-0 |
||||
tcl::dict::set TK_colour_map orange4 139-90-0 |
||||
tcl::dict::set TK_colour_map OrangeRed 255-69-0 |
||||
tcl::dict::set TK_colour_map OrangeRed1 255-69-0 |
||||
tcl::dict::set TK_colour_map OrangeRed2 238-64-0 |
||||
tcl::dict::set TK_colour_map OrangeRed3 205-55-0 |
||||
tcl::dict::set TK_colour_map OrangeRed4 139-37-0 |
||||
tcl::dict::set TK_colour_map orchid 218-112-214 |
||||
tcl::dict::set TK_colour_map orchid1 255-131-250 |
||||
tcl::dict::set TK_colour_map orchid2 238-122-233 |
||||
tcl::dict::set TK_colour_map orchid3 205-105-201 |
||||
tcl::dict::set TK_colour_map orchid4 139-71-137 |
||||
tcl::dict::set TK_colour_map "pale goldenrod" 238-232-170 |
||||
tcl::dict::set TK_colour_map "pale green" 152-251-152 |
||||
tcl::dict::set TK_colour_map "pale turquoise" 175-238-238 |
||||
tcl::dict::set TK_colour_map "pale violet red" 219-112-147 |
||||
tcl::dict::set TK_colour_map PaleGoldenrod 238-232-170 |
||||
tcl::dict::set TK_colour_map PaleGreen 152-251-152 |
||||
tcl::dict::set TK_colour_map PaleGreen1 154-255-154 |
||||
tcl::dict::set TK_colour_map PaleGreen2 144-238-144 |
||||
tcl::dict::set TK_colour_map PaleGreen3 124-205-124 |
||||
tcl::dict::set TK_colour_map PaleGreen4 84-139-84 |
||||
tcl::dict::set TK_colour_map PaleTurquoise 175-238-238 |
||||
tcl::dict::set TK_colour_map PaleTurquoise1 187-255-255 |
||||
tcl::dict::set TK_colour_map PaleTurquoise2 174-238-238 |
||||
tcl::dict::set TK_colour_map PaleTurquoise3 150-205-205 |
||||
tcl::dict::set TK_colour_map PaleTurquoise4 102-139-139 |
||||
tcl::dict::set TK_colour_map PaleVioletRed 219-112-147 |
||||
tcl::dict::set TK_colour_map PaleVioletRed1 255-130-171 |
||||
tcl::dict::set TK_colour_map PaleVioletRed2 238-121-159 |
||||
tcl::dict::set TK_colour_map PaleVioletRed3 205-104-127 |
||||
tcl::dict::set TK_colour_map PaleVioletRed4 139-71-93 |
||||
tcl::dict::set TK_colour_map "papaya whip" 255-239-213 |
||||
tcl::dict::set TK_colour_map PapayaWhip 255-239-213 |
||||
tcl::dict::set TK_colour_map "peach puff" 255-218-185 |
||||
tcl::dict::set TK_colour_map PeachPuff 255-218-185 |
||||
tcl::dict::set TK_colour_map PeachPuff1 255-218-185 |
||||
tcl::dict::set TK_colour_map PeachPuff2 238-203-173 |
||||
tcl::dict::set TK_colour_map PeachPuff3 205-175-149 |
||||
tcl::dict::set TK_colour_map PeachPuff4 139-119-101 |
||||
tcl::dict::set TK_colour_map peru 205-133-63 |
||||
tcl::dict::set TK_colour_map pink 255-192-203 |
||||
tcl::dict::set TK_colour_map pink1 255-181-197 |
||||
tcl::dict::set TK_colour_map pink2 238-169-184 |
||||
tcl::dict::set TK_colour_map pink3 205-145-158 |
||||
tcl::dict::set TK_colour_map pink4 139-99-108 |
||||
tcl::dict::set TK_colour_map plum 221-160-221 |
||||
tcl::dict::set TK_colour_map plum1 255-187-255 |
||||
tcl::dict::set TK_colour_map plum2 238-174-238 |
||||
tcl::dict::set TK_colour_map plum3 205-150-205 |
||||
tcl::dict::set TK_colour_map plum4 139-102-139 |
||||
tcl::dict::set TK_colour_map "powder blue" 176-224-230 |
||||
tcl::dict::set TK_colour_map PowderBlue 176-224-230 |
||||
tcl::dict::set TK_colour_map purple 128-0-128 |
||||
tcl::dict::set TK_colour_map purple1 155-48-255 |
||||
tcl::dict::set TK_colour_map purple2 145-44-238 |
||||
tcl::dict::set TK_colour_map purple3 125-38-205 |
||||
tcl::dict::set TK_colour_map purple4 85-26-139 |
||||
tcl::dict::set TK_colour_map red 255-0-0 |
||||
tcl::dict::set TK_colour_map red1 255-0-0 |
||||
tcl::dict::set TK_colour_map red2 238-0-0 |
||||
tcl::dict::set TK_colour_map red3 205-0-0 |
||||
tcl::dict::set TK_colour_map red4 139-0-0 |
||||
tcl::dict::set TK_colour_map "rosy brown" 188-143-143 |
||||
tcl::dict::set TK_colour_map RosyBrown 188-143-143 |
||||
tcl::dict::set TK_colour_map RosyBrown1 255-193-193 |
||||
tcl::dict::set TK_colour_map RosyBrown2 238-180-180 |
||||
tcl::dict::set TK_colour_map RosyBrown3 205-155-155 |
||||
tcl::dict::set TK_colour_map RosyBrown4 139-105-105 |
||||
tcl::dict::set TK_colour_map "royal blue" 65-105-225 |
||||
tcl::dict::set TK_colour_map RoyalBlue 65-105-225 |
||||
tcl::dict::set TK_colour_map RoyalBlue1 72-118-255 |
||||
tcl::dict::set TK_colour_map RoyalBlue2 67-110-238 |
||||
tcl::dict::set TK_colour_map RoyalBlue3 58-95-205 |
||||
tcl::dict::set TK_colour_map RoyalBlue4 39-64-139 |
||||
tcl::dict::set TK_colour_map "saddle brown" 139-69-19 |
||||
tcl::dict::set TK_colour_map SaddleBrown 139-69-19 |
||||
tcl::dict::set TK_colour_map salmon 250-128-114 |
||||
tcl::dict::set TK_colour_map salmon1 255-140-105 |
||||
tcl::dict::set TK_colour_map salmon2 238-130-98 |
||||
tcl::dict::set TK_colour_map salmon3 205-112-84 |
||||
tcl::dict::set TK_colour_map salmon4 139-76-57 |
||||
tcl::dict::set TK_colour_map "sandy brown" 244-164-96 |
||||
tcl::dict::set TK_colour_map SandyBrown 244-164-96 |
||||
tcl::dict::set TK_colour_map "sea green" 46-139-87 |
||||
tcl::dict::set TK_colour_map SeaGreen 46-139-87 |
||||
tcl::dict::set TK_colour_map SeaGreen1 84-255-159 |
||||
tcl::dict::set TK_colour_map SeaGreen2 78-238-148 |
||||
tcl::dict::set TK_colour_map SeaGreen3 67-205-128 |
||||
tcl::dict::set TK_colour_map SeaGreen4 46-139-87 |
||||
tcl::dict::set TK_colour_map seashell 255-245-238 |
||||
tcl::dict::set TK_colour_map seashell1 255-245-238 |
||||
tcl::dict::set TK_colour_map seashell2 238-229-222 |
||||
tcl::dict::set TK_colour_map seashell3 205-197-191 |
||||
tcl::dict::set TK_colour_map seashell4 139-134-130 |
||||
tcl::dict::set TK_colour_map sienna 160-82-45 |
||||
tcl::dict::set TK_colour_map sienna1 255-130-71 |
||||
tcl::dict::set TK_colour_map sienna2 238-121-66 |
||||
tcl::dict::set TK_colour_map sienna3 205-104-57 |
||||
tcl::dict::set TK_colour_map sienna4 139-71-38 |
||||
tcl::dict::set TK_colour_map silver 192-192-192 |
||||
tcl::dict::set TK_colour_map "sky blue" 135-206-235 |
||||
tcl::dict::set TK_colour_map SkyBlue 135-206-235 |
||||
tcl::dict::set TK_colour_map SkyBlue1 135-206-255 |
||||
tcl::dict::set TK_colour_map SkyBlue2 126-192-238 |
||||
tcl::dict::set TK_colour_map SkyBlue3 108-166-205 |
||||
tcl::dict::set TK_colour_map SkyBlue4 74-112-139 |
||||
tcl::dict::set TK_colour_map "slate blue" 106-90-205 |
||||
tcl::dict::set TK_colour_map "slate gray" 112-128-144 |
||||
tcl::dict::set TK_colour_map "slate grey" 112-128-144 |
||||
tcl::dict::set TK_colour_map SlateBlue 106-90-205 |
||||
tcl::dict::set TK_colour_map SlateBlue1 131-111-255 |
||||
tcl::dict::set TK_colour_map SlateBlue2 122-103-238 |
||||
tcl::dict::set TK_colour_map SlateBlue3 105-89-205 |
||||
tcl::dict::set TK_colour_map SlateBlue4 71-60-139 |
||||
tcl::dict::set TK_colour_map SlateGray 112-128-144 |
||||
tcl::dict::set TK_colour_map SlateGray1 198-226-255 |
||||
tcl::dict::set TK_colour_map SlateGray2 185-211-238 |
||||
tcl::dict::set TK_colour_map SlateGray3 159-182-205 |
||||
tcl::dict::set TK_colour_map SlateGray4 108-123-139 |
||||
tcl::dict::set TK_colour_map SlateGrey 112-128-144 |
||||
tcl::dict::set TK_colour_map snow 255-250-250 |
||||
tcl::dict::set TK_colour_map snow1 255-250-250 |
||||
tcl::dict::set TK_colour_map snow2 238-233-233 |
||||
tcl::dict::set TK_colour_map snow3 205-201-201 |
||||
tcl::dict::set TK_colour_map snow4 139-137-137 |
||||
tcl::dict::set TK_colour_map "spring green" 0-255-127 |
||||
tcl::dict::set TK_colour_map SpringGreen 0-255-127 |
||||
tcl::dict::set TK_colour_map SpringGreen1 0-255-127 |
||||
tcl::dict::set TK_colour_map SpringGreen2 0-238-118 |
||||
tcl::dict::set TK_colour_map SpringGreen3 0-205-102 |
||||
tcl::dict::set TK_colour_map SpringGreen4 0-139-69 |
||||
tcl::dict::set TK_colour_map "steel blue" 70-130-180 |
||||
tcl::dict::set TK_colour_map SteelBlue 70-130-180 |
||||
tcl::dict::set TK_colour_map SteelBlue1 99-184-255 |
||||
tcl::dict::set TK_colour_map SteelBlue2 92-172-238 |
||||
tcl::dict::set TK_colour_map SteelBlue3 79-148-205 |
||||
tcl::dict::set TK_colour_map SteelBlue4 54-100-139 |
||||
tcl::dict::set TK_colour_map tan 210-180-140 |
||||
tcl::dict::set TK_colour_map tan1 255-165-79 |
||||
tcl::dict::set TK_colour_map tan2 238-154-73 |
||||
tcl::dict::set TK_colour_map tan3 205-133-63 |
||||
tcl::dict::set TK_colour_map tan4 139-90-43 |
||||
tcl::dict::set TK_colour_map teal 0-128-128 |
||||
tcl::dict::set TK_colour_map thistle 216-191-216 |
||||
tcl::dict::set TK_colour_map thistle1 255-225-255 |
||||
tcl::dict::set TK_colour_map thistle2 238-210-238 |
||||
tcl::dict::set TK_colour_map thistle3 205-181-205 |
||||
tcl::dict::set TK_colour_map thistle4 139-123-139 |
||||
tcl::dict::set TK_colour_map tomato 255-99-71 |
||||
tcl::dict::set TK_colour_map tomato1 255-99-71 |
||||
tcl::dict::set TK_colour_map tomato2 238-92-66 |
||||
tcl::dict::set TK_colour_map tomato3 205-79-57 |
||||
tcl::dict::set TK_colour_map tomato4 139-54-38 |
||||
tcl::dict::set TK_colour_map turquoise 64-224-208 |
||||
tcl::dict::set TK_colour_map turquoise1 0-245-255 |
||||
tcl::dict::set TK_colour_map turquoise2 0-229-238 |
||||
tcl::dict::set TK_colour_map turquoise3 0-197-205 |
||||
tcl::dict::set TK_colour_map turquoise4 0-134-139 |
||||
tcl::dict::set TK_colour_map violet 238-130-238 |
||||
tcl::dict::set TK_colour_map "violet red" 208-32-144 |
||||
tcl::dict::set TK_colour_map VioletRed 208-32-144 |
||||
tcl::dict::set TK_colour_map VioletRed1 255-62-150 |
||||
tcl::dict::set TK_colour_map VioletRed2 238-58-140 |
||||
tcl::dict::set TK_colour_map VioletRed3 205-50-120 |
||||
tcl::dict::set TK_colour_map VioletRed4 139-34-82 |
||||
tcl::dict::set TK_colour_map wheat 245-222-179 |
||||
tcl::dict::set TK_colour_map wheat1 255-231-186 |
||||
tcl::dict::set TK_colour_map wheat2 238-216-174 |
||||
tcl::dict::set TK_colour_map wheat3 205-186-150 |
||||
tcl::dict::set TK_colour_map wheat4 139-126-102 |
||||
tcl::dict::set TK_colour_map white 255-255-255 |
||||
tcl::dict::set TK_colour_map "white smoke" 245-245-245 |
||||
tcl::dict::set TK_colour_map WhiteSmoke 245-245-245 |
||||
tcl::dict::set TK_colour_map yellow 255-255-0 |
||||
tcl::dict::set TK_colour_map "yellow green" 154-205-50 |
||||
tcl::dict::set TK_colour_map yellow1 255-255-0 |
||||
tcl::dict::set TK_colour_map yellow2 238-238-0 |
||||
tcl::dict::set TK_colour_map yellow3 205-205-0 |
||||
tcl::dict::set TK_colour_map yellow4 139-139-0 |
||||
tcl::dict::set TK_colour_map YellowGreen 154-205-50 |
||||
|
||||
variable TK_colour_map_lookup ;#same dict but with lower-case versions added |
||||
set TK_colour_map_lookup $TK_colour_map |
||||
dict for {key val} $TK_colour_map { |
||||
dict set TK_colour_map_lookup [tcl::string::tolower $key] $val ;#no need to test if already present - just set. |
||||
} |
||||
|
||||
variable TK_colour_map_reverse [dict create] |
||||
dict for {key val} $TK_colour_map { |
||||
dict lappend TK_colour_map_reverse $val $key |
||||
} |
||||
|
||||
#using same order as inital colour map |
||||
variable TK_colour_map_merge [dict create] |
||||
set seen_names [dict create] |
||||
dict for {key val} $TK_colour_map { |
||||
if {[dict exists $seen_names $key]} { |
||||
continue |
||||
} |
||||
set allnames [dict get $TK_colour_map_reverse $val] |
||||
set names [list] |
||||
foreach n $allnames { |
||||
if {$n ne $key} { |
||||
lappend names $n |
||||
} |
||||
} |
||||
dict set TK_colour_map_merge $key [dict create colour $val names $names] |
||||
foreach n $names { |
||||
dict set seen_names $n 1 |
||||
} |
||||
} |
||||
unset seen_names |
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace ::punk::ansi::colourmap ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval ::punk::ansi::colourmap::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace ::punk::ansi::colourmap::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::ansi::colourmap::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::ansi::colourmap |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::ansi::colourmap [tcl::namespace::eval ::punk::ansi::colourmap { |
||||
variable pkg ::punk::ansi::colourmap |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,424 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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::assertion 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::assertion 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] |
||||
#[require punk::assertion] |
||||
#[keywords module assertion assert debug] |
||||
#[description] |
||||
#[para] The punk::assertion library has the same semantics as Tcllib's control::assert library for the assert command itself. |
||||
#[para] The main difference is the way in which assert is enabled/disabled in namespaces. |
||||
#[para] Due to commands such as 'namespace path' - the assert command could be available in arbitrary namespaces unrelated by tree structure to namespaces where assert has been directly imported. |
||||
#[para] punk::assertion::active 0|1 allows activating and deactivating assertions in any namespace where the assert command is available - but only affecting the activations state of the namespace in which it is called. |
||||
#[para] If such a non-primary assertion namespace never had active set to 0 or 1 - then it will activate/deactivate when the namespace corresponding to the found assert command (primary) is activated/deactivated. |
||||
#[para] Once marked active or inactive - such a non-primary namespace will no longer follow the primary |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::assertion |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::assertion |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::assertion::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::assertion::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 ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin |
||||
tcl::namespace::eval punk::assertion::primary { |
||||
#tcl::namespace::export {[a-z]*} |
||||
tcl::namespace::export assertActive assertInactive |
||||
proc assertActive {expr args} { |
||||
|
||||
set code [catch {uplevel 1 [list expr $expr]} res] |
||||
if {$code} { |
||||
return -code $code $res |
||||
} |
||||
if {![tcl::string::is boolean -strict $res]} { |
||||
return -code error "invalid boolean expression: $expr" |
||||
} |
||||
|
||||
if {$res} {return} |
||||
|
||||
if {[llength $args]} { |
||||
#set msg "[join $args]" |
||||
set msg "$args punk::assertion failed expr $expr" |
||||
} else { |
||||
set msg "punk::assertion failed expr $expr" ;#give a clue in the default msg about which assert lib is in use |
||||
} |
||||
|
||||
upvar ::punk::assertion::CallbackCmd CallbackCmd |
||||
# Might want to catch this |
||||
tcl::namespace::eval :: $CallbackCmd [list $msg] |
||||
} |
||||
proc assertInactive args {} |
||||
|
||||
} |
||||
tcl::namespace::eval punk::assertion::secondary { |
||||
tcl::namespace::export * |
||||
#we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. |
||||
proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] |
||||
proc assertInactive args {} |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::assertion { |
||||
variable CallbackCmd [list return -code error] |
||||
|
||||
#puts --------AAA |
||||
#*very* slow in safe interp - why? |
||||
#tcl::namespace::import ::punk::assertion::primary::assertActive |
||||
|
||||
proc do_ns_import {} { |
||||
uplevel 1 [list tcl::namespace::import ::punk::assertion::primary::assertActive] |
||||
} |
||||
do_ns_import |
||||
#puts --------BBB |
||||
rename assertActive assert |
||||
|
||||
} |
||||
|
||||
|
||||
tcl::namespace::eval punk::assertion { |
||||
tcl::namespace::export * |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::assertion}] |
||||
#[para] Core API functions for punk::assertion |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
#like tcllib's control::assert - we are limited to the same callback for all namespaces. |
||||
#review - a per namespace - or per assert command callback may be tricky to do performantly. |
||||
#Would probably involve rewriting the proc body - otherwise we have a runtime penalty in the assert of looking it up. |
||||
proc callback {args} { |
||||
#set nscaller [uplevel 1 [list namespace current]] |
||||
#set which_assert [namespace eval $nscaller {namespace which assert}] |
||||
|
||||
upvar ::punk::assertion::CallbackCmd cb |
||||
set n [llength $args] |
||||
if {$n > 1} { |
||||
return -code error "wrong # args: should be\ |
||||
\"[lindex [tcl::info::level 0] 0] ?command?\"" |
||||
} |
||||
if {$n} { |
||||
set cb [lindex $args 0] |
||||
return |
||||
} |
||||
return $cb |
||||
} |
||||
|
||||
proc active {{on_off ""}} { |
||||
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||
set which_assert [tcl::namespace::eval $nscaller {tcl::namespace::which assert}] |
||||
#puts "nscaller:'$nscaller'" |
||||
#puts "which_assert: $which_assert" |
||||
|
||||
if {$on_off eq ""} { |
||||
if {$which_assert eq ""} {return 0} |
||||
set assertorigin [tcl::namespace::origin $which_assert] |
||||
#puts "ns which assert: $which_assert" |
||||
#puts "ns origin assert: $assertorigin" |
||||
return [expr {"assertActive" eq [tcl::namespace::tail $assertorigin]}] |
||||
} |
||||
if {![tcl::string::is boolean -strict $on_off]} { |
||||
error "invalid boolean value : $on_off" |
||||
} else { |
||||
set info_command [tcl::namespace::eval $nscaller {tcl::info::commands assert}] |
||||
if {$on_off} { |
||||
#Enable it in calling namespace |
||||
if {"assert" eq $info_command} { |
||||
#There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) |
||||
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||
tcl::namespace::eval $nscaller { |
||||
set assertorigin [tcl::namespace::origin assert] |
||||
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||
switch -- $assertorigin_ns { |
||||
::punk::assertion { |
||||
#original import - switch to primary origin |
||||
rename assert {} |
||||
tcl::namespace::import ::punk::assertion::primary::assertActive |
||||
rename assertActive assert |
||||
} |
||||
::punk::assertion::primary - ::punk::assertion::secondary { |
||||
#keep using from same origin ns |
||||
rename assert {} |
||||
tcl::namespace::import ${assertorigin_ns}::assertActive |
||||
rename assertActive assert |
||||
} |
||||
default { |
||||
error "The assert command in this namespace is not from punk::assertion package. Use the enable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||
} |
||||
} |
||||
} |
||||
return 1 |
||||
} else { |
||||
#assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace |
||||
tcl::namespace::eval $nscaller { |
||||
set assertorigin [tcl::namespace::origin assert] |
||||
if {[tcl::string::match ::punk::assertion::* $assertorigin]} { |
||||
tcl::namespace::import ::punk::assertion::secondary::assertActive |
||||
rename assertActive assert |
||||
} else { |
||||
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||
} |
||||
} |
||||
return 1 |
||||
} |
||||
|
||||
} else { |
||||
#no assert command reachable |
||||
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||
return 0 |
||||
} |
||||
} else { |
||||
#Disable |
||||
if {"assert" eq $info_command} { |
||||
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||
#assert is present in callers NS |
||||
tcl::namespace::eval $nscaller { |
||||
set assertorigin [tcl::namespace::origin assert] |
||||
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||
switch -glob -- $assertorigin_ns { |
||||
::punk::assertion { |
||||
#original import |
||||
rename assert {} |
||||
tcl::namespace::import punk::assertion::primary::assertInactive |
||||
rename assertInactive assert |
||||
} |
||||
::punk::assertion::primary - ::punk::assertion::secondary { |
||||
#keep using from same origin ns |
||||
rename assert {} |
||||
tcl::namespace::import ${assertorigin_ns}::assertInactive |
||||
rename assertInactive assert |
||||
} |
||||
default { |
||||
error "The assert command in this namespace is not from punk::assertion package. Use the disable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||
} |
||||
} |
||||
} |
||||
return 0 |
||||
} else { |
||||
#assert not present in callers NS - first install of secondary (if assert is from punk::assertion::*) |
||||
tcl::namespace::eval $nscaller { |
||||
set assertorigin [tcl::namespace::origin assert] |
||||
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||
if {[tcl::string::match ::punk::assertion::* $assertorigin]} { |
||||
tcl::namespace::import ::punk::assertion::secondary::assertInactive |
||||
rename assertInactive assert |
||||
} else { |
||||
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
} else { |
||||
#no assert command reachable |
||||
#If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path |
||||
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||
return 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::assertion ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::assertion::lib { |
||||
tcl::namespace::export * |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::assertion::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::assertion::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
tcl::namespace::eval punk::assertion::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::assertion::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
#Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version |
||||
#nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system |
||||
proc nsprefix {{nspath {}}} { |
||||
#normalize the common case of :::: |
||||
set nspath [tcl::string::map [list :::: ::] $nspath] |
||||
set rawprefix [tcl::string::range $nspath 0 end-[tcl::string::length [nstail $nspath]]] |
||||
if {$rawprefix eq "::"} { |
||||
return $rawprefix |
||||
} else { |
||||
if {[tcl::string::match *:: $rawprefix]} { |
||||
return [tcl::string::range $rawprefix 0 end-2] |
||||
} else { |
||||
return $rawprefix |
||||
} |
||||
#return [tcl::string::trimright $rawprefix :] |
||||
} |
||||
} |
||||
#see also punk::ns - keep in sync |
||||
proc nstail {nspath args} { |
||||
#normalize the common case of :::: |
||||
set nspath [tcl::string::map [list :::: ::] $nspath] |
||||
set mapped [tcl::string::map [list :: \u0FFF] $nspath] |
||||
set parts [split $mapped \u0FFF] |
||||
|
||||
set defaults [list -strict 0] |
||||
set opts [tcl::dict::merge $defaults $args] |
||||
set strict [tcl::dict::get $opts -strict] |
||||
|
||||
if {$strict} { |
||||
foreach p $parts { |
||||
if {[tcl::string::match :* $p]} { |
||||
error "nstail unpaired colon ':' in $nspath" |
||||
} |
||||
} |
||||
} |
||||
#e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. |
||||
return [lindex $parts end] |
||||
} |
||||
proc nsjoin {prefix name} { |
||||
if {[tcl::string::match ::* $name]} { |
||||
if {"$prefix" ne ""} { |
||||
error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" |
||||
} |
||||
return $name |
||||
} |
||||
if {"$prefix" eq "::"} { |
||||
return ::$name |
||||
} |
||||
#if {"$name" eq ""} { |
||||
# return $prefix |
||||
#} |
||||
#nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string |
||||
return ${prefix}::$name |
||||
} |
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::assertion [tcl::namespace::eval punk::assertion { |
||||
variable pkg punk::assertion |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,696 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::cap 0 0.1.0] |
||||
#[copyright "2023 JMNoble - BSD licensed"] |
||||
#[titledesc {capability provider and handler plugin system}] |
||||
#[moddesc {punk capabilities plugin system}] |
||||
#[require punk::cap] |
||||
#[description] |
||||
#[keywords module capability plugin] |
||||
#[section Overview] |
||||
#[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. |
||||
#[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters |
||||
#[subsection Concepts] |
||||
#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API |
||||
# |
||||
#[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data |
||||
# registered (or not) using register_capabilityname <capname> <capnamespace> |
||||
# |
||||
#[para][term {capability provider}] - a package which registers as providing one or more capablities. |
||||
#[para]registered using register_package <pkg> <capabilitylist> |
||||
#the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability |
||||
#A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. |
||||
|
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require oolib |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::cap { |
||||
variable pkgcapsdeclared [tcl::dict::create] |
||||
variable pkgcapsaccepted [tcl::dict::create] |
||||
variable caps [tcl::dict::create] |
||||
namespace eval class { |
||||
if {[tcl::info::commands ::punk::cap::class::interface_caphandler.registry] eq ""} { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::class}] |
||||
#[para] class definitions |
||||
#[list_begin itemized] [comment {- punk::cap::class groupings -}] |
||||
# [item] |
||||
# [para] [emph {handler_classes}] |
||||
# [list_begin enumerated] |
||||
|
||||
oo::class create ::punk::cap::class::interface_caphandler.registry { |
||||
#*** !doctools |
||||
#[enum] CLASS [class interface_caphandler.registry] |
||||
#[list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
method pkg_register {pkg capname capdict fullcapabilitylist} { |
||||
#*** !doctools |
||||
#[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] |
||||
#handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid |
||||
#overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. |
||||
return 1 ;#default to permit |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
#*** !doctools |
||||
#[call class::interface_caphandler.registry [method pkg_unregister] [arg pkg]] |
||||
return ;#unregistration return is ignored - review |
||||
} |
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
oo::class create ::punk::cap::class::interface_caphandler.sysapi { |
||||
#*** !doctools |
||||
#[enum] CLASS [class interface_caphandler.sysapi] |
||||
#[list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
#*** !doctools |
||||
# [list_end] [comment {- end enumeration handler classes -}] |
||||
|
||||
#*** !doctools |
||||
# [item] |
||||
# [para] [emph {provider_classes}] |
||||
# [list_begin enumerated] |
||||
|
||||
#Provider classes |
||||
oo::class create ::punk::cap::class::interface_capprovider.registration { |
||||
#*** !doctools |
||||
# [enum] CLASS [class interface_cappprovider.registration] |
||||
# [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. |
||||
# [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration |
||||
# [para]Example code for your provider package to evaluate within its namespace: |
||||
# [example { |
||||
#namespace eval capsystem { |
||||
# if {[info commands capprovider.registration] eq ""} { |
||||
# punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
# oo::objdefine capprovider.registration { |
||||
# method get_declarations {} { |
||||
# set decls [list] |
||||
# lappend decls [list punk.templates {relpath ../templates}] |
||||
# lappend decls [list another_capability_name {somekey blah key2 etc}] |
||||
# return $decls |
||||
# } |
||||
# } |
||||
# } |
||||
#} |
||||
#}] |
||||
#[para] The above example declares that your package can be registered as a provider for the capabilities named 'punk.templates' and 'another_capability_name' |
||||
# [list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
method get_declarations {} { |
||||
#*** |
||||
#[call class::interface_capprovider.registration [method get_declarations]] |
||||
#[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. |
||||
# There must be at least one 2-element list in the result for the provider to be registerable. |
||||
#[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. |
||||
#[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. |
||||
error "interface_capprovider.registration not implemented by provider" |
||||
} |
||||
#*** !doctools |
||||
# [list_end] |
||||
} |
||||
|
||||
oo::class create ::punk::cap::class::interface_capprovider.provider { |
||||
#*** !doctools |
||||
# [enum] CLASS [class interface_capprovider.provider] |
||||
# [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] |
||||
# [example { |
||||
# namespace eval mypackages::providerpkg { |
||||
# punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg |
||||
# } |
||||
# }] |
||||
# [list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
variable provider_pkg |
||||
variable registrationobj |
||||
constructor {providerpkg} { |
||||
#*** !doctools |
||||
#[call class::interface_capprovider.provider [method constructor] [arg providerpkg]] |
||||
variable provider_pkg |
||||
if {$providerpkg in {"" "::"}} { |
||||
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg'" |
||||
} |
||||
if {![namespace exists ::$providerpkg]} { |
||||
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg' - matching namespace not found" |
||||
} |
||||
|
||||
set registrationobj ::${providerpkg}::capsystem::capprovider.registration |
||||
if {[tcl::info::commands $registrationobj] eq ""} { |
||||
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider" |
||||
} |
||||
|
||||
#review - what are we trying to achieve here? |
||||
set provider_pkg [tcl::string::trim $providerpkg ""] |
||||
} |
||||
method register {{capabilityname_glob *}} { |
||||
#*** !doctools |
||||
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||
#[call class::interface_capprovider.provider [method register] [opt capabilityname_glob]] |
||||
# |
||||
#[para]This is the mechanism by which a user of your provider package will register your package as a provider of the capability named. |
||||
# |
||||
#[para]A user of your provider may elect to register all your declared capabilities: |
||||
#[example { |
||||
# package require mypackages::providerpkg |
||||
# mypackages::providerpkg::provider register * |
||||
#}] |
||||
#[para] Or a specific capability may be registered: |
||||
#[example { |
||||
# package require mypackages::providerpkg |
||||
# mypackages::providerpkg::provider register another_capability_name |
||||
#}] |
||||
# |
||||
variable provider_pkg |
||||
set all_decls [$registrationobj get_declarations] |
||||
set register_decls [lsearch -all -inline -index 0 $all_decls $capabilityname_glob] |
||||
punk::cap::register_package $provider_pkg $register_decls |
||||
} |
||||
method capabilities {} { |
||||
#*** !doctools |
||||
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||
#[call class::interface_capprovider.provider [method capabilities]] |
||||
#[para] return a list of capabilities supported by this provider package |
||||
variable provider_pkg |
||||
variable registrationobj |
||||
|
||||
set capabilities [list] |
||||
set decls [$registrationobj get_declarations] |
||||
foreach decl $decls { |
||||
lassign $decl capname capdict |
||||
if {$capname ni $capabilities} { |
||||
lappend capabilities $capname |
||||
} |
||||
} |
||||
return $capabilities |
||||
} |
||||
#*** !doctools |
||||
# [list_end] [comment {- end class definitions -}] |
||||
} |
||||
#*** !doctools |
||||
# [list_end] [comment {- end enumeration provider_classes }] |
||||
#[list_end] [comment {- end itemized list punk::cap::class groupings -}] |
||||
} |
||||
} ;# end namespace class |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap}] |
||||
#[para] Main punk::cap API for client programs interested in using capability handler packages and associated (registered) provider packages |
||||
#[list_begin definitions] |
||||
|
||||
#Not all capability names have to be registered. |
||||
#A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. |
||||
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. |
||||
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. |
||||
proc register_capabilityname {capname capnamespace} { |
||||
#puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" |
||||
variable caps |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
if {$capnamespace ne ""} { |
||||
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace |
||||
if {![tcl::string::match ::* $capnamespace]} { |
||||
set capnamespace ::$capnamespace |
||||
} |
||||
} |
||||
#allow register of existing capname iff there is no current handler |
||||
#as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package |
||||
#we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers |
||||
if {[set hdlr [capability_get_handler $capname]] ne ""} { |
||||
puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" |
||||
return |
||||
} |
||||
#assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. |
||||
tcl::dict::set caps $capname handler $capnamespace |
||||
if {![tcl::dict::exists $caps $capname providers]} { |
||||
tcl::dict::set caps $capname providers [list] |
||||
} |
||||
if {[llength [set providers [tcl::dict::get $caps $capname providers]]]} { |
||||
#some provider(s) were in place before the handler was registered |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
foreach pkg $providers { |
||||
set fullcapabilitylist [tcl::dict::get $pkgcapsdeclared $pkg] |
||||
set capname_capabilitylist [lsearch -all -inline -index 0 $fullcapabilitylist $capname] |
||||
foreach capspec $capname_capabilitylist { |
||||
lassign $capspec cn capdict |
||||
#if {$cn ne $capname} { |
||||
# continue |
||||
#} |
||||
if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} { |
||||
puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider" |
||||
puts stderr "error message:" |
||||
puts stderr $do_register |
||||
set do_register 0 |
||||
} |
||||
|
||||
set list_accepted [tcl::dict::get $pkgcapsaccepted $pkg] |
||||
if {$do_register} { |
||||
if {$capspec ni $list_accepted} { |
||||
tcl::dict::lappend pkgcapsaccepted $pkg $capspec |
||||
} |
||||
} else { |
||||
set posn [lsearch $list_accepted $capspec] |
||||
if {$posn >=0} { |
||||
set list_accepted [lreplace $list_accepted $posn $posn] |
||||
tcl::dict::set pkgcapsaccepted $pkg $list_accepted |
||||
} |
||||
} |
||||
} |
||||
#check if any accepted for this cap and remove from caps as necessary |
||||
set count 0 |
||||
foreach accepted_capspec [tcl::dict::get $pkgcapsaccepted $pkg] { |
||||
if {[lindex $accepted_capspec 0] eq $capname} { |
||||
incr count |
||||
} |
||||
} |
||||
if {$count == 0} { |
||||
set pkgposn [lsearch $providers $pkg] |
||||
if {$pkgposn >= 0} { |
||||
set updated_providers [lreplace $providers $posn $posn] |
||||
tcl::dict::set caps $capname providers $updated_providers |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
proc capability_exists {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_exists] [arg capname]] |
||||
# Return a boolean indicating if the named capability exists (0|1) |
||||
variable caps |
||||
return [tcl::dict::exists $caps $capname] |
||||
} |
||||
proc capability_has_handler {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_has_handler] [arg capname]] |
||||
#Return a boolean indicating if the named capability has a handler package installed (0|1) |
||||
variable caps |
||||
return [expr {[tcl::dict::exists $caps $capname handler] && [tcl::dict::get $caps $capname handler] ne ""}] |
||||
} |
||||
proc capability_get_handler {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_get_handler] [arg capname]] |
||||
#Return the base namespace of the active handler package for the named capability. |
||||
#[para] The base namespace for a handler will always be the package name, but prefixed with :: |
||||
variable caps |
||||
if {[tcl::dict::exists $caps $capname]} { |
||||
return [tcl::dict::get $caps $capname handler] |
||||
} |
||||
return "" |
||||
} |
||||
proc call_handler {capname args} { |
||||
if {[set handler [capability_get_handler $capname]] eq ""} { |
||||
error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" |
||||
} |
||||
set obj ${handler}::api_$capname |
||||
$obj [lindex $args 0] {*}[lrange $args 1 end] |
||||
} |
||||
proc get_providers {capname} { |
||||
variable caps |
||||
if {[tcl::dict::exists $caps $capname]} { |
||||
return [tcl::dict::get $caps $capname providers] |
||||
} |
||||
return [list] |
||||
} |
||||
|
||||
#register package with arbitrary capnames from capabilitylist |
||||
#The registered pkg is a module that provides some service to that capname. Possibly just data members or possibly an implementation of an API, that the capability will use. |
||||
proc register_package {pkg capabilitylist args} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
variable caps |
||||
set opts [dict create\ |
||||
-nowarnings false |
||||
] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-nowarnings { |
||||
tcl::dict::set opts $k $v |
||||
} |
||||
default { |
||||
error "Unrecognized option $k. Known options [tcl::dict::keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
set warnings [expr {! [tcl::dict::get $opts -nowarnings]}] |
||||
|
||||
if {[tcl::string::match ::* $pkg]} { |
||||
set pkg [tcl::string::range $pkg 2 end] |
||||
} |
||||
if {[tcl::dict::exists $pkgcapsaccepted $pkg]} { |
||||
set pkg_already_accepted [tcl::dict::get $pkgcapsaccepted $pkg] |
||||
} else { |
||||
set pkg_already_accepted [list] |
||||
} |
||||
package require $pkg |
||||
set providerapi ::${pkg}::provider |
||||
if {[tcl::info::commands $providerapi] eq ""} { |
||||
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)" |
||||
} |
||||
set defined_caps [$providerapi capabilities] |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
set capabilitylist_count [llength $capabilitylist] |
||||
set accepted_count 0 |
||||
set errorlist [list];# list of dicts |
||||
set warninglist [list] |
||||
foreach capspec $capabilitylist { |
||||
lassign $capspec capname capdict |
||||
|
||||
if {$warnings} { |
||||
if {$capname ni $defined_caps} { |
||||
puts stderr "WARNING: pkg '$pkg' doesn't declare support for capability '$capname'." |
||||
} |
||||
} |
||||
if {[llength $capname] !=1} { |
||||
puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" |
||||
set reason "First element of capspec not a single-word name" |
||||
lappend errorlist [tcl::dict::create msg $reason capspec $capspec] |
||||
continue |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" |
||||
set reason "The second element of the capspec isn't a valid dict" |
||||
lappend errorlist [tcl::dict::create msg $reason capspec $capspec] |
||||
continue |
||||
} |
||||
if {$capspec in $pkg_already_accepted} { |
||||
#review - multiple handlers? if so - will need to record which handler(s) accepted the capspec |
||||
if {$warnings} { |
||||
puts stderr "WARNING: register_package pkg $pkg already has capspec marked as accepted: $capspec" |
||||
} |
||||
lappend warninglist [tcl::dict::create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec] |
||||
continue |
||||
} |
||||
if {[tcl::dict::exists $caps $capname]} { |
||||
set cap_pkgs [tcl::dict::get $caps $capname providers] |
||||
} else { |
||||
dict set caps $capname [tcl::dict::create handler "" providers [list]] |
||||
set cap_pkgs [list] |
||||
} |
||||
#todo - if there's a caphandler - call it's init/validation callback for the pkg |
||||
set do_register 1 ;#default assumption unless vetoed by handler |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
#Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg |
||||
set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] |
||||
} |
||||
if {$do_register} { |
||||
if {$pkg ni $cap_pkgs} { |
||||
lappend cap_pkgs $pkg |
||||
tcl::dict::set caps $capname providers $cap_pkgs |
||||
} |
||||
tcl::dict::lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry |
||||
} |
||||
} |
||||
#another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append - but check not already present |
||||
#dict lappend pkgcapsdeclared $pkg $capabilitylist |
||||
if {[tcl::dict::exists $pkgcapsdeclared $pkg]} { |
||||
#review - untested |
||||
set mergecapspecs [tcl::dict::get $pkgcapsdeclared $pkg] |
||||
foreach spec $capabilitylist { |
||||
if {$spec ni $mergecapspecs} { |
||||
lappend mergecapspecs $spec |
||||
} |
||||
} |
||||
tcl::dict::set pkgcapsdeclared $pkg $mergecapspecs |
||||
} else { |
||||
tcl::dict::set pkgcapsdeclared $pkg $capabilitylist |
||||
} |
||||
set resultdict [list num_capabilities $capabilitylist_count num_accepted $accepted_count] |
||||
if {[llength $errorlist]} { |
||||
tcl::dict::set resultdict errors $errorlist |
||||
} |
||||
if {[llength $warninglist]} { |
||||
tcl::dict::set resultdict warnings $warninglist |
||||
} |
||||
return $resultdict |
||||
} |
||||
|
||||
#todo! |
||||
proc unregister_package {pkg {capname *}} { |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcapsdeclared $pkg] |
||||
foreach c $capabilitylist { |
||||
set do_unregister 1 |
||||
lassign $c capname _capdict |
||||
set cap_info [dict get $caps $capname] |
||||
set pkglist [dict get $cap_info providers] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
#review |
||||
# it seems not useful to allow the callback to block this unregister action |
||||
#the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter |
||||
#vetoing unregister would make this more complex for no particular advantage |
||||
#if per dataset deregistration required this should probably be a separate thing |
||||
$capreg pkg_unregister $pkg $capname |
||||
} |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname providers $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcapsdeclared $pkg |
||||
} |
||||
} |
||||
|
||||
proc pkgcap {pkg {capsearch}} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||
set accepted "" |
||||
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||
set accepted [lsearch -all -inline -glob -index 0 [dict get $pkgcapsaccepted $pkg] $capsearch] |
||||
} |
||||
return [dict create declared [lsearch -all -inline -glob -index 0 [dict get $pkgcapsdeclared $pkg] $capsearch] accepted $accepted] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc pkgcaps {} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
set result [dict create] |
||||
foreach {pkg capsdeclared} $pkgcapsdeclared { |
||||
set accepted "" |
||||
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||
set accepted [dict get $pkgcapsaccepted $pkg] |
||||
} |
||||
dict set result $pkg declared $capsdeclared |
||||
dict set result $pkg accepted $accepted |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc capability {capname} { |
||||
variable caps |
||||
if {[dict exists $caps $capname]} { |
||||
return [dict get $caps $capname] |
||||
} |
||||
return "" |
||||
} |
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set capnames [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach capname $capnames { |
||||
lappend cap_list [list $capname [dict get $caps $capname]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
proc capabilitynames {{glob *}} { |
||||
variable caps |
||||
return [lsort [dict keys $caps $glob]] |
||||
} |
||||
#return only those capnames which have at least one provider |
||||
proc capabilitynames_provided {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
if {[llength [dict get $caps $k providers]] > 0} { |
||||
lappend cap_list $k |
||||
} |
||||
} |
||||
return $cap_list |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {- end definitions for namespace punk::cap -}] |
||||
|
||||
namespace eval advanced { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::advanced}] |
||||
#[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. |
||||
#[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. |
||||
#[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. |
||||
#[list_begin definitions] |
||||
|
||||
proc promote_provider {pkg} { |
||||
#*** !doctools |
||||
# [call advanced::[fun promote_provider] [arg pkg]] |
||||
#[para]Move the named provider package to the preferred end of the list (tail). |
||||
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||
#[para] |
||||
#[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs |
||||
#[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded |
||||
#e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities <capname> |
||||
#[para]The order of providers will be the order the packages were loaded & registered |
||||
#[para]the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) |
||||
#[para]Each capability handler could and should implement specific preferencing methods within its own API if finer control needed. |
||||
#In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. |
||||
#[para]As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - |
||||
# it only allows putting the pkgs to the head or tail of the lists. |
||||
#[para]Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcapsdeclared] > 1} { |
||||
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcapsdeclared $pkg |
||||
dict set pkgcapsdeclared $pkg $pkginfo |
||||
dict for {cap cap_info} $caps { |
||||
set cap_pkgs [dict get $cap_info providers] |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap providers $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_provider {pkg} { |
||||
#*** !doctools |
||||
# [call advanced::[fun demote_provider] [arg pkg]] |
||||
#[para]Move the named provider package to the preferred end of the list (tail). |
||||
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcapsdeclared] > 1} { |
||||
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcapsdeclared $pkg |
||||
dict set pkgcapsdeclared $pkg $pkginfo |
||||
set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] |
||||
dict for {cap cap_info} $caps { |
||||
set cap_pkgs [dict get $cap_info providers] |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap providers $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[section Internal] |
||||
|
||||
namespace eval capsystem { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::capsystem}] |
||||
#[para] Internal functions used to communicate between punk::cap and capability handlers |
||||
#[list_begin definitions] |
||||
proc get_caphandler_registry {capname} { |
||||
set ns [::punk::cap::capability_get_handler $capname]::capsystem |
||||
if {[namespace exists ${ns}]} { |
||||
if {[info command ${ns}::caphandler.registry] ne ""} { |
||||
if {[info object isa object ${ns}::caphandler.registry]} { |
||||
return ${ns}::caphandler.registry |
||||
} |
||||
} |
||||
} |
||||
return "" |
||||
} |
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
variable pkg punk::cap |
||||
set version 0.1.0 |
||||
variable README.md [string map [list %pkg% $pkg %ver% $version] { |
||||
# punk capabilities system |
||||
## pkg: %pkg% version: %ver% |
||||
|
||||
punk::cap base namespace |
||||
}] |
||||
return $version |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
File diff suppressed because it is too large
Load Diff
@ -1,670 +0,0 @@
|
||||
|
||||
tcl::namespace::eval punk::config { |
||||
variable configdata [dict create] ;#key on config names. At least default, startup, running |
||||
|
||||
#variable startup ;#include env overrides |
||||
#variable running |
||||
|
||||
variable punk_env_vars |
||||
variable other_env_vars |
||||
|
||||
variable vars |
||||
|
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
namespace eval punk {namespace export config} |
||||
|
||||
proc _homedir {} { |
||||
if {[info exists ::env(HOME)]} { |
||||
set home [file normalize $::env(HOME)] |
||||
} else { |
||||
#not available on 8.6? ok will error out here. |
||||
set home [file tildeexpand ~] |
||||
} |
||||
return $home |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::config::dir |
||||
@cmd -name punk::config::dir -help\ |
||||
"Get the path for the default config folder |
||||
Config files are in toml format. |
||||
|
||||
The XDG_CONFIG_HOME env var is the preferred |
||||
choice of location. |
||||
A folder under the user's home directory, |
||||
at .config/punk/shell is chosen if |
||||
XDG_CONFIG_HOME is not configured. |
||||
" |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-quiet -type none -help\ |
||||
"Suppress warning given when the folder does |
||||
not yet exist" |
||||
@values -min 0 -max 0 |
||||
}] |
||||
proc dir {args} { |
||||
#set be_quiet [dict exists $received -quiet] |
||||
if {"-quiet" in $args} { |
||||
set be_quiet 1 |
||||
} else { |
||||
set be_quiet 0 |
||||
} |
||||
|
||||
set was_noisy 0 |
||||
|
||||
set config_home [punk::config::configure running xdg_config_home] |
||||
|
||||
set config_dir [file join $config_home punk shell] |
||||
|
||||
if {!$be_quiet && ![file exists $config_dir]} { |
||||
set msg "punk::shell data storage folder at $config_dir does not yet exist." |
||||
puts stderr $msg |
||||
set was_noisy 1 |
||||
} |
||||
|
||||
if {!$be_quiet && $was_noisy} { |
||||
puts stderr "punk::config::dir - call with -quiet option to suppress these messages" |
||||
} |
||||
return $config_dir |
||||
|
||||
#if {[info exists ::env(XDG_CONFIG_HOME)]} { |
||||
# set config_home $::env(XDG_CONFIG_HOME) |
||||
#} else { |
||||
# set config_home [file join [_homedir] .config] |
||||
# if {!$be_quiet} { |
||||
# puts stderr "Environment variable XDG_CONFIG_HOME does not exist - consider setting it if $config_home is not a suitable location" |
||||
# set was_noisy 1 |
||||
# } |
||||
#} |
||||
#if {!$be_quiet && ![file exists $config_home]} { |
||||
# #parent folder for 'punk' config dir doesn't exist |
||||
# set msg "configuration location (XDG_CONFIG_HOME or ~/.config) $config_home does not yet exist" |
||||
# append msg \n " - please create it and/or set XDG_CONFIG_HOME env var." |
||||
# puts stderr $msg |
||||
# set was_noisy 1 |
||||
#} |
||||
#set config_dir [file join $config_home punk shell] |
||||
#if {!$be_quiet && ![file exists $config_dir]} { |
||||
# set msg "punk::shell data storage folder at $config_dir does not yet exist." |
||||
# append msg \n " It will be created if api_context_save is called without specifying an alternate location." |
||||
# puts stderr $msg |
||||
# set was_noisy 1 |
||||
#} |
||||
#if {!$be_quiet && $was_noisy} { |
||||
# puts stderr "punk::config::dir - call with -quiet option to suppress these messages" |
||||
#} |
||||
#return [file join $configdir config.toml] |
||||
} |
||||
|
||||
#todo - XDG_DATA_HOME etc |
||||
#https://specifications.freedesktop.org/basedir-spec/latest/ |
||||
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ |
||||
|
||||
proc init {} { |
||||
variable configdata |
||||
|
||||
#variable defaults |
||||
#variable startup |
||||
#variable running |
||||
variable punk_env_vars |
||||
variable punk_env_vars_config |
||||
variable other_env_vars |
||||
variable other_env_vars_config |
||||
|
||||
set exename "" |
||||
catch { |
||||
#catch for safe interps |
||||
#safe base will return empty string, ordinary safe interp will raise error |
||||
set exename [tcl::info::nameofexecutable] |
||||
} |
||||
if {$exename ne ""} { |
||||
set exefolder [file dirname $exename] |
||||
#default file logs to logs folder at same level as exe if writable, or empty string |
||||
set log_folder [file normalize $exefolder/../logs] ;#~2ms |
||||
#tcl::dict::set startup scriptlib $exefolder/scriptlib |
||||
#tcl::dict::set startup apps $exefolder/../../punkapps |
||||
|
||||
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc |
||||
set default_scriptlib $exefolder/scriptlib |
||||
set default_apps $exefolder/../../punkapps |
||||
if {[file isdirectory $log_folder] && [file writable $log_folder]} { |
||||
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
set default_logfile_stdout $log_folder/repl-exec-stdout.txt |
||||
set default_logfile_stderr $log_folder/repl-exec-stderr.txt |
||||
} else { |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
} else { |
||||
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island |
||||
#review - todo? |
||||
#tcl::dict::set startup scriptlib "" |
||||
#tcl::dict::set startup apps "" |
||||
set default_scriptlib "" |
||||
set default_apps "" |
||||
set default_logfile_stdout "" |
||||
set default_logfile_stderr "" |
||||
} |
||||
|
||||
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run |
||||
|
||||
#optional channel transforms on stdout/stderr. |
||||
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands |
||||
#If no distinction necessary - should use default_color_<chan> |
||||
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation. |
||||
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default |
||||
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc) |
||||
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only |
||||
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. |
||||
#set default_color_stderr "red bold" |
||||
#set default_color_stderr "web-lightsalmon" |
||||
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive |
||||
set default_color_stderr_repl "" ;#during repl call only |
||||
|
||||
set homedir "" |
||||
if {[catch { |
||||
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp |
||||
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp |
||||
set homedir [file home] |
||||
} errM]} { |
||||
#tcl 8.6 doesn't have file home.. try again |
||||
if {[info exists ::env(HOME)]} { |
||||
set homedir $::env(HOME) |
||||
} |
||||
} |
||||
|
||||
|
||||
# per user xdg vars |
||||
# --- |
||||
set default_xdg_config_home "" ;#config data - portable |
||||
set default_xdg_data_home "" ;#data the user likely to want to be portable |
||||
set default_xdg_cache_home "" ;#local cache |
||||
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home |
||||
# --- |
||||
set default_xdg_data_dirs "" ;#non-user specific |
||||
#xdg_config_dirs ? |
||||
#xdg_runtime_dir ? |
||||
|
||||
|
||||
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent) |
||||
#(safe interp generally won't have access to ::env either) |
||||
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent. |
||||
if {$homedir ne ""} { |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them. |
||||
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment) |
||||
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do. |
||||
if {[info exists ::env(APPDATA)]} { |
||||
#Typical existing/default value for env(APPDATA) on windows is c:\Users\<username>\AppData\Roaming |
||||
set default_xdg_config_home $::env(APPDATA) |
||||
} |
||||
|
||||
#The xdg_cache_home should be kept local |
||||
if {[info exists ::env(LOCALAPPDATA)]} { |
||||
#Typical existing/default value for env(APPDATA) on windows is c:\Users\<username>\AppData\Local |
||||
set default_xdg_data_home $::env(LOCALAPPDATA) |
||||
set default_xdg_cache_home $::env(LOCALAPPDATA) |
||||
set default_xdg_state_home $::env(LOCALAPPDATA) |
||||
} |
||||
|
||||
if {[info exists ::env(PROGRAMDATA)]} { |
||||
#- equiv env(ALLUSERSPROFILE) ? |
||||
set default_xdg_data_dirs $::env(PROGRAMDATA) |
||||
} |
||||
|
||||
} else { |
||||
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html |
||||
set default_xdg_config_home [file join $homedir .config] |
||||
set default_xdg_data_home [file join $homedir .local share] |
||||
set default_xdg_cache_home [file join $homedir .cache] |
||||
set default_xdg_state_home [file join $homedir .local state] |
||||
set default_xdg_data_dirs /usr/local/share |
||||
} |
||||
} |
||||
|
||||
dict set configdata defaults [dict create\ |
||||
apps $default_apps\ |
||||
config "startup"\ |
||||
configset "main"\ |
||||
scriptlib $default_scriptlib\ |
||||
color_stdout $default_color_stdout\ |
||||
color_stdout_repl $default_color_stdout_repl\ |
||||
color_stderr $default_color_stderr\ |
||||
color_stderr_repl $default_color_stderr_repl\ |
||||
logfile_stdout $default_logfile_stdout\ |
||||
logfile_stderr $default_logfile_stderr\ |
||||
logfile_active 0\ |
||||
syslog_stdout "127.0.0.1:514"\ |
||||
syslog_stderr "127.0.0.1:514"\ |
||||
syslog_active 0\ |
||||
auto_exec_mechanism exec\ |
||||
auto_noexec 0\ |
||||
xdg_config_home $default_xdg_config_home\ |
||||
xdg_data_home $default_xdg_data_home\ |
||||
xdg_cache_home $default_xdg_cache_home\ |
||||
xdg_state_home $default_xdg_state_home\ |
||||
xdg_data_dirs $default_xdg_data_dirs\ |
||||
theme_posh_override ""\ |
||||
posh_theme ""\ |
||||
posh_themes_path ""\ |
||||
] |
||||
|
||||
dict set configdata startup [dict get $configdata defaults] |
||||
#load values from saved config file - $xdg_config_home/punk/punk.config ? |
||||
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines. |
||||
#that's possibly ok for the PUNK_ vars |
||||
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config? |
||||
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence? |
||||
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden |
||||
#- requiring user to manually unset any unwanted env vars when launching? |
||||
|
||||
#we are likely to want the saved configs for subshells/decks to override them however. |
||||
|
||||
#todo - load/save config file |
||||
|
||||
#todo - define which configvars are settable in env |
||||
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) |
||||
set punk_env_vars_config [dict create \ |
||||
PUNK_APPS {type pathlist}\ |
||||
PUNK_CONFIG {type string}\ |
||||
PUNK_CONFIGSET {type string}\ |
||||
PUNK_SCRIPTLIB {type string}\ |
||||
PUNK_AUTO_EXEC_MECHANISM {type string}\ |
||||
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ |
||||
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\ |
||||
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\ |
||||
PUNK_LOGFILE_STDOUT {type string}\ |
||||
PUNK_LOGFILE_STDERR {type string}\ |
||||
PUNK_LOGFILE_ACTIVE {type string}\ |
||||
PUNK_SYSLOG_STDOUT {type string}\ |
||||
PUNK_SYSLOG_STDERR {type string}\ |
||||
PUNK_SYSLOG_ACTIVE {type string}\ |
||||
PUNK_THEME_POSH_OVERRIDE {type string}\ |
||||
] |
||||
set punk_env_vars [dict keys $punk_env_vars_config] |
||||
|
||||
#override with env vars if set |
||||
foreach {evar varinfo} $punk_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
#e.g PUNK_SCRIPTLIB -> scriptlib |
||||
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] |
||||
if {$vartype eq "pathlist"} { |
||||
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system |
||||
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. |
||||
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. |
||||
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. |
||||
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting |
||||
# - but some programs have been known to split this value on colon anyway, which breaks things on windows. |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set configdata startup $varname $final |
||||
} else { |
||||
tcl::dict::set configdata startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# https://no-color.org |
||||
#if {[info exists ::env(NO_COLOR)]} { |
||||
# if {$::env(NO_COLOR) ne ""} { |
||||
# set colour_disabled 1 |
||||
# } |
||||
#} |
||||
set other_env_vars_config [dict create\ |
||||
NO_COLOR {type string}\ |
||||
XDG_CONFIG_HOME {type string}\ |
||||
XDG_DATA_HOME {type string}\ |
||||
XDG_CACHE_HOME {type string}\ |
||||
XDG_STATE_HOME {type string}\ |
||||
XDG_DATA_DIRS {type pathlist}\ |
||||
POSH_THEME {type string}\ |
||||
POSH_THEMES_PATH {type string}\ |
||||
TCLLIBPATH {type string}\ |
||||
] |
||||
lassign [split [info tclversion] .] tclmajorv tclminorv |
||||
#don't rely on lseq or punk::lib for now.. |
||||
set relevant_minors [list] |
||||
for {set i 0} {$i <= $tclminorv} {incr i} { |
||||
lappend relevant_minors $i |
||||
} |
||||
foreach minor $relevant_minors { |
||||
set vname TCL${tclmajorv}_${minor}_TM_PATH |
||||
if {$minor eq $tclminorv || [info exists ::env($vname)]} { |
||||
dict set other_env_vars_config $vname {type string} |
||||
} |
||||
} |
||||
set other_env_vars [dict keys $other_env_vars_config] |
||||
|
||||
foreach {evar varinfo} $other_env_vars_config { |
||||
if {[info exists ::env($evar)]} { |
||||
set vartype [dict get $varinfo type] |
||||
set f [set ::env($evar)] |
||||
if {$f ne "default"} { |
||||
set varname [tcl::string::tolower $evar] |
||||
if {$vartype eq "pathlist"} { |
||||
set paths [split $f $::tcl_platform(pathSeparator)] |
||||
set final [list] |
||||
#eliminate empty values (leading or trailing or extraneous separators) |
||||
foreach p $paths { |
||||
if {[tcl::string::trim $p] ne ""} { |
||||
lappend final $p |
||||
} |
||||
} |
||||
tcl::dict::set configdata startup $varname $final |
||||
} else { |
||||
tcl::dict::set configdata startup $varname $f |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
set config_home [dict get $configdata startup xdg_config_home] |
||||
|
||||
if {![file exists $config_home]} { |
||||
puts stderr "punk::config::init creating punk shell config dir: $config_home" |
||||
if {[catch {file mkdir $config_home} errM]} { |
||||
puts stderr "punk::config::init failed to create dir at $config_home\n$errM" |
||||
} |
||||
} |
||||
|
||||
set configset [dict get $configdata defaults configset] |
||||
set config [dict get $configdata defaults config] |
||||
|
||||
set startupfile [file join $config_home $configset $config.toml] |
||||
if {![file exists $startupfile]} { |
||||
puts stderr "punk::config::init creating punk shell config file: $config for configset: $configset" |
||||
puts stderr "(todo)" |
||||
} |
||||
|
||||
#unset -nocomplain vars |
||||
|
||||
#todo |
||||
set running [tcl::dict::create] |
||||
dict set configdata running [tcl::dict::merge $running [dict get $configdata startup]] |
||||
} |
||||
|
||||
#todo |
||||
proc Apply {config} { |
||||
variable configdata |
||||
puts stderr "punk::config::Apply partially implemented" |
||||
set configname [string map {-config ""} $config] |
||||
if {$configname in {startup running}} { |
||||
set applyconfig [dict get $configdata $configname] |
||||
|
||||
if {[dict exists $applyconfig auto_noexec]} { |
||||
set auto [dict get $applyconfig auto_noexec] |
||||
if {![string is boolean -strict $auto]} { |
||||
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" |
||||
} |
||||
if {$auto} { |
||||
set ::auto_noexec 1 |
||||
} else { |
||||
#puts "auto_noexec false" |
||||
unset -nocomplain ::auto_noexec |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
error "no config named '$config' found" |
||||
} |
||||
return "apply done" |
||||
} |
||||
|
||||
#todo - consider how to divide up settings, categories, 'devices', decks etc |
||||
proc get_running_global {varname} { |
||||
variable configdata |
||||
set running [dict get $configdata running] |
||||
if {[dict exists $running $varname]} { |
||||
return [dict get $running $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in running config" |
||||
} |
||||
proc get_startup_global {varname} { |
||||
variable configdata |
||||
set startup [dict get $configdata startup] |
||||
if {[dict exists $startup $varname]} { |
||||
return [dict get $startup $varname] |
||||
} |
||||
error "No such global configuration item '$varname' found in startup config" |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::config::get |
||||
@cmd -name punk::config::get -help\ |
||||
"Get configuration values from a config. |
||||
Accepts globs eg XDG*" |
||||
@leaders -min 1 -max 1 |
||||
#todo - load more whichconfig choices? |
||||
whichconfig -type any -choices {config startup-configuration running-configuration} |
||||
@values -min 0 -max -1 |
||||
globkey -type string -default * -optional 1 -multiple 1 |
||||
}] |
||||
proc get {args} { |
||||
set argd [punk::args::parse $args withid ::punk::config::get] |
||||
lassign [dict values $argd] leaders opts values received solos |
||||
set whichconfig [dict get $leaders whichconfig] |
||||
set globs [dict get $values globkey] ;#list |
||||
|
||||
variable configdata |
||||
|
||||
switch -- $whichconfig { |
||||
config - startup-configuration { |
||||
#review 'config' ?? |
||||
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs |
||||
set configrecords [dict get $configdata startup] |
||||
} |
||||
running-configuration { |
||||
set configrecords [dict get $configdata running] |
||||
} |
||||
default { |
||||
error "Unknown config name '$whichconfig' - try startup or running" |
||||
} |
||||
} |
||||
if {"*" in $globs} { |
||||
return $configrecords |
||||
} else { |
||||
set keys [list] |
||||
foreach g $globs { |
||||
lappend keys {*}[dict keys $configrecords [string tolower $g]] ;#review tolower? |
||||
} |
||||
|
||||
set filtered [dict create] |
||||
foreach k $keys { |
||||
dict set filtered $k [dict get $configrecords $k] |
||||
} |
||||
return $filtered |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::config::configure |
||||
@cmd -name punk::config::configure -help\ |
||||
"Get/set configuration values from a config" |
||||
@leaders -min 1 -max 1 |
||||
whichconfig -type any -choices {defaults startup-configuration running-configuration} |
||||
@values -min 0 -max 2 |
||||
key -type string -optional 1 |
||||
newvalue -optional 1 |
||||
}] |
||||
proc configure {args} { |
||||
set argd [punk::args::parse $args withid ::punk::config::configure] |
||||
lassign [dict values $argd] leaders opts values received solos |
||||
set whichconfig [dict get $argd leaders whichconfig] |
||||
variable configdata |
||||
if {"running" ni [dict keys $configdata]} { |
||||
init |
||||
Apply startup |
||||
} |
||||
switch -- $whichconfig { |
||||
defaults { |
||||
set configrecords [dict get $configdata defaults] |
||||
} |
||||
startup-configuration { |
||||
set configrecords [dict get $configdata startup] |
||||
} |
||||
running-configuration { |
||||
set configrecords [dict get $configdata running] |
||||
} |
||||
} |
||||
if {![dict exists $received key]} { |
||||
return $configrecords |
||||
} |
||||
set key [dict get $values key] |
||||
if {![dict exists $received newvalue]} { |
||||
return [dict get $configrecords $key] |
||||
} |
||||
error "setting value not implemented" |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}} |
||||
set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@dynamic |
||||
@id -id ::punk::config::show |
||||
@cmd -name punk::config::get -help\ |
||||
"Display configuration values from a config. |
||||
Accepts globs eg XDG*" |
||||
@leaders -min 1 -max 1 |
||||
}\ |
||||
{${$DYN_GET_LEADERS}}\ |
||||
"@values -min 0 -max -1"\ |
||||
{${$DYN_GET_VALUES}}\ |
||||
] |
||||
} |
||||
proc show {args} { |
||||
#todo - tables for console |
||||
set configrecords [punk::config::get {*}$args] |
||||
return [punk::lib::showdict $configrecords] |
||||
} |
||||
|
||||
|
||||
|
||||
#e.g |
||||
# copy running-config startup-config |
||||
# copy startup-config test-config.cfg |
||||
# copy backup-config.cfg running-config |
||||
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite |
||||
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration |
||||
proc copy {args} { |
||||
set argdef { |
||||
@id -id ::punk::config::copy |
||||
@cmd -name punk::config::copy -help\ |
||||
"Copy a partial or full configuration from one config to another |
||||
If a target config has additional settings, then the source config can be considered to be partial with regards to the target. |
||||
" |
||||
-type -default "" -choices {replace merge} -help\ |
||||
"Defaults to merge when target is running-config |
||||
Defaults to replace when source is running-config" |
||||
@values -min 2 -max 2 |
||||
fromconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
toconfig -help\ |
||||
"running or startup or file name (not fully implemented)" |
||||
} |
||||
set argd [punk::args::parse $args withdef $argdef] |
||||
set fromconfig [dict get $argd values fromconfig] |
||||
set toconfig [dict get $argd values toconfig] |
||||
set fromconfig [string map {-config ""} $fromconfig] |
||||
set toconfig [string map {-config ""} $toconfig] |
||||
|
||||
set copytype [dict get $argd opts -type] |
||||
|
||||
|
||||
#todo - warn & prompt if doing merge copy to startup |
||||
switch -exact -- $fromconfig-$toconfig { |
||||
running-startup { |
||||
if {$copytype eq ""} { |
||||
set copytype replace ;#full configuration |
||||
} |
||||
if {$copytype eq "replace"} { |
||||
error "punk::config::copy error. full configuration copy from running to startup config not yet supported" |
||||
} else { |
||||
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" |
||||
} |
||||
} |
||||
startup-running { |
||||
#default type merge - even though it's not always what is desired |
||||
if {$copytype eq ""} { |
||||
set copytype merge ;#load in a partial configuration |
||||
} |
||||
|
||||
#warn/prompt either way |
||||
if {$copytype eq "replace"} { |
||||
#some routers require use of a separate command for this branch. |
||||
#presumably to ensure the user doesn't accidentally load partials onto a running system |
||||
# |
||||
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" |
||||
} else { |
||||
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" |
||||
} |
||||
} |
||||
default { |
||||
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#todo - move to cli? |
||||
::tcl::namespace::eval punk::config { |
||||
#todo - something better - 'previous' rather than reverting to startup |
||||
proc channelcolors {{onoff {}}} { |
||||
variable configdata |
||||
#variable running |
||||
#variable startup |
||||
|
||||
if {![string length $onoff]} { |
||||
return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] |
||||
} else { |
||||
if {![string is boolean $onoff]} { |
||||
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no" |
||||
} |
||||
if {$onoff} { |
||||
dict set configdata running color_stdout [dict get $startup color_stdout] |
||||
dict set configdata running color_stderr [dict get $startup color_stderr] |
||||
} else { |
||||
dict set configdata running color_stdout "" |
||||
dict set configdata running color_stderr "" |
||||
} |
||||
} |
||||
return [list stdout [dict get $configdata running color_stdout] stderr [dict get $configdata running color_stderr]] |
||||
} |
||||
|
||||
} |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::config |
||||
} |
||||
|
||||
|
||||
package provide punk::config [tcl::namespace::eval punk::config { |
||||
variable version |
||||
set version 0.1 |
||||
|
||||
}] |
||||
File diff suppressed because it is too large
Load Diff
@ -1,87 +0,0 @@
|
||||
|
||||
# -*- tcl -* |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::docgen 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::repo |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::docgen { |
||||
proc get_doctools_comments {fname} { |
||||
#does no validation of doctools commands |
||||
#existence of string match #\**!doctools is taken as evidence enough that the file has inline doctools - review |
||||
if {![file exists $fname]} { |
||||
error "get_doctools_comments file '$fname' not found" |
||||
} |
||||
set fd [open $fname r] |
||||
chan conf $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
if {![string match "*#\**!doctools*" $data]} { |
||||
return |
||||
} |
||||
set data [string map [list \r\n \n] $data] |
||||
set in_doctools 0 |
||||
set doctools "" |
||||
#foreach ln [split $data \n] { |
||||
# set ln [string trim $ln] |
||||
# if {$in_doctools && [string index $ln 0] != "#"} { |
||||
# set in_doctools 0 |
||||
# } elseif {[string range $ln 0 1] == "#*"} { |
||||
# #todo - process doctools ordering hints in tail of line |
||||
# set in_doctools 1 |
||||
# } elseif {$in_doctools} { |
||||
# append doctools [string range $ln 1 end] \n |
||||
# } |
||||
#} |
||||
foreach ln [split $data \n] { |
||||
set ln [string trim $ln] |
||||
if {$in_doctools} { |
||||
if {[string index $ln 0] != "#"} { |
||||
set in_doctools 0 |
||||
} else { |
||||
append doctools [string range $ln 1 end] \n |
||||
} |
||||
} else { |
||||
if {[string range $ln 0 1] == "#*" && [string first "!doctools" $ln] >=2} { |
||||
#todo - process doctools ordering hints in tail of line |
||||
set in_doctools 1 |
||||
} |
||||
} |
||||
} |
||||
return $doctools |
||||
} |
||||
#todo - proc autogen_doctools_comments {fname} {} |
||||
# - will probably need to use something like parsetcl - as we won't be able to reliably source in an interp without side-effects and use info body etc. |
||||
# - mechanism will be to autodocument namespaces, procs, methods where no #*** doctools indication present - but use existing doctools comments for that particular item if it is present. |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::docgen [namespace eval punk::docgen { |
||||
variable pkg punk::docgen |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -1,437 +0,0 @@
|
||||
# -*- 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: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.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::encmime 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::encmime 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {mime encodings related subset of tcllib mime}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {mime encoding names and aliases}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::encmime] |
||||
#[keywords module encodings] |
||||
#[description] |
||||
#[para] This is a workaround package to provide the mime encoding names used in tcllib's mime package - without additional dependencies |
||||
#[para]tcllib mime loads either Trf or tcl::memchan functions. punk::encmime needs to work in a context where tcllib may not yet be loaded/available, and even these few dependencies are too much. |
||||
#[para]MAINTENANCE NOTE: The data in this module needs to be checked against the latest tcllib mime package |
||||
#[para]taken from tcllib mime version: 1.7.2 in 2024 |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::encmime |
||||
#[subsection Concepts] |
||||
#[para] Where practical - the actual tcllib mime package should be used instead. |
||||
#[para]This set of encoding related functions is a snapshot of the data from the mime package - and may not be up to date. |
||||
#[para]This pseudo-package was created to minimize dependencies for punk::char and punk::overtype |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::encmime |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6-}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::class}] |
||||
#[para] class definitions |
||||
if {[info commands [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 |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime { |
||||
namespace export * |
||||
|
||||
variable encList { |
||||
ascii US-ASCII |
||||
big5 Big5 |
||||
cp1250 Windows-1250 |
||||
cp1251 Windows-1251 |
||||
cp1252 Windows-1252 |
||||
cp1253 Windows-1253 |
||||
cp1254 Windows-1254 |
||||
cp1255 Windows-1255 |
||||
cp1256 Windows-1256 |
||||
cp1257 Windows-1257 |
||||
cp1258 Windows-1258 |
||||
cp437 IBM437 |
||||
cp737 {} |
||||
cp775 IBM775 |
||||
cp850 IBM850 |
||||
cp852 IBM852 |
||||
cp855 IBM855 |
||||
cp857 IBM857 |
||||
cp860 IBM860 |
||||
cp861 IBM861 |
||||
cp862 IBM862 |
||||
cp863 IBM863 |
||||
cp864 IBM864 |
||||
cp865 IBM865 |
||||
cp866 IBM866 |
||||
cp869 IBM869 |
||||
cp874 {} |
||||
cp932 {} |
||||
cp936 GBK |
||||
cp949 {} |
||||
cp950 {} |
||||
dingbats {} |
||||
ebcdic {} |
||||
euc-cn EUC-CN |
||||
euc-jp EUC-JP |
||||
euc-kr EUC-KR |
||||
gb12345 GB12345 |
||||
gb1988 GB1988 |
||||
gb2312 GB2312 |
||||
iso2022 ISO-2022 |
||||
iso2022-jp ISO-2022-JP |
||||
iso2022-kr ISO-2022-KR |
||||
iso8859-1 ISO-8859-1 |
||||
iso8859-2 ISO-8859-2 |
||||
iso8859-3 ISO-8859-3 |
||||
iso8859-4 ISO-8859-4 |
||||
iso8859-5 ISO-8859-5 |
||||
iso8859-6 ISO-8859-6 |
||||
iso8859-7 ISO-8859-7 |
||||
iso8859-8 ISO-8859-8 |
||||
iso8859-9 ISO-8859-9 |
||||
iso8859-10 ISO-8859-10 |
||||
iso8859-13 ISO-8859-13 |
||||
iso8859-14 ISO-8859-14 |
||||
iso8859-15 ISO-8859-15 |
||||
iso8859-16 ISO-8859-16 |
||||
jis0201 JIS_X0201 |
||||
jis0208 JIS_C6226-1983 |
||||
jis0212 JIS_X0212-1990 |
||||
koi8-r KOI8-R |
||||
koi8-u KOI8-U |
||||
ksc5601 KS_C_5601-1987 |
||||
macCentEuro {} |
||||
macCroatian {} |
||||
macCyrillic {} |
||||
macDingbats {} |
||||
macGreek {} |
||||
macIceland {} |
||||
macJapan {} |
||||
macRoman {} |
||||
macRomania {} |
||||
macThai {} |
||||
macTurkish {} |
||||
macUkraine {} |
||||
shiftjis Shift_JIS |
||||
symbol {} |
||||
tis-620 TIS-620 |
||||
unicode {} |
||||
utf-8 UTF-8 |
||||
} |
||||
variable encodings |
||||
array set encodings $encList |
||||
variable reversemap |
||||
variable encAliasList { |
||||
ascii ANSI_X3.4-1968 |
||||
ascii iso-ir-6 |
||||
ascii ANSI_X3.4-1986 |
||||
ascii ISO_646.irv:1991 |
||||
ascii ASCII |
||||
ascii ISO646-US |
||||
ascii us |
||||
ascii IBM367 |
||||
ascii cp367 |
||||
cp437 cp437 |
||||
cp437 437 |
||||
cp775 cp775 |
||||
cp850 cp850 |
||||
cp850 850 |
||||
cp852 cp852 |
||||
cp852 852 |
||||
cp855 cp855 |
||||
cp855 855 |
||||
cp857 cp857 |
||||
cp857 857 |
||||
cp860 cp860 |
||||
cp860 860 |
||||
cp861 cp861 |
||||
cp861 861 |
||||
cp861 cp-is |
||||
cp862 cp862 |
||||
cp862 862 |
||||
cp863 cp863 |
||||
cp863 863 |
||||
cp864 cp864 |
||||
cp865 cp865 |
||||
cp865 865 |
||||
cp866 cp866 |
||||
cp866 866 |
||||
cp869 cp869 |
||||
cp869 869 |
||||
cp869 cp-gr |
||||
cp936 CP936 |
||||
cp936 MS936 |
||||
cp936 Windows-936 |
||||
iso8859-1 ISO_8859-1:1987 |
||||
iso8859-1 iso-ir-100 |
||||
iso8859-1 ISO_8859-1 |
||||
iso8859-1 latin1 |
||||
iso8859-1 l1 |
||||
iso8859-1 IBM819 |
||||
iso8859-1 CP819 |
||||
iso8859-2 ISO_8859-2:1987 |
||||
iso8859-2 iso-ir-101 |
||||
iso8859-2 ISO_8859-2 |
||||
iso8859-2 latin2 |
||||
iso8859-2 l2 |
||||
iso8859-3 ISO_8859-3:1988 |
||||
iso8859-3 iso-ir-109 |
||||
iso8859-3 ISO_8859-3 |
||||
iso8859-3 latin3 |
||||
iso8859-3 l3 |
||||
iso8859-4 ISO_8859-4:1988 |
||||
iso8859-4 iso-ir-110 |
||||
iso8859-4 ISO_8859-4 |
||||
iso8859-4 latin4 |
||||
iso8859-4 l4 |
||||
iso8859-5 ISO_8859-5:1988 |
||||
iso8859-5 iso-ir-144 |
||||
iso8859-5 ISO_8859-5 |
||||
iso8859-5 cyrillic |
||||
iso8859-6 ISO_8859-6:1987 |
||||
iso8859-6 iso-ir-127 |
||||
iso8859-6 ISO_8859-6 |
||||
iso8859-6 ECMA-114 |
||||
iso8859-6 ASMO-708 |
||||
iso8859-6 arabic |
||||
iso8859-7 ISO_8859-7:1987 |
||||
iso8859-7 iso-ir-126 |
||||
iso8859-7 ISO_8859-7 |
||||
iso8859-7 ELOT_928 |
||||
iso8859-7 ECMA-118 |
||||
iso8859-7 greek |
||||
iso8859-7 greek8 |
||||
iso8859-8 ISO_8859-8:1988 |
||||
iso8859-8 iso-ir-138 |
||||
iso8859-8 ISO_8859-8 |
||||
iso8859-8 hebrew |
||||
iso8859-9 ISO_8859-9:1989 |
||||
iso8859-9 iso-ir-148 |
||||
iso8859-9 ISO_8859-9 |
||||
iso8859-9 latin5 |
||||
iso8859-9 l5 |
||||
iso8859-10 iso-ir-157 |
||||
iso8859-10 l6 |
||||
iso8859-10 ISO_8859-10:1992 |
||||
iso8859-10 latin6 |
||||
iso8859-14 iso-ir-199 |
||||
iso8859-14 ISO_8859-14:1998 |
||||
iso8859-14 ISO_8859-14 |
||||
iso8859-14 latin8 |
||||
iso8859-14 iso-celtic |
||||
iso8859-14 l8 |
||||
iso8859-15 ISO_8859-15 |
||||
iso8859-15 Latin-9 |
||||
iso8859-16 iso-ir-226 |
||||
iso8859-16 ISO_8859-16:2001 |
||||
iso8859-16 ISO_8859-16 |
||||
iso8859-16 latin10 |
||||
iso8859-16 l10 |
||||
jis0201 X0201 |
||||
jis0208 iso-ir-87 |
||||
jis0208 x0208 |
||||
jis0208 JIS_X0208-1983 |
||||
jis0212 x0212 |
||||
jis0212 iso-ir-159 |
||||
ksc5601 iso-ir-149 |
||||
ksc5601 KS_C_5601-1989 |
||||
ksc5601 KSC5601 |
||||
ksc5601 korean |
||||
shiftjis MS_Kanji |
||||
utf-8 UTF8 |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime}] |
||||
#[para] Core API functions for punk::encmime |
||||
#[list_begin definitions] |
||||
|
||||
# ::mime::mapencoding -- |
||||
# |
||||
# mime::mapencodings maps tcl encodings onto the proper names for their |
||||
# MIME charset type. This is only done for encodings whose charset types |
||||
# were known. The remaining encodings return {} for now. |
||||
# |
||||
# Arguments: |
||||
# enc The tcl encoding to map. |
||||
# |
||||
# Results: |
||||
# Returns the MIME charset type for the specified tcl encoding, or {} |
||||
# if none is known. |
||||
proc mapencoding {enc} { |
||||
#*** !doctools |
||||
#[call mapencoding [arg enc]] |
||||
#[para]maps tcl encodings onto the proper names for their MIME charset type. |
||||
#[para]This is only done for encodings whose charset types were known. |
||||
#[para]The remaining encodings return {} for now. |
||||
#[para]NOTE: consider using tcllib's mime::mapencoding instead if mime package available |
||||
|
||||
variable encodings |
||||
if {[info exists encodings($enc)]} { |
||||
return $encodings($enc) |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
proc reversemapencoding {mimeType} { |
||||
#*** !doctools |
||||
#[call reversemapencoding [arg mimeType]] |
||||
#[para]mime::reversemapencodings maps MIME charset types onto tcl encoding names. |
||||
#[para]Returns the tcl encoding name for the specified mime charset, or {} if none is known |
||||
#[para] Arguments: |
||||
# [list_begin arguments] |
||||
# [arg_def string mimeType] The MIME charset to convert into a tcl encoding type. |
||||
# [list_end] |
||||
#[para]NOTE: consider using tcllib's mime::reversemapencoding instead if mime package available |
||||
|
||||
variable reversemap |
||||
|
||||
set lmimeType [string tolower $mimeType] |
||||
if {[info exists reversemap($lmimeType)]} { |
||||
return $reversemap($lmimeType) |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::encmime ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
::apply {{} { |
||||
variable encList |
||||
variable encAliasList |
||||
variable reversemap |
||||
foreach {enc mimeType} $encList { |
||||
if {$mimeType eq {}} continue |
||||
set reversemap([string tolower $mimeType]) $enc |
||||
} |
||||
foreach {enc mimeType} $encAliasList { |
||||
set reversemap([string tolower $mimeType]) $enc |
||||
} |
||||
# Drop the helper variables |
||||
unset encList encAliasList |
||||
|
||||
} ::punk::encmime} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime::lib { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::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::encmime::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval punk::encmime::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::encmime [namespace eval punk::encmime { |
||||
variable pkg punk::encmime |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,32 +0,0 @@
|
||||
|
||||
package require punk::cap |
||||
|
||||
|
||||
tcl::namespace::eval punk::mix { |
||||
proc init {} { |
||||
package require punk::cap::handlers::templates ;#handler for templates cap |
||||
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us |
||||
|
||||
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap |
||||
set t [time { |
||||
if {[catch {punk::mix::templates::provider register *} errM]} { |
||||
puts stderr "punk::mix failure during punk::mix::templates::provider register *" |
||||
puts stderr $errM |
||||
puts stderr "-----" |
||||
puts stderr $::errorInfo |
||||
} |
||||
}] |
||||
puts stderr "->punk::mix::templates::provider register * t=$t" |
||||
} |
||||
init |
||||
|
||||
} |
||||
|
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
package provide punk::mix [tcl::namespace::eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
||||
@ -1,993 +0,0 @@
|
||||
package provide punk::mix::base [namespace eval punk::mix::base { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
package require punk::path |
||||
package require punk::lib ;#format_number etc |
||||
|
||||
#base internal plumbing functions |
||||
namespace eval punk::mix::base { |
||||
proc set_alias {cmdname args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||
} |
||||
proc _cli {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||
if {![string length $extension]} { |
||||
#if still no extension - must have been called directly as punk::mix::base::_cli |
||||
if {![llength $args]} { |
||||
set args "help" |
||||
} |
||||
set extension [namespace current] |
||||
} |
||||
#init usually used to load commandsets (and export their names) into the extension namespace/ensemble |
||||
${extension}::_init |
||||
if {![llength $args]} { |
||||
if {[info exists ${extension}::default_command]} { |
||||
tailcall $extension [set ${extension}::default_command] |
||||
} |
||||
tailcall $extension |
||||
} else { |
||||
tailcall $extension {*}$args |
||||
} |
||||
} |
||||
proc _unknown {ns args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "arglen:[llength $args]" |
||||
#puts stdout "_unknown '$ns' '$args'" |
||||
|
||||
set d_commands [get_commands -extension $extension] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
|
||||
|
||||
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||
} |
||||
proc _redirected {from_ns subcommand args} { |
||||
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||
set pname [namespace current]::$subcommand |
||||
if {$pname in [info procs $pname]} { |
||||
set argnames [info args $pname] |
||||
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||
if {[lindex $argnames end] eq "args"} { |
||||
set pos_argnames [lrange $argnames 0 end-1] |
||||
} else { |
||||
set pos_argnames $argnames |
||||
} |
||||
set argvals [list] |
||||
set numargs [llength $pos_argnames] |
||||
if {$numargs > 0} { |
||||
set argvals [lrange $args 0 $numargs-1] |
||||
set args [lrange $args $numargs end] |
||||
} |
||||
if {[llength $argvals] < $numargs} { |
||||
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||
} else { |
||||
if {[regexp {.*[*?].*} $subcommand]} { |
||||
set d_commands [get_commands -extension $from_ns] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
set matched_commands [lsearch -all -inline $all_commands $subcommand] |
||||
set commands "" |
||||
foreach m $matched_commands { |
||||
append commands $m \n |
||||
} |
||||
return $commands |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||
} |
||||
} |
||||
proc _split_args {arglist} { |
||||
#don't assume arglist is fully paired. |
||||
set posn [lsearch $arglist -extension] |
||||
set opts [list] |
||||
if {$posn >= 0} { |
||||
if {$posn+2 <= [llength $arglist]} { |
||||
set opts [list -extension [lindex $arglist $posn+1]] |
||||
set argsremaining [lreplace $arglist $posn $posn+1] |
||||
} else { |
||||
#no value supplied to -extension |
||||
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||
} |
||||
} else { |
||||
set argsremaining $arglist |
||||
} |
||||
|
||||
return [list opts $opts args $argsremaining] |
||||
} |
||||
} |
||||
|
||||
|
||||
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||
namespace eval punk::mix::base { |
||||
namespace ensemble create |
||||
namespace export help dostuff get_commands set_alias |
||||
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||
proc get_commands {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
|
||||
set maincommands [list] |
||||
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||
if {[string length $extension]} { |
||||
set nsmain $extension |
||||
#puts stdout "get_commands nsmain: $nsmain" |
||||
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||
set nscommands [list] |
||||
foreach p $parentpatterns { |
||||
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||
} |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
lappend maincommands $cmd |
||||
} |
||||
set maincommands [lsort $maincommands] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set nsbase [namespace current] |
||||
set basepatterns [namespace export] |
||||
#puts stdout "basepatterns:$basepatterns" |
||||
set nscommands [list] |
||||
foreach p $basepatterns { |
||||
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||
} |
||||
|
||||
set basecommands [list] |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
if {$cmd ni $maincommands} { |
||||
lappend basecommands $cmd |
||||
} |
||||
} |
||||
set basecommands [lsort $basecommands] |
||||
|
||||
|
||||
return [list main $maincommands base $basecommands] |
||||
} |
||||
proc help {args} { |
||||
#' **%ensemblecommand% help** *args* |
||||
#' |
||||
#' Help for ensemble commands in the command line interface |
||||
#' |
||||
#' |
||||
#' Arguments: |
||||
#' |
||||
#' * args - first word of args is the helptopic requested - usually a command name |
||||
#' - calling help with no arguments will list available commands |
||||
#' |
||||
#' Returns: help text (text) |
||||
#' |
||||
#' Examples: |
||||
#' |
||||
#' ``` |
||||
#' %ensemblecommand% help <commandname> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||
# >} inspect -label a {| |
||||
# >} .=e>end,data>end pipeswitch { |
||||
# pipecase ,0/1/#= $switchargs {| |
||||
# e/0 |
||||
# >} .=>. {set e} |
||||
# pipecase /1,1/1/#= $switchargs |
||||
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||
|
||||
|
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
|
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "-1:[info level -1]" |
||||
|
||||
set command_info [punk::mix::base::get_commands -extension $extension] |
||||
set subhelp1 [lindex $args 0] |
||||
if {[string length $subhelp1]} { |
||||
if {[regexp {[*?]} $subhelp1]} { |
||||
set helpstr "" |
||||
append helpstr "matched commands:\n" |
||||
dict for {source cmdlist} $command_info { |
||||
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||
if {[llength $matches]} { |
||||
append helpstr \n " $source" |
||||
foreach cmd $matches { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
} |
||||
return $helpstr |
||||
} else { |
||||
dict for {source cmdlist} $command_info { |
||||
if {$subhelp1 in $cmdlist} { |
||||
if {$source eq "base"} { |
||||
set ns [namespace current] |
||||
} else { |
||||
set ns $extension |
||||
} |
||||
set procname ${ns}::$subhelp1 |
||||
if {$procname in [info procs $procname]} { |
||||
return "proc: $subhelp1 arguments: [info args $procname]" |
||||
} else { |
||||
set a [interp alias {} ${ns}::$subhelp1] |
||||
if {[string length $a]} { |
||||
return "alias: $subhelp1 target: $a" |
||||
} else { |
||||
return "command: $subhelp1 (No info available)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "No info found" |
||||
} |
||||
|
||||
} |
||||
#result for just 'pmix help' |
||||
puts stderr "-->$args" |
||||
set helpstr "" |
||||
append helpstr "limit commandlist with a glob search such as *word*" |
||||
append helpstr "commands:\n" |
||||
|
||||
foreach {source cmdlist} $command_info { |
||||
append helpstr \n " $source" |
||||
foreach cmd $cmdlist { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
return $helpstr |
||||
} |
||||
#proc dostuff {args} { |
||||
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||
#} |
||||
namespace eval lib { |
||||
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||
namespace export * |
||||
|
||||
#----------------------------------------------------- |
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
#----------------------------------------------------- |
||||
|
||||
|
||||
|
||||
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||
proc find_source_module_paths {{path {}}} { |
||||
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||
} |
||||
#we can return module paths even if the project isn't yet under revision control |
||||
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||
set tm_folders [list] |
||||
foreach sub $src_subs { |
||||
set is_ok 1 |
||||
foreach anti $antipatterns { |
||||
if {[string match $anti $sub]} { |
||||
set is_ok 0 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_ok} { |
||||
continue |
||||
} |
||||
set testfolder [file join $candidate src $sub] |
||||
#ensure that if src/modules exists - it is always included even if empty |
||||
if {[string tolower $sub] eq "modules"} { |
||||
lappend tm_folders $testfolder |
||||
continue |
||||
} |
||||
#set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||
#set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*] |
||||
if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} { |
||||
lappend tm_folders $testfolder |
||||
} |
||||
} |
||||
return $tm_folders |
||||
} |
||||
|
||||
proc mix_templates_dir {} { |
||||
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||
set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpldir $tmdir/mix/templates |
||||
if {![file exists $tpldir]} { |
||||
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||
} |
||||
return $tpldir |
||||
} |
||||
|
||||
#get_template_basefolders |
||||
# startpath - file or folder |
||||
# It represents the base point from which to search for templates folders either directly related to the scriptpath (../) or in the containing project if any |
||||
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||
proc get_template_basefolders {{startpath ""}} { |
||||
# templates from punk.templates provider packages (ordered by order in which packages registered with punk::cap) |
||||
if {[file isfile $startpath]} { |
||||
set startpath [file dirname $startpath] |
||||
} |
||||
|
||||
package require punk::cap |
||||
if {[punk::cap::capability_has_handler punk.templates]} { |
||||
set template_folder_dict [punk::cap::call_handler punk.templates folders -startdir $startpath] |
||||
} else { |
||||
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||
} |
||||
|
||||
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||
return $template_folder_dict |
||||
} |
||||
|
||||
proc module_subpath {modulename} { |
||||
set modulename [string trim $modulename :] |
||||
set nsq [namespace qualifiers $modulename] |
||||
return [string map {:: /} $nsq] |
||||
} |
||||
|
||||
proc get_build_workdir {path} { |
||||
set repo_info [punk::repo::find_repos $path] |
||||
set base [lindex [dict get $repo_info project] 0] |
||||
if {![string length $base]} { |
||||
error "get_build_workdir unable to determine project base for path '$path'" |
||||
} |
||||
if {![file exists $base/src] || ![file writable $base/src]} { |
||||
error "get_build_workdir unable to access $base/src" |
||||
} |
||||
file mkdir $base/src/_build |
||||
return $base/src/_build |
||||
} |
||||
|
||||
|
||||
|
||||
#todo - move cksum stuff to punkcheck - more logical home |
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}$args |
||||
} |
||||
|
||||
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||
variable cksum_default_opts |
||||
set default_hash sha1 ;#but fall back to md5 if either sha1 is unavailable or unaccelerated (pure tcl sha1 is way slower than pure tcl md5 - can take minutes on even moderate sized source files) |
||||
if {![catch {package require sha1}]} { |
||||
set impls [::sha1::Implementations] |
||||
if {[llength $impls] == 1 && [string tolower [lindex $impls 0]] eq "tcl"} { |
||||
set default_hash md5 |
||||
} |
||||
} else { |
||||
set default_hash md5 |
||||
} |
||||
set cksum_default_opts [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm $default_hash] |
||||
proc cksum_default_opts {} { |
||||
variable cksum_default_opts |
||||
return $cksum_default_opts |
||||
} |
||||
|
||||
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||
# - try builtin zlib crc instead? |
||||
#sha1 is performant (when accelerator present) - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||
#sha1 as at 2023 seems a reasonable default - (but only if accelerator present) |
||||
proc cksum_algorithms {} { |
||||
variable sha3_implementation |
||||
#sha2 is an alias for sha256 |
||||
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||
if {[auto_execok sqlite3] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation sqlite3_sha3 |
||||
} else { |
||||
if {[auto_execok fossil] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation fossil_sha3 |
||||
} |
||||
} |
||||
return $algs |
||||
} |
||||
|
||||
proc sqlite3_sha3 {bits filename} { |
||||
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||
} |
||||
proc fossil_sha3 {bits filename} { |
||||
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||
} |
||||
|
||||
#adler32 via file-slurp |
||||
proc cksum_adler32_file {filename} { |
||||
#2024 - zlib should be builtin - otherwise fallback to trf + zlibtcl? |
||||
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
||||
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||
zlib adler32 $data |
||||
} |
||||
#zlib crc via file-slurp |
||||
proc cksum_crc_file {filename} { |
||||
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
||||
zlib crc32 $data |
||||
} |
||||
|
||||
proc cksum_md5_data {data} { |
||||
if {[package vsatisfies [package present md5] 2-]} { |
||||
return [md5::md5 -hex $data] |
||||
} else { |
||||
return [md5::md5 $data] |
||||
} |
||||
} |
||||
#fallback md5 via file-slurp - shouldn't be needed if have md5 2- |
||||
proc cksum_md5_file {filename} { |
||||
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
||||
cksum_md5_data $data |
||||
} |
||||
|
||||
|
||||
#required to be able to accept relative paths |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
variable sha3_implementation |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [cksum_default_opts] |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||
} |
||||
} |
||||
|
||||
set opts [dict merge $defaults $args] |
||||
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||
|
||||
#if {![file exists $path]} { |
||||
# return [list cksum "" opts $opts] |
||||
#} |
||||
|
||||
if {[catch {file type $path} ftype]} { |
||||
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||
} |
||||
|
||||
#review - links? |
||||
switch -- $ftype { |
||||
file - directory {} |
||||
default { |
||||
error "cksum_path error file type '$ftype' not supported" |
||||
} |
||||
} |
||||
|
||||
|
||||
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts known_algorithms [cksum_algorithms]] |
||||
} |
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
|
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
set opt_use_tar [dict get $opts -cksum_usetar] |
||||
switch -- $ftype { |
||||
file { |
||||
switch -- $opt_use_tar { |
||||
auto { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
set opt_use_tar 1 |
||||
} else { |
||||
#prefer no tar if meta not required - faster/simpler |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
set opt_use_tar 0 |
||||
} |
||||
} |
||||
0 { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
} |
||||
} |
||||
default { |
||||
#tar == 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
directory { |
||||
switch -- $opt_use_tar { |
||||
auto { |
||||
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||
set opt_use_tar 1 |
||||
set opt_cksum_meta 1 |
||||
} else { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||
} |
||||
} |
||||
0 { |
||||
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||
} |
||||
default { |
||||
#tar 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||
dict set opts_actual -cksum_usetar $opt_use_tar |
||||
|
||||
|
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported_path opts $opts] |
||||
} |
||||
switch -- $opt_cksum_algorithm { |
||||
sha1 { |
||||
package require sha1 |
||||
#review - any utf8 issues in tcl9? |
||||
set cksum_command [list sha1::sha1 -hex -file] |
||||
} |
||||
sha2 - sha256 { |
||||
package require sha256 |
||||
set cksum_command [list sha2::sha256 -hex -file] |
||||
} |
||||
md5 { |
||||
package require md5 |
||||
if {[package vsatisfies [package present md5] 2- ] } { |
||||
set cksum_command [list md5::md5 -hex -file] |
||||
} else { |
||||
set cksum_comand [list cksum_md5_file] |
||||
} |
||||
} |
||||
cksum { |
||||
package require cksum ;#tcllib |
||||
set cksum_command [list crc::cksum -format 0x%X -file] |
||||
} |
||||
crc { |
||||
set cksum_command [list cksum_crc_file] |
||||
} |
||||
adler32 { |
||||
set cksum_command [list cksum_adler32_file] |
||||
} |
||||
sha3 - sha3-256 { |
||||
#todo - replace with something that doesn't call another process - only if tcllibc not available! |
||||
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||
set cksum_command [list $sha3_implementation 256] |
||||
} |
||||
sha3-224 - sha3-384 - sah3-512 { |
||||
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||
set cksum_command [list $sha3_implementation $bits] |
||||
} |
||||
} |
||||
|
||||
set cksum "" |
||||
if {$opt_use_tar != 0} { |
||||
set target [file tail $path] |
||||
set tmplocation [punk::mix::util::tmpdir] |
||||
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive for $path" |
||||
puts -nonewline stdout " at: $archivename ..." |
||||
set tsstart [clock millis] |
||||
if {[set tarpath [auto_execok tar]] ne ""} { |
||||
#using an external binary is *significantly* faster than tar::create - but comes with some risks |
||||
#review - need to check behaviour/flag variances across platforms |
||||
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum |
||||
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?) |
||||
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath |
||||
set tsend [clock millis] |
||||
set ms [expr {$tsend - $tsstart}] |
||||
puts stdout " tar -cf done ($ms ms)" |
||||
} else { |
||||
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create |
||||
tar::create $archivename $target |
||||
set tsend [clock millis] |
||||
set ms [expr {$tsend - $tsstart}] |
||||
puts stdout " tar::create done ($ms ms)" |
||||
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" |
||||
} |
||||
|
||||
if {$ftype eq "file"} { |
||||
set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" |
||||
} else { |
||||
set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" |
||||
} |
||||
set tsstart [clock millis] |
||||
puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " |
||||
set cksum [{*}$cksum_command $archivename] |
||||
set tsend [clock millis] |
||||
set ms [expr {$tsend - $tsstart}] |
||||
puts stdout " cksum done ($ms ms)" |
||||
puts stdout " cksum: $cksum" |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {$ftype eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||
} else { |
||||
set cksum [{*}$cksum_command $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts_actual |
||||
return $result |
||||
} |
||||
|
||||
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||
#base can be empty string in which case paths must be absolute |
||||
#expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts |
||||
# ie subdict for <path> can be created from output of cksum_path <path> (for already known values not requiring filling) |
||||
# or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) |
||||
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||
if {$base eq ""} { |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "absolute"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||
puts stderr "error_paths: $error_paths" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||
} |
||||
} else { |
||||
if {[file pathtype $base] ne "absolute"} { |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||
} |
||||
#conversely now we have a base - so we require all paths are relative. |
||||
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "relative"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||
} |
||||
} |
||||
|
||||
|
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW" |
||||
#review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob |
||||
if {![dict exists $pathinfo cksum]} { |
||||
dict set pathinfo cksum "" |
||||
} else { |
||||
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||
continue ;#already filled with non-tag value |
||||
} |
||||
} |
||||
if {$base ne ""} { |
||||
set fullpath [file join $base $path] |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
|
||||
if {[dict exists $pathinfo opts]} { |
||||
set ckopts [cksum_filter_opts {*}[dict get $pathinfo opts]] |
||||
} else { |
||||
set ckopts {} |
||||
} |
||||
|
||||
if {![file exists $fullpath]} { |
||||
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||
} else { |
||||
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $dict_path_cksum |
||||
} |
||||
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||
proc cksum_is_tag {cksum} { |
||||
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||
} |
||||
proc cksum_filter_opts {args} { |
||||
set ck_opt_names [dict keys [cksum_default_opts]] |
||||
set ck_opts [dict create] |
||||
foreach {k v} $args { |
||||
if {$k in $ck_opt_names} { |
||||
dict set ck_opts $k $v |
||||
} |
||||
} |
||||
return $ck_opts |
||||
} |
||||
|
||||
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) |
||||
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||
proc get_relativecksum_from_base {base specifiedpath args} { |
||||
if {$base ne ""} { |
||||
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
if {[file pathtype $base] eq "relative"} { |
||||
set normbase [file normalize $base] |
||||
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||
set targetpath $normtarg |
||||
set storedpath [punk::path::relative $normbase $normtarg] |
||||
} else { |
||||
set targetpath [file join $base $specifiedpath] |
||||
set storedpath $specifiedpath |
||||
} |
||||
} else { |
||||
#specifed absolute |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||
} |
||||
#both absolute - compute relative path if they share a common prefix |
||||
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||
if {$commonprefix eq ""} { |
||||
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||
} |
||||
set targetpath $specifiedpath |
||||
set storedpath [punk::path::relative $base $specifiedpath] |
||||
|
||||
} |
||||
} else { |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||
set targetpath [file normalize $specifiedpath] |
||||
set storedpath $targetpath |
||||
} else { |
||||
set targetpath $specifiedpath |
||||
set storedpath $targetpath |
||||
} |
||||
} |
||||
|
||||
# |
||||
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||
# |
||||
#todo - write tests |
||||
|
||||
|
||||
if {[llength $args] % 2} { |
||||
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||
} |
||||
if {[dict exists $args cksum]} { |
||||
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||
} |
||||
} |
||||
|
||||
|
||||
set ckopts [cksum_filter_opts {*}$args] |
||||
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||
|
||||
set keyvals $args ;# REVIEW |
||||
dict set keyvals cksum [dict get $ckinfo cksum] |
||||
#dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||
dict set keyvals opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set keyvals cksum_error [dict get $ckinfo error] |
||||
} |
||||
|
||||
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||
#storedpath is relative if possible |
||||
return [dict create $storedpath $keyvals] |
||||
} |
||||
|
||||
#calculate the runtime checksum and vfs checksums |
||||
proc get_all_vfs_build_cksums {path {cksum_opts {}}} { |
||||
set buildfolder [get_build_workdir $path] |
||||
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||
set dict_cksums [dict create] |
||||
|
||||
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||
|
||||
foreach vfstail $vfs_tail_list { |
||||
set vname [file rootname $vfstail] |
||||
dict set dict_cksums $vfstail [list cksum ""] |
||||
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||
} |
||||
|
||||
#buildruntime.exe obsolete.. |
||||
puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" |
||||
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||
|
||||
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||
set ck [dict get $ckinfo_buildruntime cksum] |
||||
|
||||
|
||||
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||
dict set dict_cksums $relpath [list cksum $ck opts $cksum_opts] |
||||
|
||||
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||
|
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set vfs [file tail $vfsfolder] |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||
set ckfile $buildfolder/$vname.cksums |
||||
if {[file exists $ckfile]} { |
||||
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||
foreach ln [split $data \n] { |
||||
if {[string trim $ln] eq ""} {continue} |
||||
lassign $ln path cksum |
||||
dict set dict_vfs $path $cksum |
||||
} |
||||
} |
||||
return $dict_vfs |
||||
} |
||||
proc get_all_build_cksums_stored {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
|
||||
set vfscontainer [file dirname $buildfolder] |
||||
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||
set dict_cksums [dict create] |
||||
foreach vfs $vfslist { |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||
|
||||
dict set dict_cksums $vname $dict_vfs |
||||
} |
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc store_vfs_build_cksums {vfsfolder} { |
||||
if {![file isdirectory $vfsfolder]} { |
||||
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||
} |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||
set data "" |
||||
dict for {path cksum} $dict_vfs { |
||||
append data "$path $cksum" \n |
||||
} |
||||
set fd [open $buildfolder/$vname.cksums w] |
||||
chan configure $fd -translation binary |
||||
puts $fd $data |
||||
close $fd |
||||
return $dict_vfs |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,152 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::buildsuite { |
||||
namespace export * |
||||
proc projects {suite} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||
return |
||||
} |
||||
set suite_dir [file join $suites_dir $suite] |
||||
set projects [glob -dir $suite_dir -type d -tails *] |
||||
|
||||
#use internal du which although breadth-first is generally faster |
||||
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||
set du_sizes [dict create] |
||||
set suite_total_size "-" |
||||
foreach du_record $du_info { |
||||
if {[llength $du_record] != 2} { |
||||
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||
continue |
||||
} |
||||
set sz [lindex $du_record 0] |
||||
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||
set s [lindex $path_parts end-1] |
||||
set p [lindex $path_parts end] |
||||
|
||||
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||
if {![string match -nocase $s $suite]} { |
||||
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||
} else { |
||||
#something else - shouldn't happen |
||||
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||
puts stderr "$du_record" |
||||
#try to continue anyway |
||||
} |
||||
} else { |
||||
dict set du_sizes $p $sz |
||||
} |
||||
} |
||||
|
||||
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||
set psizes [list] |
||||
foreach p $projects { |
||||
if {[dict exists $du_sizes $p]} { |
||||
dict set psizes $p [dict get $du_sizes $p] |
||||
} else { |
||||
dict set psizes $p - |
||||
} |
||||
} |
||||
set total_source_size "-" |
||||
if {[catch { |
||||
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||
} errM]} { |
||||
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||
} |
||||
package require overtype |
||||
|
||||
set title1 "Projects" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set size_values [dict values $psizes] |
||||
# Title is probably widest - but go through the process anyway! |
||||
set title2 "Source Bytes" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
|
||||
set output "" |
||||
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||
foreach p [lsort $projects] { |
||||
#todo - provide some basic info for each - last build time? last time-to-build? |
||||
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||
} |
||||
append output "Total Source size: $total_source_size bytes" \n |
||||
return $output |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file exists $suites_dir]} { |
||||
puts stderr "No buildsuites folder found at $suites_dir" |
||||
return |
||||
} |
||||
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||
if {$glob ne "*"} { |
||||
set suites [lsearch -all -inline $suites $glob] |
||||
} |
||||
return $suites |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,92 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::debug 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export get paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
#Except for 'get' - all debug commands should emit to stdout |
||||
proc paths {} { |
||||
set out "" |
||||
puts stdout "find_repos output:" |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
pdict pathinfo |
||||
|
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
puts stdout "get_template_basefolders output:" |
||||
pdict template_base_dict */* |
||||
return |
||||
} |
||||
|
||||
#call other debug command - but capture stdout as return value |
||||
proc get {args} { |
||||
set nm [lindex $args 0] |
||||
if {$nm eq ""} { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get missing debug command argument. Try one of: $cmds" |
||||
return |
||||
} |
||||
set nextargs [lrange $args 1 end] |
||||
set out "" |
||||
if {[info commands [namespace current]::$nm] ne ""} { |
||||
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||
} else { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||
} |
||||
return $out |
||||
} |
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,324 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::path ;# for treefilenames, relative |
||||
package require punk::repo |
||||
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc |
||||
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call |
||||
#package require punkcheck ;#for path_relative |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
puts "commands: doc.status" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
#user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite |
||||
#we still generate output in src/docgen so user can diff and manually update if thats what they prefer |
||||
set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] |
||||
foreach maybedoomed $oldfiles { |
||||
set fd [open $maybedoomed r] |
||||
chan conf $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
if {[string match "*--- punk::docgen overwrites *" $data]} { |
||||
file delete -force $maybedoomed |
||||
} |
||||
} |
||||
set generated [lib::do_docgen modules] |
||||
if {[dict get $generated count] > 0} { |
||||
#review |
||||
set doclist [dict get $generated docs] |
||||
set source_base [dict get $generated base] |
||||
set target_base $projectdir/src/doc |
||||
foreach dinfo $doclist { |
||||
lassign $dinfo module fpath |
||||
set relpath [punk::path::relative $source_base $fpath] |
||||
set relfolder [file dirname $relpath] |
||||
if {$relfolder eq "."} { |
||||
set relfolder "" |
||||
} |
||||
file mkdir [file join $target_base $relfolder] |
||||
set target [file join $target_base $relfolder _module_[file tail $fpath]] |
||||
puts stderr "target --> $target" |
||||
if {![file exists $target]} { |
||||
file copy $fpath $target |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
if {"::meta" eq [info commands ::meta]} { |
||||
puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" |
||||
::meta destroy |
||||
} |
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {args} { |
||||
set argd [punk::args::parse $args withdef { |
||||
@id -id ::punk::mix::commandset::doc::validate |
||||
-- -type none -optional 1 -help "end of options marker --" |
||||
-individual -type boolean -default 1 |
||||
@values -min 0 -max -1 |
||||
patterns -default {*.man} -type any -multiple 1 |
||||
}] |
||||
set opt_individual [tcl::dict::get $argd opts -individual] |
||||
set patterns [tcl::dict::get $argd values patterns] |
||||
|
||||
|
||||
#todo - run and validate punk::docgen output |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
set docroot $projectdir/src/doc |
||||
cd $docroot |
||||
|
||||
if {!$opt_individual && "*.man" in $patterns} { |
||||
if {[catch { |
||||
dtplite validate $docroot |
||||
} errM]} { |
||||
puts stderr "commandset::doc::validate failed for projectdir '$projectdir'" |
||||
puts stderr "docroot '$docroot'" |
||||
puts stderr "dtplite error was: $errM" |
||||
} |
||||
} else { |
||||
foreach p $patterns { |
||||
set treefiles [punk::path::treefilenames $p] |
||||
foreach path $treefiles { |
||||
puts stdout "dtplite validate $path" |
||||
dtplite validate $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
#punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
proc do_docgen {{project_subpath modules}} { |
||||
#Extract doctools comments from source code |
||||
set projectdir [punk::repo::find_project] |
||||
set output_base [file join $projectdir src docgen] |
||||
set codesource_path [file join $projectdir $project_subpath] |
||||
if {![file isdirectory $codesource_path]} { |
||||
puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" |
||||
return |
||||
} |
||||
if {[file isdirectory $output_base]} { |
||||
if {[catch { |
||||
file delete -force $output_base |
||||
}]} { |
||||
error "do_docgen failed to delete existing output base folder: $output_base" |
||||
} |
||||
} |
||||
file mkdir $output_base |
||||
|
||||
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] |
||||
set count 0 |
||||
set newdocs [list] |
||||
set docgen_header_comments "" |
||||
append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n |
||||
foreach fullpath $matched_paths { |
||||
puts stdout "do_docgen processing: $fullpath" |
||||
set doctools [punk::docgen::get_doctools_comments $fullpath] |
||||
if {$doctools ne ""} { |
||||
set fname [file tail $fullpath] |
||||
set mod_tail [file rootname $fname] |
||||
set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] |
||||
if {$relpath eq "."} { |
||||
set relpath "" |
||||
} |
||||
set tailsegs [file split $relpath] |
||||
set module_fullname [join $tailsegs ::]::$mod_tail |
||||
set target_docname $fname.man |
||||
set this_outdir [file join $output_base $relpath] |
||||
|
||||
if {[string length $fname] > 99} { |
||||
#output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. |
||||
#hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format |
||||
#work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? |
||||
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. |
||||
#review - if we're checking fname - should also test length of whole path and determine limits for tar |
||||
package require md5 |
||||
if {[package vsatisfies [package present md5] 2- ] } { |
||||
set md5opt "-hex" |
||||
} else { |
||||
set md5opt "" |
||||
} |
||||
set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man |
||||
puts stderr "WARNING - overlong file name - renaming $fullpath" |
||||
puts stderr " to [file dirname $fullpath]/$target_docname" |
||||
} |
||||
|
||||
file mkdir $this_outdir |
||||
puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" |
||||
set outfile [file join $this_outdir $target_docname] |
||||
set fd [open $outfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $docgen_header_comments$doctools |
||||
close $fd |
||||
incr count |
||||
lappend newdocs [list $module_fullname $outfile] |
||||
} |
||||
} |
||||
return [list count $count docs $newdocs base $output_base] |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,302 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::layout 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::args |
||||
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
package require punk::lib |
||||
package require textblock |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::layout { |
||||
namespace export * |
||||
|
||||
|
||||
namespace eval argdoc { |
||||
proc layout_names {} { |
||||
if {[catch {punk::mix::commandset::layout::lib::layouts_dict *} ldict]} { |
||||
#REVIEW |
||||
return "punk.project" |
||||
} else { |
||||
return [dict keys $ldict] |
||||
} |
||||
} |
||||
} |
||||
#per layout functions |
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id ::punk::mix::commandset::layout::files |
||||
-datetime -default "%Y-%m-%dT%H:%M:%S" -help\ |
||||
"Datetime format for mtime. Use empty string for no datetime output" |
||||
@values -min 1 -max 1 |
||||
layout -type string -choices {${[punk::mix::commandset::layout::argdoc::layout_names]}} |
||||
} |
||||
proc files {args} { |
||||
set argd [punk::args::get_by_id ::punk::mix::commandset::layout::files $args] |
||||
set layout [dict get $argd values layout] |
||||
set dtformat [dict get $argd opts -datetime] |
||||
|
||||
set allfiles [lib::layout_all_files $layout] |
||||
if {$dtformat eq ""} { |
||||
return [join $allfiles \n] |
||||
} else { |
||||
set out "" |
||||
foreach f $allfiles { |
||||
set mtime [dict get [file stat $f] mtime] |
||||
append out "$f [clock format $mtime -format $dtformat]" \n |
||||
} |
||||
set out [string range $out 0 end-1] |
||||
return $out |
||||
} |
||||
} |
||||
proc templatefiles {layout} { |
||||
set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] |
||||
set flatlist [punk::lib::lmapflat v $templatefiles_and_tags {lrange $v 0 end}] |
||||
#return [join $templatefiles \n] |
||||
textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist |
||||
} |
||||
proc templatefiles.relative {layout} { |
||||
|
||||
set layoutdict [lib::layouts_dict] |
||||
if {![dict exists $layoutdict $layout]} { |
||||
puts stderr "layout '$layout' not found." |
||||
return |
||||
} |
||||
set layoutinfo [dict get $layoutdict $layout] |
||||
set layoutfolder [dict get $layoutinfo path] |
||||
|
||||
|
||||
set stripprefix [file normalize $layoutfolder] |
||||
set templatefiles_and_tags [lib::layout_scan_for_template_files $layout] |
||||
set flatlist [list] |
||||
foreach entry $templatefiles_and_tags { |
||||
lassign $entry templatefullpath tags |
||||
lappend flatlist [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] $tags |
||||
} |
||||
#return [join $tails \n] |
||||
textblock::list_as_table -header {"File with tags found" "Tags"} -columns 2 $flatlist |
||||
} |
||||
|
||||
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _defaultx {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
set layouts [list] |
||||
set layoutdict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] |
||||
#set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||
dict for {layoutname layoutinfo} $layoutdict { |
||||
lappend layouts [list $layoutname $layoutinfo] |
||||
} |
||||
#return [join [lsort -index 0 $layouts] \n] |
||||
return [join $layouts \n] |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::punk::mix::commandset::layout::collection::_default |
||||
@cmd -name ::punk::mix::commandset::layout::collection::_default |
||||
-startdir -type string |
||||
-not -type string -multiple 1 |
||||
globsearches -default * -multiple 1 |
||||
} |
||||
proc _default {args} { |
||||
punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default |
||||
|
||||
|
||||
set tdict_low_to_high [as_dict {*}$args] |
||||
#convert to screen order - with higher priority at the top |
||||
set tdict [dict create] |
||||
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||
} |
||||
|
||||
package require overtype |
||||
package require textblock |
||||
#set pathinfolist [dict values $tdict] |
||||
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||
|
||||
set names [dict keys $tdict] |
||||
set paths [list] |
||||
set pathtypes [list] |
||||
dict for {nm tinfo} $tdict { |
||||
lappend paths [dict get $tinfo path] |
||||
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||
} |
||||
|
||||
set title(path) "Path" |
||||
|
||||
set title(pathtype) "[a+ green]Path Type[a]" |
||||
|
||||
set title(name) "Layout Name" |
||||
|
||||
set data [list] |
||||
foreach n $names pt $pathtypes p $paths { |
||||
lappend data $n $pt $p |
||||
} |
||||
set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] |
||||
|
||||
return $table |
||||
} |
||||
proc references {args} { |
||||
set tdict_low_to_high [references_as_dict {*}$args] |
||||
#convert to screen order - with higher priority at the top |
||||
set tdict [dict create] |
||||
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||
} |
||||
|
||||
package require overtype |
||||
package require textblock |
||||
#set pathinfolist [dict values $tdict] |
||||
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||
|
||||
set names [dict keys $tdict] |
||||
set paths [list] |
||||
set pathtypes [list] |
||||
dict for {nm tinfo} $tdict { |
||||
lappend paths [dict get $tinfo path] |
||||
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||
} |
||||
|
||||
set title(name) "Layout Name" |
||||
set title(pathtype) "[a+ green]Path Type[a]" |
||||
set title(path) "Path" |
||||
|
||||
set data [list] |
||||
foreach n $names pt $pathtypes p $paths { |
||||
#append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n |
||||
lappend data $n $pt $p |
||||
} |
||||
set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] |
||||
|
||||
return $table |
||||
} |
||||
|
||||
proc as_dict {args} { |
||||
punk::mix::commandset::layout::lib::layouts_dict {*}$args |
||||
} |
||||
proc references_as_dict {args} { |
||||
package require punk::cap |
||||
if {[punk::cap::capability_has_handler punk.templates]} { |
||||
set ref_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayoutrefs {*}$args] |
||||
} else { |
||||
put stderr "commandset::layout::lib::layouts_dict WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||
} |
||||
return $ref_dict |
||||
} |
||||
} |
||||
namespace eval lib { |
||||
proc layouts_dict {args} { |
||||
package require punk::cap |
||||
if {[punk::cap::capability_has_handler punk.templates]} { |
||||
set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts {*}$args] |
||||
} else { |
||||
put stderr "commandset::layout::lib::layouts_dict WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||
} |
||||
return $layout_dict |
||||
} |
||||
|
||||
proc layout_all_files {layout} { |
||||
#todo - allow versionless layout name to pick highest version found |
||||
set layoutdict [layouts_dict] |
||||
if {![dict exists $layoutdict $layout]} { |
||||
puts stderr "layout '$layout' not found." |
||||
return |
||||
} |
||||
set layoutinfo [dict get $layoutdict $layout] |
||||
set layoutfolder [dict get $layoutinfo path] |
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' points to path $layoutfolder - but it doesn't seem to exist" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
|
||||
# |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#todo JMN |
||||
set layoutdict [layouts_dict] |
||||
if {![dict exists $layoutdict $layout]} { |
||||
puts stderr "layout '$layout' not found." |
||||
return |
||||
} |
||||
set layoutinfo [dict get $layoutdict $layout] |
||||
set layoutfolder [dict get $layoutinfo path] |
||||
|
||||
#use last matching layout found. review silent if multiple? |
||||
if {![llength $tags]} { |
||||
#todo - get standard tags from somewhere |
||||
set tagnames [list project] |
||||
foreach tn $tagnames { |
||||
lappend tags [string cat % $tn %] ;#make sure actual tag literal doesn't appear in this source file |
||||
} |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
set fd [open $path r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
set found_tags [list] |
||||
foreach tag $tags tn $tagnames { |
||||
if {[string match "*$tag*" $data]} { |
||||
lappend found_tags $tn |
||||
} |
||||
} |
||||
if {[llength $found_tags]} { |
||||
lappend file_list [list $path $found_tags] |
||||
} |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,617 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::ns |
||||
package require punk::lib |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::loadedlib { |
||||
namespace export * |
||||
#search automatically wrapped in * * - can contain inner * ? globs |
||||
punk::args::define { |
||||
@id -id ::punk::mix::commandset::loadedlib::search |
||||
@cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" |
||||
-return -type string -default table -choices {table tableobject list lines} |
||||
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ |
||||
"(unimplemented) Display only those that are 0:absent 1:present 2:either" |
||||
-highlight -type boolean -default 1 -help\ |
||||
"Highlight which version is present with ansi underline and colour" |
||||
-refresh -default 0 -type boolean -help "Re-scan the tm and library folders" |
||||
searchstring -default * -multiple 1 -help\ |
||||
"Names to search for, may contain glob chars (* ?) e.g *lib* |
||||
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. |
||||
eg name -> *name* |
||||
To search for an exact name prefix it with = |
||||
e.g =name -> name |
||||
If search is not prefixed with '=' the search is case insensitive." |
||||
} |
||||
proc search {args} { |
||||
set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] |
||||
set searchstrings [dict get $argd values searchstring] |
||||
set opts [dict get $argd opts] |
||||
set opt_return [dict get $opts -return] |
||||
set opt_highlight [dict get $opts -highlight] |
||||
set opt_refresh [dict get $opts -refresh] |
||||
|
||||
if {$opt_refresh} { |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans |
||||
foreach tm_path [tcl::tm::list] { |
||||
set paths_below [punk::path::subfolders -recursive $tm_path] |
||||
foreach folder $paths_below { |
||||
set tail [file tail $folder] |
||||
if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { |
||||
continue |
||||
} |
||||
if {[string match */_build/* $folder]} {continue} |
||||
set relpath [string tolower [punk::path::relative $tm_path $folder]] |
||||
set modpath [string map {/ ::} $relpath] |
||||
catch {package require ${modpath}::flobrudder99} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
set packages [package names] |
||||
set matches [list] |
||||
foreach search $searchstrings { |
||||
if {[regexp {[?*\[]} $search]} { |
||||
#caller has specified specific glob pattern - use it |
||||
#todo - respect supplied case only if uppers present? require another flag? |
||||
lappend matches {*}[lsearch -all -inline -nocase $packages $search] |
||||
} elseif {[string match =* $search]} { |
||||
lappend matches {*}[lsearch -all -inline -exact $packages [string range $search 1 end]] |
||||
} else { |
||||
#make it easy to search for anything |
||||
lappend matches {*}[lsearch -all -inline -nocase $packages "*$search*"] |
||||
} |
||||
} |
||||
set matches [lsort -unique $matches][unset matches] |
||||
set matchinfo [list] |
||||
set highlight_ansi [a+ web-limegreen underline] |
||||
set RST [a] |
||||
foreach m $matches { |
||||
set versions [package versions $m] |
||||
if {![llength $versions]} { |
||||
#e.g builtins such as zlib - shows no versions - but will show version when package present/provide used |
||||
set versions [package provide $m] |
||||
#if {![catch {package present $m} v]} { |
||||
# set versions $v |
||||
#} |
||||
} |
||||
set versions [lsort -command {package vcompare} $versions] |
||||
if {$opt_highlight} { |
||||
set v [package provide $m] |
||||
if {$v ne ""} { |
||||
set posn [lsearch $versions $v] |
||||
if {$posn >= 0} { |
||||
#FIXME! (probably in textblock::pad ?) |
||||
#TODO - determine why underline is extended to padding even with double reset. (space or other char required to prevent) |
||||
set highlighted "$highlight_ansi$v$RST $RST" |
||||
set versions [lreplace $versions $posn $posn $highlighted] |
||||
} else { |
||||
#shouldn't be possible? |
||||
puts stderr "failed to find version '$v' in versions:$versions for package $m" |
||||
} |
||||
} |
||||
} |
||||
lappend matchinfo [list $m $versions] |
||||
} |
||||
switch -- $opt_return { |
||||
list { |
||||
return $matchinfo |
||||
} |
||||
lines { |
||||
return [join $matchinfo \n] |
||||
} |
||||
table - tableobject { |
||||
set t [textblock::class::table new] |
||||
$t add_column -headers "Package" |
||||
$t add_column -headers "Version" |
||||
$t configure -show_hseps 0 |
||||
foreach m $matchinfo { |
||||
$t add_row [list [lindex $m 0] [join [lindex $m 1] " "]] |
||||
} |
||||
if {$opt_return eq "tableobject"} { |
||||
return $t |
||||
} |
||||
set result [$t print] |
||||
$t destroy |
||||
return $result |
||||
} |
||||
} |
||||
} |
||||
|
||||
punk::args::define { |
||||
@id -id ::punk::mix::commandset::loadedlib::loaded.search |
||||
@cmd -name "punk::mix::commandset::loadedlib loaded.search"\ |
||||
-summary\ |
||||
"Search loaded libraries."\ |
||||
-help "search all Tcl libraries currently loaded in your local interpreter. |
||||
ie those that have been loaded directly or indirectly by 'package require'." |
||||
}\ |
||||
@values\ |
||||
[punk::args::resolved_def -types values ::punk::mix::commandset::loadedlib::search searchstring] |
||||
|
||||
proc loaded.search {args} { |
||||
set argd [punk::args::parse $args withid ::punk::mix::commandset::loadedlib::loaded.search] |
||||
lassign [dict values $argd] leaders opts values |
||||
set searchstrings [dict get $values searchstring] |
||||
|
||||
set all_libs [search -return list -highlight 0 {*}$searchstrings] |
||||
|
||||
set col1items [list] |
||||
set col2items [list] |
||||
set col3items [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend col1items $libname |
||||
lappend col2items $versions |
||||
lappend col3items $ver |
||||
} |
||||
} |
||||
|
||||
package require overtype |
||||
set title1 "Library" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Versions Avail." |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Loaded Version" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||
} |
||||
|
||||
return $table |
||||
|
||||
|
||||
set loaded_libs [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||
} |
||||
} |
||||
return [join $loaded_libs \n] |
||||
} |
||||
|
||||
proc info {libname} { |
||||
catch {package require $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range |
||||
set pkgsknown [package names] |
||||
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||
} else { |
||||
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||
} |
||||
set versions [package versions [lindex $libname 0]] |
||||
set versions [lsort -command {package vcompare} $versions] |
||||
if {![llength $versions]} { |
||||
puts stderr "No version numbers found for library/module $libname" |
||||
return false |
||||
} |
||||
puts stdout "Versions of $libname found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
foreach ver $versions { |
||||
set loadinfo [package ifneeded $libname $ver] |
||||
puts stdout "$libname $ver" |
||||
puts stdout "--- 'package ifneeded' script ---" |
||||
puts stdout $loadinfo |
||||
puts stdout "---" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc copyasmodule {library modulefoldername args} { |
||||
set defaults [list -askme 1] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
|
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
|
||||
catch {package require $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range) |
||||
|
||||
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||
if {![file exists $modulefoldername]} { |
||||
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||
} |
||||
#use the target folder as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolder_path $modulefoldername |
||||
} else { |
||||
#use the current working directory as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
if {$projectdir ne ""} { |
||||
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||
set majorv [lindex [split [info tclversion] .] 0] |
||||
foreach k [list modules modules_tcl$majorv vendormodules vendormodules_tcl$majorv] { |
||||
set knownfolder [file join $projectdir src $k] |
||||
if {$knownfolder ni $modulefolders} { |
||||
lappend modulefolders $knownfolder |
||||
} |
||||
} |
||||
set mtails [list] |
||||
foreach path $modulefolders { |
||||
lappend mtails [file tail $path] |
||||
} |
||||
|
||||
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||
|
||||
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules bootsupport/modules_tcl$majorv"} { |
||||
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||
append msg "Known module folders: [lsort $mtails]\n" |
||||
append msg "Use a name from the above list, or a fully qualified path\n" |
||||
error $msg |
||||
} |
||||
|
||||
if {$modulefoldername eq "bootsupport"} { |
||||
set modulefoldername "bootsupport/modules" |
||||
} |
||||
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||
} else { |
||||
set msg "No current project found at or above current directory\n" |
||||
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||
error $msg |
||||
} |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {$projectdir ne ""} { |
||||
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||
} else { |
||||
puts stdout "No current project." |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {![file exists $modulefolder_path]} { |
||||
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||
} |
||||
|
||||
|
||||
set libfound [lsearch -all -inline [package names] $library] |
||||
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||
} |
||||
|
||||
set versions [package versions [lindex $libfound 0]] |
||||
set versions [lsort -command {package vcompare} $versions] |
||||
#if {$has_natsort} { |
||||
# set versions [natsort::sort $versions] |
||||
#} else { |
||||
# set versions [lsort $versions] |
||||
#} |
||||
if {![llength $versions]} { |
||||
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||
} |
||||
puts stdout "Versions of $libfound found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
|
||||
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||
if {[llength $versions] > 1} { |
||||
puts stdout "Version selected: $ver" |
||||
} |
||||
|
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map {\r\n \n} $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||
set is_package_require_self_recased 0 |
||||
set is_package_require_diversion 0 |
||||
set lib_diversion_name "" |
||||
if {[llength $loadinfo_lines] == 1} { |
||||
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||
set line1 [lindex $loadinfo_lines 0] |
||||
#check if multiparted with semicolon |
||||
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||
set parts [list] |
||||
if {[regexp {;} $line1]} { |
||||
foreach p [split $line1 {;}] { |
||||
set p [string trim $p] |
||||
if {[string length $p]} { |
||||
#only append parts with some content that doesn't look like a comment |
||||
if {![string match "#*" $p]} { |
||||
lappend parts $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
if {[llength $parts] == 1} { |
||||
#seems like a lone package require statement. |
||||
#check if package require, package\trequire etc |
||||
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||
set is_package_require_diversion 1 |
||||
if {[lindex $line1 2] eq "-exact"} { |
||||
#package require -exact <pkg> <ver> |
||||
set lib_diversion_name [lindex $line1 3] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
if {[lindex $line1 4] eq $ver} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} else { |
||||
#may be package require <pkg> <ver> |
||||
#or package require <pkg> <ver> ?<ver>?... |
||||
set lib_diversion_name [lindex $line1 2] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
set requiredversions [lrange $line1 3 end] |
||||
if {$ver in $requiredversions} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||
set libfound $lib_diversion_name |
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map {\r\n \n} $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {$is_package_require_diversion} { |
||||
#single |
||||
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||
#We could automate - but it seems likely to be surprising. |
||||
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||
set source_file [lindex $loadinfo 1] |
||||
} elseif {[string match "*source*" $loadinfo]} { |
||||
set parts [list] |
||||
foreach ln $loadinfo_lines { |
||||
if {![string length $ln]} {continue} |
||||
lappend parts {*}[split $ln ";"] |
||||
} |
||||
set sources_found [list] |
||||
set loads_found [list] |
||||
set dependencies [list] |
||||
set incomplete_lines [list] |
||||
foreach p $parts { |
||||
set p [string trim $p] |
||||
if {![string length $p]} { |
||||
continue ;#empty line or trailing colon |
||||
} |
||||
if {[string match "*tclPkgSetup*" $p]} { |
||||
puts stderr "Unable to process load script for library $libfound" |
||||
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||
return false |
||||
} |
||||
if {![::info complete $p]} { |
||||
# |
||||
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||
#better to defer to manual processing |
||||
lappend incomplete_lines $p |
||||
continue |
||||
} |
||||
if {[lindex $p 0] eq "source"} { |
||||
#may have args.. e.g -encoding utf-8 |
||||
lappend sources_found [lindex $p end] |
||||
} |
||||
if {[lindex $p 0] eq "load"} { |
||||
lappend loads_found [lrange $p 1 end] |
||||
} |
||||
if {[lrange $p 0 1] eq "package require"} { |
||||
lappend dependencies [lrange $p 2 end] |
||||
} |
||||
} |
||||
if {[llength $incomplete_lines]} { |
||||
puts stderr "unable to interpret load script for library $libfound" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $loads_found]} { |
||||
puts stderr "package $libfound appears to have binary components" |
||||
foreach l $loads_found { |
||||
puts stderr " binary - $l" |
||||
} |
||||
foreach s $sources_found { |
||||
puts stderr " script - $s" |
||||
} |
||||
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||
return false |
||||
} |
||||
|
||||
if {[llength $sources_found] != 1} { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Only 1 source supported for now" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $dependencies]} { |
||||
#todo - check/ignore if dependency is Tcl ? |
||||
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||
foreach d $dependencies { |
||||
puts stderr " - $d" |
||||
} |
||||
} |
||||
|
||||
set source_file [lindex $sources_found 0] |
||||
} else { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
|
||||
# -- --------------------------------------- |
||||
#Analyse source file |
||||
if {![file exists $source_file]} { |
||||
error "Unable to verify source file existence at: $source_file" |
||||
} |
||||
set source_data [fcat -translation binary $source_file] |
||||
if {![string match "*package provide*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||
return false |
||||
} else { |
||||
if {![string match "*$libfound*" $source_data]} { |
||||
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||
#e.g anyname-0.1.tm example |
||||
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||
puts stderr "Copy the library across to a lib folder instead" |
||||
return false |
||||
} |
||||
# -- --------------------------------------- |
||||
|
||||
set moduleprefix [punk::ns::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::ns::nstail $libfound] |
||||
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||
|
||||
if {$opt_askme} { |
||||
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||
puts stdout "" |
||||
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||
puts stdout "" |
||||
puts stdout "Base module path: $modulefolder_path" |
||||
puts stdout "Target path : $target_path" |
||||
puts stdout "results of 'package ifneeded $libfound'" |
||||
puts stdout "---" |
||||
puts stdout "$loadinfo" |
||||
puts stdout "---" |
||||
set question "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||
set answer [punk::lib::askuser $question] ;#takes account of previous stdin state and terminal raw vs line state |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {![file exists $modulefolder_path]} { |
||||
puts stdout "Creating module base folder at $modulefolder_path" |
||||
file mkdir $modulefolder_path |
||||
} |
||||
if {![file exists [file dirname $target_path]]} { |
||||
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||
file mkdir [file dirname $target_path] |
||||
} |
||||
|
||||
if {[file exists $target_path]} { |
||||
puts stdout "WARNING - module already exists at $target_path" |
||||
if {$opt_askme} { |
||||
set question "Copy anyway? Y|N" |
||||
set answer [punk::lib::askuser $question] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
file copy -force $source_file $target_path |
||||
|
||||
return $target_path |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,554 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::module 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::repo |
||||
# depends on punk,punk::mix::base,punk::mix::cli |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::module { |
||||
namespace export * |
||||
|
||||
proc paths {} { |
||||
#set roots [punk::repo::find_repos ""] |
||||
#set project [lindex [dict get $roots project] 0] |
||||
set project [punk::repo::find_project ""] |
||||
|
||||
if {$project ne ""} { |
||||
set is_project 1 |
||||
set searchbase $project |
||||
} else { |
||||
set is_project 0 |
||||
set searchbase [pwd] |
||||
} |
||||
|
||||
if {[catch { |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||
} errMsg]} { |
||||
set source_module_folderlist [list] |
||||
} |
||||
|
||||
set tm_folders [tcl::tm::list] |
||||
package require overtype |
||||
|
||||
set result "" |
||||
if {$is_project} { |
||||
append result "Project module source paths:" \n |
||||
foreach f $source_module_folderlist { |
||||
append result "$f" \n |
||||
} |
||||
} |
||||
append result \n |
||||
append result "tcl::tm::list" \n |
||||
foreach f $tm_folders { |
||||
if {$is_project} { |
||||
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||
set pinfo "(within project)" |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
set warning "" |
||||
if {![file isdirectory $f]} { |
||||
set warning "(PATH NOT FOUND)" |
||||
} |
||||
append result "$f $pinfo $warning" \n |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
#require current dir when calling to be the projectdir, or |
||||
punk::args::define { |
||||
@dynamic |
||||
@id -id "::punk::mix::commandset::module::templates" |
||||
@cmd -name "punk::mix::commandset::module::templates" |
||||
${[punk::args::resolved_def -antiglobs {@id @cmd} "::punk::mix::commandset::module::templates_dict"]} |
||||
} |
||||
proc templates {args} { |
||||
set tdict_low_to_high [templates_dict {*}$args] |
||||
#convert to screen order - with higher priority at the top |
||||
set tdict [dict create] |
||||
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||
} |
||||
|
||||
package require overtype |
||||
package require textblock |
||||
#set pathinfolist [dict values $tdict] |
||||
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||
|
||||
set names [dict keys $tdict] |
||||
set paths [list] |
||||
set pathtypes [list] |
||||
set providers [list] |
||||
dict for {nm tinfo} $tdict { |
||||
lappend paths [dict get $tinfo path] |
||||
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||
lappend providers [dict get $tinfo sourceinfo source] ;#name of provider module of punk.templates capability for this path |
||||
} |
||||
|
||||
set title(name) "Template Name" |
||||
set title(pathtype) "[a+ italic]Provider[a]\n[a+ green]Path Type[a]" |
||||
set title(path) "Path" |
||||
|
||||
set data [list] |
||||
foreach n $names pt $pathtypes pv $providers p $paths { |
||||
#append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n |
||||
lappend data $n "[a+ italic]$pv[a]\n$pt" $p |
||||
} |
||||
set table [textblock::list_as_table -columns 3 -header [list $title(name) $title(pathtype) $title(path)] $data] |
||||
|
||||
return $table |
||||
} |
||||
|
||||
#return all module templates with repeated ones suffixed with #2 #3 etc |
||||
punk::args::define { |
||||
@id -id ::punk::mix::commandset::module::templates_dict |
||||
@cmd -name templates_dict -help\ |
||||
"Templates from module and project paths" |
||||
-startdir -default "" -help\ |
||||
"Project folder used in addition to module paths" |
||||
-not -default "" -multiple 1 |
||||
@values |
||||
globsearches -default * -multiple 1 |
||||
} |
||||
proc templates_dict {args} { |
||||
#set argd [punk::args::get_by_id ::punk::mix::commandset::module::templates_dict $args] |
||||
set argd [punk::args::parse $args withid ::punk::mix::commandset::module::templates_dict] |
||||
package require punk::cap |
||||
if {[punk::cap::capability_has_handler punk.templates]} { |
||||
set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args] |
||||
} else { |
||||
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||
} |
||||
} |
||||
|
||||
|
||||
set moduletypes [punk::mix::cli::lib::module_types] |
||||
punk::args::define [subst { |
||||
@id -id ::punk::mix::commandset::module::new |
||||
@cmd -name "punk::mix::commandset::module::new" -help\ |
||||
"Create a new module file in the appropriate folder within src/modules. |
||||
If the name given in the module argument is namespaced, |
||||
the necessary subfolder(s) will be used or created." |
||||
-project -optional 1 |
||||
-version -default "0.1.0" -help\ |
||||
"version to use if not specified as part of the module argument. |
||||
If a version is specified in the module argument as well as in -version |
||||
the higher version number will be used. |
||||
" |
||||
-license -default <unspecified> |
||||
-author -default <unspecified> -multiple 1 |
||||
-template -default punk.module |
||||
-type -default "[lindex $moduletypes 0]" -choices {$moduletypes} |
||||
-force -default 0 -type boolean -help\ |
||||
"If set true, will OVERWRITE an existing .tm file if there is one. |
||||
If false (default) an error will be raised if there is a conflict." |
||||
-quiet -default 0 -type boolean -help\ |
||||
"Suppress information messages on stdout" |
||||
@values -min 1 -max 1 |
||||
module -type string -help\ |
||||
"Name of module, possibly including a namespace and/or version number |
||||
e.g mynamespace::mymodule-1.0" |
||||
}] |
||||
proc new {args} { |
||||
set year [clock format [clock seconds] -format %Y] |
||||
# use \uFFFD because unicode replacement char should consistently render as 1 wide |
||||
set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set module [dict get $values module] |
||||
|
||||
#set opts [dict merge $defaults $args] |
||||
|
||||
#todo - review compatibility between -template and -type |
||||
#-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl) |
||||
#-template may be a folder - but only if the selected -type suports it |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# option -version |
||||
# we need this value before looking at the named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_version_supplied [dict get $opts -version] |
||||
set opt_version $opt_version_supplied |
||||
if {![util::is_valid_tm_version $opt_version]} { |
||||
error "deck module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set mversion_supplied "" ;#version supplied directly in module argument |
||||
if {[string first - $module]> 0} { |
||||
#if it has a dash then version is required to be valid |
||||
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||
if {![util::is_valid_tm_version $mversion]} { |
||||
error "deck module.new error - unable to determine modulename-version from supplied value '$module'" |
||||
} |
||||
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||
if {$vcompare_is_mversion_bigger > 0} { |
||||
set opt_version $mversion; #module parameter has higher value than -version |
||||
set vmsg "from module argument: $module" |
||||
} else { |
||||
set vmsg "from -version option: $opt_version_supplied" |
||||
} |
||||
if {"-version" in $received} { |
||||
if {$vcompare_is_mversion_bigger != 0} { |
||||
#is bigger or smaller |
||||
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||
} |
||||
} |
||||
} else { |
||||
set modulename $module |
||||
} |
||||
punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" |
||||
|
||||
if {[regexp {[A-Z]} $module]} { |
||||
set msg "module names containing uppercase are not recommended (see tip 590).\n" |
||||
append msg "Please retype the module name '$module' to proceed.\n" |
||||
append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" |
||||
append msg "Retype it all in lowercase to use recommended naming" |
||||
set answer [util::askuser $msg] |
||||
if {[regexp {[A-Z]} $answer]} { |
||||
if {$answer eq $module} { |
||||
#ok - user insists |
||||
} else { |
||||
|
||||
} |
||||
} else { |
||||
#user has resupplied modulename all as lowercase |
||||
if {$answer eq [string tolower $module]} { |
||||
set module $answer |
||||
} else { |
||||
#.. but it doesn't match original - require rerun |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#options |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set testdir [pwd] |
||||
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||
set msg [punk::repo::is_candidate_root_requirements_msg] |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||
} |
||||
} |
||||
if {![dict exists $received -project]} { |
||||
set projectname [file tail $projectdir] |
||||
} else { |
||||
set opt_project [dict get $opts -project] |
||||
set projectname $opt_project |
||||
if {$projectname ne [file tail $projectdir]} { |
||||
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_license [dict get $opts -license] |
||||
set opt_authors [dict get $opts -author] ;#-multiple true |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_template [dict get $opts -template] |
||||
if {[regexp {.*[?*].*} $opt_template]} { |
||||
error "module.new -template does not support glob chars. Use an exact full name including version (and optionally .tm) - or use just the name without version or .tm, and the latest version will be selected" |
||||
} |
||||
|
||||
set templates_dict [templates_dict] ;#keys are possibly prefixed with <vendor>. and/or suffixed with #2 #3 etc if there are collisions - the remaining unsuffixed being the one with highest preference |
||||
#todo - allow versionless name - pick latest which isn't suffixed with #2 etc |
||||
#if the user wants to exactly match an unversioned template, in the presence of versioned ones - they may need to include the trailing .tm |
||||
if {[dict exists $templates_dict $opt_template]} { |
||||
#exact long name (possibly including version) |
||||
#Note - an unversioned .tm template will be matched here - even though versioned templates of the same name may exist. |
||||
set templatefile [dict get $templates_dict $opt_template path] |
||||
set templatefile_info [dict get $templates_dict $opt_template sourceinfo] |
||||
} else { |
||||
#if it wasn't an exact match for opt_template - then opt_template now shouldn't contain a version (we have also ruled out glob chars * & ? above) |
||||
#(if it does - then we just won't find anything - which is fine) |
||||
#module file name could contain dots - but only one dash - if it is versioned |
||||
|
||||
set matches [lsearch -all -inline [dict keys $templates_dict] $opt_template-*] ;#the key is of form vendor.modulename-version(#suffix) (version optional, suffix if lower precedence with same name was found) |
||||
#only .tm (or .TM .Tm .tM) files make it into the templates_dict - they are allowed to be unversioned though. |
||||
set key_version_list [list] |
||||
foreach m $matches { |
||||
#vendorname could contain dashes or dots - so easiest way to split out is to examine the stored vendor value in sourceinfo |
||||
set vendor [dict get $templates_dict $m sourceinfo vendor] |
||||
if {$vendor ne "_project"} { |
||||
#_project special case - not included in module names |
||||
set module $m |
||||
} else { |
||||
set module [string range [string length $vendor.] end] |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $m] _tailmname mversion |
||||
lappend key_version_list [list $m $mversion] |
||||
} |
||||
if {[llength $matches]} { |
||||
set highest_m "" |
||||
set highest_v "" |
||||
foreach kv $key_version_list { |
||||
if {$highest_v eq ""} { |
||||
set highest_m [lindex $kv 0] |
||||
set highest_v [lindex $kv 1] |
||||
} else { |
||||
if {[package vcompare $highest_v [lindex $kv 1]] == -1} { |
||||
set highest_m [lindex $kv 0] |
||||
set highest_v [lindex $kv 1] |
||||
} |
||||
} |
||||
} |
||||
set templatefile [dict get $templates_dict $highest_m path] |
||||
set templatefile_info [dict get $templates_dict $highest_m sourceinfo] |
||||
} else { |
||||
error "module.new unable to find template '$opt_template'. [dict size $templates_dict] Known templates. Use deck module.templates to display" |
||||
} |
||||
} |
||||
|
||||
|
||||
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_quiet [dict get $opts -quiet] |
||||
set opt_force [dict get $opts -force] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||
if {![string length $subpath]} { |
||||
set modulefolder $projectdir/src/modules |
||||
} else { |
||||
set modulefolder $projectdir/src/modules/$subpath |
||||
} |
||||
file mkdir $modulefolder |
||||
|
||||
set moduletail [namespace tail $modulename] |
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
|
||||
|
||||
|
||||
|
||||
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||
set template_tail [string range $template_tail [string length template_] end] |
||||
set ext [string tolower [file extension $template_tail]] |
||||
if {$ext eq ".tm"} { |
||||
set template_modulename_part [file rootname $template_tail] |
||||
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||
#something like modulename-0.0.1.tm.2 |
||||
#strip of last 2 dotted parts |
||||
set shortened [file rootname $template_tail] |
||||
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||
} |
||||
set template_modulename_part [file rootname $shortened] |
||||
} else { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||
|
||||
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||
if {[string match "*$magicversion*" $template_filedata]} { |
||||
set use_magic 1 |
||||
set build_version $opt_version |
||||
set infile_version $magicversion |
||||
} else { |
||||
set use_magic 0 |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
set build_version $opt_version |
||||
} else { |
||||
# |
||||
|
||||
if {[util::is_valid_tm_version $t_version]} { |
||||
if {$mversion_supplied eq ""} { |
||||
set build_version $t_version |
||||
} else { |
||||
#we have a version from the named argument 'module' |
||||
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||
set build_version $mversion_supplied |
||||
} else { |
||||
set build_version $t_version |
||||
} |
||||
} |
||||
} else { |
||||
#probably an unversioned module template |
||||
#use opt_version default from above |
||||
set build_version $opt_version |
||||
} |
||||
} |
||||
set infile_version $build_version |
||||
} |
||||
|
||||
set moduletemplate [file join $projectname [punk::path::relative $projectdir $templatefile]] ;#if templatfile is on another volume - just $templatefile will be returned. |
||||
#moduletemplate should usually be a relative path - but could be absolute, or contain info about the relative locations of projectdir vs templatefile if template comes from another project or a module outside the project |
||||
#This path info may be undesired in the template output (%moduletemplate%) |
||||
#it is nevertheless useful information - and not the only way developer-machine/build-machine paths can leak |
||||
#for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern |
||||
|
||||
#Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens |
||||
set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license authors $opt_authors version $infile_version] |
||||
set strmap [list] |
||||
foreach {tag val} $tagnames { |
||||
lappend strmap %$tag% $val |
||||
} |
||||
set template_filedata [string map $strmap $template_filedata] |
||||
|
||||
set tmfile $modulefolder/${moduletail}-$infile_version.tm |
||||
set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm |
||||
set has_tm [file exists $tmfile] |
||||
set has_pod [file exists $podfile] |
||||
if {$has_tm && $has_pod} { |
||||
#invalid configuration - bomb out |
||||
error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again." |
||||
} |
||||
if {$opt_type eq "plain"} { |
||||
set modulefile $tmfile |
||||
} else { |
||||
set modulefile $podfile |
||||
} |
||||
if {$has_tm || $has_pod} { |
||||
if {!$opt_force} { |
||||
if {$has_tm} { |
||||
set errmsg "module.new error: module file $tmfile already exists - aborting" |
||||
} else { |
||||
set errmsg "module.new error: module file $podfile already exists - aborting" |
||||
} |
||||
if {[string match "*$magicversion*" $tmfile]} { |
||||
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
#review - prompt here vs caller? |
||||
#we are committed to overwriting/replacing if there was a pre-existing module of same version |
||||
if {$has_pod} { |
||||
file delete -force [file dirname $podfile] |
||||
} elseif {$has_tm} { |
||||
file delete -force $tmfile |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} else { |
||||
#mix_templates_dir warns of deprecation - review |
||||
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} |
||||
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||
set existing_build_version "" |
||||
if {!$opt_force && [file exists $buildversionfile]} { |
||||
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||
set lines [split $buildversiondata \n] |
||||
set existing_build_version [string trim [lindex $lines 0]] |
||||
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||
} |
||||
} |
||||
|
||||
set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||
set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*] |
||||
set existing_versions [concat $existing_tm_versions $existing_pod_versions] |
||||
|
||||
if {[llength $existing_versions]} { |
||||
set name_version_pairs [list] |
||||
lappend name_version_pairs [list $moduletail $infile_version] |
||||
foreach existing $existing_versions { |
||||
lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored |
||||
if {[string match #modpod-* $namepart]} { |
||||
set namepart [string range $namepart 8 end] |
||||
} |
||||
lappend name_version_pairs [list $namepart $version] |
||||
} |
||||
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||
append errmsg \n "Other versions found: $other_versions" |
||||
if {$magicversion in $other_versions} { |
||||
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||
} |
||||
} |
||||
|
||||
if {!$opt_quiet} { |
||||
puts stdout "Creating $modulefile from template $moduletemplate" |
||||
} |
||||
file mkdir [file dirname $modulefile] |
||||
|
||||
set fd [open $modulefile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $template_filedata |
||||
close $fd |
||||
|
||||
|
||||
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||
set fd [open $buildversionfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $buildversion_filedata |
||||
close $fd |
||||
|
||||
return [list file $modulefile version $build_version] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -1,464 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::repo { |
||||
namespace export * |
||||
|
||||
variable PUNKARGS |
||||
|
||||
proc tickets {{project ""}} { |
||||
#todo |
||||
set result "" |
||||
if {[string length $project]} { |
||||
puts stderr "project status unimplemented" |
||||
return |
||||
} |
||||
set active_dir [pwd] |
||||
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||
append result [exec fossil timeline -n 10 -t t] |
||||
|
||||
return $result |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::mix::commandset::repo::fossilize |
||||
@cmd -name punk::mix::commandset::repo::fossilize |
||||
-summary\ |
||||
"Initialise and check in a project to fossil (unimplemented)."\ |
||||
-help\ |
||||
"(unimplemented)" |
||||
}] |
||||
proc fossilize { args} { |
||||
#check if project already managed by fossil.. initialise and check in if not. |
||||
puts stderr "unimplemented" |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::mix::commandset::repo::unfossilize |
||||
@cmd -name punk::mix::commandset::repo::unfossilize |
||||
-summary\ |
||||
"Remove/archive .fossil (unimplemented)."\ |
||||
-help\ |
||||
"(unimplemented)" |
||||
}] |
||||
proc unfossilize {projectname args} { |
||||
#remove/archive .fossil |
||||
puts stderr "unimplemented" |
||||
} |
||||
proc state {} { |
||||
set result "" |
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [a+ bold yellow][dict get $repopaths warnings][a] |
||||
} else { |
||||
append result [a+ bold yellow][dict get $repopaths warnings][a] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
append result \n "Fossil repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
if {"git" in $repotypes} { |
||||
append result \n "Git repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#punk::args |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::mix::commandset::repo::fossil-move-repository |
||||
@cmd -name punk::mix::commandset::repo::fossil-move-repository |
||||
-summary\ |
||||
"Move a fossil repository database file."\ |
||||
-help\ |
||||
"Move the fossil repository file (usually named with .fossil extension). |
||||
This is an interactive function which will prompt for answers on stdin |
||||
before proceeding. |
||||
The move can be done even if there are open checkouts and will maintain |
||||
the link between checkout databases and the repository file. |
||||
|
||||
The call can be made from within a folder containing fossil databases, |
||||
or from within one of the checkouts of the fossil database that is to |
||||
be moved. |
||||
" |
||||
|
||||
#todo? |
||||
#@values -min 0 -max 1 |
||||
#path |
||||
}] |
||||
proc fossil-move-repository {{path ""}} { |
||||
#path unused for now - todo - allow calling with a specific target rather than relying on cwd? |
||||
set searchbase [pwd] |
||||
set projectinfo [punk::repo::find_repos $searchbase] |
||||
set projectbase [dict get $projectinfo closest] |
||||
set is_fossil [expr {"fossil" in [dict get $projectinfo closest_types]}] |
||||
if {[catch { |
||||
package require sqlite3 |
||||
} errM]} { |
||||
puts stderr "sqlite3 package failed to load" |
||||
puts stderr "Try using 'fossil test-move-repository <targetpath>' from within an open checkout folder, or ensure that the Tcl sqlite3 package is available." |
||||
return |
||||
} |
||||
set ansiprompt [a+ green bold] |
||||
set ansiwarn [a+ red bold] |
||||
set ansihighlight [a+ cyan bold] |
||||
set ansireset [a] |
||||
|
||||
set in_checkout 0 |
||||
set is_checkout_relink 0; #whether we are attempting to link a checkout that has lost its repo |
||||
#we may also encounter a different kind of relink candidate - other checkouts of the same repo that we examine and find don't point back. |
||||
if {$projectbase eq "" || !$is_fossil} { |
||||
set repodbs [glob -dir $searchbase -type f -tail *.fossil] |
||||
if {![llength $repodbs]} { |
||||
puts stderr "Current directory does not seem to be directly below a fossil checkout, and no .fossil files found" |
||||
puts stderr "Please move to a folder containing the .fossil repository database to move, or to a folder directly within a fossil checkout (and with no intermediate git/fossil repos)" |
||||
return |
||||
} |
||||
set choice_files [list] |
||||
set i 1 |
||||
set menu_message "" |
||||
append menu_message "${ansiprompt}Select the number of the fossil repo db to potentially move (confirmation will be requested before any action is taken)${ansireset}" \n |
||||
foreach db $repodbs { |
||||
sqlite3 dbinfo [file join $searchbase $db] |
||||
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
||||
dbinfo close |
||||
lappend choice_files [list index $i repofile $db checkouts [llength $ckouts]] |
||||
append menu_message "$i $db checkouts: [llength $ckouts]" \n |
||||
incr i |
||||
} |
||||
puts stdout $menu_message |
||||
set max [llength $choice_files] |
||||
if {$max == 1} { |
||||
set rangemsg "the number 1" |
||||
} else { |
||||
set rangemsg "a number from 1 to $max" |
||||
} |
||||
set answer [punk::repo::askuser "${ansiprompt}Enter $rangemsg to select a .fossil repository database to show details and potentially move. (or N to abort)${ansireset}"] |
||||
if {![string is integer -strict $answer]} { |
||||
puts stderr "Aborting" |
||||
return |
||||
} |
||||
|
||||
set index [expr {int($answer) -1}] |
||||
if {$index >= 0 && $index <= $max-1} { |
||||
set repo_file_choice [lindex $choice_files $index] |
||||
set repo_file [dict get $repo_file_choice repofile] |
||||
set repo_file [file join $searchbase $repo_file] |
||||
puts stdout "Selected fossil repo database file: $repo_file" |
||||
} else { |
||||
puts stderr " No menu number matched - aborting." |
||||
return |
||||
} |
||||
} else { |
||||
if {[file exists $projectbase/_FOSSIL_]} { |
||||
set cdbfile [file join $projectbase/_FOSSIL_] |
||||
} elseif {[file exists $projectbase/.fslckout]} { |
||||
set cdbfile [file join $projectbase/.fslckout] |
||||
} else { |
||||
puts stderr "No checkout database (_FOSSIL_ or .fslckout) found in nearest repository folder $projectbase (looked upwards from $searchbase)" |
||||
puts stderr "Unable to locate repository databases for potential move. Please move to a checkout folder or a folder containing .fossil repositories" |
||||
puts stderr "If run from a location where repositories are found, fossil-move-repository will give you the option to select a repository or cancel the operation" |
||||
return |
||||
} |
||||
set in_checkout 1 |
||||
sqlite3 cdb $cdbfile |
||||
set repo_file [cdb eval {select value from vvar where name='repository'}] |
||||
cdb close |
||||
if {[string length [string trim $repo_file]] && [file pathtype $repo_file] eq "relative"} { |
||||
set repo_file [file join $projectbase $repo_file] |
||||
} |
||||
if {![string length [string trim $repo_file]] || ![file exists $repo_file]} { |
||||
puts stderr "${ansiwarn}Checkout at $projectbase points to repository '$repo_file' - but it doesn't seem to exist${ansireset}" |
||||
set answer [punk::repo::askuser "${ansiprompt}Do you want to link this to an existing repository file? (Y|N)${ansireset}"] |
||||
if {[string match y* [string tolower $answer]]} { |
||||
set is_checkout_relink 1 |
||||
} else { |
||||
puts stderr "Aborting - Unable to link this checkout dir to a repository database file" |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
set pname [file rootname [file tail $repo_file]] |
||||
set full_path_repo_file [file join $searchbase $repo_file] |
||||
if {[file isfile $full_path_repo_file]} { |
||||
sqlite3 dbinfo [file join $searchbase $repo_file] |
||||
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
||||
dbinfo close |
||||
if {![llength $ckouts]} { |
||||
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have no open checkouts" |
||||
} else { |
||||
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have [llength $ckouts] open checkouts:" |
||||
foreach ck $ckouts { |
||||
puts stdout [string range $ck 6 end] |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "${ansiwarn}Missing repository db at $full_path_repo_file${ansireset}" |
||||
} |
||||
puts stdout "${ansihighlight}Report for all projects with repository file name $pname${ansireset}" |
||||
puts stdout [punk::mix::commandset::project::collection::detail $pname] |
||||
puts stdout [punk::mix::commandset::project::collection::work $pname -detail 1] |
||||
|
||||
#todo |
||||
#ask user if they want to select a different pname |
||||
set wantrenameprompt "${ansiprompt}Would you like to rename the .fossil file? (Y|N)${ansireset}" |
||||
append wantrenameprompt \n "${ansiprompt}.eg change $pname.fossil to something else such as ${pname}_new.fossil${ansireset}" |
||||
set answer [punk::repo::askuser $wantrenameprompt] |
||||
set pname2 $pname |
||||
if {[string match y* [string tolower $answer]]} { |
||||
set dorenameprompt "${ansiprompt}Enter the new name and hit enter. (Just an alphanumeric name (possibly with dots/dashes/underscores) without .fossil and without any path)${ansireset}" |
||||
set namechoice [punk::repo::askuser $dorenameprompt] |
||||
if {[string length $namechoice]} { |
||||
set permittedmap [list . "" - "" _ ""] |
||||
if {[string is alnum -strict [string map $permittedmap $namechoice]]} { |
||||
set pname2 $namechoice |
||||
} else { |
||||
puts stderr "Entered name was invalid. Must be numbers,letters,underscore,dot,dash" |
||||
} |
||||
} |
||||
puts stdout "Continuing with name $pname2 - cancel at next prompt if this is incorrect" |
||||
} |
||||
|
||||
set target_repodb_folder [punk::repo::fossil_get_repository_folder_for_project $pname2 -parentfolder $searchbase -askpath 1] |
||||
#target_repodb_folder might be same as source folder - check for same file if name wasn't changed? |
||||
if {![string length $target_repodb_folder]} { |
||||
puts stderr "No usable repository database folder selected for $pname2.fossil file" |
||||
return |
||||
} |
||||
|
||||
set existing_target_repofile 0 |
||||
if {[file exists $target_repodb_folder/$pname2.fossil]} { |
||||
set existing_target_repofile 1 |
||||
puts stdout "${ansiwarn}NOTICE: $target_repodb_folder/$pname2.fossil already exists${ansireset}" |
||||
if {!$is_checkout_relink} { |
||||
set finalquestion "${ansiprompt}Are you sure you want to switch the repository $repo_file for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
||||
} else { |
||||
set finalquestion "${ansiprompt}Are you sure you want to attempt to linke the repository (previously linked with '$repo_file') for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
||||
} |
||||
} else { |
||||
if {!$is_checkout_relink} { |
||||
set finalquestion "${ansiprompt}Proceed to move repository $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
||||
} else { |
||||
set finalquestion "${ansiprompt}Proceed to attempt link for missing repo db $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
||||
} |
||||
} |
||||
set line "${ansiwarn}[string repeat - [string length $finalquestion]]${ansireset}" |
||||
set finalprompt $line\n |
||||
append finalprompt $finalquestion \n |
||||
append finalprompt $line \n |
||||
|
||||
set answer [punk::repo::askuser $finalprompt] |
||||
if {[string match y* [string tolower $answer]]} { |
||||
if {!$existing_target_repofile && !$is_checkout_relink} { |
||||
if {[catch { |
||||
file copy $repo_file $target_repodb_folder/$pname2.fossil |
||||
} errM]} { |
||||
puts stderr "${ansiwarn}FAILED to copy $repo_file to $target_repodb_folder/$pname2.fossil - aborting${ansireset}" |
||||
puts stderr "Error message was:\n $errM" |
||||
return |
||||
} |
||||
if {$in_checkout} { |
||||
#in_checkout means we can assume projectbase var exists |
||||
#there may be other checkouts on the old repo |
||||
#if so, we will remind the user of their existence |
||||
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||
puts stderr "$errM" |
||||
} else { |
||||
|
||||
sqlite3 oldrepo $repo_file |
||||
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||
set pcode [oldrepo eval {select value from config where name = 'project-code'}] |
||||
oldrepo close |
||||
if {[string length $pcode] < 20} { |
||||
puts stderr "WARNING: Failed to get project-code from repo db $repo_file" |
||||
} |
||||
set other_checkouts [list] |
||||
set norm_projectbase [file normalize $projectbase] |
||||
foreach ck $ckouts { |
||||
set ckfolder [string trim [string range $ck 6 end]] |
||||
if {![file isdirectory $ckfolder]} { |
||||
#as the process was launched within a checkout - we won't bother user with reports of non-existant other checkouts |
||||
continue |
||||
} |
||||
if {[file normalize $ckfolder] ne $norm_projectbase} { |
||||
lappend other_checkouts $ckfolder |
||||
} |
||||
} |
||||
if {[llength $other_checkouts]} { |
||||
puts stderr "${ansiwarn}Other checkouts of $repo_file that may need consideration${ansireset}" |
||||
foreach other $other_checkouts { |
||||
puts stdout $other |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#we aren't in a checkout - moving a repo to a new db location and/or name so there's no reason to prefer one checkout over another.. presumably the user either wants to move them all - or be asked.. |
||||
sqlite3 oldrepo $repo_file |
||||
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||
oldrepo close |
||||
if {[llength $ckouts] > 1} { |
||||
puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" |
||||
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
||||
} |
||||
set original_cwd [pwd] |
||||
foreach ck $ckouts { |
||||
set ckfolder [string trim [string range $ck 6 end]] |
||||
if {![file isdirectory $ckfolder]} { |
||||
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
||||
continue |
||||
} |
||||
cd $ckfolder |
||||
puts stdout [exec fossil info] |
||||
puts stdout [state] |
||||
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
||||
if {[string match q* [string tolower $answer]]} { |
||||
puts stderr "User aborting loop" |
||||
break |
||||
} |
||||
if {[string match y* [string tolower $answer]]} { |
||||
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
||||
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||
puts stderr "$moveresult" |
||||
} else { |
||||
puts stdout "OK - move performed with result:" |
||||
puts stdout $moveresult |
||||
} |
||||
} |
||||
} |
||||
cd $original_cwd |
||||
|
||||
} |
||||
} else { |
||||
if {$is_checkout_relink} { |
||||
#relinking a lost checkout to an existing repo.. we should probably check it's other checkouts and see if they point back |
||||
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||
puts stderr "$errM" |
||||
} |
||||
} else { |
||||
if {$in_checkout} { |
||||
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||
puts stderr "$errM" |
||||
} |
||||
} else { |
||||
#not in checkout - we're wanting what pointed to one repo to point to a different existing one - presumably for all checkouts |
||||
sqlite3 newrepo $target_repodb_folder/$pname2.fossil |
||||
set newpname [newrepo eval {select value from config where name = 'project-name'}] |
||||
set newpcode [newrepo eval {select value from config where name = 'project-code'}] |
||||
set newckouts [newrepo eval {select name from config where name like 'ckout:%'}] |
||||
newrepo close |
||||
|
||||
sqlite3 oldrepo $repo_file |
||||
set oldpname [oldrepo eval {select value from config where name = 'project-name'}] |
||||
set oldpcode [oldrepo eval {select value from config where name = 'project-code'}] |
||||
set oldckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||
oldrepo close |
||||
if {$newpname eq $oldpname} { |
||||
set ansi_newpname [a+ green bold]$newpname[a] |
||||
set ansi_oldpname [a+ green bold]$oldpname[a] |
||||
} else { |
||||
set ansi_newpname [a+ cyan bold]$newpname[a] |
||||
set ansi_oldpname [a+ red bold]$oldpname[a] |
||||
} |
||||
if {$newpcode eq $oldpcode} { |
||||
set ansi_newpcode [a+ green bold]$newpcode[a] |
||||
set ansi_oldpcode [a+ green bold]$oldpcode[a] |
||||
} else { |
||||
set ansi_newpcode [a+ cyan bold]$newpcode[a] |
||||
set ansi_oldpcode [a+ red bold]$oldpcode[a] |
||||
} |
||||
puts stdout "Target repository $target_repodb_folder/$pname2.fossil has project-name: $ansi_newpname and [llength $newckouts] existing checkouts" |
||||
puts stdout "Target project code: $ansi_newpcode" |
||||
puts stdout "Source repository $repo_file has project-name: $ansi_oldpname and [llength $oldckouts] existing checkouts" |
||||
puts stdout "Source project code: $ansi_oldpcode" |
||||
if {[llength $oldckouts] > 1} { |
||||
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
||||
} |
||||
set original_cwd [pwd] |
||||
foreach ck $oldckouts { |
||||
set ckfolder [string trim [string range $ck 6 end]] |
||||
if {![file isdirectory $ckfolder]} { |
||||
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
||||
continue |
||||
} |
||||
cd $ckfolder |
||||
puts stdout [exec fossil info] |
||||
puts stdout [state] |
||||
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
||||
if {[string match q* [string tolower $answer]]} { |
||||
puts stderr "User aborting loop" |
||||
break |
||||
} |
||||
if {[string match y* [string tolower $answer]]} { |
||||
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
||||
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||
puts stderr "$moveresult" |
||||
} else { |
||||
puts stdout "OK - move performed with result:" |
||||
puts stdout $moveresult |
||||
} |
||||
} |
||||
} |
||||
cd $original_cwd |
||||
|
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
puts stdout "-done-" |
||||
} else { |
||||
puts stdout "-cancelled by user-" |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::mix::commandset::repo |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -1,94 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
variable pkg punk::mix::templates |
||||
variable cap_provider |
||||
|
||||
namespace eval capsystem { |
||||
if {[info commands capprovider.registration] eq ""} { |
||||
punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
oo::objdefine capprovider.registration { |
||||
method get_declarations {} { |
||||
set decls [list] |
||||
lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? |
||||
|
||||
lappend decls [list punk.templates {path templates pathtype module vendor punk}] |
||||
#only punk::templates is allowed to register a _multivendor path - review |
||||
#other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only |
||||
lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] |
||||
lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] |
||||
|
||||
|
||||
#we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! |
||||
#need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version |
||||
#perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) |
||||
lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] |
||||
lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. |
||||
#review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. |
||||
#we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. |
||||
return $decls |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info commands provider] eq ""} { |
||||
punk::cap::class::interface_capprovider.provider create provider punk::mix::templates |
||||
oo::objdefine provider { |
||||
method register {{capabilityname_glob *}} { |
||||
#puts registering punk::mix::templates $capabilityname |
||||
next $capabilityname_glob |
||||
} |
||||
method capabilities {} { |
||||
next |
||||
} |
||||
} |
||||
} |
||||
|
||||
# -- --- |
||||
#provider api |
||||
# -- --- |
||||
#none - declarations only |
||||
#todo - template folder install/update/status methods? |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,112 +0,0 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,112 +0,0 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
||||
@ -1,367 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::util 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::mix::util { |
||||
variable has_winpath 0 |
||||
} |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {![catch {package require punk::winpath}]} { |
||||
set punk::mix::util::has_winpath 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::util { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
namespace export * |
||||
|
||||
#NOTE fileutil::cat seems to silently ignore options if passed at end instead of before file! |
||||
proc fcat {args} { |
||||
variable has_winpath |
||||
|
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {$i % 2} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
|
||||
#puts stderr "opts: $opts paths: $paths" |
||||
|
||||
#let's proceed, but warn the user if an apparent option is in paths |
||||
foreach opt [list -encoding -eofchar -translation] { |
||||
if {$opt in $paths} { |
||||
puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" |
||||
} |
||||
} |
||||
|
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
|
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
namespace eval internal { |
||||
proc path_common_prefix_pop {varname} { |
||||
upvar 1 $varname var |
||||
set var [lassign $var head] |
||||
return $head |
||||
} |
||||
} |
||||
proc path_common_prefix {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {$cmp ne $elt} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#retains case from first argument only - caseless comparison |
||||
proc path_common_prefix_nocase {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {![string equal -nocase $cmp $elt]} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
#namespace import ::punk::ns::nsimport_noclobber |
||||
|
||||
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
|
||||
proc askuser {question} { |
||||
if {![catch {package require punk::lib}]} { |
||||
return [punk::lib::askuser $question] ;#takes account of terminal mode raw vs line (if punk::console used) |
||||
} |
||||
puts stdout $question |
||||
flush stdout |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [gets stdin] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
return $answer |
||||
} |
||||
|
||||
#review - can be surprising if caller unaware it uses try |
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
|
||||
proc foreach-file {path script_pathvariable script} { |
||||
upvar 1 $script_pathvariable thepath |
||||
|
||||
set known {} |
||||
lappend waiting $path |
||||
while {[llength $waiting]} { |
||||
set pending $waiting |
||||
set waiting {} |
||||
set at 0 |
||||
while {$at < [llength $pending]} { |
||||
set current [lindex $pending $at] |
||||
incr at |
||||
|
||||
# Do not follow into parent. |
||||
if {[string match *.. $current]} continue |
||||
|
||||
# Ignore what we have visited already. |
||||
set c [file dirname [file normalize $current/___]] |
||||
if {[dict exists $known $c]} continue |
||||
dict set known $c . |
||||
|
||||
if {[file tail $c] eq ".git"} { |
||||
continue |
||||
} |
||||
|
||||
# Expand directories. |
||||
if {[file isdirectory $c]} { |
||||
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||
continue |
||||
} |
||||
|
||||
# Handle files as per the user's will. |
||||
set thepath $current |
||||
switch -exact -- [catch { uplevel 1 $script } result] { |
||||
0 - 4 { |
||||
# ok, continue - nothing |
||||
} |
||||
2 { |
||||
# return, abort, rethrow |
||||
return -code return |
||||
} |
||||
3 { |
||||
# break, abort |
||||
return |
||||
} |
||||
1 - default { |
||||
# error, any thing else - rethrow |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# review punk::lib::tm_version.. functions |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#Note that semver only has a small overlap with tcl tm versions. |
||||
#todo - work out what overlap and whether it's even useful |
||||
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||
proc semver {versionstring} { |
||||
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||
} |
||||
#todo - semver conversion/validation for other systems? |
||||
proc magic_tm_version {} { |
||||
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||
return ${magicbase}.0a1.0 |
||||
} |
||||
|
||||
|
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TEMP TMP TMPDIR} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::util [namespace eval punk::mix::util { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,161 +0,0 @@
|
||||
#punkapps app manager |
||||
# deck cli |
||||
|
||||
namespace eval punk::mod::cli { |
||||
namespace export help list run |
||||
namespace ensemble create |
||||
|
||||
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown |
||||
if 0 { |
||||
proc _unknown {ns args} { |
||||
puts stderr "punk::mod::cli::_unknown '$ns' '$args'" |
||||
puts stderr "punk::mod::cli::help $args" |
||||
puts stderr "arglen:[llength $args]" |
||||
punk::mod::cli::help {*}$args |
||||
} |
||||
} |
||||
|
||||
#cli must have _init method - usually used to load commandsets lazily |
||||
# |
||||
variable initialised 0 |
||||
proc _init {args} { |
||||
variable initialised |
||||
if {$initialised} { |
||||
return |
||||
} |
||||
#... |
||||
set initialised 1 |
||||
} |
||||
|
||||
proc help {args} { |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#namespace export |
||||
return $basehelp |
||||
} |
||||
proc getraw {appname} { |
||||
set app_folders [punk::config::configure running apps] |
||||
#todo search each app folder |
||||
set bases [::list] |
||||
set versions [::list] |
||||
set mains [::list] |
||||
set appinfo [::list bases {} mains {} versions {}] |
||||
|
||||
foreach containerfolder $app_folders { |
||||
lappend bases $containerfolder |
||||
if {[file exists $containerfolder]} { |
||||
if {[file exists $containerfolder/$appname/main.tcl]} { |
||||
#exact match - only return info for the exact one specified |
||||
set namematches $appname |
||||
set parts [split $appname -] |
||||
} else { |
||||
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
} |
||||
foreach nm $namematches { |
||||
set mainfile $containerfolder/$nm/main.tcl |
||||
set parts [split $nm -] |
||||
if {[llength $parts] == 1} { |
||||
set ver "" |
||||
} else { |
||||
set ver [lindex $parts end] |
||||
} |
||||
if {$ver ni $versions} { |
||||
lappend versions $ver |
||||
lappend mains $ver $mainfile |
||||
} else { |
||||
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config" |
||||
} |
||||
} |
||||
dict set appinfo versions $versions |
||||
#todo - natsort! |
||||
set sorted_versions [lsort $versions] |
||||
set latest [lindex $sorted_versions 0] |
||||
if {$latest eq "" && [llength $sorted_versions] > 1} { |
||||
set latest [lindex $sorted_versions 1] |
||||
} |
||||
dict set appinfo latest $latest |
||||
|
||||
dict set appinfo bases $bases |
||||
dict set appinfo mains $mains |
||||
return $appinfo |
||||
} |
||||
|
||||
proc list {{glob *}} { |
||||
set apps_folder [punk::config::configure running apps] |
||||
if {[file exists $apps_folder]} { |
||||
if {[file exists $apps_folder/$glob]} { |
||||
#tailcall source $apps_folder/$glob/main.tcl |
||||
return $glob |
||||
} |
||||
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob] |
||||
if {[llength $apps] == 0} { |
||||
if {[string first * $glob] <0 && [string first ? $glob] <0} { |
||||
#no glob chars supplied - only launch if exact match for name part |
||||
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*] |
||||
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort? |
||||
if {[llength $namematches] > 0} { |
||||
set latest [lindex $namematches end] |
||||
lassign $latest nm ver |
||||
#tailcall source $apps_folder/$latest/main.tcl |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $apps |
||||
} |
||||
} |
||||
|
||||
#todo - way to launch as separate process |
||||
# solo-opts only before appname - args following appname are passed to the app |
||||
proc run {args} { |
||||
set nameposn [lsearch -not $args -*] |
||||
if {$nameposn < 0} { |
||||
error "punkapp::run unable to determine application name" |
||||
} |
||||
set appname [lindex $args $nameposn] |
||||
set controlargs [lrange $args 0 $nameposn-1] |
||||
set appargs [lrange $args $nameposn+1 end] |
||||
|
||||
set appinfo [punk::mod::cli::getraw $appname] |
||||
if {[llength [dict get $appinfo versions]]} { |
||||
set ver [dict get $appinfo latest] |
||||
puts stdout "info: $appinfo" |
||||
set ::argc [llength $appargs] |
||||
set ::argv $appargs |
||||
source [dict get $appinfo mains $ver] |
||||
if {"-hideconsole" in $controlargs} { |
||||
puts stderr "attempting console hide" |
||||
#todo - something better - a callback when window mapped? |
||||
after 500 {::punkapp::hide_console} |
||||
} |
||||
return $appinfo |
||||
} else { |
||||
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval punk::mod::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
package provide punk::mod [namespace eval punk::mod { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,193 +0,0 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
package require punk::args |
||||
|
||||
tcl::namespace::eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![tcl::string::match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [tcl::namespace::qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [tcl::namespace::tail $routine] |
||||
|
||||
if {![tcl::string::match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [tcl::namespace::which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [tcl::namespace::eval $base [ |
||||
list [tcl::namespace::which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
tcl::namespace::eval $routine [ |
||||
::list tcl::namespace::ensemble configure $routine -unknown [ |
||||
::list ::apply {{base ensemble subcommand args} { |
||||
::list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#::namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# ::namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] { |
||||
if {[tcl::namespace::exists <base>::lib]} { |
||||
::set current_paths [tcl::namespace::path] |
||||
if {"<routine>" ni $current_paths} { |
||||
::lappend current_paths <routine> |
||||
} |
||||
tcl::namespace::path $current_paths |
||||
} |
||||
}] |
||||
|
||||
tcl::namespace::eval $routine { |
||||
::set exportlist [::list] |
||||
::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { |
||||
::set c [tcl::namespace::tail $cmd] |
||||
if {![tcl::string::match _* $c]} { |
||||
::lappend exportlist $c |
||||
} |
||||
} |
||||
tcl::namespace::export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
punk::args::define { |
||||
@id -id ::punk::overlay::import_commandset |
||||
@cmd -name punk::overlay::import_commandset\ |
||||
-summary\ |
||||
"Import commands into caller's namespace with optional prefix and separator."\ |
||||
-help\ |
||||
"Import commands that have been exported by another namespace into the caller's |
||||
namespace. Usually a prefix and optionally a separator should be used. |
||||
This is part of the punk::mix CLI commandset infrastructure - design in flux. |
||||
Todo - .toml configuration files for defining CLI configurations." |
||||
@values |
||||
prefix -type string |
||||
separator -type string -help\ |
||||
"A string, usually punctuation, to separate the prefix and the command name |
||||
of the final imported command. The value \"::\" is disallowed in this context." |
||||
cmdnamespace -type string -help\ |
||||
"Namespace from which to import commands. Commands are those that have been exported." |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
if {$prefix in $bad_seps} { |
||||
error "import_commandset invalid prefix '$prefix'" |
||||
} |
||||
if {"$prefix$separator" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
if {"[string index $prefix end][string index $separator 0]" in $bad_seps} { |
||||
error "import_commandset invalid prefix/separator combination '$prefix$separator'" |
||||
} |
||||
#review - do we allow prefixes/separators such as a::b? |
||||
|
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [tcl::string::range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![tcl::namespace::exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[tcl::string::length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] { |
||||
::set nspaths [tcl::namespace::path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
::lappend nspaths <cmdns> |
||||
} |
||||
tcl::namespace::path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set imported_tails [list] |
||||
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||
if {[catch { |
||||
#review - noclobber? |
||||
tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] |
||||
foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [tcl::namespace::tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
lappend imported_tails [namespace tail $import_as] |
||||
} |
||||
#make imported commands exported so they are available to the ensemble |
||||
tcl::namespace::eval ${nscaller} [list namespace export {*}$imported_tails] |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [tcl::namespace::eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
@ -1,503 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/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 punkshell_module_punk::packagepreference 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::packagepreference] |
||||
#[keywords module package] |
||||
#[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 PUNKARGS |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::packagepreference}] |
||||
#[para] Core API functions for punk::packagepreference |
||||
#[list_begin definitions] |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::packagepreference::uninstall |
||||
@cmd -name ::punk::packagepreference::uninstall -help\ |
||||
"Uninstall override for ::package builtin - for 'require' subcommand only." |
||||
@values -min 0 -max 0 |
||||
}] |
||||
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} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::packagepreference::install |
||||
@cmd -name ::punk::packagepreference::install -help\ |
||||
"Install override for ::package builtin - for 'require' subcommand only." |
||||
@values -min 0 -max 0 |
||||
}] |
||||
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](todo - check info loaded and restrict to existing version as determined from dll/so?) |
||||
#[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 |
||||
set is_exact 0 |
||||
if {[lindex $args 1] eq "-exact"} { |
||||
set pkg [lindex $args 2] |
||||
set vwant [lindex $args 3]-[lindex $args 3] |
||||
set is_exact 1 |
||||
} else { |
||||
set pkg [lindex $args 1] |
||||
set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements |
||||
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { |
||||
#only one version - and it has a dash |
||||
lassign [split [lindex $vwant 0] -] a b |
||||
if {$a eq $b} { |
||||
#string compare version nums (can contain dots and a|b) |
||||
set is_exact 1 |
||||
} |
||||
} |
||||
} |
||||
if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { |
||||
#although we could shortcircuit using vsatisfies to return the ver |
||||
#we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. |
||||
#e.g a package require logger further down the commandstack |
||||
return [$COMMANDSTACKNEXT {*}$args] |
||||
} |
||||
|
||||
if {!$is_exact && [llength $vwant] <= 1 } { |
||||
#required version unspecified - or specified singularly |
||||
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] |
||||
if {[llength $available_versions] >= 1} { |
||||
# --------------------------------------------------------------- |
||||
#An attempt to detect dll/so loaded and try to load same version |
||||
#dll/so files are often named with version numbers that don't contain dots or a version number at all |
||||
#e.g sqlite3400.dll Thread288.dll |
||||
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] |
||||
|
||||
if {[llength $pkgloadedinfo]} { |
||||
if {[llength $available_versions] > 1} { |
||||
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available" |
||||
} |
||||
lassign $pkgloadedinfo loaded_path name |
||||
set lc_loadedpath [string tolower $loaded_path] |
||||
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. |
||||
set lcpath_to_version [dict create] |
||||
foreach av $available_versions { |
||||
set scr [package ifneeded $pkg $av] |
||||
#ifneeded script not always a valid tcl list |
||||
if {![catch {llength $scr} scrlen]} { |
||||
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { |
||||
#a basic 'load <path> <pkg>' statement |
||||
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[dict exists $lcpath_to_version $lc_loadedpath]} { |
||||
set lversion [dict get $lcpath_to_version $lc_loadedpath] |
||||
} else { |
||||
#fallback to a best effort guess based on the path |
||||
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg] |
||||
} |
||||
#puts "====lcpath_to_version: $lcpath_to_version" |
||||
if {$lversion ne ""} { |
||||
#name matches pkg |
||||
#hack for known dll version mismatch |
||||
if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} { |
||||
set lversion 3.0b3 |
||||
} |
||||
if {[llength $vwant] == 1} { |
||||
#todo - still check vsatisfies - report a conflict? review |
||||
} |
||||
#return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] |
||||
try { |
||||
set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] |
||||
} trap {} {emsg eopts} { |
||||
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry |
||||
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown |
||||
#May be obsolete.. issue still not clear |
||||
|
||||
#A hack for 'couldn't open "<path.dll>": permission denied' |
||||
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls. |
||||
#exact cause unknown. |
||||
#e.g |
||||
#%package ifneeded registry 1.3.7 |
||||
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry |
||||
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry |
||||
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied |
||||
|
||||
#a subsequent load of the path used in the error message works. |
||||
|
||||
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {} |
||||
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} { |
||||
#Since this is a hack that shouldn't be required - be noisy about it. |
||||
puts stderr ">>> $emsg" |
||||
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath" |
||||
return [load $newpath $pkg] |
||||
} else { |
||||
#puts stderr "??? $emsg" |
||||
#dunno - re-raise |
||||
return -options $eopts $emsg |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path" |
||||
} |
||||
} |
||||
} |
||||
# --------------------------------------------------------------- |
||||
#?? |
||||
#set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg] |
||||
|
||||
|
||||
|
||||
if {[regexp {[A-Z]} $pkg]} { |
||||
#legacy package names |
||||
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
||||
if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { |
||||
try { |
||||
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
||||
} trap {} {emsg eopts} { |
||||
return -options $eopts $emsg |
||||
} |
||||
} else { |
||||
set require_result $v |
||||
} |
||||
} else { |
||||
#return [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
||||
try { |
||||
set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
||||
} trap {} {emsg eopts} { |
||||
return -options $eopts $emsg |
||||
} |
||||
} |
||||
#--------------------------------------------------------------- |
||||
#load relevant punk::args::<docname> package(s) |
||||
#todo - review whether 'packagepreference' is the right place for this. |
||||
#It is conceptually different from the main functions of packagepreference, |
||||
#but we don't really want to have a chain of 'package' overrides slowing performance. |
||||
#there may be a more generic way to add soft side-dependencies that the original package doesn't/can't specify. |
||||
#--------------------------------------------------------------- |
||||
|
||||
set lc_pkg [string tolower $pkg] |
||||
#todo - lookup list of docpkgs for a package? from where? |
||||
#we should have the option to not load punk::args::<docpkg> at all for many(most?) cases where they're unneeded. |
||||
#e.g skip if not ::tcl_interactive? |
||||
switch -exact -- $lc_pkg { |
||||
tcl { |
||||
set docpkgs [list tclcore] |
||||
} |
||||
tk { |
||||
set docpkgs [list tkcore] |
||||
} |
||||
default { |
||||
set docpkgs [list $lc_pkg] |
||||
} |
||||
} |
||||
foreach dp $docpkgs { |
||||
#review - versions? |
||||
#we should be able to load more specific punk::args pkg based on result of [package present $pkg] |
||||
catch { |
||||
#$COMMANDSTACKNEXT require $pkg {*}$vwant |
||||
#j2 |
||||
$COMMANDSTACKNEXT require punk::args::$dp |
||||
} |
||||
} |
||||
#--------------------------------------------------------------- |
||||
return $require_result |
||||
} |
||||
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" |
||||
return 1 |
||||
} else { |
||||
puts stderr "punk::packagepreference failed to rename ::package" |
||||
return 0 |
||||
} |
||||
#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 |
||||
variable PUNKARGS |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::packagepreference::system::slibpath_guess_pkgversion |
||||
@cmd -name punk::packagepreference::system::slibpath_guess_pkgversion -help\ |
||||
"Assistance function to determine pkg version from the information |
||||
obtained from [info loaded]. This is used to try to avoid loading a different |
||||
version of a binary package in another thread/interp when the package isn't |
||||
present in the interp, but [info loaded] indicates the binary is already loaded. |
||||
The more general/robust way to avoid this is to ensure ::auto_path and |
||||
tcl::tm::list are the same in each interp/thread. |
||||
|
||||
This call should only be used as a fallback in case a binary package has a more |
||||
complex ifneeded script. If the ifneeded script for a binary package is a |
||||
straightforward 'load <path_to_binary> <pkgname>' - then that information |
||||
should be used to determine the version by matching <path_to_binary> |
||||
rather than this one. |
||||
|
||||
Takes a path to a shared lib (.so/.dll), and the name of its providing |
||||
package, and return the version of the package if possible to determine |
||||
from the path. |
||||
The filename portion of the lib is often missing a version number or has |
||||
a version number that has been shortened (e.g dots removed). |
||||
The filename itself is first checked for a version number - but the number |
||||
is ignored if it doesn't contain any dots. |
||||
(prefix is checked to match with $pkgname, with a possible additional prefix |
||||
of lib or tcl<int>) |
||||
Often (even usually) the parent or grandparent folder will be named as |
||||
per the package name with a proper version. If so we can return it, |
||||
otherwise return empty string. |
||||
The parent/grandparent matching will be done by looking for a case |
||||
insensitive match of the prefix to $pkgname. |
||||
" |
||||
@values -min 1 |
||||
libpath -help "Full path to shared library (.so,.dll etc)" |
||||
pkgname -help "" |
||||
}] |
||||
proc slibpath_guess_pkgversion {libpath pkgname} { |
||||
set root [file rootname [file tail $libpath]] |
||||
set namelen [string length $pkgname] |
||||
regexp {^(tcl(?:[0-9])+){0,1}(.*)} $root _match tclxx root ;#regexp will match anything - but only truncate leading tclXX.. |
||||
set testv "" |
||||
if {[string match -nocase $pkgname* $root]} { |
||||
set testv [string range $root $namelen end] |
||||
} elseif {[string match -nocase lib$pkgname* $root]} { |
||||
set testv [string range $root $namelen+3 end] |
||||
} |
||||
if {[string first . $testv] > 0} { |
||||
if {![catch [list package vcompare $testv $testv]]} { |
||||
#testv has an inner dot and is understood by tcl as a valid version number |
||||
return $testv |
||||
} |
||||
} |
||||
#no valid dotted version found directly on dll or so filename |
||||
set parent [file dirname $libpath] ;#parent folder is often some differentiator for platform or featureset (e.g win-x64) |
||||
set grandparent [file dirname $parent] |
||||
foreach path [list $parent $grandparent] { |
||||
set segment [file tail $path] |
||||
if {$segment eq "bin"} { |
||||
continue |
||||
} |
||||
set testv "" |
||||
if {[string match -nocase $pkgname* $segment]} { |
||||
set testv [string range $segment $namelen end] |
||||
} elseif {[string match -nocase critcl_$pkgname* $segment]} { |
||||
set testv [string range $segment $namelen+7 end] |
||||
} |
||||
#we don't look for dot in parent/grandparent version - a bare integer here after the <pkgname> will be taken to be the version |
||||
if {![catch [list package vcompare $testv $testv]]} { |
||||
return $testv |
||||
} |
||||
} |
||||
#review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion |
||||
#using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion |
||||
return "" |
||||
} |
||||
|
||||
} |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::packagepreference ::punk::packagepreference::system |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## 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] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,854 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2025 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::pipe 1.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::pipe 0 1.0] |
||||
#[copyright "2025"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::pipe] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::pipe |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::pipe |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::pipe::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::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 ---}] |
||||
#} |
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::pipe { |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe}] |
||||
#[para] Core API functions for punk::pipe |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ |
||||
# |
||||
#we can't provide a float comparison suitable for every situation, |
||||
#but we should pick something reasonable, keep it stable, and document it. |
||||
proc float_almost_equal {a b} { |
||||
package require math::constants |
||||
set diff [expr {abs($a - $b)}] |
||||
if {$diff <= $::math::constants::eps} { |
||||
return 1 |
||||
} |
||||
set A [expr {abs($a)}] |
||||
set B [expr {abs($b)}] |
||||
set largest [expr {($B > $A) ? $B : $A}] |
||||
return [expr {$diff <= $largest * $::math::constants::eps}] |
||||
} |
||||
|
||||
#debatable whether boolean_almost_equal is more surprising than helpful. |
||||
#values from a calculation that are extremely close to zero but aren't false could also be surprising - especially if they compare equal numerically |
||||
#perhaps a fuzzy-boolean is a step too far for a default - but it's inline with float-comparison for pattern-matching. |
||||
#alternatively - use an even more complex classifier? (^&~) ? |
||||
proc boolean_almost_equal {a b} { |
||||
if {[string is double -strict $a]} { |
||||
if {[float_almost_equal $a 0]} { |
||||
set a 0 |
||||
} |
||||
} |
||||
if {[string is double -strict $b]} { |
||||
if {[float_almost_equal $b 0]} { |
||||
set b 0 |
||||
} |
||||
} |
||||
#must handle true,no etc. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
#boolean could be tr, true, y, ye, yes,Yes, 1 , 0 etc. |
||||
proc boolean_equal {a b} { |
||||
#equivalenttly xnor: expr {!(($a && 1) ^ ($b && 1))} ;# less clear and no discernable timing benefit. |
||||
expr {($a && 1) == ($b && 1)} |
||||
} |
||||
|
||||
|
||||
proc val [list [list v [lreplace x 0 0]]] {return $v} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::pipe::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::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 |
||||
#} |
||||
|
||||
#map rhs to names suitable to use in pipemcd proc name (whitespace mapping) |
||||
# (for .= and = pipecmds) |
||||
proc pipecmd_namemapping {rhs} { |
||||
#used to build a command from a pattern which could contain :: - we need to map it to keep it a single command in the desired namespace. |
||||
#glob chars will prevent us using simple test {[info commands $cmd] eq ""} to test existence |
||||
#we could use the test {$cmd in [info commands]} - but mapping away globchars is more robust, allowing the simpler test |
||||
#set rhs [string trim $rhs];#ignore all leading & trailing whitespace |
||||
set rhs [string trimleft $rhs] |
||||
#--- |
||||
#REVIEW! |
||||
#set rhs [regsub -all {\s{1,}} $rhs {<sp>}] ;#collapse all internal whitespace to a single <sp> token |
||||
#This stops us matching {/@**@x x} vs {/@**@x x} |
||||
#--- |
||||
|
||||
set rhs [tcl::string::map {: <c> ? <q> * <star> [ <lb> ] <rb> \\ <bsl> {"} <dq> " " <sp>} $rhs] |
||||
#review - we don't expect other command-incompatible chars such as colon? |
||||
return $rhs |
||||
} |
||||
|
||||
# relatively slow on even small sized scripts |
||||
#proc arg_is_script_shaped2 {arg} { |
||||
# set re {^(\s|;|\n)$} |
||||
# set chars [split $arg ""] |
||||
# if {[lsearch -regex $chars $re] >=0} { |
||||
# return 1 |
||||
# } else { |
||||
# return 0 |
||||
# } |
||||
#} |
||||
|
||||
#exclude quoted whitespace |
||||
proc arg_is_script_shaped {arg} { |
||||
if {[tcl::string::first \n $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first ";" $arg] >= 0} { |
||||
return 1 |
||||
} elseif {[tcl::string::first " " $arg] >= 0 || [tcl::string::first \t $arg] >= 0} { |
||||
lassign [_rhs_tail_split $arg] _ part2 ;#will have part2 if unquoted whitespace found |
||||
return [expr {$part2 ne ""}] |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#split top level of patterns only. |
||||
proc _split_patterns_memoized {varspecs} { |
||||
set name_mapped [pipecmd_namemapping $varspecs] |
||||
set cmdname ::punk::pipecmds::split_patterns::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
set result [_split_patterns $varspecs] |
||||
proc $cmdname {} [list return $result] |
||||
#debug.punk.pipe.compile {proc $cmdname} 4 |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#note - empty data after trailing , is ignored. (comma as very last character) |
||||
# - fix by documentation only. double up trailing comma e.g <pattern>,, if desired to return pattern match plus all at end! |
||||
#todo - move to punk::pipe |
||||
proc _split_patterns {varspecs} { |
||||
|
||||
set varlist [list] |
||||
# @ @@ - list and dict functions |
||||
# / level separator |
||||
# # list count, ## dict size |
||||
# % string functions |
||||
# ! not |
||||
set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) |
||||
#right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname |
||||
|
||||
#except when prefixed directly by pin classifier ^ |
||||
set protect_terminals [list "^"] ;# e.g sequence ^# |
||||
#also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string |
||||
#ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' |
||||
set in_brackets 0 ;#count depth |
||||
set in_atom 0 |
||||
set token "" |
||||
set end_var_posn -1 ;#first var_terminal encountered within each comma delimited section |
||||
set token_index 0 ;#index of terminal char within each token |
||||
set indq 0 |
||||
set inbraces 0 |
||||
set inesc 0 ;#whether last char was backslash (see also punk::escv) |
||||
set prevc "" |
||||
set char_index 0 |
||||
#if {[string index $varspecs end] eq ","} { |
||||
# set varspecs [string range $varspecs 0 end-1] |
||||
#} |
||||
set charcount 0 |
||||
foreach c [split $varspecs ""] { |
||||
incr charcount |
||||
if {$indq} { |
||||
if {$inesc} { |
||||
#puts stderr "inesc adding '$c'" |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq {"}} { |
||||
set indq 0 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$inbraces} { |
||||
if {$inesc} { |
||||
append token \\$c |
||||
} else { |
||||
if {$c eq "\}"} { |
||||
incr inbraces -1 |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
incr inbraces |
||||
if {$inbraces} { |
||||
append token $c |
||||
} |
||||
} else { |
||||
append token $c |
||||
} |
||||
} |
||||
} elseif {$in_atom} { |
||||
#ignore dquotes/brackets in atoms - pass through |
||||
append token $c |
||||
#set nextc [lindex $chars $char_index+1] |
||||
if {$c eq "'"} { |
||||
set in_atom 0 |
||||
} |
||||
} elseif {$in_brackets > 0} { |
||||
append token $c |
||||
if {$c eq ")"} { |
||||
incr in_brackets -1 |
||||
} |
||||
} else { |
||||
if {$c eq {"}} { |
||||
if {!$inesc} { |
||||
set indq 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq "\{"} { |
||||
if {!$inesc} { |
||||
set inbraces 1 |
||||
} else { |
||||
append token $c |
||||
} |
||||
} elseif {$c eq ","} { |
||||
#set var $token |
||||
#set spec "" |
||||
#if {$end_var_posn > 0} { |
||||
# #tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
#} else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
#} |
||||
#lappend varlist [list [string trim $var] [string trim $spec]] |
||||
#set token "" |
||||
#set token_index -1 ;#reduce by 1 because , not included in next token |
||||
#set end_var_posn -1 |
||||
} else { |
||||
append token $c |
||||
switch -exact -- $c { |
||||
' { |
||||
set in_atom 1 |
||||
} |
||||
( { |
||||
incr in_brackets |
||||
} |
||||
default { |
||||
if {$end_var_posn == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { |
||||
set end_var_posn $token_index |
||||
} |
||||
} |
||||
} |
||||
} |
||||
if {$c eq ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
#lassign [punk::lib::string_splitbefore $token $end_var_posn] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
|
||||
} |
||||
} |
||||
|
||||
if {$charcount == [string length $varspecs]} { |
||||
if {!($indq || $inbraces || $in_atom || $in_brackets)} { |
||||
if {$c ne ","} { |
||||
set var $token |
||||
set spec "" |
||||
if {$end_var_posn > 0} { |
||||
#tcl scan with %s will not handle whitespace as desired. Be explicit using string range instead. |
||||
#lassign [scan $token %${end_var_posn}s%s] var spec |
||||
set var [string range $token 0 $end_var_posn-1] |
||||
set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
} else { |
||||
if {$end_var_posn == 0} { |
||||
set var "" |
||||
set spec $token |
||||
} |
||||
} |
||||
lappend varlist [list [string trim $var] $spec] |
||||
set token "" |
||||
set token_index -1 |
||||
set end_var_posn -1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set prevc $c |
||||
if {$c eq "\\"} { |
||||
#review |
||||
if {$inesc} { |
||||
set inesc 0 |
||||
} else { |
||||
set token [string range $token 0 end-1] |
||||
set inesc 1 |
||||
} |
||||
} else { |
||||
set inesc 0 |
||||
} |
||||
incr token_index |
||||
incr char_index |
||||
} |
||||
|
||||
#if {[string length $token]} { |
||||
# #lappend varlist [punk::lib::string_splitbefore $token $end_var_posn] |
||||
# set var $token |
||||
# set spec "" |
||||
# if {$end_var_posn > 0} { |
||||
# #lassign [scan $token %${end_var_posn}s%s] var spec |
||||
# set var [string range $token 0 $end_var_posn-1] |
||||
# set spec [string range $token $end_var_posn end] ;#key section includes the terminal char which ended the var and starts the spec |
||||
# } else { |
||||
# if {$end_var_posn == 0} { |
||||
# set var "" |
||||
# set spec $token |
||||
# } |
||||
# } |
||||
# #lappend varlist [list [string trim $var] [string trim $spec]] |
||||
# #spec needs to be able to match whitespace too |
||||
# lappend varlist [list [string trim $var] $spec] |
||||
#} |
||||
|
||||
return $varlist |
||||
} |
||||
|
||||
#todo - consider whether we can use < for insertion/iteration combinations |
||||
# =a<,b< iterate once through |
||||
# =a><,b>< cartesian product |
||||
# =a<>,b<> ??? zip ? |
||||
# |
||||
# ie = {a b c} |> .=< inspect |
||||
# would call inspect 3 times, once for each argument |
||||
# .= list {a b c} {x y z} |a/0,b/1> .=a><,b>< list |
||||
# would produce list of cartesian pairs? |
||||
# |
||||
proc _split_equalsrhs {insertionpattern} { |
||||
#map the insertionpattern so we can use faster globless info command search |
||||
set name_mapped [pipecmd_namemapping $insertionpattern] |
||||
set cmdname ::punk::pipecmds::split_rhs::_$name_mapped |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
set lst_var_indexposition [_split_patterns_memoized $insertionpattern] |
||||
set i 0 |
||||
set return_triples [list] |
||||
foreach v_pos $lst_var_indexposition { |
||||
lassign $v_pos v index_and_position |
||||
#e.g varname@@data/ok>0 varname/1/0>end |
||||
#ensure only one ">" is detected |
||||
if {![string length $index_and_position]} { |
||||
set indexspec "" |
||||
set positionspec "" |
||||
} else { |
||||
set chars [split $index_and_position ""] |
||||
set posns [lsearch -all $chars ">"] |
||||
if {[llength $posns] > 1} { |
||||
error "pipesyntax error in segment insertion pattern '$insertionpattern' -v '$v' multiple '>' characters. Pattern not understood." "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
if {![llength $posns]} { |
||||
set indexspec $index_and_position |
||||
set positionspec "" |
||||
} else { |
||||
set splitposn [lindex $posns 0] |
||||
set indexspec [string range $index_and_position 0 $splitposn-1] |
||||
set positionspec [string range $index_and_position $splitposn+1 end] |
||||
} |
||||
} |
||||
|
||||
#review - |
||||
if {($positionspec in [list "*" "/*" "@*" "/" "@"]) || ($v eq "*" && $positionspec eq "")} { |
||||
set star "" |
||||
if {$v eq "*"} { |
||||
set v "" |
||||
set star "*" |
||||
} |
||||
if {[string index $positionspec end] eq "*"} { |
||||
set star "*" |
||||
} |
||||
#it is always possible to insert at end of list regardless of current length - so /end* and @end* are equivalent |
||||
#as are /end and @end |
||||
#lset lst_var_indexposition $i [list $v "/end$star"] |
||||
set triple [list $v $indexspec "/end$star"] |
||||
} else { |
||||
if {$positionspec eq ""} { |
||||
#e.g just =varname |
||||
#lset lst_var_indexposition $i [list $v "/end"] |
||||
set triple [list $v $indexspec "/end"] |
||||
#error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' missing position spec e.g /0" |
||||
} else { |
||||
if {[string index $indexspec 0] ni [list "" "/" "@"]} { |
||||
error "pipesyntax error in segment insertionpattern '$insertionpattern' - v '$v' bad index spec '$indexspec'" "_split_equalsrhs $insertionpattern" [list pipesyntax insertionpattern_invalid] |
||||
} |
||||
set triple [list $v $indexspec $positionspec] |
||||
} |
||||
} |
||||
lappend return_triples $triple |
||||
incr i |
||||
} |
||||
proc $cmdname {} [list return $return_triples] |
||||
return $return_triples |
||||
} |
||||
|
||||
proc _rhs_tail_split {fullrhs} { |
||||
set inq 0; set indq 0 |
||||
set equalsrhs "" |
||||
set i 0 |
||||
foreach ch [split $fullrhs ""] { |
||||
if {$inq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {'}} { |
||||
set inq 0 |
||||
} |
||||
} elseif {$indq} { |
||||
append equalsrhs $ch |
||||
if {$ch eq {"}} { |
||||
set indq 0 |
||||
} |
||||
} else { |
||||
switch -- $ch { |
||||
{'} { |
||||
set inq 1 |
||||
} |
||||
{"} { |
||||
set indq 1 |
||||
} |
||||
" " { |
||||
#whitespace outside of quoting |
||||
break |
||||
} |
||||
0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - z {} |
||||
default { |
||||
#\t not a literal for switch jumpTable bytecompile - review - can we do it without for example string mapping to <t> (and without a literal binary tab in source file)? |
||||
#we can't (reliably?) put \t as one of our switch keys |
||||
# |
||||
if {$ch eq "\t"} { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
append equalsrhs $ch |
||||
} |
||||
incr i |
||||
} |
||||
set tail [tcl::string::range $fullrhs $i end] |
||||
return [list $equalsrhs $tail] |
||||
} |
||||
|
||||
#todo - recurse into bracketed sub parts |
||||
#JMN3 |
||||
#e.g @*/(x@0,y@2) |
||||
proc _var_classify {multivar} { |
||||
set cmdname ::punk::pipecmds::var_classify::_[pipecmd_namemapping $multivar] |
||||
if {[info commands $cmdname] ne ""} { |
||||
return [$cmdname] |
||||
} |
||||
|
||||
|
||||
#comma seems a natural choice to split varspecs, |
||||
#but also for list and dict subelement access |
||||
#/ normally indicates some sort of hierarchical separation - (e.g in filesytems) |
||||
#so / will indicate subelements e.g @0/1 for lindex $list 0 1 |
||||
#set valsource_key_list [_split_var_key_at_unbracketed_comma $multivar] |
||||
set valsource_key_list [_split_patterns_memoized $multivar] |
||||
|
||||
|
||||
|
||||
#mutually exclusive - atom/pin |
||||
#set map [list "" ' ^ &] ;#0 = default/var/not-yet-determined 1 = atom 2 = pin |
||||
#set var_class [lmap var $valsource_key_list {expr {([set m [lsearch $map [string index [lindex $var 0] 0]]] >= 0) ? [list $var $m] : [list $var 0]}}] |
||||
#0 - novar |
||||
#1 - atom ' |
||||
#2 - pin ^ |
||||
#3 - boolean & |
||||
#4 - integer |
||||
#5 - double |
||||
#6 - var |
||||
#7 - glob (no classifier and contains * or ?) |
||||
#8 - numeric |
||||
#9 - > (+) |
||||
#10 - < (-) |
||||
|
||||
set var_names [list] |
||||
set var_class [list] |
||||
set varspecs_trimmed [list] ;#raw varspecs without pin/atom modifiers - or empty string for glob |
||||
|
||||
|
||||
set leading_classifiers [list "'" "&" "^" ] |
||||
set trailing_classifiers [list + -] |
||||
set possible_number_start [list - + . 0 1 2 3 4 5 6 7 8 9 > <] |
||||
|
||||
foreach v_key $valsource_key_list { |
||||
lassign $v_key v key |
||||
set vname $v ;#default |
||||
set classes [list] |
||||
if {$v eq ""} { |
||||
lappend var_class [list $v_key 0] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
set lastchar [string index $v end] |
||||
switch -- $lastchar { |
||||
+ { |
||||
lappend classes 9 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
- { |
||||
lappend classes 10 |
||||
set vname [string range $v 0 end-1] |
||||
} |
||||
} |
||||
set firstchar [string index $v 0] |
||||
switch -- $firstchar { |
||||
' { |
||||
lappend var_class [list $v_key 1] |
||||
#set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
^ { |
||||
lappend classes [list 2] |
||||
#use vname - may already have trailing +/- stripped |
||||
set vname [string range $vname 1 end] |
||||
set secondclassifier [string index $v 1] |
||||
switch -- $secondclassifier { |
||||
"&" { |
||||
#pinned boolean |
||||
lappend classes 3 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
"#" { |
||||
#pinned numeric comparison instead of string comparison |
||||
#e.g set x 2 |
||||
# this should match: ^#x.= list 2.0 |
||||
lappend classes 8 |
||||
set vname [string range $vname 1 end] |
||||
} |
||||
"*" { |
||||
#pinned glob |
||||
lappend classes 7 |
||||
set vname [string range $v 2 end] |
||||
} |
||||
} |
||||
#todo - check for second tag - & for pinned boolean? |
||||
#consider requiring ^# for numeric comparisons. currently no way to do a strictly string comparison on pinned variables.... default ^var really shouldn't be doing any magic. |
||||
#while we're at it.. pinned glob would be nice. ^* |
||||
#maybe even pinned scan ^% ? regex? ^/ or ^? these would be hard to have corresponding literals in the pattern mini-lang. |
||||
#These all limit the range of varnames permissible - which is no big deal. |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
& { |
||||
#we require boolean literals to be single-quoted so we can use cross-binding on boolean vars. |
||||
#ie &true is the variable true whereas &'true' or &'1' &'t' etc are literal booleans |
||||
#allow exception of &1 &0 to be literal booleans - because we disallow 0 & 1 as varnames in other contexts anyway - so it would be more consistent not to treat as varnames here. |
||||
lappend var_class [list $v_key 3] |
||||
set vname [string range $v 1 end] |
||||
lappend varspecs_trimmed [list $vname $key] |
||||
} |
||||
default { |
||||
if {([string first ? $v]) >=0 || ([string first * $v] >=0)} { |
||||
lappend var_class [list $v_key 7] ;#glob |
||||
#leave vname as the full glob |
||||
lappend varspecs_trimmed [list "" $key] |
||||
} else { |
||||
#scan vname not v - will either be same as v - or possibly stripped of trailing +/- |
||||
set numtestv [join [scan $vname %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, decimal points and sci notation - fails to handle leading dot e.g .5 |
||||
#leading . still need to test directly for double |
||||
if {[string is double -strict $vname] || [string is double -strict $numtestv]} { |
||||
if {[string is integer -strict $numtestv]} { |
||||
#this will pick up boolean 1 or 0 - but that's ok - they require "&" marker if boolean comparison desired |
||||
#integer test before double.. |
||||
#note there is also string is wide (string is wideinteger) for larger ints.. |
||||
lappend classes 4 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} else { |
||||
#double |
||||
#sci notation 1e123 etc |
||||
#also large numbers like 1000000000 - even without decimal point - (tcl bignum) |
||||
lappend classes 5 |
||||
lappend var_class [list $v_key $classes] |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} else { |
||||
lappend var_class [list $v_key 6] ;#var |
||||
lappend varspecs_trimmed $v_key |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend var_names $vname |
||||
} |
||||
|
||||
set result [list var_names $var_names var_class $var_class varspecs_trimmed $varspecs_trimmed] |
||||
|
||||
proc $cmdname {} [list return $result] |
||||
#JMN |
||||
#debug.punk.pipe.compile {proc $cmdname} |
||||
return $result |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::pipe::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::pipe::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::pipe::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::pipe { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::pipe" |
||||
@package -name "punk::pipe" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::pipe |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
return $about_topics |
||||
} |
||||
proc default_topics {} {return [list Description outline *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
punk pipeline features |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "MIT" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return $::punk::pipe::version |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{Julian Noble <julian@precisium.com.au>}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_outline {} { |
||||
punk::args::lib::tstr -return string { |
||||
todo.. |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::pipe::about" |
||||
dict set overrides @cmd -name "punk::pipe::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::pipe |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::pipe::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::pipe::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::pipe::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::pipe::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::punk::pipe |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::pipe [tcl::namespace::eval punk::pipe { |
||||
variable pkg punk::pipe |
||||
variable version |
||||
set version 1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,276 +0,0 @@
|
||||
# -*- 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.2.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::repl::codethread 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::repl::codethread] |
||||
#[keywords module repl] |
||||
#[description] |
||||
#[para] This is part of the infrastructure required for the punk::repl to operate |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::repl::codethread |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::repl::codethread |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::config |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::repl::codethread::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::class}] |
||||
#[para] class definitions |
||||
#if {[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::repl::codethread { |
||||
tcl::namespace::export * |
||||
variable replthread |
||||
variable replthread_cond |
||||
variable running 0 |
||||
|
||||
variable output_stdout "" |
||||
variable output_stderr "" |
||||
|
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread}] |
||||
#[para] Core API functions for punk::repl::codethread |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
#proc sample1 {p1 n args} { |
||||
# #*** !doctools |
||||
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||
# #[para]Description of sample1 |
||||
# #[para] Arguments: |
||||
# # [list_begin arguments] |
||||
# # [arg_def tring p1] A description of string argument p1. |
||||
# # [arg_def integer n] A description of integer argument n. |
||||
# # [list_end] |
||||
# return "ok" |
||||
#} |
||||
|
||||
variable run_command_cache |
||||
|
||||
proc is_running {} { |
||||
variable running |
||||
return $running |
||||
} |
||||
proc runscript {script} { |
||||
|
||||
#puts stderr "->runscript" |
||||
variable replthread_cond |
||||
#variable output_stdout |
||||
#set output_stdout "" |
||||
#variable output_stderr |
||||
#set output_stderr "" |
||||
#expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available |
||||
#if a thread::send is done from the commandline in a codethread - Tcl will |
||||
if {"code" ni [interp children] || ![info exists replthread_cond]} { |
||||
#in case someone tries calling from codethread directly - don't do anything or change any state |
||||
#(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) |
||||
#if called directly - the context will be within the first 'code' interp. |
||||
#inappropriate caller could add superfluous entries to shellfilter stack if function errors out |
||||
#inappropriate caller could affect tsv vars (if their interp allows that anyway) |
||||
puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" |
||||
return |
||||
} |
||||
interp eval code [list set ::punk::repl::codethread::output_stdout ""] |
||||
interp eval code [list set ::punk::repl::codethread::output_stderr ""] |
||||
|
||||
set outstack [list] |
||||
set errstack [list] |
||||
upvar ::punk::config::running running_config |
||||
if {[string length [dict get $running_config color_stdout_repl]] && [interp eval code punk::console::colour]} { |
||||
lappend outstack [interp eval code [list shellfilter::stack::add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] |
||||
} |
||||
lappend outstack [interp eval code [list shellfilter::stack::add stdout tee_to_var -settings {-varname ::punk::repl::codethread::output_stdout}]] |
||||
|
||||
if {[string length [dict get $running_config color_stderr_repl]] && [interp eval code punk::console::colour]} { |
||||
lappend errstack [interp eval code [list shellfilter::stack::add stderr ansiwrap -settings [list -colour [dict get $running_config color_stderr_repl]]]] |
||||
# #lappend errstack [shellfilter::stack::add stderr ansiwrap -settings [list -colour cyan]] |
||||
} |
||||
lappend errstack [interp eval code [list shellfilter::stack::add stderr tee_to_var -settings {-varname ::punk::repl::codethread::output_stderr}]] |
||||
|
||||
#an experiment |
||||
#set errhandle [shellfilter::stack::item_tophandle stderr] |
||||
#interp transfer "" $errhandle code |
||||
|
||||
set status [catch { |
||||
#shennanigans to keep compiled script around after call. |
||||
#otherwise when $script goes out of scope - internal rep of vars set in script changes. |
||||
#The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. |
||||
interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone |
||||
interp eval code { |
||||
lappend ::codeinterp::run_command_cache $::codeinterp::clonescript |
||||
if {[llength $::codeinterp::run_command_cache] > 2000} { |
||||
set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] |
||||
} |
||||
tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript |
||||
} |
||||
} result] |
||||
|
||||
|
||||
flush stdout |
||||
flush stderr |
||||
|
||||
#interp transfer code $errhandle "" |
||||
#flush $errhandle |
||||
set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] |
||||
set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] |
||||
#puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" |
||||
|
||||
set tid [thread::id] |
||||
tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] |
||||
tsv::set codethread_$tid status $status |
||||
tsv::set codethread_$tid result $result |
||||
tsv::set codethread_$tid errorcode $::errorCode |
||||
|
||||
|
||||
#only remove from shellfilter::stack the items we added to stack in this function |
||||
foreach s [lreverse $outstack] { |
||||
interp eval code [list shellfilter::stack::remove stdout $s] |
||||
} |
||||
foreach s [lreverse $errstack] { |
||||
interp eval code [list shellfilter::stack::remove stderr $s] |
||||
} |
||||
thread::cond notify $replthread_cond |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::repl::codethread ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::repl::codethread::lib { |
||||
tcl::namespace::export * |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::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::repl::codethread::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
tcl::namespace::eval punk::repl::codethread::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::repl::codethread::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { |
||||
variable pkg punk::repl::codethread |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,109 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tdl 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tdl { |
||||
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||
|
||||
variable sample_script { |
||||
server -name bsd1 -os FreeBSD |
||||
server -name p1 -os linux |
||||
server -name trillion -os windows |
||||
|
||||
server -name vmhost1 -os FreeBSD { |
||||
guest -name bsd1 -vmmanager bastille |
||||
guest -name p1 -vmmanager bhyve |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc prettyparse {script {safe 1}} { |
||||
if {$safe} { |
||||
set i [interp create -safe] |
||||
} else { |
||||
set i [interp create] |
||||
} |
||||
try { |
||||
# $i eval {unset {*}[info vars]} |
||||
# foreach command [$i eval {info commands}] {$i hide $command} |
||||
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||
$i alias unknown apply {{i tag args} { |
||||
upvar 1 result result |
||||
set e [concat [list tag $tag]\ |
||||
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||
if {[llength $args] % 2} { |
||||
set saved $result |
||||
set result {} |
||||
$i eval [lindex $args end] |
||||
lappend e body $result |
||||
set result $saved |
||||
} |
||||
lappend result $e |
||||
list |
||||
}} $i |
||||
set result {} |
||||
$i eval $script |
||||
return $result |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
|
||||
proc prettyprint {data {level 0}} { |
||||
set ind [string repeat " " $level] |
||||
incr level |
||||
set result {} |
||||
foreach e $data { |
||||
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||
} |
||||
lappend result $line |
||||
} |
||||
join $result \n |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tdl [namespace eval punk::tdl { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,605 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) CMcC 2010 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::trie 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::trie 0 0.1.0] |
||||
#[copyright "2010"] |
||||
#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::trie] |
||||
#[keywords module datastructure trie] |
||||
#[description] tcl trie implementation courtesy of CmcC (tcl wiki) |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::trie |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::trie |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# #tcl::namespace::eval punk::trie::class { |
||||
# #*** !doctools |
||||
# #[subsection {Namespace punk::trie::class}] |
||||
# #[para] class definitions |
||||
# #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||
# #*** !doctools |
||||
# #[list_begin enumerated] |
||||
# |
||||
# # oo::class create interface_sample1 { |
||||
# # #*** !doctools |
||||
# # #[enum] CLASS [class interface_sample1] |
||||
# # #[list_begin definitions] |
||||
# |
||||
# # method test {arg1} { |
||||
# # #*** !doctools |
||||
# # #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# # #[para] test method |
||||
# # puts "test: $arg1" |
||||
# # } |
||||
# |
||||
# # #*** !doctools |
||||
# # #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# # } |
||||
# |
||||
# #*** !doctools |
||||
# #[list_end] [comment {--- end class enumeration ---}] |
||||
# #} |
||||
# #} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::trie { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
proc Dolog {lvl txt} { |
||||
#return "$lvl -- $txt" |
||||
#logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted |
||||
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" |
||||
puts stderr $msg |
||||
} |
||||
package require logger |
||||
logger::initNamespace ::punk::trie |
||||
foreach lvl [logger::levels] { |
||||
interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl |
||||
log::logproc $lvl ::punk::trie::Log_$lvl |
||||
} |
||||
#namespace path ::punk::trie::log |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::trie}] |
||||
#[para] Core API functions for punk::trie |
||||
if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
oo::class create [tcl::namespace::current]::trieclass { |
||||
#*** !doctools |
||||
#[enum] CLASS [class trieclass] |
||||
#[list_begin definitions] |
||||
|
||||
variable trie id |
||||
|
||||
method matches {t what} { |
||||
#*** !doctools |
||||
#[call class::trieclass [method matches] [arg t] [arg what]] |
||||
#[para] search for longest prefix, return matching prefix, element and suffix |
||||
|
||||
set matches {} |
||||
set wlen [string length $what] |
||||
foreach k [lsort -decreasing -dictionary [dict keys $t]] { |
||||
set klen [string length $k] |
||||
set match "" |
||||
for {set i 0} {$i < $klen |
||||
&& $i < $wlen |
||||
&& [string index $k $i] eq [string index $what $i] |
||||
} {incr i} { |
||||
append match [string index $k $i] |
||||
} |
||||
if {$match ne ""} { |
||||
lappend matches $match $k |
||||
} |
||||
} |
||||
#Debug.trie {matches: $what -> $matches} |
||||
::punk::trie::log::debug {matches: $what -> $matches} |
||||
|
||||
if {[dict size $matches]} { |
||||
# find the longest matching prefix |
||||
set match [lindex [lsort -dictionary [dict keys $matches]] end] |
||||
set mel [dict get $matches $match] |
||||
set suffix [string range $what [string length $match] end] |
||||
|
||||
return [list $match $mel $suffix] |
||||
} else { |
||||
return {} ;# no matches |
||||
} |
||||
} |
||||
|
||||
# return next unique id if there's no proffered value |
||||
method id {value} { |
||||
if {$value} { |
||||
return $value |
||||
} else { |
||||
return [incr id] |
||||
} |
||||
} |
||||
|
||||
# insert an element with a given optional value into trie |
||||
# along path given by $args (no need to specify) |
||||
method insert {what {value 0} args} { |
||||
if {[llength $args]} { |
||||
set t [dict get $trie {*}$args] |
||||
} else { |
||||
set t $trie |
||||
} |
||||
|
||||
if {[dict exists $t $what]} { |
||||
#Debug.trie {$what is an exact match on path ($args $what)} |
||||
::punk::trie::log::debug {$what is an exact match on path ($args $what)} |
||||
if {[catch {dict size [dict get $trie {*}$args $what]} size]} { |
||||
# the match is a leaf - we're done |
||||
} else { |
||||
# the match is a dict - we have to add a null |
||||
dict set trie {*}$args $what "" [my id $value] |
||||
} |
||||
|
||||
return ;# exact match - no change |
||||
} |
||||
|
||||
# search for longest prefix |
||||
set match [my matches $t $what] |
||||
|
||||
if {![llength $match]} { |
||||
;# no matching prefix - new element |
||||
#Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} |
||||
::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} |
||||
dict set trie {*}$args $what [my id $value] |
||||
return |
||||
} |
||||
|
||||
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||
|
||||
if {$match ne $mel} { |
||||
# the matching element shares a prefix, but has a variant suffix |
||||
# it must be split |
||||
#Debug.trie {splitting '$mel' along '$match'} |
||||
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||
|
||||
set melC [dict get $t $mel] |
||||
dict unset trie {*}$args $mel |
||||
dict set trie {*}$args $match [string range $mel [string length $match] end] $melC |
||||
} |
||||
|
||||
if {[catch {dict size [dict get $trie {*}$args $match]} size]} { |
||||
# the match is a leaf - must be split |
||||
if {$match eq $mel} { |
||||
# the matching element shares a prefix, but has a variant suffix |
||||
# it must be split |
||||
#Debug.trie {splitting '$mel' along '$match'} |
||||
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||
set melC [dict get $t $mel] |
||||
dict unset trie {*}$args $mel |
||||
dict set trie {*}$args $match "" $melC |
||||
} |
||||
#Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||
::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||
set melid [dict get $t $mel] |
||||
dict set trie {*}$args $match $suffix [my id $value] |
||||
} else { |
||||
# it's a dict - keep searching |
||||
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||
::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||
my insert $suffix $value {*}$args $match |
||||
} |
||||
return |
||||
} |
||||
|
||||
# find a path matching an element $what |
||||
# if the element's not found, return the nearest path |
||||
method find_path {what args} { |
||||
if {[llength $args]} { |
||||
set t [dict get $trie {*}$args] |
||||
} else { |
||||
set t $trie |
||||
} |
||||
|
||||
if {[dict exists $t $what]} { |
||||
#Debug.trie {$what is an exact match on path ($args $what)} |
||||
return [list {*}$args $what] ;# exact match - no change |
||||
} |
||||
|
||||
# search for longest prefix |
||||
set match [my matches $t $what] |
||||
|
||||
if {![llength $match]} { |
||||
return $args |
||||
} |
||||
|
||||
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||
|
||||
if {$match ne $mel} { |
||||
# the matching element shares a prefix, but has a variant suffix |
||||
# no match |
||||
return $args |
||||
} |
||||
|
||||
if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { |
||||
# got to a non-matching leaf - no match |
||||
return $args |
||||
} else { |
||||
# it's a dict - keep searching |
||||
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||
return [my find_path $suffix {*}$args $match] |
||||
} |
||||
} |
||||
|
||||
# given a trie, which may have been modified by deletion, |
||||
# optimize it by removing empty nodes and coalescing singleton nodes |
||||
method optimize {args} { |
||||
if {[llength $args]} { |
||||
set t [dict get $trie {*}$args] |
||||
} else { |
||||
set t $trie |
||||
} |
||||
|
||||
if {[catch {dict size $t} size]} { |
||||
#Debug.trie {optimize leaf '$t' along '$args'} |
||||
::punk::trie::log::debug {optimize leaf '$t' along '$args'} |
||||
# leaf - leave it |
||||
} else { |
||||
switch -- $size { |
||||
0 { |
||||
#Debug.trie {optimize empty dict ($t) along '$args'} |
||||
::punk::trie::log::debug {optimize empty dict ($t) along '$args'} |
||||
if {[llength $args]} { |
||||
dict unset trie {*}$args |
||||
} |
||||
} |
||||
1 { |
||||
#Debug.trie {optimize singleton dict ($t) along '$args'} |
||||
::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} |
||||
lassign $t k v |
||||
if {[llength $args]} { |
||||
dict unset trie {*}$args |
||||
} |
||||
append args $k |
||||
if {[llength $v]} { |
||||
dict set trie {*}$args $v |
||||
} |
||||
my optimize {*}$args |
||||
} |
||||
default { |
||||
#Debug.trie {optimize dict ($t) along '$args'} |
||||
::punk::trie::log::debug {optimize dict ($t) along '$args'} |
||||
dict for {k v} $t { |
||||
my optimize {*}$args $k |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# delete element $what from trie |
||||
method delete {what} { |
||||
set path [my find_path $what] |
||||
if {[join $path ""] eq $what} { |
||||
#Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} |
||||
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||
# got to a matching leaf - delete it |
||||
dict unset trie {*}$path |
||||
set path [lrange $path 0 end-1] |
||||
} else { |
||||
dict unset trie {*}$path "" |
||||
} |
||||
|
||||
my optimize ;# remove empty and singleton elements |
||||
} else { |
||||
# nothing to delete, guess we're done |
||||
} |
||||
} |
||||
|
||||
# find the value of element $what in trie, |
||||
# error if not found |
||||
method find_or_error {what} { |
||||
set path [my find_path $what] |
||||
if {[join $path ""] eq $what} { |
||||
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||
# got to a matching leaf - done |
||||
return [dict get $trie {*}$path] |
||||
} else { |
||||
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||
if {[dict exists $trie {*}$path ""]} { |
||||
return [dict get $trie {*}$path ""] |
||||
} else { |
||||
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||
error "'$what' not found" |
||||
} |
||||
} |
||||
} else { |
||||
error "'$what' not found" |
||||
} |
||||
} |
||||
#JMN - renamed original find to find_or_error |
||||
#prefer not to catch on result - but test for -1 |
||||
method find {what} { |
||||
set path [my find_path $what] |
||||
if {[join $path ""] eq $what} { |
||||
#presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep |
||||
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||
# got to a matching leaf - done |
||||
return [dict get $trie {*}$path] |
||||
} else { |
||||
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||
if {[dict exists $trie {*}$path ""]} { |
||||
return [dict get $trie {*}$path ""] |
||||
} else { |
||||
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||
return -1 |
||||
} |
||||
} |
||||
} else { |
||||
return -1 |
||||
} |
||||
} |
||||
|
||||
# dump the trie as a string |
||||
method dump {} { |
||||
return $trie |
||||
} |
||||
|
||||
# return a string rep of the trie sorted in dict order |
||||
method order {{t {}}} { |
||||
if {![llength $t]} { |
||||
set t $trie |
||||
} elseif {[llength $t] == 1} { |
||||
return $t |
||||
} |
||||
set acc {} |
||||
|
||||
foreach key [lsort -dictionary [dict keys $t]] { |
||||
lappend acc $key [my order [dict get $t $key]] |
||||
} |
||||
return $acc |
||||
} |
||||
|
||||
# return the trie as a dict of names with values |
||||
method flatten {{t {}} {prefix ""}} { |
||||
if {![llength $t]} { |
||||
set t $trie |
||||
} elseif {[llength $t] == 1} { |
||||
return [list $prefix $t] |
||||
} |
||||
|
||||
set acc {} |
||||
dict for {key val} $t { |
||||
lappend acc {*}[my flatten $val $prefix$key] |
||||
} |
||||
return $acc |
||||
} |
||||
|
||||
#shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match |
||||
#ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. |
||||
#JMN - REVIEW - better algorithms? |
||||
#caller having retained all members can avoid flatten call |
||||
#by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. |
||||
#when all 'which' members are in the tree - scanning stops when they're all found |
||||
# - and a dict containing result and scanned keys is returned |
||||
# - result contains a dict with keys for each which member |
||||
# - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) |
||||
method shortest_idents {which {allmembers {}}} { |
||||
set t $trie |
||||
if {![llength $allmembers]} { |
||||
set members [dict keys [my flatten]] |
||||
} else { |
||||
set members $allmembers |
||||
} |
||||
set len_members [lmap m $members {list [string length $m] $m}] |
||||
set longestfirst [lsort -index 0 -integer -decreasing $len_members] |
||||
set longestfirst [lmap v $longestfirst {lindex $v 1}] |
||||
set taken [dict create] |
||||
set scanned [dict create] |
||||
set result [dict create] ;#words in our which list - if found |
||||
foreach w $longestfirst { |
||||
set path [my find_path $w] |
||||
if {[dict exists $taken $w]} { |
||||
#whole word - no unique prefix |
||||
dict set scanned $w $w |
||||
if {$w in $which} { |
||||
#puts stderr "$w -> $w" |
||||
dict set result $w $w |
||||
if {[dict size $result] == [llength $which]} { |
||||
return [dict create result $result scanned $scanned] |
||||
} |
||||
} |
||||
continue |
||||
} |
||||
set acc "" |
||||
foreach p [lrange $path 0 end-1] { |
||||
dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present |
||||
} |
||||
append acc [string index [lindex $path end] 0] |
||||
dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary |
||||
if {$w in $which} { |
||||
#puts stderr "$w -> $acc" |
||||
dict set result $w $acc |
||||
if {[dict size $result] == [llength $which]} { |
||||
return [dict create result $result scanned $scanned] |
||||
} |
||||
} |
||||
} |
||||
return [dict create result $result scanned $scanned] |
||||
} |
||||
|
||||
# overwrite the trie |
||||
method set {t} { |
||||
set trie $t |
||||
} |
||||
|
||||
constructor {args} { |
||||
set trie {} |
||||
set id 0 |
||||
foreach a $args { |
||||
my insert $a |
||||
} |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions ---}] |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
|
||||
set testlist [list blah x black blacken] |
||||
proc test1 {} { |
||||
#JMN |
||||
#test that find_or_error of a path that isn't stored as a value returns an appropriate error |
||||
#(used to report couldn't find dict key "") |
||||
set t [punk::trie::trieclass new blah x black blacken] |
||||
if {[catch {$t find_or_error bla} errM]} { |
||||
puts stderr "should be error indicating 'bla' not found" |
||||
puts stderr "err during $t find bla\n$errM" |
||||
} |
||||
return $t |
||||
} |
||||
|
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#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" |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::trie::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::trie::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::trie::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::trie::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::trie [tcl::namespace::eval punk::trie { |
||||
variable pkg punk::trie |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,237 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::unixywindows 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#for illegalname_test |
||||
package require punk::winpath |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::unixywindows { |
||||
#'cached' name to make obvious it could be out of date - and to distinguish from unixyroot arg |
||||
variable cachedunixyroot "" |
||||
|
||||
|
||||
#----------------- |
||||
#e.g something like c:/Users/geek/scoop/apps/msys2/current c:/msys2 |
||||
proc get_unixyroot {} { |
||||
variable cachedunixyroot |
||||
if {![string length $cachedunixyroot]} { |
||||
if {![catch { |
||||
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||
set cachedunixyroot [punk::objclone $result] |
||||
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||
#set ::punk::last_run_display [list] ;#hack - review shouldn't really be necessary.. but because we call winpath from ./ - the repl looks for last_run_display |
||||
} errM]} { |
||||
|
||||
} else { |
||||
puts stderr "Warning: Failed to determine base for unix-like paths - using default of c:/msys2" |
||||
file pathtype [set cachedunixyroot [punk::objclone "c:/msys2"]] |
||||
} |
||||
} |
||||
#will have been shimmered from string to 'path' internal rep by 'file pathtype' call |
||||
|
||||
#let's return a different copy as it's so easy to lose path-rep |
||||
set copy [punk::objclone $cachedunixyroot] |
||||
return $copy |
||||
} |
||||
proc refresh_unixyroot {} { |
||||
variable cachedunixyroot |
||||
set result [exec cygpath -m /] ;# -m gives result with forward-slashes - which is ok for windows paths in a Tcl context. |
||||
set cachedunixyroot [punk::objclone $result] |
||||
file pathtype $cachedunixyroot; #this call causes the int-rep to be path |
||||
|
||||
set copy [punk::objclone $cachedunixyroot] |
||||
return $copy |
||||
} |
||||
proc set_unixyroot {windows_path} { |
||||
variable cachedunixyroot |
||||
file pathtype $windows_path |
||||
set cachedunixyroot [punk::objclone $windows_path] |
||||
#return the original - but probably int-rep will have shimmered to path even if started out as string |
||||
#- that's probably what we want. Caller can use as string or path without affecting cachedunixyroot |
||||
return $windows_path |
||||
} |
||||
|
||||
|
||||
proc windir {path} { |
||||
if {$path eq "~"} { |
||||
#as the tilde hasn't been normalized.. we can't assume we're running on the actual platform |
||||
return ~/.. |
||||
} |
||||
return [file dirname [towinpath $path]] |
||||
} |
||||
|
||||
#REVIEW high-coupling |
||||
proc cdwin {path} { |
||||
set path [towinpath $path] |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
if {[llength [info commands ::punk::console::titleset]]} { |
||||
::punk::console::titleset $path |
||||
} |
||||
} |
||||
cd $path |
||||
} |
||||
proc cdwindir {path} { |
||||
set path [towinpath $path] |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
if {[llength [info commands ::punk::console::titleset]]} { |
||||
::punk::console::titleset $path |
||||
} |
||||
} |
||||
cd [file dirname $path] |
||||
} |
||||
|
||||
#NOTE - this is an expensive operation - avoid where possible. |
||||
#review - is this intended to be useful/callable on non-windows platforms? |
||||
#it should in theory be useable from another platform that wants to create a path for use on windows. |
||||
#In this case - we shouldn't examine what volumes exist (assume A: .. Z: are valid) |
||||
#review zipfs:// other uri schemes? |
||||
proc towinpath {unixypath {unixyroot ""}} { |
||||
#NOTE: tcl file exists gives different answers on windows for paths like /c depending on cwd (presumably based on file pathtype of volumerelative) |
||||
#(Tcl is also somewhat broken as at 2023 as far as volume relative paths - process can get out of sync with tcl if cd to a vol relative path is used) |
||||
#This is add odds with attempting to navigate on a windows system which has cygwin, wsl etc... It also makes it difficult for functions intended to operate independent of CWD. |
||||
#e.g there is potential confusion when there is a c folder on c: drive (c:/c) |
||||
#I will attempt to provide a coherent operation for winpath ./ ../ etc , but it may disallow for example; change to /something or /x where these don't match a driveletter or /mnt |
||||
#whereas tcl may allow cd to /something if a something folder happens to exist on the current volume based on cwd. |
||||
#I think it's preferable to require an explicit driveletter /x or /mnt when using unix-like paths on windows - but practical considerations may prove me wrong.. |
||||
#It's possible that this function should also ignore the current set of driveletters - and operate completely independent of whether a path actually exists |
||||
#This makes it hard to use things like 'file normalize' - which also looks at things like current volume. |
||||
# |
||||
#Note for example the results of 'which' grep on windows can produce a path like /c/Users/somewhere/bin/grep |
||||
#which tcl's file normalize may change to C:/c/Users or X:/c/Users - based on current volumen. Given that C:/c might exist - this can be problematic in a couple of ways. |
||||
#The mixing of unix-like and windows commands on the same machine is a large part of the problem.. but this mix is now common |
||||
# |
||||
#convert /c/etc to C:/etc |
||||
set re_slash_x_slash {^/([[:alpha:]]){1}/.*} |
||||
set re_slash_else {^/([[:alpha:]]*)(.*)} |
||||
set volumes [file volumes] |
||||
#exclude things like //zipfs:/ ?? |
||||
set driveletters [list] |
||||
foreach v $volumes { |
||||
if {[regexp {^([[:alpha:]]){1}:/$} $v _ letter]} { |
||||
lappend driveletters $letter |
||||
} |
||||
} |
||||
#puts stderr "->$driveletters" |
||||
|
||||
set path [punk::objclone $unixypath] ;#take another copy that we can deliberatley shimmer to path and know is separate to the supplied argument |
||||
set supplied_pathtype [file pathtype $path] ;#we don't care about the pathtype so much as the act of making this call shimmers to a path internal-rep |
||||
|
||||
#copy of var that we can treat as a string without affecting path rep |
||||
#Note that some but not all read operations will lose path rep e.g 'string length $x' will lose any path-rep $x had, (but 'string equal $x something' won't) |
||||
#Todo - make int-rep tests to check stability of these behaviours across Tcl versions! |
||||
set strcopy_path [punk::objclone $path] |
||||
|
||||
set str_newpath "" |
||||
|
||||
set have_pathobj 0 |
||||
|
||||
if {[regexp $re_slash_x_slash $strcopy_path _ letter]} { |
||||
#upper case appears to be windows canonical form |
||||
set str_newpath [string toupper $letter]:/[string range $strcopy_path 3 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $strcopy_path] _ letter]} { |
||||
set str_newpath [string toupper $letter]:/[string range $strcopy_path 7 end] |
||||
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $strcopy_path] _ letter]} { |
||||
set str_newpath [string toupper $letter]:/ |
||||
} elseif {[regexp $re_slash_else $strcopy_path _ firstpart remainder]} { |
||||
#could be for example /c or /something/users |
||||
if {[string length $firstpart] == 1} { |
||||
set letter $firstpart |
||||
set str_newpath [string toupper $letter]:/ |
||||
} else { |
||||
#according to regex we have a single leading slash |
||||
set str_tail [string range $strcopy_path 1 end] |
||||
if {$unixyroot eq ""} { |
||||
set unixyroot [get_unixyroot] |
||||
} else { |
||||
file pathtype $unixyroot; #side-effect generates int-rep of type path ) |
||||
} |
||||
set pathobj [file join $unixyroot $str_tail] |
||||
file pathtype $pathobj |
||||
set have_pathobj 1 |
||||
} |
||||
} |
||||
|
||||
if {!$have_pathobj} { |
||||
if {$str_newpath eq ""} { |
||||
#dunno - pass through |
||||
set pathobj $path |
||||
} else { |
||||
set pathobj [punk::objclone $str_newpath] |
||||
file pathtype $pathobj |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
#puts stderr "=> $path" |
||||
#things like 'which' seem to return a path minus the .exe - so we'll just test the containing folder |
||||
# |
||||
#By now file normalize shouldn't do too many shannanigans related to cwd.. |
||||
#We want it to look at cwd for relative paths.. |
||||
#but we don't consider things like /c/Users to be relative even on windows where it would normally mean a volume-relative path e.g c:/c/Users if cwd happens to be somewhere on C: at the time. |
||||
#if {![file exists [file dirname $path]]} { |
||||
# set path [file normalize $path] |
||||
# #may still not exist.. that's ok. |
||||
#} |
||||
|
||||
|
||||
|
||||
#file normalize may change backslashes to forward slashes.. including things like the special \\?\ prefix which is intended to stop windows api from parsing a name |
||||
#2023 - this is ok as //?/ also seems to work.. but it is unclear if that is because Tcl is re-converting to backslashes |
||||
if {[punk::winpath::illegalname_test $pathobj]} { |
||||
set pathobj [punk::winpath::illegalname_fix $pathobj] |
||||
} |
||||
|
||||
return $pathobj |
||||
} |
||||
|
||||
#---------------------------------------------- |
||||
#leave the unixywindows related aliases available on all platforms |
||||
#interp alias {} cdwin {} punk::unixywindows::cdwin |
||||
#interp alias {} cdwindir {} punk::unixywindoes::cdwindir |
||||
#interp alias {} towinpath {} punk::unixywindows::towinpath |
||||
#interp alias {} windir {} punk::unixywindows::windir |
||||
#---------------------------------------------- |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::unixywindows [namespace eval punk::unixywindows { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,363 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# 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) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::winpath 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winpath { |
||||
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||
|
||||
|
||||
|
||||
|
||||
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||
proc is_unc_path {path} { |
||||
set strcopy_path [punk::winpath::system::objclone $path] |
||||
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string first "//" $strcopy_path] == 0} { |
||||
#check for "Dos device path" syntax |
||||
if {[string range $strcopy_path 0 3] in {//?/ //./}} { |
||||
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||
if {[string range $strcopy_path 4 6] eq "UNC"} { |
||||
return 1 |
||||
} else { |
||||
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||
return 0 |
||||
} |
||||
} else { |
||||
#leading double slash and not dos device path syntax |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||
proc is_unc_path_plain {path} { |
||||
if {[is_unc_path $path]} { |
||||
if {![is_dos_device_path $path]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
||||
proc pwdshortname {{path {}}} { |
||||
if {$path eq ""} { |
||||
set path [pwd] |
||||
} else { |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
} |
||||
return [dict get [file attributes $path] -shortname] |
||||
} |
||||
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||
proc is_dos_device_path {path} { |
||||
set strcopy_path [punk::winpath::system::objclone $path] |
||||
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string range $strcopy_path 0 3] in {//?/ //./}} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc strip_dos_device_prefix {path} { |
||||
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||
#(review.. or raise error because a //?/UNC path isn't an ordinary dos device path? ) |
||||
if {[is_unc_path $path]} { |
||||
return [strip_unc_path_prefix $path] |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
return [string range $path 4 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
proc strip_unc_path_prefix {path} { |
||||
if {[is_unc_path_plain $path]} { |
||||
#plain unc //server |
||||
set strcopy_path [punk::winpath::system::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 2 end] |
||||
file pathtype $trimmedpath |
||||
return $trimmedpath |
||||
} elseif {is_unc_path $path} { |
||||
#//?/UNC/server/subpath or //./UNC/server/subpath |
||||
set strcopy_path [punk::winpath::system::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 7 end] |
||||
file pathtype $trimmedpath ;#shimmer it to path rep |
||||
return $trimmedpath |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||
#The caller can apply this to any path. |
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) |
||||
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
||||
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
||||
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
||||
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
||||
#- it also depends on the history of the folder |
||||
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
||||
#- the shortname may have been generated during a different directory state. |
||||
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
||||
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
||||
# and would be subject to potential collisions if there are race-conditions in file creation |
||||
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
||||
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
||||
proc illegalname_fix {path} { |
||||
#don't add extra dos device path syntax protection-prefix if already done |
||||
if {[is_unc_path $path]} { |
||||
error "illegalname_fix called on UNC path $path - unable to process" |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
#we may have appended |
||||
return $path |
||||
} |
||||
|
||||
|
||||
|
||||
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||
#(but mapped drive to same path will work) |
||||
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||
if {[is_unc_path $path]} { |
||||
set err "" |
||||
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||
error $err |
||||
} |
||||
|
||||
set strcopy_path [punk::winpath::system::objclone $path] |
||||
|
||||
|
||||
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||
if {[file pathtype $path] eq "absolute"} { |
||||
if {$path eq "~"} { |
||||
# non-normalized ~ is classified as absolute |
||||
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||
# unlikely this fix will be called on a plain tilde anyway |
||||
return $path |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
} else { |
||||
#set fullpath [file normalize $path] ;#very slow on windows |
||||
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||
if {[string range $strcopy_path 0 1] eq "./"} { |
||||
set strcopy_path [string range $strcopy_path 2 end] |
||||
} |
||||
set fullpath [file join [pwd] $strcopy_path] |
||||
} |
||||
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||
# and to send the string that follows it straight to the file system. |
||||
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||
set protect2 "//?/" ;#file normalize may do this - it still works |
||||
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||
|
||||
|
||||
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||
set result ${protect2}$fullpath |
||||
file pathtype $result ;#make it return a path rep |
||||
return $result |
||||
} |
||||
|
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||
# |
||||
# path int-rep preserving |
||||
proc illegalname_test {path} { |
||||
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
||||
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
||||
set reserved [list < > : \" / \\ | ? *] |
||||
|
||||
|
||||
#we need to exclude things like path/.. path/. |
||||
foreach seg [file split $path] { |
||||
if {$seg in [list . ..]} { |
||||
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||
#unlikely in normal use - but could done deliberately for bad reasons? |
||||
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||
# |
||||
#/./ /../ segments don't require protection - keep checking. |
||||
continue |
||||
} |
||||
|
||||
#only check for actual space as other whitespace seems to work without being stripped |
||||
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||
if {[string index $seg end] in [list " " "."]} { |
||||
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||
return 1 |
||||
} |
||||
} |
||||
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||
#- they seem to be readable from cmd and tclsh as is. |
||||
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||
#(at least with encoding system utf-8) |
||||
|
||||
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||
return 0 |
||||
} |
||||
|
||||
proc shortname {path} { |
||||
set shortname "NA" |
||||
if {[catch { |
||||
set shortname [dict get [file attributes $path] -shortname] |
||||
} errM]} { |
||||
puts stderr "Failed to get shortname for '$path'" |
||||
} |
||||
return $shortname |
||||
} |
||||
proc test_ntfs_tunneling {prefix args} { |
||||
puts stderr "We are looking for whether any of the final $prefix files or dirs took over the ctime attribute of the original $prefix files or dirs" |
||||
puts stderr "We expect the ino values to get potentially reassigned depending on order of deletion/creation so matches are coincidental and not material" |
||||
puts stderr "The shortnames are similarly allocated as they come - so presumably match by coincidence" |
||||
puts stderr "However - if we record a file's shortname, then delete it. Recreating it by shortname within the tunneling timeframe will magically reassociate the longname" |
||||
puts stderr "use test_ntfs_tunneling2 to test shortname tunneling" |
||||
file mkdir $prefix-dir-rename |
||||
file mkdir $prefix-dir-recreate |
||||
set fd [open $prefix-file-recreate.txt w] |
||||
puts $fd "original for recreate" |
||||
close $fd |
||||
set fd [open $prefix-file-rename.txt w] |
||||
puts $fd "original for rename" |
||||
close $fd |
||||
puts stdout "ORIGINAL files/dirs" |
||||
puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename] " |
||||
puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" |
||||
puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" |
||||
puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" |
||||
puts stderr "waiting 10secs (to have discernable ctime differences)" |
||||
after 5000 |
||||
puts -nonewline stderr . |
||||
after 5000 |
||||
puts -nonewline stderr . |
||||
after 500 |
||||
|
||||
#-- |
||||
#seems to make no diff whether created or copied - no tunneling seen with dirs |
||||
#file mkdir $prefix-dir-rename-temp |
||||
file copy $prefix-dir-rename $prefix-dir-rename-temp |
||||
#-- |
||||
puts stderr \n |
||||
puts stdout "$prefix-dir-rename-temp [file stat $prefix-dir-rename-temp] (temp to rename into place)" |
||||
puts stderr "deleting $prefix-dir-rename" |
||||
file delete $prefix-dir-rename |
||||
puts stdout "renaming $prefix-dir-rename-temp to $prefix-dir-rename" |
||||
file rename $prefix-dir-rename-temp $prefix-dir-rename |
||||
|
||||
puts stderr "deleting $prefix-dir-recreate" |
||||
file delete $prefix-dir-recreate |
||||
puts stdout "re-creating $prefix-dir-recreate" |
||||
file mkdir $prefix-dir-recreate |
||||
|
||||
puts stderr "deleting $prefix-file-recreate.txt" |
||||
file delete $prefix-file-recreate.txt |
||||
puts stderr "Recreating $prefix-file-recreate.txt" |
||||
set fd [open $prefix-file-recreate.txt w] |
||||
puts $fd "replacement" |
||||
close $fd |
||||
|
||||
puts stderr "copying $prefix-file-rename.txt to $prefix-file-rename-temp.txt" |
||||
file copy $prefix-file-rename.txt $prefix-file-rename-temp.txt |
||||
puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of initial temp copy)" |
||||
puts stderr "modifying temp copy before deletion of original.. (append)" |
||||
set fd [open $prefix-file-rename-temp.txt a] |
||||
puts $fd "added to file" |
||||
close $fd |
||||
puts stdout "$prefix-file-rename-temp.txt [file stat $prefix-file-rename-temp.txt] short:[shortname $prefix-file-rename-temp.txt] (status of appended temp copy)" |
||||
puts stderr "deleting $prefix-file-rename.txt" |
||||
file delete $prefix-file-rename.txt |
||||
puts stderr "renaming temp file $prefix-file-rename-temp.txt to original $prefix-file-rename.txt" |
||||
file rename $prefix-file-rename-temp.txt $prefix-file-rename.txt |
||||
|
||||
puts stdout "Final files/dirs" |
||||
puts stdout "$prefix-dir-rename [file stat $prefix-dir-rename]" |
||||
puts stdout "$prefix-dir-recreate [file stat $prefix-dir-recreate]" |
||||
puts stdout "$prefix-file-recreate.txt [file stat $prefix-file-recreate.txt] short:[shortname $prefix-file-recreate.txt]" |
||||
puts stdout "$prefix-file-rename.txt [file stat $prefix-file-rename.txt] short:[shortname $prefix-file-rename.txt]" |
||||
} |
||||
proc test_ntfs_tunneling2 {prefix {waitms 15000}} { |
||||
#shortname -> longname tunneling |
||||
puts stderr "Tunneling only happens if we delete via shortname? review" |
||||
set f1 $prefix-longname-file1.txt |
||||
set f2 $prefix-longname-file2.txt |
||||
|
||||
set fd [open $f1 w];close $fd |
||||
set shortname1 [shortname $f1] |
||||
puts stderr "longname:$f1 has shortname:$shortname1" |
||||
set fd [open $f2 w];close $fd |
||||
set shortname2 [shortname $f2] |
||||
puts stderr "longname:$f2 has shortname:$shortname2" |
||||
|
||||
puts stderr "deleting $f1 via name $shortname1" |
||||
file delete $shortname1 |
||||
puts stdout "immediately recreating $shortname1 - should retain longname $f1 via tunneling" |
||||
set fd [open $shortname1 w];close $fd |
||||
set f1_exists [file exists $f1] |
||||
puts stdout "file exists $f1 = $f1_exists" |
||||
|
||||
puts stderr "deleting $f2 via name $shortname2" |
||||
file delete $shortname2 |
||||
puts stderr "Waiting [expr {$waitms / 1000}] seconds.. (standard tunneling timeframe is 15 seconds if registry hasn't been tweaked)" |
||||
after $waitms |
||||
puts stdout "recreating $shortname2 after wait of $waitms ms - longname lost?" |
||||
set fd [open $shortname2 w];close $fd |
||||
set f2_exists [file exists $f2] |
||||
puts stdout "file exists $f2 = $f2_exists" |
||||
|
||||
puts stdout -done- |
||||
} |
||||
} |
||||
|
||||
|
||||
namespace eval punk::winpath::system { |
||||
#get a copy of the item without affecting internal rep |
||||
proc objclone {obj} { |
||||
append obj2 $obj {} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winpath [namespace eval punk::winpath { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
@ -1,761 +0,0 @@
|
||||
# -*- 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 JMN |
||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::zip 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::zip 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::zip] |
||||
#[keywords module] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::zip |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::zip |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#tcl::namespace::eval punk::zip::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::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::zip { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip}] |
||||
#[para] Core API functions for punk::zip |
||||
#[list_begin definitions] |
||||
|
||||
proc Path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc Path_a_at_b {path_a path_b} { |
||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||
} |
||||
|
||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
if {$prefix eq ""} { |
||||
return $path |
||||
} |
||||
set pathparts [file split $path] |
||||
set prefixparts [file split $prefix] |
||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||
return "" |
||||
} |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
$pathparts \ |
||||
[llength $prefixparts] \ |
||||
end]] |
||||
} |
||||
|
||||
#StripPath - borrowed from tcllib fileutil |
||||
# ::fileutil::stripPath -- |
||||
# |
||||
# If the specified path references/is a path in prefix (or prefix itself) it |
||||
# is made relative to prefix. Otherwise it is left unchanged. |
||||
# In the case of it being prefix itself the result is the string '.'. |
||||
# |
||||
# Arguments: |
||||
# prefix prefix to strip from the path. |
||||
# path path to modify |
||||
# |
||||
# Results: |
||||
# path The (possibly) modified path. |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
# Windows. While paths are stored with letter-case preserved al |
||||
# comparisons have to be done case-insensitive. For reference see |
||||
# SF Tcllib Bug 2499641. |
||||
|
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal -nocase $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match -nocase "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} else { |
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} |
||||
|
||||
proc Timet_to_dos {time_t} { |
||||
#*** !doctools |
||||
#[call [fun Timet_to_dos] [arg time_t]] |
||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||
#[example { |
||||
# DOS timestamps are 32 bits split into bit regions as follows: |
||||
# 24 16 8 0 |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
#}] |
||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||
} |
||||
|
||||
proc walk {args} { |
||||
#*** !doctools |
||||
#[call [fun walk] [arg ?options?] [arg base]] |
||||
#[para] Walk a directory tree rooted at base |
||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||
#[para] e.g |
||||
#[example { |
||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||
#}] |
||||
|
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::walk |
||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||
-subpath -default "" |
||||
*values -min 1 -max -1 |
||||
base |
||||
fileglobs -default {*} -multiple 1 |
||||
} $args] |
||||
set base [dict get $argd values base] |
||||
set fileglobs [dict get $argd values fileglobs] |
||||
set subpath [dict get $argd opts -subpath] |
||||
set excludes [dict get $argd opts -excludes] |
||||
|
||||
|
||||
set imatch [list] |
||||
foreach fg $fileglobs { |
||||
lappend imatch [file join $subpath $fg] |
||||
} |
||||
|
||||
set result {} |
||||
#set imatch [file join $subpath $match] |
||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||
foreach file $files { |
||||
set excluded 0 |
||||
foreach glob $excludes { |
||||
if {[string match $glob $file]} { |
||||
set excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$excluded} {lappend result $file} |
||||
} |
||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||
if {[llength $subdir_entries]>0} { |
||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||
set result [list {*}$result "$dir/" {*}$subdir_entries] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc extract_zip_prefix {infile outfile} { |
||||
set inzip [open $infile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
if {[file exists $outfile]} { |
||||
error "outfile $outfile already exists - please remove first" |
||||
} |
||||
chan seek $inzip 0 end |
||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||
chan seek $inzip 0 start |
||||
#only scan last 64k - cover max signature size?? review |
||||
if {$insize < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$insize - 65559}] |
||||
} |
||||
chan seek $inzip $tailsearch_start start |
||||
set scan [read $inzip] |
||||
#EOCD - End Of Central Directory record |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||
puts stdout "==>start_of_end: $start_of_end" |
||||
|
||||
if {$start_of_end == -1} { |
||||
#no zip cdr - consider entire file to be the zip prefix |
||||
set baseoffset $insize |
||||
} else { |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
chan seek $inzip $filerelative_eocd_posn |
||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#rule out a false positive from within a nonzip (e.g plain exe) |
||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||
#review - should keep searching? |
||||
#for now we assume not a zip |
||||
set baseoffset $insize |
||||
} else { |
||||
#use the central dir size to jump back tko start of central dir |
||||
#determine if diroffset is file or archive relative |
||||
|
||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||
puts stdout "---> [read $inzip 4]" |
||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||
#easy case - 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||
#though we are assuming zip offsets are not corrupted |
||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||
} else { |
||||
#hard case - either no prefix - or offsets have been adjusted to be file relative. |
||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||
|
||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||
set baseoffset "unknown" |
||||
chan seek $inzip $filerelative_cdir_start start |
||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#load the whole central dir into cdir |
||||
|
||||
#todo! loop through all cdr file headers - find highest offset? |
||||
#tclZipfs.c just looks at first file header in Central Directory |
||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||
|
||||
set cdirdata [read $inzip $eocd(dirsize)] |
||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||
|
||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||
chan seek $inzip $cdir(relativeoffset) |
||||
#let's at least check that we landed on a local file header.. |
||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||
puts stdout "1st local file header sig: $lfh(signature)" |
||||
if {$lfh(signature) == 67324752} { |
||||
#looks like a local file header |
||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||
set baseoffset $cdir(relativeoffset) |
||||
} |
||||
} |
||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||
} |
||||
} |
||||
puts stdout "baseoffset: $baseoffset" |
||||
#expect CDFH PK\1\2 |
||||
#above the CDFH - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||
|
||||
if {![string is integer -strict $baseoffset]} { |
||||
error "unable to determine zip baseoffset of file $infile" |
||||
} |
||||
|
||||
if {$baseoffset < $insize} { |
||||
set out [open $outfile w] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
chan seek $inzip 0 start |
||||
chan copy $inzip $out -size $baseoffset |
||||
close $out |
||||
close $inzip |
||||
} else { |
||||
close $inzip |
||||
file copy $infile $outfile |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# Mkzipfile -- |
||||
# |
||||
# FIX ME: should handle the current offset for non-seekable channels |
||||
# |
||||
proc Mkzipfile {zipchan base path {comment ""}} { |
||||
#*** !doctools |
||||
#[call [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||
#[para] Add a single file to a zip archive |
||||
#[para] The zipchan channel should already be open and binary. |
||||
#[para] You can provide a -comment for the file. |
||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||
|
||||
set fullpath [file join $base $path] |
||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||
set utfpath [encoding convertto utf-8 $path] |
||||
set utfcomment [encoding convertto utf-8 $comment] |
||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||
set method 0 ;# store 0, deflate 8 |
||||
set attr 0 ;# text or binary (default binary) |
||||
set version 20 ;# minumum version req'd to extract |
||||
set extra "" |
||||
set crc 0 |
||||
set size 0 |
||||
set csize 0 |
||||
set data "" |
||||
set seekable [expr {[tell $zipchan] != -1}] |
||||
if {[file isdirectory $fullpath]} { |
||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||
#set attrex 0x40000010 |
||||
} elseif {[file executable $fullpath]} { |
||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||
} else { |
||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||
set attr 1 ;# text |
||||
} |
||||
} |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
set size [file size $fullpath] |
||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||
} |
||||
|
||||
|
||||
set offset [tell $zipchan] |
||||
set local [binary format a4sssiiiiss PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]] |
||||
append local $utfpath $extra |
||||
puts -nonewline $zipchan $local |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||
# streaming to avoid requiring excess memory. This helps to prevent |
||||
# storing re-compressed data that may be larger than the source when |
||||
# handling PNG or JPEG or nested ZIP files. |
||||
if {$size < 0x00200000} { |
||||
set fin [open $fullpath rb] |
||||
set data [read $fin] |
||||
set crc [zlib crc32 $data] |
||||
set cdata [zlib deflate $data] |
||||
if {[string length $cdata] < $size} { |
||||
set method 8 |
||||
set data $cdata |
||||
} |
||||
close $fin |
||||
set csize [string length $data] |
||||
puts -nonewline $zipchan $data |
||||
} else { |
||||
set method 8 |
||||
set fin [open $fullpath rb] |
||||
set zlib [zlib stream deflate] |
||||
while {![eof $fin]} { |
||||
set data [read $fin 4096] |
||||
set crc [zlib crc32 $data $crc] |
||||
$zlib put $data |
||||
if {[string length [set zdata [$zlib get]]]} { |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
} |
||||
} |
||||
close $fin |
||||
$zlib finalize |
||||
set zdata [$zlib get] |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
$zlib close |
||||
} |
||||
|
||||
if {$seekable} { |
||||
# update the header if the output is seekable |
||||
set local [binary format a4sssiiii PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size] |
||||
set current [tell $zipchan] |
||||
seek $zipchan $offset |
||||
puts -nonewline $zipchan $local |
||||
seek $zipchan $current |
||||
} else { |
||||
# Write a data descriptor record |
||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||
puts -nonewline $zipchan $ddesc |
||||
} |
||||
} |
||||
|
||||
#PK\x01\x02 Cdentral directory file header |
||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||
|
||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]\ |
||||
[string length $utfcomment] 0 $attr $attrex $offset] |
||||
append hdr $utfpath $extra $utfcomment |
||||
return $hdr |
||||
} |
||||
|
||||
#### REVIEW!!! |
||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||
# we probably want offsets to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||
#### |
||||
|
||||
# zip::mkzip -- |
||||
# |
||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||
# |
||||
proc mkzip {args} { |
||||
#*** !doctools |
||||
#[call [fun mkzip] [arg ?options?] [arg filename]] |
||||
#[para] Create a zip archive in 'filename' |
||||
#[para] If a file already exists, an error will be raised. |
||||
set argd [punk::args::get_dict { |
||||
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||
*opts |
||||
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||
to return a formatted list for the terminal |
||||
" |
||||
-zipkit -default 0 -type none -help "" |
||||
-runtime -default "" -help "specify a prefix file |
||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||
will create a self-extracting zip archive from the subdir/ folder. |
||||
" |
||||
-comment -default "" -help "An optional comment for the archive" |
||||
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||
it must be a parent of -directory" |
||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||
*values -min 1 -max -1 |
||||
filename -default "" -help "name of zipfile to create" |
||||
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||
Only directories with matching files will be included in the archive" |
||||
} $args] |
||||
|
||||
set filename [dict get $argd values filename] |
||||
if {$filename eq ""} { |
||||
error "mkzip filename cannot be empty string" |
||||
} |
||||
if {[regexp {[?*]} $filename]} { |
||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||
error "mkzip filename should not contain glob characters ? *" |
||||
} |
||||
if {[file exists $filename]} { |
||||
error "mkzip filename:$filename already exists" |
||||
} |
||||
dict for {k v} [dict get $argd opts] { |
||||
switch -- $k { |
||||
-comment { |
||||
dict set argd opts $k [encoding convertto utf-8 $v] |
||||
} |
||||
-directory - -base { |
||||
dict set argd opts $k [file normalize $v] |
||||
} |
||||
} |
||||
} |
||||
|
||||
array set opts [dict get $argd opts] |
||||
|
||||
|
||||
if {$opts(-directory) ne ""} { |
||||
if {$opts(-base) ne ""} { |
||||
#-base and -directory have been normalized already |
||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||
} |
||||
set base $opts(-base) |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||
} else { |
||||
set base $opts(-directory) |
||||
set relpath "" |
||||
} |
||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||
|
||||
set norm_filename [file normalize $filename] |
||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||
#check that we aren't adding the zipfile to itself |
||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||
|
||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||
set self_globs_match 0 |
||||
foreach g [dict get $argd values globs] { |
||||
if {[string match $g [file tail $filename]]} { |
||||
set self_globs_match 1 |
||||
break |
||||
} |
||||
} |
||||
if {$self_globs_match} { |
||||
#still dangerous |
||||
set self_excluded 0 |
||||
foreach e $opts(-exclude) { |
||||
if {[string match $e [file tail $filename]]} { |
||||
set self_excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$self_excluded} { |
||||
#still dangerous - likely to be in resultset - check each path |
||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||
set self_is_matched 0 |
||||
set i 0 |
||||
foreach p $paths { |
||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||
set self_is_matched 1 |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$self_is_matched} { |
||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||
set paths [lremove $paths $i] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set paths [list] |
||||
set dir [pwd] |
||||
if {$opts(-base) ne ""} { |
||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||
} |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||
} else { |
||||
set relpath "" |
||||
} |
||||
set base $opts(-base) |
||||
|
||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||
foreach m $matches { |
||||
if {$m eq $filename} { |
||||
#puts stderr "--> excluding $filename" |
||||
continue |
||||
} |
||||
set isok 1 |
||||
foreach e [concat $opts(-exclude) $filename] { |
||||
if {[string match $e $m]} { |
||||
set isok 0 |
||||
break |
||||
} |
||||
} |
||||
if {$isok} { |
||||
lappend paths [file join $relpath $m] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
return "" |
||||
} |
||||
|
||||
set zf [open $filename wb] |
||||
if {$opts(-runtime) ne ""} { |
||||
set rt [open $opts(-runtime) rb] |
||||
fcopy $rt $zf |
||||
close $rt |
||||
} elseif {$opts(-zipkit)} { |
||||
#TODO - update to zipfs ? |
||||
#see modpod |
||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||
append zkd "package require vfs::zip\n" |
||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||
append zkd "}\n" |
||||
append zkd \x1A |
||||
puts -nonewline $zf $zkd |
||||
} |
||||
|
||||
#todo - subtract this from the endrec offset.. and any ... ? |
||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of data section //JMN 2024 |
||||
|
||||
set count 0 |
||||
set cd "" |
||||
|
||||
set members [list] |
||||
foreach path $paths { |
||||
#puts $path |
||||
lappend members $path |
||||
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath |
||||
incr count |
||||
} |
||||
set cdoffset [tell $zf] |
||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||
$count $count [string length $cd] $cdoffset\ |
||||
[string length $opts(-comment)]] |
||||
append endrec $opts(-comment) |
||||
puts -nonewline $zf $cd |
||||
puts -nonewline $zf $endrec |
||||
close $zf |
||||
|
||||
set result "" |
||||
switch -exact -- $opts(-return) { |
||||
list { |
||||
set result $members |
||||
} |
||||
pretty { |
||||
if {[info commands showlist] ne ""} { |
||||
set result [plist -channel none members] |
||||
} else { |
||||
set result $members |
||||
} |
||||
} |
||||
none { |
||||
set result "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::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::zip::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
#tcl::namespace::eval punk::zip::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
#} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||
variable pkg punk::zip |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,914 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/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 JMN |
||||
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::zip 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::zip 0 0.1.1] |
||||
#[copyright "2024"] |
||||
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::zip] |
||||
#[keywords module zip fileformat] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::zip |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::zip |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6- |
||||
package require punk::args |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {punk::args}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip}] |
||||
#[para] Core API functions for punk::zip |
||||
#[list_begin definitions] |
||||
|
||||
proc Path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc Path_a_at_b {path_a path_b} { |
||||
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||
} |
||||
|
||||
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||
if {$prefix eq ""} { |
||||
return $path |
||||
} |
||||
set pathparts [file split $path] |
||||
set prefixparts [file split $prefix] |
||||
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||
return "" |
||||
} |
||||
return [file join \ |
||||
{*}[lrange \ |
||||
$pathparts \ |
||||
[llength $prefixparts] \ |
||||
end]] |
||||
} |
||||
|
||||
#StripPath - borrowed from tcllib fileutil |
||||
# ::fileutil::stripPath -- |
||||
# |
||||
# If the specified path references/is a path in prefix (or prefix itself) it |
||||
# is made relative to prefix. Otherwise it is left unchanged. |
||||
# In the case of it being prefix itself the result is the string '.'. |
||||
# |
||||
# Arguments: |
||||
# prefix prefix to strip from the path. |
||||
# path path to modify |
||||
# |
||||
# Results: |
||||
# path The (possibly) modified path. |
||||
|
||||
if {[string equal $::tcl_platform(platform) windows]} { |
||||
# Windows. While paths are stored with letter-case preserved al |
||||
# comparisons have to be done case-insensitive. For reference see |
||||
# SF Tcllib Bug 2499641. |
||||
|
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal -nocase $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match -nocase "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} else { |
||||
proc StripPath {prefix path} { |
||||
# [file split] is used to generate a canonical form for both |
||||
# paths, for easy comparison, and also one which is easy to modify |
||||
# using list commands. |
||||
|
||||
set prefix [file split $prefix] |
||||
set npath [file split $path] |
||||
|
||||
if {[string equal $prefix $npath]} { |
||||
return "." |
||||
} |
||||
|
||||
if {[string match "${prefix} *" $npath]} { |
||||
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||
} |
||||
return $path |
||||
} |
||||
} |
||||
|
||||
proc Timet_to_dos {time_t} { |
||||
#*** !doctools |
||||
#[call [fun Timet_to_dos] [arg time_t]] |
||||
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||
#[example { |
||||
# DOS timestamps are 32 bits split into bit regions as follows: |
||||
# 24 16 8 0 |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||
#}] |
||||
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||
} |
||||
punk::args::define { |
||||
@id -id ::punk::zip::walk |
||||
@cmd -name punk::zip::walk -help\ |
||||
"Walk the directory structure starting at base/<-subpath> |
||||
and return a list of the files and folders encountered. |
||||
Resulting paths are relative to base unless -resultrelative |
||||
is supplied. |
||||
Folder names will end with a trailing slash. |
||||
" |
||||
-resultrelative -optional 1 -help\ |
||||
"Resulting paths are relative to this value. |
||||
Defaults to the value of base. If empty string |
||||
is given to -resultrelative the paths returned |
||||
are effectively absolute paths." |
||||
-emptydirs -default 0 -type boolean -help\ |
||||
"Whether to include directory trees in the result which had no |
||||
matches for the given fileglobs. |
||||
Intermediate dirs are always returned if there is a match with |
||||
fileglobs further down even if -emptdirs is 0. |
||||
" |
||||
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||
-subpath -default "" -help\ |
||||
"May contain glob chars for folder elements" |
||||
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the -- |
||||
-- -type none -optional 1 |
||||
@values -min 1 -max -1 |
||||
base |
||||
fileglobs -default {*} -multiple 1 |
||||
} |
||||
proc walk {args} { |
||||
#*** !doctools |
||||
#[call [fun walk] [arg ?options?] [arg base]] |
||||
#[para] Walk a directory tree rooted at base |
||||
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||
#[para] e.g |
||||
#[example { |
||||
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||
#}] |
||||
|
||||
#todo: -relative 0|1 flag? |
||||
set argd [punk::args::parse $args withid ::punk::zip::walk] |
||||
set base [dict get $argd values base] |
||||
set fileglobs [dict get $argd values fileglobs] |
||||
set subpath [dict get $argd opts -subpath] |
||||
set excludes [dict get $argd opts -excludes] |
||||
set emptydirs [dict get $argd opts -emptydirs] |
||||
|
||||
set received [dict get $argd received] |
||||
|
||||
set imatch [list] |
||||
foreach fg $fileglobs { |
||||
lappend imatch [file join $subpath $fg] |
||||
} |
||||
|
||||
if {![dict exists $received -resultrelative]} { |
||||
set relto $base |
||||
set prefix "" |
||||
} else { |
||||
set relto [file normalize [dict get $argd opts -resultrelative]] |
||||
if {$relto ne ""} { |
||||
if {![Path_a_atorbelow_b $base $relto]} { |
||||
error "punk::zip::walk base must be at or below -resultrelative value (backtracking not currently supported)" |
||||
} |
||||
set prefix [Path_strip_alreadynormalized_prefixdepth $base $relto] |
||||
} else { |
||||
set prefix $base |
||||
} |
||||
} |
||||
|
||||
set result {} |
||||
#set imatch [file join $subpath $match] |
||||
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||
foreach file $files { |
||||
set excluded 0 |
||||
foreach glob $excludes { |
||||
if {[string match $glob $file]} { |
||||
set excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$excluded} {lappend result [file join $prefix $file]} |
||||
} |
||||
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||
set submatches [walk -subpath $dir -emptydirs $emptydirs -excludes $excludes $base {*}$fileglobs] |
||||
set subdir_entries [list] |
||||
set thisdir_match [list] |
||||
set has_file 0 |
||||
foreach sd $submatches { |
||||
set fullpath [file join $prefix $sd] ;#file join destroys trailing slash |
||||
if {[string index $sd end] eq "/"} { |
||||
lappend subdir_entries $fullpath/ |
||||
} else { |
||||
set has_file 1 |
||||
lappend subdir_entries $fullpath |
||||
} |
||||
} |
||||
if {$emptydirs} { |
||||
set thisdir_match [list "[file join $prefix $dir]/"] |
||||
} else { |
||||
if {$has_file} { |
||||
set thisdir_match [list "[file join $prefix $dir]/"] |
||||
} else { |
||||
set subdir_entries [list] |
||||
} |
||||
} |
||||
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||
set result [list {*}$result {*}$thisdir_match {*}$subdir_entries] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) |
||||
#Otherwise extract an internal preamble. |
||||
#if neither -? |
||||
#review - reconsider auto-determination of internal vs external preamble |
||||
punk::args::define { |
||||
@id -id ::punk::zip::extract_preamble |
||||
@cmd -name punk::zip::extract_preamble -help\ |
||||
"Split a zipfs based executable or library into its constituent |
||||
binary and zip parts. |
||||
|
||||
Note that the binary preamble might be either 'within' the zip offsets, |
||||
or simply catenated prior to an unadjusted zip. |
||||
Some build processes may have 'adjusted' the zip offsets to make the zip cover the entire file |
||||
('file based' offset) whilst the more modern approach is to simply concatenate the binary and the zip |
||||
('archive based' offset). An archive-based offset is simpler and more reliably points to the proper |
||||
split location. It also allows 'zipfs info //zipfs:/app' to return the correct offset information. |
||||
|
||||
Either way, extract_preamble can usually separate them, but in the unusual case that there is both an |
||||
external preamble and a preamble within the zip, only the external preamble will be split, with the |
||||
internal one remaining in the zip. |
||||
|
||||
The inverse of this process would be to extract the .zip file created by this split to a folder, |
||||
e.g extracted_zip_folder (adjusting contents as required) and then to run: |
||||
zipfs mkimg newbinaryname.exe extracted_zip_folder <prefix> \"\" <extracted_preamble_or_alternative exe> |
||||
" |
||||
@values -min 2 -max 3 |
||||
infile -type file -optional 0 -help\ |
||||
"Name of existing tcl executable or shared lib with attached zipfs filesystem" |
||||
outfile_preamble -optional 0 -type file -help\ |
||||
"Name of output file for binary preamble to be extracted to. |
||||
If this file already exists, an error will be raised" |
||||
outfile_zip -default "" -type file -help\ |
||||
"Name of output file for zip data to be extracted to. |
||||
If this file already exists, an error will be raised" |
||||
} |
||||
proc extract_preamble {args} { |
||||
set argd [punk::args::parse $args withid ::punk::zip::extract_preamble] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
set infile [dict get $values infile] |
||||
set outfile_preamble [dict get $values outfile_preamble] |
||||
set outfile_zip [dict get $values outfile_zip] |
||||
|
||||
set inzip [open $infile r] |
||||
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||
if {[file exists $outfile_preamble]} { |
||||
error "outfile_preamble $outfile_preamble already exists - please remove first" |
||||
} |
||||
if {$outfile_zip ne ""} { |
||||
if {[file exists $outfile_zip] && [file size $outfile_zip]} { |
||||
error "outfile_zip $outfile_zip already exists - please remove first" |
||||
} |
||||
} |
||||
chan seek $inzip 0 end |
||||
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||
chan seek $inzip 0 start |
||||
#only scan last 64k - cover max signature size?? review |
||||
if {$insize < 65559} { |
||||
set tailsearch_start 0 |
||||
} else { |
||||
set tailsearch_start [expr {$insize - 65559}] |
||||
} |
||||
chan seek $inzip $tailsearch_start start |
||||
set scan [read $inzip] |
||||
#EOCD - End Of Central Directory record |
||||
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||
puts stdout "==>start_of_end: $start_of_end" |
||||
|
||||
if {$start_of_end == -1} { |
||||
#no zip eocdr - consider entire file to be the zip preamble |
||||
set baseoffset $insize |
||||
} else { |
||||
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||
chan seek $inzip $filerelative_eocd_posn |
||||
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#rule out a false positive from within a nonzip (e.g plain exe) |
||||
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||
#review - should keep searching? |
||||
#for now we assume not a zip |
||||
set baseoffset $insize |
||||
} else { |
||||
#use the central dir size to jump back tko start of central dir |
||||
#determine if diroffset is file or archive relative |
||||
|
||||
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||
puts stdout "---> [read $inzip 4]" |
||||
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||
#'external preamble' easy case |
||||
# - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||
#though we are assuming zip offsets are not corrupted |
||||
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||
} else { |
||||
#'internal preamble' hard case |
||||
# - either no preamble - or offsets have been adjusted to be file relative. |
||||
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||
|
||||
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||
set baseoffset "unknown" |
||||
chan seek $inzip $filerelative_cdir_start start |
||||
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||
#load the whole central dir into cdir |
||||
|
||||
#todo! loop through all cdr file headers - find highest offset? |
||||
#tclZipfs.c just looks at first file header in Central Directory |
||||
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||
|
||||
set cdirdata [read $inzip $eocd(dirsize)] |
||||
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||
|
||||
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||
chan seek $inzip $cdir(relativeoffset) |
||||
#let's at least check that we landed on a local file header.. |
||||
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||
puts stdout "1st local file header sig: $lfh(signature)" |
||||
if {$lfh(signature) == 67324752} { |
||||
#looks like a local file header |
||||
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||
set baseoffset $cdir(relativeoffset) |
||||
} |
||||
} |
||||
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||
} |
||||
} |
||||
puts stdout "baseoffset: $baseoffset" |
||||
#expect CDFH PK\1\2 |
||||
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||
|
||||
if {![string is integer -strict $baseoffset]} { |
||||
error "unable to determine zip baseoffset of file $infile" |
||||
} |
||||
|
||||
if {$baseoffset < $insize} { |
||||
set pout [open $outfile_preamble w] |
||||
fconfigure $pout -encoding iso8859-1 -translation binary |
||||
chan seek $inzip 0 start |
||||
chan copy $inzip $pout -size $baseoffset |
||||
close $pout |
||||
if {$outfile_zip ne ""} { |
||||
#todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile |
||||
set zout [open $outfile_zip w] |
||||
fconfigure $zout -encoding iso8859-1 -translation binary |
||||
chan copy $inzip $zout |
||||
close $zout |
||||
} |
||||
close $inzip |
||||
} else { |
||||
#no valid (from our perspective) eocdr found - baseoffset has been set to insize |
||||
close $inzip |
||||
file copy $infile $outfile_preamble |
||||
if {$outfile_zip ne ""} { |
||||
#touch equiv? |
||||
set fd [open $outfile_zip w] |
||||
close $fd |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
punk::args::define { |
||||
@id -id ::punk::zip::Addentry |
||||
@cmd -name punk::zip::Addentry\ |
||||
-summary\ |
||||
"Add zip-entry for file at 'path'"\ |
||||
-help\ |
||||
"Add a single file at 'path' to open channel 'zipchan' |
||||
return a central directory file record" |
||||
@opts |
||||
-comment -default "" -help "An optional comment specific to the added file" |
||||
@values -min 3 -max 4 |
||||
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" |
||||
base -help "base path for entries" |
||||
path -type file -help "path of file to add" |
||||
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe |
||||
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" |
||||
} |
||||
|
||||
# Addentry - was Mkzipfile -- |
||||
# |
||||
# FIX ME: should handle the current offset for non-seekable channels |
||||
# |
||||
proc Addentry {args} { |
||||
#*** !doctools |
||||
#[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||
#[para] Add a single file to a zip archive |
||||
#[para] The zipchan channel should already be open and binary. |
||||
#[para] You can provide a -comment for the file. |
||||
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||
|
||||
set argd [punk::args::parse $args withid ::punk::zip::Addentry] |
||||
set zipchan [dict get $argd values zipchan] |
||||
set base [dict get $argd values base] |
||||
set path [dict get $argd values path] |
||||
set zipdataoffset [dict get $argd values zipdataoffset] |
||||
|
||||
set comment [dict get $argd opts -comment] |
||||
|
||||
set fullpath [file join $base $path] |
||||
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||
set utfpath [encoding convertto utf-8 $path] |
||||
set utfcomment [encoding convertto utf-8 $comment] |
||||
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||
set method 0 ;# store 0, deflate 8 |
||||
set attr 0 ;# text or binary (default binary) |
||||
set version 20 ;# minumum version req'd to extract |
||||
set extra "" |
||||
set crc 0 |
||||
set size 0 |
||||
set csize 0 |
||||
set data "" |
||||
set seekable [expr {[tell $zipchan] != -1}] |
||||
if {[file isdirectory $fullpath]} { |
||||
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||
#set attrex 0x40000010 |
||||
} elseif {[file executable $fullpath]} { |
||||
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||
} else { |
||||
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||
set attr 1 ;# text |
||||
} |
||||
} |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
set size [file size $fullpath] |
||||
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||
} |
||||
|
||||
|
||||
set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip |
||||
set local [binary format a4sssiiiiss PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]] |
||||
append local $utfpath $extra |
||||
puts -nonewline $zipchan $local |
||||
|
||||
if {[file isfile $fullpath]} { |
||||
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||
# streaming to avoid requiring excess memory. This helps to prevent |
||||
# storing re-compressed data that may be larger than the source when |
||||
# handling PNG or JPEG or nested ZIP files. |
||||
if {$size < 0x00200000} { |
||||
set fin [open $fullpath rb] |
||||
set data [read $fin] |
||||
set crc [zlib crc32 $data] |
||||
set cdata [zlib deflate $data] |
||||
if {[string length $cdata] < $size} { |
||||
set method 8 |
||||
set data $cdata |
||||
} |
||||
close $fin |
||||
set csize [string length $data] |
||||
puts -nonewline $zipchan $data |
||||
} else { |
||||
set method 8 |
||||
set fin [open $fullpath rb] |
||||
set zlib [zlib stream deflate] |
||||
while {![eof $fin]} { |
||||
set data [read $fin 4096] |
||||
set crc [zlib crc32 $data $crc] |
||||
$zlib put $data |
||||
if {[string length [set zdata [$zlib get]]]} { |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
} |
||||
} |
||||
close $fin |
||||
$zlib finalize |
||||
set zdata [$zlib get] |
||||
incr csize [string length $zdata] |
||||
puts -nonewline $zipchan $zdata |
||||
$zlib close |
||||
} |
||||
|
||||
if {$seekable} { |
||||
# update the header if the output is seekable |
||||
set local [binary format a4sssiiii PK\03\04 \ |
||||
$version $flags $method $mtime $crc $csize $size] |
||||
set current [tell $zipchan] |
||||
seek $zipchan $channeloffset |
||||
puts -nonewline $zipchan $local |
||||
seek $zipchan $current |
||||
} else { |
||||
# Write a data descriptor record |
||||
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||
puts -nonewline $zipchan $ddesc |
||||
} |
||||
} |
||||
|
||||
#PK\x01\x02 Cdentral directory file header |
||||
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||
|
||||
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||
$version $flags $method $mtime $crc $csize $size \ |
||||
[string length $utfpath] [string length $extra]\ |
||||
[string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. |
||||
append hdr $utfpath $extra $utfcomment |
||||
return $hdr |
||||
} |
||||
|
||||
#### REVIEW!!! |
||||
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||
#### |
||||
|
||||
|
||||
punk::args::define { |
||||
@id -id ::punk::zip::mkzip |
||||
@cmd -name punk::zip::mkzip\ |
||||
-summary\ |
||||
"Create a zip archive in 'filename'."\ |
||||
-help\ |
||||
"Create a zip archive in 'filename'" |
||||
@opts |
||||
-offsettype -default "archive" -choices {archive file}\ |
||||
-help\ |
||||
"zip offsets stored relative to start of entire file or relative to start of zip-archive |
||||
Only relevant if the created file has a script/runtime prefix." |
||||
-return -default "pretty" -choices {pretty list none}\ |
||||
-help\ |
||||
"mkzip can return a list of the files and folders added to the archive |
||||
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||
to return a formatted list for the terminal |
||||
" |
||||
-zipkit -default 0 -type none\ |
||||
-help\ |
||||
"whether to add mounting script |
||||
mutually exclusive with -runtime option |
||||
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs" |
||||
-runtime -default ""\ |
||||
-help\ |
||||
"specify a prefix file |
||||
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip |
||||
will create a self-extracting zip archive from the subdir/ folder. |
||||
Expects runtime with no existing vfs attached (review)" |
||||
-comment -default ""\ |
||||
-help "An optional comment for the archive" |
||||
-directory -default ""\ |
||||
-help "Scan for contents within this folder or current directory if not provided." |
||||
-base -default ""\ |
||||
-help\ |
||||
"The new zip archive will be rooted in this directory if provided |
||||
it must be a parent of -directory or the same path as -directory" |
||||
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||
-- -type none -help\ |
||||
"End of options marker" |
||||
|
||||
@values -min 1 -max -1 |
||||
filename -type file -default ""\ |
||||
-help "name of zipfile to create" |
||||
globs -default {*} -multiple 1\ |
||||
-help\ |
||||
"list of glob patterns to match. |
||||
Only directories with matching files will be included in the archive." |
||||
} |
||||
|
||||
# zip::mkzip -- |
||||
# |
||||
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||
# |
||||
proc mkzip {args} { |
||||
#todo - doctools - [arg ?globs...?] syntax? |
||||
|
||||
#*** !doctools |
||||
#[call [fun mkzip]\ |
||||
# [opt "[option -offsettype] [arg offsettype]"]\ |
||||
# [opt "[option -return] [arg returntype]"]\ |
||||
# [opt "[option -zipkit] [arg 0|1]"]\ |
||||
# [opt "[option -runtime] [arg preamble_filename]"]\ |
||||
# [opt "[option -comment] [arg zipfilecomment]"]\ |
||||
# [opt "[option -directory] [arg dir_to_zip]"]\ |
||||
# [opt "[option -base] [arg archive_root]"]\ |
||||
# [opt "[option -exclude] [arg globlist]"]\ |
||||
# [arg zipfilename]\ |
||||
# [arg ?glob...?]] |
||||
#[para] Create a zip archive in 'zipfilename' |
||||
#[para] If a file already exists, an error will be raised. |
||||
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. |
||||
|
||||
set argd [punk::args::parse $args withid ::punk::zip::mkzip] |
||||
set filename [dict get $argd values filename] |
||||
if {$filename eq ""} { |
||||
error "mkzip filename cannot be empty string" |
||||
} |
||||
if {[regexp {[?*]} $filename]} { |
||||
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||
error "mkzip filename should not contain glob characters ? *" |
||||
} |
||||
if {[file exists $filename]} { |
||||
error "mkzip filename:$filename already exists" |
||||
} |
||||
dict for {k v} [dict get $argd opts] { |
||||
switch -- $k { |
||||
-comment { |
||||
dict set argd opts $k [encoding convertto utf-8 $v] |
||||
} |
||||
-directory - -base { |
||||
dict set argd opts $k [file normalize $v] |
||||
} |
||||
} |
||||
} |
||||
|
||||
array set opts [dict get $argd opts] |
||||
|
||||
|
||||
if {$opts(-directory) ne ""} { |
||||
if {$opts(-base) ne ""} { |
||||
#-base and -directory have been normalized already |
||||
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" |
||||
} |
||||
set base $opts(-base) |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||
} else { |
||||
set base $opts(-directory) |
||||
set relpath "" |
||||
} |
||||
#will pick up intermediary folders as paths (ending with trailing slash) |
||||
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||
|
||||
set norm_filename [file normalize $filename] |
||||
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||
#check that we aren't adding the zipfile to itself |
||||
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||
|
||||
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||
set self_globs_match 0 |
||||
foreach g [dict get $argd values globs] { |
||||
if {[string match $g [file tail $filename]]} { |
||||
set self_globs_match 1 |
||||
break |
||||
} |
||||
} |
||||
if {$self_globs_match} { |
||||
#still dangerous |
||||
set self_excluded 0 |
||||
foreach e $opts(-exclude) { |
||||
if {[string match $e [file tail $filename]]} { |
||||
set self_excluded 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$self_excluded} { |
||||
#still dangerous - likely to be in resultset - check each path |
||||
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||
set self_is_matched 0 |
||||
set i 0 |
||||
foreach p $paths { |
||||
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||
set self_is_matched 1 |
||||
break |
||||
} |
||||
incr i |
||||
} |
||||
if {$self_is_matched} { |
||||
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||
set paths [lremove $paths $i] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#NOTE that we don't add intermediate folders when creating an archive without using the -directory flag! |
||||
#ie - only the exact *files* matching the glob are stored. |
||||
set paths [list] |
||||
set dir [pwd] |
||||
if {$opts(-base) ne ""} { |
||||
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||
} |
||||
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||
} else { |
||||
set relpath "" |
||||
} |
||||
set base $opts(-base) |
||||
|
||||
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||
foreach m $matches { |
||||
if {$m eq $filename} { |
||||
#puts stderr "--> excluding $filename" |
||||
continue |
||||
} |
||||
set isok 1 |
||||
foreach e [concat $opts(-exclude) $filename] { |
||||
if {[string match $e $m]} { |
||||
set isok 0 |
||||
break |
||||
} |
||||
} |
||||
if {$isok} { |
||||
lappend paths [file join $relpath $m] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $paths]} { |
||||
return "" |
||||
} |
||||
|
||||
set zf [open $filename wb] |
||||
if {$opts(-runtime) ne ""} { |
||||
#todo - strip any existing vfs - option to merge contents.. only if zip attached? |
||||
set rt [open $opts(-runtime) rb] |
||||
fcopy $rt $zf |
||||
close $rt |
||||
} elseif {$opts(-zipkit)} { |
||||
#TODO - update to zipfs ? |
||||
#see modpod |
||||
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||
append zkd "package require vfs::zip\n" |
||||
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||
append zkd "}\n" |
||||
append zkd \x1A |
||||
puts -nonewline $zf $zkd |
||||
} |
||||
|
||||
#todo - subtract this from the endrec offset |
||||
if {$opts(-offsettype) eq "archive"} { |
||||
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 |
||||
} else { |
||||
set dataStartOffset 0 ;#offsets relative to file - the (old) zipfs mkzip way :/ |
||||
} |
||||
|
||||
set count 0 |
||||
set cd "" |
||||
|
||||
set members [list] |
||||
foreach path $paths { |
||||
#puts $path |
||||
lappend members $path |
||||
append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath |
||||
incr count |
||||
} |
||||
set cdoffset [tell $zf] |
||||
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||
$count $count [string length $cd] [expr {$cdoffset - $dataStartOffset}]\ |
||||
[string length $opts(-comment)]] |
||||
append endrec $opts(-comment) |
||||
puts -nonewline $zf $cd |
||||
puts -nonewline $zf $endrec |
||||
close $zf |
||||
|
||||
set result "" |
||||
switch -exact -- $opts(-return) { |
||||
list { |
||||
set result $members |
||||
} |
||||
pretty { |
||||
if {[info commands showlist] ne ""} { |
||||
set result [plist -channel none members] |
||||
} else { |
||||
set result $members |
||||
} |
||||
} |
||||
none { |
||||
set result "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::zip::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::zip::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::zip::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||
variable pkg punk::zip |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,239 +0,0 @@
|
||||
#utilities for punk apps to call |
||||
|
||||
package provide punkapp [namespace eval punkapp { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval punkapp { |
||||
variable result |
||||
variable waiting "no" |
||||
proc hide_dot_window {} { |
||||
#alternative to wm withdraw . |
||||
#see https://wiki.tcl-lang.org/page/wm+withdraw |
||||
wm geometry . 1x1+0+0 |
||||
wm overrideredirect . 1 |
||||
wm transient . |
||||
} |
||||
proc is_toplevel {w} { |
||||
if {![llength [info commands winfo]]} { |
||||
return 0 |
||||
} |
||||
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]} |
||||
} |
||||
proc get_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list {} |
||||
if {[is_toplevel $w]} { |
||||
lappend list $w |
||||
} |
||||
foreach w [winfo children $w] { |
||||
lappend list {*}[get_toplevels $w] |
||||
} |
||||
return $list |
||||
} |
||||
|
||||
proc make_toplevel_next {prefix} { |
||||
set top [get_toplevel_next $prefix] |
||||
return [toplevel $top] |
||||
} |
||||
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
||||
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
||||
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
||||
proc get_toplevel_next {prefix} { |
||||
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
||||
|
||||
|
||||
|
||||
} |
||||
proc exit {{toplevel ""}} { |
||||
variable waiting |
||||
variable result |
||||
variable default_result |
||||
set toplevels [get_toplevels] |
||||
if {[string length $toplevel]} { |
||||
set wposn [lsearch $toplevels $toplevel] |
||||
if {$wposn > 0} { |
||||
destroy $toplevel |
||||
} |
||||
} else { |
||||
#review |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "punkapp::exit called without toplevel - showing console" |
||||
show_console |
||||
return 0 |
||||
} else { |
||||
puts stderr "punkapp::exit called without toplevel - exiting" |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
|
||||
set controllable [get_user_controllable_toplevels] |
||||
if {![llength $controllable]} { |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
show_console |
||||
} else { |
||||
if {$waiting ne "no"} { |
||||
if {[info exists result(shell)]} { |
||||
set temp [set result(shell)] |
||||
unset result(shell) |
||||
set waiting $temp |
||||
} elseif {[info exists result($toplevel)]} { |
||||
set temp [set result($toplevel)] |
||||
unset result($toplevel) |
||||
set waiting $temp |
||||
} elseif {[info exists default_result]} { |
||||
set temp $default_result |
||||
unset default_result |
||||
set waiting $temp |
||||
} else { |
||||
set waiting "" |
||||
} |
||||
} else { |
||||
::exit |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc close_window {toplevel} { |
||||
wm withdraw $toplevel |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
punkapp::exit $toplevel |
||||
} |
||||
destroy $toplevel |
||||
} |
||||
proc wait {args} { |
||||
variable waiting |
||||
variable default_result |
||||
if {[dict exists $args -defaultresult]} { |
||||
set default_result [dict get $args -defaultresult] |
||||
} |
||||
foreach t [punkapp::get_toplevels] { |
||||
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
||||
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
||||
} |
||||
} |
||||
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
||||
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
||||
} else { |
||||
if {$waiting eq "no"} { |
||||
set waiting "waiting" |
||||
vwait ::punkapp::waiting |
||||
return $::punkapp::waiting |
||||
} |
||||
} |
||||
} |
||||
|
||||
#A window can be 'visible' according to this - but underneath other windows etc |
||||
#REVIEW - change name? |
||||
proc get_visible_toplevels {{w .}} { |
||||
if {![llength [info commands winfo]]} { |
||||
return [list] |
||||
} |
||||
set list [get_toplevels $w] |
||||
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}] |
||||
set mapped [concat {*}$mapped] ;#ignore {} |
||||
set visible [list] |
||||
foreach m $mapped { |
||||
if {[wm overrideredirect $m] == 0 } { |
||||
lappend visible $m |
||||
} else { |
||||
if {[winfo height $m] >1 && [winfo width $m] > 1} { |
||||
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1 |
||||
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible |
||||
lappend visible $m |
||||
} |
||||
} |
||||
} |
||||
return $visible |
||||
} |
||||
proc get_user_controllable_toplevels {{w .}} { |
||||
set visible [get_visible_toplevels $w] |
||||
set controllable [list] |
||||
foreach v $visible { |
||||
if {[wm overrideredirect $v] == 0} { |
||||
lappend controllable $v |
||||
} |
||||
} |
||||
#only return visible windows with overrideredirect == 0 because there exists some user control. |
||||
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily |
||||
return $controllable |
||||
} |
||||
proc hide_console {args} { |
||||
set opts [dict create -force 0] |
||||
if {([llength $args] % 2) != 0} { |
||||
error "hide_console expects pairs of arguments. e.g -force 1" |
||||
} |
||||
#set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
switch -- $k { |
||||
-force { |
||||
dict set opts $k $v |
||||
} |
||||
default { |
||||
error "Unrecognised options '$k' known options: [dict keys $opts]" |
||||
} |
||||
} |
||||
} |
||||
set force [dict get $opts -force] |
||||
|
||||
if {!$force} { |
||||
if {![llength [get_user_controllable_toplevels]]} { |
||||
puts stderr "Cannot hide console while no user-controllable windows available" |
||||
return 0 |
||||
} |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
||||
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
||||
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
||||
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
||||
package require twapi |
||||
set h [twapi::get_console_window] |
||||
set pid [twapi::get_window_process $h] |
||||
set pinfo [twapi::get_process_info $pid -name] |
||||
set pname [dict get $pinfo -name] |
||||
set wstyle [twapi::get_window_style $h] |
||||
#tclkitsh/tclsh? |
||||
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
||||
twapi::hide_window $h |
||||
return 1 |
||||
} else { |
||||
puts stderr "punkapp::hide_console unable to hide this type of console window" |
||||
return 0 |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::hide_console unimplemented on this platform (todo)" |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
proc show_console {} { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
package require twapi |
||||
if {![catch {set h [twapi::get_console_window]} errM]} { |
||||
twapi::show_window $h -activate -normal |
||||
} else { |
||||
#no console - assume launched from something like wish? |
||||
catch {console show} |
||||
} |
||||
} else { |
||||
#todo |
||||
puts stderr "punkapp::show_console unimplemented on this platform" |
||||
} |
||||
} |
||||
|
||||
} |
||||
File diff suppressed because it is too large
Load Diff
@ -1,814 +0,0 @@
|
||||
# sha1.tcl - |
||||
# |
||||
# Copyright (C) 2001 Don Libes <libes@nist.gov> |
||||
# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm" |
||||
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" |
||||
# |
||||
# This is an implementation of SHA1 based upon the example code given in |
||||
# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas |
||||
# and methods from the earlier tcllib sha1 version by Don Libes. |
||||
# |
||||
# This implementation permits incremental updating of the hash and |
||||
# provides support for external compiled implementations either using |
||||
# critcl (sha1c) or Trf. |
||||
# |
||||
# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
# @mdgen EXCLUDE: sha1c.tcl |
||||
|
||||
package require Tcl 8.2-; # tcl minimum version |
||||
|
||||
namespace eval ::sha1 { |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0 cryptkit 0 trf 0} |
||||
|
||||
variable loaded {} |
||||
variable active |
||||
array set active {tcl 0 critcl 0 cryptkit 0 trf 0} |
||||
|
||||
namespace export sha1 hmac SHA1Init SHA1Update SHA1Final |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 0 |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Management of sha1 implementations. |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::sha1::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
tcl { |
||||
# Already present (this file) |
||||
set r 1 |
||||
} |
||||
critcl { |
||||
if {![catch {package require tcllibc}] |
||||
|| ![catch {package require sha1c}]} { |
||||
set r [expr {[info commands ::sha1::sha1c] != {}}] |
||||
} |
||||
} |
||||
cryptkit { |
||||
if {![catch {package require cryptkit}]} { |
||||
set r [expr {![catch {cryptkit::cryptInit}]}] |
||||
} |
||||
} |
||||
trf { |
||||
if {![catch {package require Trf}]} { |
||||
set r [expr {![catch {::sha1 aa} msg]}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::sha1::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::sha1::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::sha1::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::sha1::KnownImplementations {} { |
||||
return {critcl cryptkit trf tcl} |
||||
} |
||||
|
||||
proc ::sha1::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
cryptkit {cryptkit based} |
||||
trf {Trf based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ::sha1::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::sha1::SwitchTo {key} { |
||||
variable accel |
||||
variable active |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
set active($loaded) 0 |
||||
} |
||||
if {![string equal $key ""]} { |
||||
set active($key) 1 |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# SHA1Init -- |
||||
# |
||||
# Create and initialize an SHA1 state variable. This will be |
||||
# cleaned up when we call SHA1Final |
||||
# |
||||
|
||||
proc ::sha1::SHA1Init {} { |
||||
variable active |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
|
||||
# FIPS 180-1: 7 - Initialize the hash state |
||||
array set state \ |
||||
[list \ |
||||
A [expr {int(0x67452301)}] \ |
||||
B [expr {int(0xEFCDAB89)}] \ |
||||
C [expr {int(0x98BADCFE)}] \ |
||||
D [expr {int(0x10325476)}] \ |
||||
E [expr {int(0xC3D2E1F0)}] \ |
||||
n 0 i "" ] |
||||
if {$active(cryptkit)} { |
||||
cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA |
||||
} elseif {$active(trf)} { |
||||
set s {} |
||||
switch -exact -- $::tcl_platform(platform) { |
||||
windows { set s [open NUL w] } |
||||
unix { set s [open /dev/null w] } |
||||
} |
||||
if {$s != {}} { |
||||
fconfigure $s -translation binary -buffering none |
||||
::sha1 -attach $s -mode write \ |
||||
-read-type variable \ |
||||
-read-destination [subst $token](trfread) \ |
||||
-write-type variable \ |
||||
-write-destination [subst $token](trfwrite) |
||||
array set state [list trfread 0 trfwrite 0 trf $s] |
||||
} |
||||
} |
||||
return $token |
||||
} |
||||
|
||||
# SHA1Update -- |
||||
# |
||||
# This is called to add more data into the hash. You may call this |
||||
# as many times as you require. Note that passing in "ABC" is equivalent |
||||
# to passing these letters in as separate calls -- hence this proc |
||||
# permits hashing of chunked data |
||||
# |
||||
# If we have a C-based implementation available, then we will use |
||||
# it here in preference to the pure-Tcl implementation. |
||||
# |
||||
proc ::sha1::SHA1Update {token data} { |
||||
variable active |
||||
upvar #0 $token state |
||||
|
||||
if {$active(critcl)} { |
||||
if {[info exists state(sha1c)]} { |
||||
set state(sha1c) [sha1c $data $state(sha1c)] |
||||
} else { |
||||
set state(sha1c) [sha1c $data] |
||||
} |
||||
return |
||||
} elseif {[info exists state(ckctx)]} { |
||||
if {[string length $data] > 0} { |
||||
cryptkit::cryptEncrypt $state(ckctx) $data |
||||
} |
||||
return |
||||
} elseif {[info exists state(trf)]} { |
||||
puts -nonewline $state(trf) $data |
||||
return |
||||
} |
||||
|
||||
# Update the state values |
||||
incr state(n) [string length $data] |
||||
append state(i) $data |
||||
|
||||
# Calculate the hash for any complete blocks |
||||
set len [string length $state(i)] |
||||
for {set n 0} {($n + 64) <= $len} {} { |
||||
SHA1Transform $token [string range $state(i) $n [incr n 64]] |
||||
} |
||||
|
||||
# Adjust the state for the blocks completed. |
||||
set state(i) [string range $state(i) $n end] |
||||
return |
||||
} |
||||
|
||||
# SHA1Final -- |
||||
# |
||||
# This procedure is used to close the current hash and returns the |
||||
# hash data. Once this procedure has been called the hash context |
||||
# is freed and cannot be used again. |
||||
# |
||||
# Note that the output is 160 bits represented as binary data. |
||||
# |
||||
proc ::sha1::SHA1Final {token} { |
||||
upvar #0 $token state |
||||
|
||||
# Check for either of the C-compiled versions. |
||||
if {[info exists state(sha1c)]} { |
||||
set r $state(sha1c) |
||||
unset state |
||||
return $r |
||||
} elseif {[info exists state(ckctx)]} { |
||||
cryptkit::cryptEncrypt $state(ckctx) "" |
||||
cryptkit::cryptGetAttributeString $state(ckctx) \ |
||||
CRYPT_CTXINFO_HASHVALUE r 20 |
||||
cryptkit::cryptDestroyContext $state(ckctx) |
||||
# If nothing was hashed, we get no r variable set! |
||||
if {[info exists r]} { |
||||
unset state |
||||
return $r |
||||
} |
||||
} elseif {[info exists state(trf)]} { |
||||
close $state(trf) |
||||
set r $state(trfwrite) |
||||
unset state |
||||
return $r |
||||
} |
||||
|
||||
# Padding |
||||
# |
||||
set len [string length $state(i)] |
||||
set pad [expr {56 - ($len % 64)}] |
||||
if {$len % 64 > 56} { |
||||
incr pad 64 |
||||
} |
||||
if {$pad == 0} { |
||||
incr pad 64 |
||||
} |
||||
append state(i) [binary format a$pad \x80] |
||||
|
||||
# Append length in bits as big-endian wide int. |
||||
set dlen [expr {8 * $state(n)}] |
||||
append state(i) [binary format II 0 $dlen] |
||||
|
||||
# Calculate the hash for the remaining block. |
||||
set len [string length $state(i)] |
||||
for {set n 0} {($n + 64) <= $len} {} { |
||||
SHA1Transform $token [string range $state(i) $n [incr n 64]] |
||||
} |
||||
|
||||
# Output |
||||
set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)] |
||||
unset state |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# HMAC Hashed Message Authentication (RFC 2104) |
||||
# |
||||
# hmac = H(K xor opad, H(K xor ipad, text)) |
||||
# |
||||
|
||||
# HMACInit -- |
||||
# |
||||
# This is equivalent to the SHA1Init procedure except that a key is |
||||
# added into the algorithm |
||||
# |
||||
proc ::sha1::HMACInit {K} { |
||||
|
||||
# Key K is adjusted to be 64 bytes long. If K is larger, then use |
||||
# the SHA1 digest of K and pad this instead. |
||||
set len [string length $K] |
||||
if {$len > 64} { |
||||
set tok [SHA1Init] |
||||
SHA1Update $tok $K |
||||
set K [SHA1Final $tok] |
||||
set len [string length $K] |
||||
} |
||||
set pad [expr {64 - $len}] |
||||
append K [string repeat \0 $pad] |
||||
|
||||
# Cacluate the padding buffers. |
||||
set Ki {} |
||||
set Ko {} |
||||
binary scan $K i16 Ks |
||||
foreach k $Ks { |
||||
append Ki [binary format i [expr {$k ^ 0x36363636}]] |
||||
append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] |
||||
} |
||||
|
||||
set tok [SHA1Init] |
||||
SHA1Update $tok $Ki; # initialize with the inner pad |
||||
|
||||
# preserve the Ko value for the final stage. |
||||
# FRINK: nocheck |
||||
set [subst $tok](Ko) $Ko |
||||
|
||||
return $tok |
||||
} |
||||
|
||||
# HMACUpdate -- |
||||
# |
||||
# Identical to calling SHA1Update |
||||
# |
||||
proc ::sha1::HMACUpdate {token data} { |
||||
SHA1Update $token $data |
||||
return |
||||
} |
||||
|
||||
# HMACFinal -- |
||||
# |
||||
# This is equivalent to the SHA1Final procedure. The hash context is |
||||
# closed and the binary representation of the hash result is returned. |
||||
# |
||||
proc ::sha1::HMACFinal {token} { |
||||
upvar #0 $token state |
||||
|
||||
set tok [SHA1Init]; # init the outer hashing function |
||||
SHA1Update $tok $state(Ko); # prepare with the outer pad. |
||||
SHA1Update $tok [SHA1Final $token]; # hash the inner result |
||||
return [SHA1Final $tok] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Description: |
||||
# This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but |
||||
# includes an extra round and a set of constant modifiers throughout. |
||||
# |
||||
set ::sha1::SHA1Transform_body { |
||||
upvar #0 $token state |
||||
|
||||
# FIPS 180-1: 7a: Process Message in 16-Word Blocks |
||||
binary scan $msg I* blocks |
||||
set blockLen [llength $blocks] |
||||
for {set i 0} {$i < $blockLen} {incr i 16} { |
||||
set W [lrange $blocks $i [expr {$i+15}]] |
||||
|
||||
# FIPS 180-1: 7b: Expand the input into 80 words |
||||
# For t = 16 to 79 |
||||
# let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1 |
||||
set t3 12 |
||||
set t8 7 |
||||
set t14 1 |
||||
set t16 -1 |
||||
for {set t 16} {$t < 80} {incr t} { |
||||
set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ |
||||
[lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] |
||||
lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}] |
||||
} |
||||
|
||||
# FIPS 180-1: 7c: Copy hash state. |
||||
set A $state(A) |
||||
set B $state(B) |
||||
set C $state(C) |
||||
set D $state(D) |
||||
set E $state(E) |
||||
|
||||
# FIPS 180-1: 7d: Do permutation rounds |
||||
# For t = 0 to 79 do |
||||
# TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt; |
||||
# E = D; D = C; C = S30(B); B = A; A = TEMP; |
||||
|
||||
# Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19) |
||||
for {set t 0} {$t < 20} {incr t} { |
||||
set TEMP [F1 $A $B $C $D $E [lindex $W $t]] |
||||
set E $D |
||||
set D $C |
||||
set C [rotl32 $B 30] |
||||
set B $A |
||||
set A $TEMP |
||||
} |
||||
|
||||
# Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) |
||||
for {} {$t < 40} {incr t} { |
||||
set TEMP [F2 $A $B $C $D $E [lindex $W $t]] |
||||
set E $D |
||||
set D $C |
||||
set C [rotl32 $B 30] |
||||
set B $A |
||||
set A $TEMP |
||||
} |
||||
|
||||
# Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) |
||||
for {} {$t < 60} {incr t} { |
||||
set TEMP [F3 $A $B $C $D $E [lindex $W $t]] |
||||
set E $D |
||||
set D $C |
||||
set C [rotl32 $B 30] |
||||
set B $A |
||||
set A $TEMP |
||||
} |
||||
|
||||
# Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) |
||||
for {} {$t < 80} {incr t} { |
||||
set TEMP [F4 $A $B $C $D $E [lindex $W $t]] |
||||
set E $D |
||||
set D $C |
||||
set C [rotl32 $B 30] |
||||
set B $A |
||||
set A $TEMP |
||||
} |
||||
|
||||
# Then perform the following additions. (That is, increment each |
||||
# of the four registers by the value it had before this block |
||||
# was started.) |
||||
incr state(A) $A |
||||
incr state(B) $B |
||||
incr state(C) $C |
||||
incr state(D) $D |
||||
incr state(E) $E |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
proc ::sha1::F1 {A B C D E W} { |
||||
expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
||||
+ ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} |
||||
} |
||||
|
||||
proc ::sha1::F2 {A B C D E W} { |
||||
expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
||||
+ ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} |
||||
} |
||||
|
||||
proc ::sha1::F3 {A B C D E W} { |
||||
expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
||||
+ (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} |
||||
} |
||||
|
||||
proc ::sha1::F4 {A B C D E W} { |
||||
expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
||||
+ ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} |
||||
} |
||||
|
||||
proc ::sha1::rotl32 {v n} { |
||||
return [expr {((($v << $n) \ |
||||
| (($v >> (32 - $n)) \ |
||||
& (0x7FFFFFFF >> (31 - $n))))) \ |
||||
& 0xFFFFFFFF}] |
||||
} |
||||
|
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# |
||||
# In order to get this code to go as fast as possible while leaving |
||||
# the main code readable we can substitute the above function bodies |
||||
# into the transform procedure. This inlines the code for us an avoids |
||||
# a procedure call overhead within the loops. |
||||
# |
||||
# We can do some minor tweaking to improve speed on Tcl < 8.5 where we |
||||
# know our arithmetic is limited to 64 bits. On > 8.5 we may have |
||||
# unconstrained integer arithmetic and must avoid letting it run away. |
||||
# |
||||
|
||||
regsub -all -line \ |
||||
{\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body \ |
||||
{[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
|
||||
regsub -all -line \ |
||||
{\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp \ |
||||
{[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
|
||||
regsub -all -line \ |
||||
{\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp \ |
||||
{[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
|
||||
regsub -all -line \ |
||||
{\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp \ |
||||
{[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
|
||||
regsub -all -line \ |
||||
{rotl32\(\$A,5\)} \ |
||||
$::sha1::SHA1Transform_body_tmp \ |
||||
{((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
|
||||
regsub -all -line \ |
||||
{\[rotl32 \$B 30\]} \ |
||||
$::sha1::SHA1Transform_body_tmp \ |
||||
{[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \ |
||||
::sha1::SHA1Transform_body_tmp |
||||
# |
||||
# Version 2 avoids a few truncations to 32 bits in non-essential places. |
||||
# |
||||
regsub -all -line \ |
||||
{\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body \ |
||||
{[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
regsub -all -line \ |
||||
{\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp2 \ |
||||
{[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
regsub -all -line \ |
||||
{\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp2 \ |
||||
{[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
regsub -all -line \ |
||||
{\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||
$::sha1::SHA1Transform_body_tmp2 \ |
||||
{[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
regsub -all -line \ |
||||
{rotl32\(\$A,5\)} \ |
||||
$::sha1::SHA1Transform_body_tmp2 \ |
||||
{(($A << 5) | (($A >> 27) \& 0x1f))} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
regsub -all -line \ |
||||
{\[rotl32 \$B 30\]} \ |
||||
$::sha1::SHA1Transform_body_tmp2 \ |
||||
{[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \ |
||||
::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
if {[package vsatisfies [package provide Tcl] 8.5]} { |
||||
proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp |
||||
} else { |
||||
proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2 |
||||
} |
||||
|
||||
unset ::sha1::SHA1Transform_body |
||||
unset ::sha1::SHA1Transform_body_tmp |
||||
unset ::sha1::SHA1Transform_body_tmp2 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} |
||||
proc ::sha1::bytes {v} { |
||||
#format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] |
||||
format %c%c%c%c \ |
||||
[expr {((0xFF000000 & $v) >> 24) & 0xFF}] \ |
||||
[expr {(0xFF0000 & $v) >> 16}] \ |
||||
[expr {(0xFF00 & $v) >> 8}] \ |
||||
[expr {0xFF & $v}] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::sha1::Hex {data} { |
||||
binary scan $data H* result |
||||
return $result |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Description: |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::sha1::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# fileevent handler for chunked file hashing. |
||||
# |
||||
proc ::sha1::Chunk {token channel {chunksize 4096}} { |
||||
upvar #0 $token state |
||||
|
||||
SHA1Update $token [read $channel $chunksize] |
||||
|
||||
if {[eof $channel]} { |
||||
fileevent $channel readable {} |
||||
set state(reading) 0 |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::sha1::sha1 {args} { |
||||
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||
if {[llength $args] == 1} { |
||||
set opts(-hex) 1 |
||||
} else { |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-hex { set opts(-hex) 1 } |
||||
-bin { set opts(-hex) 0 } |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-channel { set opts(-channel) [Pop args 1] } |
||||
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args; break } |
||||
set err [join [lsort [concat -bin [array names opts]]] ", "] |
||||
return -code error "bad option $option:\ |
||||
must be one of $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args:\ |
||||
should be \"sha1 ?-hex? -filename file | string\"" |
||||
} |
||||
set tok [SHA1Init] |
||||
SHA1Update $tok [lindex $args 0] |
||||
set r [SHA1Final $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [SHA1Init] |
||||
# FRINK: nocheck |
||||
set [subst $tok](reading) 1 |
||||
fileevent $opts(-channel) readable \ |
||||
[list [namespace origin Chunk] \ |
||||
$tok $opts(-channel) $opts(-chunksize)] |
||||
# FRINK: nocheck |
||||
vwait [subst $tok](reading) |
||||
set r [SHA1Final $tok] |
||||
|
||||
# If we opened the channel - we should close it too. |
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
if {$opts(-hex)} { |
||||
set r [Hex $r] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::sha1::hmac {args} { |
||||
array set opts {-hex 1 -filename {} -channel {} -chunksize 4096} |
||||
if {[llength $args] != 2} { |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-key { set opts(-key) [Pop args 1] } |
||||
-hex { set opts(-hex) 1 } |
||||
-bin { set opts(-hex) 0 } |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-channel { set opts(-channel) [Pop args 1] } |
||||
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args; break } |
||||
set err [join [lsort [array names opts]] ", "] |
||||
return -code error "bad option $option:\ |
||||
must be one of $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
} |
||||
|
||||
if {[llength $args] == 2} { |
||||
set opts(-key) [Pop args] |
||||
} |
||||
|
||||
if {![info exists opts(-key)]} { |
||||
return -code error "wrong # args:\ |
||||
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args:\ |
||||
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||
} |
||||
set tok [HMACInit $opts(-key)] |
||||
HMACUpdate $tok [lindex $args 0] |
||||
set r [HMACFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [HMACInit $opts(-key)] |
||||
# FRINK: nocheck |
||||
set [subst $tok](reading) 1 |
||||
fileevent $opts(-channel) readable \ |
||||
[list [namespace origin Chunk] \ |
||||
$tok $opts(-channel) $opts(-chunksize)] |
||||
# FRINK: nocheck |
||||
vwait [subst $tok](reading) |
||||
set r [HMACFinal $tok] |
||||
|
||||
# If we opened the channel - we should close it too. |
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
if {$opts(-hex)} { |
||||
set r [Hex $r] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::sha1 { |
||||
variable e {} |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide sha1 2.0.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local Variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,893 +0,0 @@
|
||||
# vim: set ft=tcl |
||||
# |
||||
#purpose: handle the run commands that call shellfilter::run |
||||
#e.g run,runout,runerr,runx |
||||
|
||||
package require shellfilter |
||||
package require punk::ansi |
||||
|
||||
#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run. |
||||
# - If it did run, but there was a non-zero exitcode it is up to the application to check that. |
||||
#This is deliberate, but means 'catch' doesn't catch errors within the command itself - the exitcode has to be checked. |
||||
#The user can always use exec for different process error semantics (they don't get exitcode with exec) |
||||
|
||||
namespace eval shellrun { |
||||
variable PUNKARGS |
||||
variable runout |
||||
variable runerr |
||||
|
||||
#do we need these? |
||||
#variable punkout |
||||
#variable punkerr |
||||
|
||||
#some ugly coupling with punk/punk::config for now |
||||
#todo - something better |
||||
if {[info exists ::punk::config::configdata]} { |
||||
set conf_running [punk::config::configure running] |
||||
set syslog_stdout [dict get $conf_running syslog_stdout] |
||||
set syslog_stderr [dict get $conf_running syslog_stderr] |
||||
set logfile_stdout [dict get $conf_running logfile_stdout] |
||||
set logfile_stderr [dict get $conf_running logfile_stderr] |
||||
} else { |
||||
lassign [list "" "" "" ""] syslog_stdout syslog_stderr logfile_stdout logfile_stderr |
||||
} |
||||
if {"punkshout" ni [shellfilter::stack::items]} { |
||||
set outdevice [shellfilter::stack::new punkshout -settings [list -tag "punkshout" -buffering none -raw 1 -syslog $syslog_stdout -file $logfile_stdout]] |
||||
set out [dict get $outdevice localchan] |
||||
} else { |
||||
set out [dict get [shellfilter::stack::item punkshout] device localchan] |
||||
} |
||||
if {"punksherr" ni [shellfilter::stack::items]} { |
||||
set errdevice [shellfilter::stack::new punksherr -settings [list -tag "punksherr" -buffering none -raw 1 -syslog $syslog_stderr -file $logfile_stderr]] |
||||
set err [dict get $errdevice localchan] |
||||
} else { |
||||
set err [dict get [shellfilter::stack::item punksherr] device localchan] |
||||
} |
||||
|
||||
namespace import ::punk::ansi::a+ |
||||
namespace import ::punk::ansi::a |
||||
|
||||
|
||||
|
||||
|
||||
#repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen |
||||
#todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. |
||||
#somewhat strong coupling to punk - but let's try to behave decently if it's not loaded |
||||
#The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. |
||||
proc set_last_run_display {chunklist} { |
||||
#chunklist as understood by the |
||||
if {![info exists ::punk::repltelemetry_emmitters]} { |
||||
namespace eval ::punk { |
||||
variable repltelemetry_emmitters |
||||
set repltelemetry_emmitters "shellrun" |
||||
} |
||||
} else { |
||||
if {"shellrun" ni $::punk::repltelemetry_emmitters} { |
||||
lappend punk::repltelemetry_emmitters "shellrun" |
||||
} |
||||
} |
||||
|
||||
#most basic of validity tests here.. just that it is a list (can be empty). We don't want to duplicate or over-constrain the way repls/shells/terminals interpet the info |
||||
if {[catch {llength $chunklist} errMsg]} { |
||||
error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" |
||||
} |
||||
#todo - |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
} |
||||
|
||||
|
||||
|
||||
#maintenance: similar used in punk::ns & punk::winrun |
||||
#todo - take runopts + aliases as args |
||||
#longopts must be passed as a single item ie --timeout=100 not --timeout 100 |
||||
proc get_run_opts {arglist} { |
||||
if {[catch { |
||||
set callerinfo [info level -1] |
||||
} errM]} { |
||||
set caller "" |
||||
} else { |
||||
set caller [lindex $callerinfo 0] |
||||
} |
||||
|
||||
#we provide -nonewline even for 'run' even though run doesn't deliver stderr or stdout to the tcl return value |
||||
#This is for compatibility with other runX commands, and the difference is also visible when calling from repl. |
||||
set known_runopts [list "-echo" "-e" "-nonewline" "-n" "-tcl" "-debug"] |
||||
set known_longopts [list "--timeout"] |
||||
set known_longopts_msg "" |
||||
foreach lng $known_longopts { |
||||
append known_longopts_msg "${lng}=val " |
||||
} |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-n" "-nonewline" "-nonewline" "-nonewline" "-tcl" "-tcl" "-debug" "-debug"] ;#include map to self |
||||
set runopts [list] |
||||
set runoptslong [list] |
||||
set cmdargs [list] |
||||
|
||||
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
||||
|
||||
set allopts [lrange $arglist 0 $idx_first_cmdarg-1] |
||||
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
||||
foreach o $allopts { |
||||
if {[string match --* $o]} { |
||||
lassign [split $o =] flagpart valpart |
||||
if {$valpart eq ""} { |
||||
error "$caller: longopt $o seems to be missing a value - must be of form --option=value" |
||||
} |
||||
if {$flagpart ni $known_longopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runoptslong $flagpart $valpart |
||||
} else { |
||||
if {$o ni $known_runopts} { |
||||
error "$caller: Unknown runoption $o - known options $known_runopts $known_longopts_msg" |
||||
} |
||||
lappend runopts [dict get $aliases $o] |
||||
} |
||||
} |
||||
return [list runopts $runopts runoptslong $runoptslong cmdargs $cmdargs] |
||||
} |
||||
|
||||
|
||||
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected. |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::run |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc run {args} { |
||||
#set_last_run_display [list] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set runoptslong [dict get $splitargs runoptslong] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
set argd [punk::args::parse $args withid ::shellrun::run] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
#review nonewline does nothing here.. |
||||
|
||||
set idlist_stderr [list] |
||||
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. |
||||
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. |
||||
#A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, |
||||
#but having an option to configure stderr to red is a compromise. |
||||
#Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. |
||||
#TODO - fix. This has no effect if/when the repl adds an ansiwrap transform |
||||
# what we probably want to do is 'aside' that transform for runxxx commands only. |
||||
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
#--------------------------------------------------------------------------------------------- |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
#--------------------------------------------------------------------------------------------- |
||||
|
||||
foreach id $idlist_stderr { |
||||
shellfilter::stack::remove stderr $id |
||||
} |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
error "[dict get $exitinfo error]\n$exitinfo" |
||||
} |
||||
|
||||
return $exitinfo |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runconsole |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
#run in the way tcl unknown does - but without regard to auto_noexec |
||||
proc runconsole {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runconsole] |
||||
lassign [dict values $argd] leaders opts values received |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set arglist [dict get $values cmdarg] |
||||
} else { |
||||
set arglist {} |
||||
} |
||||
|
||||
set resolved_cmdname [auto_execok $cmdname] |
||||
if {$resolved_cmdname eq ""} { |
||||
error "Cannot find path for executable '$cmdname'" |
||||
} |
||||
set repl_runid [punk::get_repl_runid] |
||||
#set ::punk::last_run_display [list] |
||||
|
||||
set redir ">&@stdout <@stdin" |
||||
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions] |
||||
#we can't detect stdout/stderr output from the exec |
||||
#for now emit an extra \n on stderr |
||||
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console |
||||
#This is probably a tricky problem - especially to do cross-platform |
||||
# |
||||
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit |
||||
if {[dict get $::tcl::UnknownOptions -code] == 0} { |
||||
set c green |
||||
set m "ok" |
||||
} else { |
||||
set c yellow |
||||
set m "errorCode $::errorCode" |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" "[a $c]$m[a] " ] |
||||
if {$repl_runid != 0} { |
||||
tsv::lappend repl runchunks-$repl_runid {*}$chunklist |
||||
} |
||||
|
||||
dict incr ::tcl::UnknownOptions -level |
||||
return -options $::tcl::UnknownOptions $::tcl::UnknownResult |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runout |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runout {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runout] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
set RST [a] |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
|
||||
#puts stdout "RUNOUT cmdargs: $cmdargs" |
||||
|
||||
#todo add -data boolean and -data lastwrite to -settings with default being -data all |
||||
# because sometimes we're only interested in last char (e.g to detect something was output) |
||||
|
||||
#set outvar_stackid [shellfilter::stack::add commandout tee_to_var -action float -settings {-varname ::runout}] |
||||
# |
||||
#when not echoing - use float-locked so that the repl's stack is bypassed |
||||
if {[dict exists $received "-echo"]} { |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
} else { |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
} |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
#shellfilter::run [lrange $args 1 end] -teehandle punksh -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] |
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
#shellfilter::stack::remove commandout $outvar_stackid |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#we must raise an error. |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
# |
||||
set msg "" |
||||
append msg [dict get $exitinfo error] |
||||
append msg "\n(add -tcl option to run as a tcl command/script instead of an external command)" |
||||
error $msg |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
#exitcode not part of return value for runout - colourcode appropriately |
||||
set n $RST |
||||
set c "" |
||||
|
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
#lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "stderr" [dict get $exitinfo errorInfo]] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c \x1b\[m "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
set chunk "[a+ red bold]stderr$RST" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
#append chunk "[a+ red normal]$e$RST\n" |
||||
append chunk "[a+ red normal]$e$RST" |
||||
} |
||||
lappend chunklist [list stderr $chunk] |
||||
|
||||
|
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout$RST"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "$o" |
||||
} |
||||
lappend chunklist [list result $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
return $::shellrun::runout |
||||
} |
||||
} |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id ::shellrun::runerr |
||||
@leaders -min 0 -max 0 |
||||
@opts |
||||
-echo -type none |
||||
-nonewline -type none |
||||
-tcl -type none -default 0 |
||||
-debug -type none -default 0 |
||||
--timeout= -type integer |
||||
@values -min 1 -max -1 |
||||
cmdname -type string |
||||
cmdarg -type any -multiple 1 -optional 1 |
||||
}] |
||||
proc runerr {args} { |
||||
set argd [punk::args::parse $args withid ::shellrun::runerr] |
||||
lassign [dict values $argd] leaders opts values received |
||||
|
||||
if {[dict exists $received "-nonewline"]} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#set splitargs [get_run_opts $args] |
||||
#set runopts [dict get $splitargs runopts] |
||||
#set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
set callopts [dict create] |
||||
if {[dict exists $received "-tcl"]} { |
||||
dict set callopts -tclscript 1 |
||||
} |
||||
if {[dict exists $received "-debug"]} { |
||||
dict set callopts -debug 1 |
||||
} |
||||
if {[dict exists $received --timeout]} { |
||||
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash |
||||
} |
||||
set cmdname [dict get $values cmdname] |
||||
if {[dict exists $received cmdarg]} { |
||||
set cmdarglist [dict get $values cmdarg] |
||||
} else { |
||||
set cmdarglist {} |
||||
} |
||||
set cmdargs [concat $cmdname $cmdarglist] |
||||
|
||||
if {[dict exists $received "-tcl"]} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
if {[dict exists $received "-echo"]} { |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
|
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
#we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch |
||||
# to determine something other than just a nonzero exit code or output on stderr. |
||||
if {[dict exists $exitinfo error]} { |
||||
if {[dict exists $received "-tcl"]} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
set chunklist [list] |
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list "info" "error [dict get $exitinfo error]"] |
||||
lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] |
||||
lappend chunklist [list "info" "errorInfo [list [dict get $exitinfo errorInfo]]"] |
||||
} else { |
||||
set c [a+ Yellow red bold] |
||||
#lappend chunklist [list "info" "$c$exitinfo$n"] |
||||
lappend chunklist [list "info" [punk::ansi::ansiwrap_raw $c "\x1b\[m" "" $exitinfo]] |
||||
} |
||||
|
||||
|
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. |
||||
} |
||||
lappend chunklist [list stdout $chunk] |
||||
|
||||
|
||||
#set c_stderr [punk::config] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "info" $chunk] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
append chunk "$e" |
||||
} |
||||
lappend chunklist [list resulterr $chunk] |
||||
|
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
if {$nonewline} { |
||||
return [string trimright $::shellrun::runerr \r\n] |
||||
} |
||||
return $::shellrun::runerr |
||||
} |
||||
|
||||
|
||||
proc runx {args} { |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
|
||||
if {"-nonewline" in $runopts} { |
||||
set nonewline 1 |
||||
} else { |
||||
set nonewline 0 |
||||
} |
||||
|
||||
#shellfilter::stack::remove stdout $::repl::id_outstack |
||||
|
||||
if {"-echo" in $runopts} { |
||||
#float to ensure repl transform doesn't interfere with the output data |
||||
set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action float -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] |
||||
} else { |
||||
#set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::shellrun::runerr}] |
||||
#set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::shellrun::runout}] |
||||
|
||||
#float above the repl's tee_to_var to deliberately block it. |
||||
#a var transform is naturally a junction point because there is no flow-through.. |
||||
# - but mark it with -junction 1 just to be explicit |
||||
set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] |
||||
set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] |
||||
} |
||||
|
||||
set callopts "" |
||||
if {"-tcl" in $runopts} { |
||||
append callopts " -tclscript 1" |
||||
} |
||||
#set exitinfo [shellfilter::run $cmdargs -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none] |
||||
|
||||
shellfilter::stack::remove stdout $stdout_stackid |
||||
shellfilter::stack::remove stderr $stderr_stackid |
||||
|
||||
|
||||
flush stderr |
||||
flush stdout |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
if {"-tcl" in $runopts} { |
||||
|
||||
} else { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
} |
||||
|
||||
#set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runout]} { |
||||
if {$nonewline} { |
||||
set o [string trimright $::shellrun::runout \r\n] |
||||
} else { |
||||
set o $::shellrun::runout |
||||
} |
||||
set chunk $o |
||||
} |
||||
set chunklist [list] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" stdout] ;#key 'stdout' forms part of the resulting dictionary output |
||||
lappend chunklist [list "info" "[a+ white bold]stdout[a]"] |
||||
lappend chunklist [list result $chunk] ;#value corresponding to 'stdout' key in resulting dict |
||||
|
||||
|
||||
lappend chunklist [list "info" " "] |
||||
set chunk "[a+ red bold]stderr[a]" |
||||
lappend chunklist [list "result" $chunk] |
||||
lappend chunklist [list "info" stderr] |
||||
|
||||
set chunk "" |
||||
if {[string length $::shellrun::runerr]} { |
||||
if {$nonewline} { |
||||
set e [string trimright $::shellrun::runerr \r\n] |
||||
} else { |
||||
set e $::shellrun::runerr |
||||
} |
||||
set chunk $e |
||||
} |
||||
#stderr is part of the result |
||||
lappend chunklist [list "resulterr" $chunk] |
||||
|
||||
|
||||
|
||||
set n [a] |
||||
set c "" |
||||
if {[dict exists $exitinfo exitcode]} { |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ yellow bold] |
||||
} |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" exitcode] |
||||
lappend chunklist [list "info" "exitcode $code"] |
||||
lappend chunklist [list "result" "$c$code$n"] |
||||
set exitdict [list exitcode $code] |
||||
} elseif {[dict exists $exitinfo result]} { |
||||
# presumably from a -tcl call |
||||
set val [dict get $exitinfo result] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" result] |
||||
lappend chunklist [list "info" result] |
||||
lappend chunklist [list "result" $val] |
||||
set exitdict [list result $val] |
||||
} elseif {[dict exists $exitinfo error]} { |
||||
# -tcl call with error |
||||
#set exitdict [dict create] |
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" error] |
||||
lappend chunklist [list "info" error] |
||||
lappend chunklist [list "result" [dict get $exitinfo error]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorCode] |
||||
lappend chunklist [list "info" errorCode] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorCode]] |
||||
|
||||
lappend chunklist [list "info" " "] |
||||
lappend chunklist [list "result" errorInfo] |
||||
lappend chunklist [list "info" errorInfo] |
||||
lappend chunklist [list "result" [dict get $exitinfo errorInfo]] |
||||
|
||||
set exitdict $exitinfo |
||||
} else { |
||||
#review - if no exitcode or result. then what is it? |
||||
lappend chunklist [list "info" exitinfo] |
||||
set c [a+ yellow bold] |
||||
lappend chunklist [list result "$c$exitinfo$n"] |
||||
set exitdict [list exitinfo $exitinfo] |
||||
} |
||||
|
||||
#set_last_run_display $chunklist |
||||
tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist |
||||
|
||||
#set ::repl::result_print 0 |
||||
#return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0] |
||||
|
||||
|
||||
if {$nonewline} { |
||||
return [list {*}$exitdict stdout [string trimright $::shellrun::runout \r\n] stderr [string trimright $::shellrun::runerr \r\n]] |
||||
} |
||||
#always return exitinfo $code at beginning of dict (so that punk unknown can interpret the exit code as a unix-style bool if double evaluated) |
||||
return [list {*}$exitdict stdout $::shellrun::runout stderr $::shellrun::runerr] |
||||
} |
||||
|
||||
#an experiment |
||||
# |
||||
#run as raw string instead of tcl-list - no variable subst etc |
||||
# |
||||
#dummy repl_runraw that repl will intercept |
||||
proc repl_runraw {args} { |
||||
error "runraw: only available in repl as direct call - not from script" |
||||
} |
||||
#we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) |
||||
proc runraw {commandline} { |
||||
#runraw fails as intended - because we can't bypass exec/open interference quoting :/ |
||||
#set_last_run_display [list] |
||||
variable runout |
||||
variable runerr |
||||
set runout "" |
||||
set runerr "" |
||||
|
||||
#return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] |
||||
puts stdout ">>runraw got: $commandline" |
||||
|
||||
#run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing |
||||
#for consistency with other runxxx commands - we'll just consume it. (review) |
||||
|
||||
set reallyraw 1 |
||||
if {$reallyraw} { |
||||
set wordparts [regexp -inline -all {\S+} $commandline] |
||||
set runwords $wordparts |
||||
} else { |
||||
#shell style args parsing not suitable for windows where we can't assume matched quotes etc. |
||||
package require string::token::shell |
||||
set parts [string token shell -indices -- $commandline] |
||||
puts stdout ">>shellparts: $parts" |
||||
set runwords [list] |
||||
foreach p $parts { |
||||
set ptype [lindex $p 0] |
||||
set pval [lindex $p 3] |
||||
if {$ptype eq "PLAIN"} { |
||||
lappend runwords [lindex $p 3] |
||||
} elseif {$ptype eq "D:QUOTED"} { |
||||
set v {"} |
||||
append v $pval |
||||
append v {"} |
||||
lappend runwords $v |
||||
} elseif {$ptype eq "S:QUOTED"} { |
||||
set v {'} |
||||
append v $pval |
||||
append v {'} |
||||
lappend runwords $v |
||||
} |
||||
} |
||||
} |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
set runwords [lrange $runwords 1 end] |
||||
|
||||
puts stdout ">>runraw runwords: $runwords" |
||||
#set args [lrange $args 1 end] |
||||
#set runwords [lrange $wordparts 1 end] |
||||
|
||||
set known_runopts [list "-echo" "-e" "-terminal" "-t"] |
||||
set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self |
||||
set runopts [list] |
||||
set cmdwords [list] |
||||
set idx_first_cmdarg [lsearch -not $runwords "-*"] |
||||
set runopts [lrange $runwords 0 $idx_first_cmdarg-1] |
||||
set cmdwords [lrange $runwords $idx_first_cmdarg end] |
||||
|
||||
foreach o $runopts { |
||||
if {$o ni $known_runopts} { |
||||
error "runraw: Unknown runoption $o" |
||||
} |
||||
} |
||||
set runopts [lmap o $runopts {dict get $aliases $o}] |
||||
|
||||
set cmd_as_string [join $cmdwords " "] |
||||
puts stdout ">>cmd_as_string: $cmd_as_string" |
||||
|
||||
if {"-terminal" in $runopts} { |
||||
#fake terminal using 'script' command. |
||||
#not ideal: smushes stdout & stderr together amongst other problems |
||||
set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords] |
||||
puts stdout ">>tcmd: $tcmd" |
||||
set exitinfo [shellfilter::run $tcmd -teehandle punksh -inbuffering line -outbuffering none ] |
||||
set exitinfo "exitcode not-implemented" |
||||
} else { |
||||
set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] |
||||
} |
||||
|
||||
if {[dict exists $exitinfo error]} { |
||||
#todo - check errorInfo makes sense.. return -code? tailcall? |
||||
error [dict get $exitinfo error] |
||||
} |
||||
set code [dict get $exitinfo exitcode] |
||||
if {$code == 0} { |
||||
set c [a+ green] |
||||
} else { |
||||
set c [a+ white bold] |
||||
} |
||||
puts stderr $c |
||||
return $exitinfo |
||||
} |
||||
|
||||
proc sh_run {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
#e.g sh -c "ls -l *" |
||||
#we pass cmdargs to sh -c as a list, not individually |
||||
tailcall shellrun::run {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runout {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runout {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runerr {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runerr {*}$runopts sh -c $cmdargs |
||||
} |
||||
proc sh_runx {args} { |
||||
set splitargs [get_run_opts $args] |
||||
set runopts [dict get $splitargs runopts] |
||||
set cmdargs [dict get $splitargs cmdargs] |
||||
tailcall shellrun::runx {*}$runopts sh -c $cmdargs |
||||
} |
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
interp alias {} run {} shellrun::run |
||||
interp alias {} sh_run {} shellrun::sh_run |
||||
interp alias {} runout {} shellrun::runout |
||||
interp alias {} sh_runout {} shellrun::sh_runout |
||||
interp alias {} runerr {} shellrun::runerr |
||||
interp alias {} sh_runerr {} shellrun::sh_runerr |
||||
interp alias {} runx {} shellrun::runx |
||||
interp alias {} sh_runx {} shellrun::sh_runx |
||||
|
||||
interp alias {} runc {} shellrun::runconsole |
||||
interp alias {} runraw {} shellrun::runraw |
||||
|
||||
|
||||
#the shortened versions deliberately don't get pretty output from the repl |
||||
interp alias {} r {} shellrun::run |
||||
interp alias {} ro {} shellrun::runout |
||||
interp alias {} re {} shellrun::runerr |
||||
interp alias {} rx {} shellrun::runx |
||||
|
||||
|
||||
} |
||||
|
||||
namespace eval shellrun { |
||||
proc test_cffi {} { |
||||
package require test_cffi |
||||
cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] |
||||
::shellrun::kernel32 stdcall CreateProcessA |
||||
#todo - stuff. |
||||
return ::shellrun::kernel32 |
||||
} |
||||
|
||||
} |
||||
namespace eval ::punk::args::register { |
||||
#use fully qualified so 8.6 doesn't find existing var in global namespace |
||||
lappend ::punk::args::register::NAMESPACES ::shellrun |
||||
} |
||||
|
||||
|
||||
package provide shellrun [namespace eval shellrun { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
@ -1,829 +0,0 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
#after $timeout [list set ::shellthread::waitfor] |
||||
#2025-07 timed-out untested review |
||||
set cancelid [after $timeout [list set ::shellthread::waitfor timed-out]] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
after cancel $cancelid |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,80 +0,0 @@
|
||||
# textutil.tcl -- |
||||
# |
||||
# Utilities for manipulating strings, words, single lines, |
||||
# paragraphs, ... |
||||
# |
||||
# Copyright (c) 2000 by Ajuba Solutions. |
||||
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||
# Copyright (c) 2002 by Joe English <jenglish@users.sourceforge.net> |
||||
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: textutil.tcl,v 1.17 2006/09/21 06:46:24 andreas_kupries Exp $ |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.2- |
||||
|
||||
namespace eval ::textutil {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API implementation |
||||
## All through sub-packages imported here. |
||||
|
||||
package require textutil::string |
||||
package require textutil::repeat |
||||
package require textutil::adjust |
||||
package require textutil::split |
||||
package require textutil::tabify |
||||
package require textutil::trim |
||||
package require textutil::wcswidth |
||||
|
||||
namespace eval ::textutil { |
||||
# Import the miscellaneous string command for public export |
||||
|
||||
namespace import -force string::chop string::tail |
||||
namespace import -force string::cap string::uncap string::capEachWord |
||||
namespace import -force string::longestCommonPrefix |
||||
namespace import -force string::longestCommonPrefixList |
||||
|
||||
# Import the repeat commands for public export |
||||
|
||||
namespace import -force repeat::strRepeat repeat::blank |
||||
|
||||
# Import the adjust commands for public export |
||||
|
||||
namespace import -force adjust::adjust adjust::indent adjust::undent |
||||
|
||||
# Import the split commands for public export |
||||
|
||||
namespace import -force split::splitx split::splitn |
||||
|
||||
# Import the trim commands for public export |
||||
|
||||
namespace import -force trim::trim trim::trimleft trim::trimright |
||||
namespace import -force trim::trimPrefix trim::trimEmptyHeading |
||||
|
||||
# Import the tabify commands for public export |
||||
|
||||
namespace import -force tabify::tabify tabify::untabify |
||||
namespace import -force tabify::tabify2 tabify::untabify2 |
||||
|
||||
# Re-export all the imported commands |
||||
|
||||
namespace export chop tail cap uncap capEachWord |
||||
namespace export longestCommonPrefix longestCommonPrefixList |
||||
namespace export strRepeat blank |
||||
namespace export adjust indent undent |
||||
namespace export splitx splitn |
||||
namespace export trim trimleft trimright trimPrefix trimEmptyHeading |
||||
namespace export tabify untabify tabify2 untabify2 |
||||
} |
||||
|
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide textutil 0.9 |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue