Browse Source

A late checkin of much functionality. Tcl du cmd, Multishell cross-platform shell script and pmix wrap, make.tcl fixes & changes

master
Julian Noble 1 year ago
parent
commit
86c612704b
  1. 2
      .gitignore
  2. 229
      src/make.tcl
  3. 1
      src/modules/flagfilter-0.3.tm
  4. 160
      src/modules/punk-0.1.tm
  5. 10
      src/modules/punk/config-0.1.tm
  6. 1111
      src/modules/punk/mix-0.2.tm
  7. 9
      src/modules/punk/mix/base-0.1.tm
  8. 6
      src/modules/punk/mix/templates/layouts/project/.fossil-settings/empty-dirs
  9. 2
      src/modules/punk/mix/templates/layouts/project/src/README.md
  10. 5
      src/modules/punk/mix/templates/layouts/project/src/embedded/README.md
  11. 7
      src/modules/punk/mix/templates/layouts/project/src/lib/README.md
  12. 54
      src/modules/punk/mix/templates/layouts/project/src/make.tcl
  13. 11
      src/modules/punk/mix/templates/layouts/project/src/modules/README.md
  14. 3
      src/modules/punk/mix/templates/layouts/project/src/runtime/Readme.md
  15. 20
      src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md
  16. 8
      src/modules/punk/mix/templates/layouts/project/src/vendorlib/README.md
  17. 7
      src/modules/punk/mix/templates/layouts/project/src/vendormodules/README.md
  18. 264
      src/modules/punk/mix/templates/utility/multishell.cmd
  19. 22
      src/modules/punk/mix/templates/utility/shellbat.txt
  20. 106
      src/modules/punk/mix/templates/utility/shellbat_v1.txt
  21. 420
      src/modules/punk/repo-999999.0a1.0.tm
  22. 4
      src/modules/punk/winpath-999999.0a1.0.tm
  23. 28
      src/scriptapps/dtplite.tcl
  24. 0
      src/scriptapps/fetchruntime.ps1
  25. 0
      src/vendormodules/dictutils-0.2.tm
  26. 0
      src/vendormodules/metaface-1.2.5.tm
  27. 1883
      src/vendormodules/natsort-0.1.1.5.tm
  28. 195
      src/vendormodules/oolib-0.1.tm
  29. 0
      src/vendormodules/pattern-1.2.4.tm
  30. 0
      src/vendormodules/patterncmd-1.2.4.tm
  31. 0
      src/vendormodules/patternlib-1.2.6.tm
  32. 0
      src/vendormodules/patternpredator2-1.2.4.tm

2
.gitignore vendored

@ -34,5 +34,7 @@ _FOSSIL_
#miscellaneous editor files etc #miscellaneous editor files etc
*.swp *.swp
/src/modules/punk/mix/templates/utility/multishell.ps1
todo.txt todo.txt

229
src/make.tcl

@ -5,32 +5,199 @@
#It is assumed the src folder has been placed somewhere where appropriate #It is assumed the src folder has been placed somewhere where appropriate
#(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations) #(e.g not in /usr or c:/ - unless you intend it to directly make and place folders and files in those locations)
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###"
puts $hashline
puts " punkshell make script "
puts $hashline\n
namespace eval ::punkmake {
variable scriptfolder [file normalize [file dirname [info script]]]
variable foldername [file tail $scriptfolder]
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info]
}
if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
exit 1
}
# ** *** *** *** *** *** *** *** *** *** *** ***
#*temporarily* hijack package command
# ** *** *** *** *** *** *** *** *** *** *** ***
try {
rename ::package ::punkmake::package_temp_aside
proc ::package {args} {
if {[lindex $args 0] eq "require"} {
lappend ::punkmake::pkg_requirements [lindex $args 1]
}
}
package require punk::mix package require punk::mix
package require punk::repo
} finally {
catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package}
}
# ** *** *** *** *** *** *** *** *** *** *** ***
foreach pkg $::punkmake::pkg_requirements {
if {[catch {package require $pkg} errM]} {
puts stderr "missing pkg: $pkg"
lappend ::punkmake::pkg_missing $pkg
} else {
lappend ::punkmake::pkg_loaded $pkg
}
}
proc punkmake_gethelp {args} {
set scriptname [file tail [info script]]
append h "Usage:" \n
append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n
append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \n
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n
append h " $scriptname get-project-info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n
if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n
append h " punkmake has detected that the following packages could not be loaded:" \n
append h " " [join $::punkmake::pkg_missing "\n "] \n
append h "* ** *** *** ***" \n
append h " These packages are required for punk make to function" \n \n
append h "* ** *** *** ***" \n\n
append h "Successfully Loaded packages:" \n
append h " " [join $::punkmake::pkg_loaded "\n "] \n
}
return $h
}
set scriptargs $::argv
set do_help 0
if {![llength $scriptargs]} {
set do_help 1
} else {
foreach h $::punkmake::help_flags {
if {[lsearch $scriptargs $h] >= 0} {
set do_help 1
break
}
}
}
set commands_found [list]
foreach a $scriptargs {
if {![string match -* $a]} {
lappend commands_found $a
} else {
if {$a ni $::punkmake::non_help_flags} {
set do_help 1
}
}
}
if {[llength $commands_found] != 1 } {
set do_help 1
} elseif {[lindex $commands_found 0] ni $::punkmake::known_commands} {
puts stderr "Unknown command: [lindex $commands_found 0]\n\n"
set do_help 1
}
if {$do_help} {
puts stderr [punkmake_gethelp]
exit 1
}
set ::punkmake::command [lindex $commands_found 0]
if {[lsearch $::argv -k] >= 0} { if {[lsearch $::argv -k] >= 0} {
set forcekill 1 set forcekill 1
} else { } else {
set forcekill 0 set forcekill 0
} }
puts stdout "::argv $::argv" #puts stdout "::argv $::argv"
set sourcefolder [file normalize [file dirname [info script]]]
# ---------------------------------------- # ----------------------------------------
set target_modules_base [file dirname $sourcefolder]/modules set scriptfolder $::punkmake::scriptfolder
file mkdir $target_modules_base
#first look for a project root (something under fossil or git revision control AND matches punk project folder structure)
#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules
if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} {
if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} {
puts stderr "punkmake script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure"
puts stderr " -aborted- "
exit 2
#todo?
#ask user for a project name and create basic structure?
#call punk::mix::cli::new $projectname on parent folder?
} else {
puts stderr "WARNING punkmake script operating in project space that is not under version control"
}
} else {
}
if {$::punkmake::command eq "get-project-info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---"
puts stdout "- -- get-project-info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---"
puts stdout "- projectroot : $projectroot"
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder]
} elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} {
set vc "git"
set rev [punk::repo::git_revision $scriptfolder]
} else {
set vc " - none found -"
set rev "n/a"
}
puts stdout "- version control : $vc"
puts stdout "- revision : $rev"
puts stdout "- -- --- --- --- --- --- --- --- --- ---"
exit 0
}
if {$::punkmake::command ne "project"} {
puts stderr "Command $::punkmake::command not implemented - aborting."
exit 1
}
#external modules first - and any supporting files - no 'building' required
set copied [punk::mix::cli::lib::copy_files_from_source_to_base $sourcefolder/deps $target_modules_base -force 1]
puts stderr "Copied [llength $copied] dependencies"
set sourcefolder $projectroot/src
set src_module_dir $sourcefolder/modules #only a single consolidated /modules folder used for target
set target_modules_base $projectroot/modules
file mkdir $target_modules_base
#external libs and modules first - and any supporting files - no 'building' required
if {[file exists $sourcefolder/vendorlib]} {
set copied [punk::mix::cli::lib::copy_files_from_source_to_target $sourcefolder/vendorlib $projectroot/lib -overwrite ALL-TARGETS]
puts stderr "Copied [llength $copied] vendor libs from src/vendorlib to $projectroot/lib"
} else {
puts stderr "NOTE: No src/vendorlib folder found."
}
if {[file exists $sourcefolder/vendormodules]} {
set copied [punk::mix::cli::lib::copy_files_from_source_to_target $sourcefolder/vendormodules $target_modules_base -overwrite ALL-TARGETS]
puts stderr "Copied [llength $copied] vendor modules from src/vendormodules to $target_modules_base"
} else {
puts stderr "NOTE: No src/vendormodules folder found."
}
#default source module folder is at projectroot/src/modules
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root)
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
foreach src_module_dir $source_module_folderlist {
set dirtail [file tail $src_module_dir]
#modules and associated files belonging to this package/app #modules and associated files belonging to this package/app
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm
puts stderr "Copied [llength $copied] app modules" puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base "
set copied [punk::mix::cli::lib::copy_nonmodules_from_source_to_base $src_module_dir $target_modules_base -force 1]
set copied [punk::mix::cli::lib::copy_nonmodules_from_source_to_base $src_module_dir $target_modules_base -overwrite ALL-TARGETS]
}
# ---------------------------------------- # ----------------------------------------
@ -40,7 +207,14 @@ if {![llength $vfs_folders]} {
puts stdout " -done- " puts stdout " -done- "
exit 0 exit 0
} }
file mkdir $sourcefolder/_build
set buildfolder [punk::mix::cli::lib::get_build_folder $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
puts stdout " -aborted- "
exit 2
}
#find runtime - only supports one for now.. REVIEW #find runtime - only supports one for now.. REVIEW
set rtfolder $sourcefolder/runtime set rtfolder $sourcefolder/runtime
@ -65,27 +239,28 @@ if {[llength $runtimes] > 1} {
set runtimefile [lindex $runtimes 0] set runtimefile [lindex $runtimes 0]
#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh #sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) #sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW)
if {![file exists $sourcefolder/_build/buildruntime.exe]} { if {![file exists $buildfolder/buildruntime.exe]} {
file copy $rtfolder/$runtimefile $sourcefolder/_build/buildruntime.exe file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe
} }
set startdir [pwd]
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..."
cd [file dirname $buildfolder]
foreach vfs $vfs_folders { foreach vfs $vfs_folders {
set vfsname [file rootname $vfs] set vfsname [file rootname $vfs]
puts stdout " Processing vfs $sourcefolder/$vfs" puts stdout " Processing vfs $sourcefolder/$vfs"
puts stdout " ------------------------------------" puts stdout " ------------------------------------"
if {[file exists $sourcefolder/_build/$vfsname]} { if {[file exists $buildfolder/$vfsname]} {
puts stderr "deleting existing $sourcefolder/_build/$vfsname" puts stderr "deleting existing $buildfolder/$vfsname"
file delete $sourcefolder/_build/$vfsname file delete $sourcefolder/_build/$vfsname
} }
puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]"
if {[catch { if {[catch {
exec sdx wrap [pwd]/_build/$vfsname -vfs [pwd]/$vfs -runtime $sourcefolder/_build/buildruntime.exe -verbose exec sdx wrap $buildfolder/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose
} result]} { } result]} {
puts stderr "sdx wrap _build/$vfsname -vfs [pwd]/$vfs -runtime $sourcefolder/_build/buildruntime.exe -verbose failed with msg: $result" puts stderr "sdx wrap _build/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose failed with msg: $result"
} else { } else {
puts stdout "ok - finished sdx" puts stdout "ok - finished sdx"
set separator [string repeat = 40] set separator [string repeat = 40]
@ -94,7 +269,7 @@ foreach vfs $vfs_folders {
puts stdout $separator puts stdout $separator
} }
if {![file exists $sourcefolder/_build/$vfsname]} { if {![file exists $buildfolder/$vfsname]} {
puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname"
exit 2 exit 2
} }
@ -158,18 +333,18 @@ foreach vfs $vfs_folders {
set targetexe $vfsname set targetexe $vfsname
} }
if {[file exists $sourcefolder/_build/$targetexe]} { if {[file exists $buildfolder/$targetexe]} {
puts stderr "deleting existing $sourcefolder/_build/$targetexe" puts stderr "deleting existing $buildfolder/$targetexe"
if {[catch { if {[catch {
file delete $sourcefolder/_build/$targetexe file delete $sourcefolder/_build/$targetexe
} msg]} { } msg]} {
puts stderr "Failed to delete $sourcefolder/_build/$targetexe" puts stderr "Failed to delete $buildfolder/$targetexe"
exit 4 exit 4
} }
} }
if {$::tcl_platform(platform) eq "windows"} { if {$::tcl_platform(platform) eq "windows"} {
file rename $sourcefolder/_build/$vfsname $sourcefolder/_build/${vfsname}.exe file rename $buildfolder/$vfsname $sourcefolder/_build/${vfsname}.exe
} }
after 200 after 200
@ -189,13 +364,13 @@ foreach vfs $vfs_folders {
puts stdout "copying.." puts stdout "copying.."
puts stdout "$sourcefolder/_build/$targetexe" puts stdout "$buildfolder/$targetexe"
puts stdout "to:" puts stdout "to:"
puts stdout "$deployment_folder/$targetexe" puts stdout "$deployment_folder/$targetexe"
after 500 after 500
file copy $sourcefolder/_build/$targetexe $deployment_folder/$targetexe file copy $buildfolder/$targetexe $deployment_folder/$targetexe
} }
cd $startdir
puts stdout "done" puts stdout "done"
exit 0 exit 0

1
src/modules/flagfilter-0.3.tm

@ -624,6 +624,7 @@ namespace eval flagfilter {
set o_values $values set o_values $values
set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6 set o_remaining [lsearch -all $values *] ;#create a list of indices e.g 0 1 2 3 4 5 6
set o_allocated [list] set o_allocated [list]
set o_map [list]
foreach posn $o_remaining { foreach posn $o_remaining {
lappend o_map $posn unallocated lappend o_map $posn unallocated
} }

160
src/modules/punk-0.1.tm

@ -135,7 +135,44 @@ namespace eval punk {
set the_var set the_var
} }
} }
proc src {args} {
#based on wiki.. https://wiki.tcl-lang.org/page/source+with+args
#added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename
# review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here.
set cmdargs [list]
set scriptargs [list]
set inopts 0
set i 0
foreach a $args {
if {$i eq [llength $args]-1} {
#reached end without finding end of opts
#must be file - even if it does match -* ?
break
}
if {!$inopts} {
if {[string match -* $a]} {
set inopts 1
} else {
#leave loop at first nonoption - i should be index of file
break
}
} else {
#leave for next iteration to check
set inopts 0
}
incr i
}
set cmdargs [lrange $args 0 $i]
set scriptargs [lrange $args $i+1 end]
set argv $::argv
set argc $::argc
set ::argv $scriptargs
set ::argc [llength $scriptargs]
set code [catch {uplevel [list source {*}$cmdargs]} return]
set ::argv $argv
set ::argc $argc
return -code $code $return
}
#https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/ #https://randomascii.wordpress.com/2012/02/25/comparing-floating-point-numbers-2012-edition/
# #
#we can't provide a float comparison suitable for every situation, #we can't provide a float comparison suitable for every situation,
@ -6803,129 +6840,10 @@ namespace eval punk {
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|
proc norm {path} {
#kettle::path::norm
#see also wiki
#full path normalization
return [file dirname [file normalize $path/__]]
}
proc path_strip_prefix {path prefix} {
return [file join \
{*}[lrange \
[file split [norm $path]] \
[llength [file split [norm $prefix]]] \
end]]
}
proc path_relative {base dst} {
# Modified copy of ::fileutil::relative (tcllib)
# Adapted to 8.5 ({*}).
#
# Taking two _directory_ paths, a base and a destination, computes the path
# of the destination relative to the base.
#
# Arguments:
# base The path to make the destination relative to.
# dst The destination path
#
# Results:
# The path of the destination, relative to the base.
# Ensure that the link to directory 'dst' is properly done relative to
# the directory 'base'.
if {[file pathtype $base] ne [file pathtype $dst]} {
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
}
set base [norm $base]
set dst [norm $dst]
set save $dst
set base [file split $base]
set dst [file split $dst]
while {[lindex $dst 0] eq [lindex $base 0]} {
set dst [lrange $dst 1 end]
set base [lrange $base 1 end]
if {![llength $dst]} {break}
}
set dstlen [llength $dst]
set baselen [llength $base]
if {($dstlen == 0) && ($baselen == 0)} {
# Cases:
# (a) base == dst
set dst .
} else {
# Cases:
# (b) base is: base/sub = sub
# dst is: base = {}
# (c) base is: base = {}
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
incr baselen -1
}
set dst [file join {*}$dst]
}
return $dst
}
proc fcat {args} {
if {$::tcl_platform(platform) ne "windows"} {
return [fileutil::cat {*}$args]
}
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) != 0} {
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"
set finalpaths [list]
foreach p $paths {
if {[punk::winpath::illegalname_test $p]} {
lappend finalpaths [punk::winpath::illegalname_fix $p]
} else {
lappend finalpaths $p
}
}
fileutil::cat {*}$opts {*}$finalpaths
}
#simplify path with respect to /./ & /../ elements - independent of platform #simplify path with respect to /./ & /../ elements - independent of platform
#NOTE: anomalies in standard tcl processing on windows: #NOTE: anomalies in standard tcl processing on windows:
@ -6959,7 +6877,7 @@ namespace eval punk {
} }
#fileutil::cat except with checking for windows illegal path names (when on windows platform) #fileutil::cat except with checking for windows illegal path names (when on windows platform)
interp alias {} fcat {} punk::fcat interp alias {} fcat {} punk::repo::fcat
#---------------------------------------------- #----------------------------------------------
interp alias {} linelistraw {} punk::linelistraw interp alias {} linelistraw {} punk::linelistraw

10
src/modules/punk/config-0.1.tm

@ -14,6 +14,8 @@ namespace eval punk::config {
variable vars variable vars
set vars [list \ set vars [list \
apps \ apps \
config \
configset \
scriptlib \ scriptlib \
color_stdout \ color_stdout \
color_stderr \ color_stderr \
@ -21,17 +23,20 @@ namespace eval punk::config {
logfile_stderr \ logfile_stderr \
syslog_stdout \ syslog_stdout \
syslog_stderr \ syslog_stderr \
syslog_active \
exec_unknown \ exec_unknown \
] ]
#todo pkg punk::config #todo pkg punk::config
#defaults #defaults
dict set startup configset .punkshell
dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run dict set startup exec_unknown true ;#whether to use exec instead of experimental shellfilter::run
dict set startup color_stdout [list cyan bold] dict set startup color_stdout [list cyan bold]
dict set startup color_stderr [list red bold] dict set startup color_stderr [list red bold]
dict set startup syslog_stdout "127.0.0.1:514" dict set startup syslog_stdout "127.0.0.1:514"
dict set startup syslog_stderr "127.0.0.1:514" dict set startup syslog_stderr "127.0.0.1:514"
dict set startup syslog_active 0
#default file logs to logs folder at same location as exe if writable, or empty string #default file logs to logs folder at same location as exe if writable, or empty string
dict set startup logfile_stdout "" dict set startup logfile_stdout ""
dict set startup logfile_stderr "" dict set startup logfile_stderr ""
@ -54,6 +59,8 @@ namespace eval punk::config {
#todo - define which configvars are settable in env #todo - define which configvars are settable in env
set known_punk_env_vars [list \ set known_punk_env_vars [list \
PUNK_APPS \ PUNK_APPS \
PUNK_CONFIG \
PUNK_CONFIGSET \
PUNK_SCRIPTLIB \ PUNK_SCRIPTLIB \
PUNK_EXECUNKNOWN \ PUNK_EXECUNKNOWN \
PUNK_COLOR_STDERR \ PUNK_COLOR_STDERR \
@ -62,6 +69,7 @@ namespace eval punk::config {
PUNK_LOGFILE_STDERR \ PUNK_LOGFILE_STDERR \
PUNK_SYSLOG_STDOUT \ PUNK_SYSLOG_STDOUT \
PUNK_SYSLOG_STDERR \ PUNK_SYSLOG_STDERR \
PUNK_SYSLOG_ACTIVE \
] ]
#override with env vars if set #override with env vars if set
@ -81,4 +89,6 @@ namespace eval punk::config {
set running [dict create] set running [dict create]
set running [dict merge $running $startup] set running [dict merge $running $startup]
} }

1111
src/modules/punk/mix-0.2.tm

File diff suppressed because it is too large Load Diff

9
src/modules/punk/mix/base-0.1.tm

@ -207,10 +207,9 @@ namespace eval punk::mix::base {
} }
return $helpstr return $helpstr
} }
proc dostuff {args} { #proc dostuff {args} {
extension@@opts/@?@-extension,args@@args= [_split_args $args] # extension@@opts/@?@-extension,args@@args= [_split_args $args]
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'"
puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" #}
}
} }

6
src/modules/punk/mix/templates/layouts/project/.fossil-settings/empty-dirs

@ -1,3 +1,7 @@
src src
src/deps src/vendorlib
src/vendormodules
src/modules src/modules
src/lib
lib
modules

2
src/modules/punk/mix/templates/layouts/project/src/README.md

@ -6,7 +6,7 @@ Build Instructions
+ Use tclsh|punk make.tcl to build .tm modules and rebuild the executable (if applicable) + Use tclsh|punk make.tcl to build .tm modules and rebuild the executable (if applicable)
+ Then Use tclsh|punk build.tcl to run the 'kettle' system to build docs and/or standard tcl libraries with pkgIndex.tcl files, + Use tclsh|punk build.tcl to run the 'kettle' system to build docs and/or standard tcl libraries with pkgIndex.tcl files,
or - use the `pmix KettleShell` command from within the punk shell to perform kettle operations. or - use the `pmix KettleShell` command from within the punk shell to perform kettle operations.
(The name 'build.tcl' is the standard name used by the [Kettle](https://chiselapp.com/user/andreas_kupries/repository/Kettle/home) system) (The name 'build.tcl' is the standard name used by the [Kettle](https://chiselapp.com/user/andreas_kupries/repository/Kettle/home) system)

5
src/modules/punk/mix/templates/layouts/project/src/embedded/README.md

@ -0,0 +1,5 @@
Documents and help files (for the repository website)
These are html, markdown, manfiles etc which live within src/embedded and are intended to be checked into source control so they can form part of the online documentation available when browsing the repository.
These files shouldn't be modified directly as they are built from the files in the src/doc folder
(Using the Kettle build system)

7
src/modules/punk/mix/templates/layouts/project/src/lib/README.md

@ -0,0 +1,7 @@
Tcl Library Source files for the project.
These are Tcl packages which use the pkgIndex system.
The Kettle Build tool can be used to generate pkgIndex.tcl files and install these to appropriate locations.

54
src/modules/punk/mix/templates/layouts/project/src/make.tcl

@ -40,13 +40,15 @@ if {![llength $vfs_folders]} {
puts stdout " -done- " puts stdout " -done- "
exit 0 exit 0
} }
file mkdir $sourcefolder/_build
if {[catch {exec sdx help} errM]} { set buildfolder [punk::mix::cli::lib::get_build_folder $sourcefolder]
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "err: $errM" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
exit 1 puts stdout " -aborted- "
exit 2
} }
#find runtime - only supports one for now.. REVIEW #find runtime - only supports one for now.. REVIEW
set rtfolder $sourcefolder/runtime set rtfolder $sourcefolder/runtime
set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *]
@ -54,30 +56,44 @@ if {![llength $runtimes]} {
puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables."
exit 2 exit 2
} }
if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM"
exit 1
}
if {[llength $runtimes] > 1} { if {[llength $runtimes] > 1} {
puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one." puts stderr "Found multiple runtimes in $rtfolder ($runtimes) - unable to proceed - currently limited to one."
exit 3 exit 3
} }
set runtimefile [lindex $runtimes 0] set runtimefile [lindex $runtimes 0]
#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW)
if {![file exists $buildfolder/buildruntime.exe]} {
file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe
}
set startdir [pwd]
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..."
cd [file dirname $buildfolder]
foreach vfs $vfs_folders { foreach vfs $vfs_folders {
set vfsname [file rootname $vfs] set vfsname [file rootname $vfs]
puts stdout " Processing vfs $sourcefolder/$vfs" puts stdout " Processing vfs $sourcefolder/$vfs"
puts stdout " ------------------------------------" puts stdout " ------------------------------------"
if {[file exists $sourcefolder/_build/$vfsname]} { if {[file exists $buildfolder/$vfsname]} {
puts stderr "deleting existing $sourcefolder/_build/$vfsname" puts stderr "deleting existing $buildfolder/$vfsname"
file delete $sourcefolder/_build/$vfsname file delete $sourcefolder/_build/$vfsname
} }
puts stdout "building $vfsname with sdx.." puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]"
if {[catch { if {[catch {
exec sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose exec sdx wrap $buildfolder/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose
} result]} { } result]} {
puts stderr "sdx wrap _build/$vfsname -runtime runtime/$runtimefile -verbose failed with msg: $result" puts stderr "sdx wrap _build/$vfsname -vfs $sourcefolder/$vfs -runtime $buildfolder/buildruntime.exe -verbose failed with msg: $result"
} else { } else {
puts stdout "ok - finished sdx" puts stdout "ok - finished sdx"
set separator [string repeat = 40] set separator [string repeat = 40]
@ -86,7 +102,7 @@ foreach vfs $vfs_folders {
puts stdout $separator puts stdout $separator
} }
if {![file exists $sourcefolder/_build/$vfsname]} { if {![file exists $buildfolder/$vfsname]} {
puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname" puts stderr "|err> build didn't seem to produce output at $sourcefolder/_build/$vfsname"
exit 2 exit 2
} }
@ -150,18 +166,18 @@ foreach vfs $vfs_folders {
set targetexe $vfsname set targetexe $vfsname
} }
if {[file exists $sourcefolder/_build/$targetexe]} { if {[file exists $buildfolder/$targetexe]} {
puts stderr "deleting existing $sourcefolder/_build/$targetexe" puts stderr "deleting existing $buildfolder/$targetexe"
if {[catch { if {[catch {
file delete $sourcefolder/_build/$targetexe file delete $sourcefolder/_build/$targetexe
} msg]} { } msg]} {
puts stderr "Failed to delete $sourcefolder/_build/$targetexe" puts stderr "Failed to delete $buildfolder/$targetexe"
exit 4 exit 4
} }
} }
if {$::tcl_platform(platform) eq "windows"} { if {$::tcl_platform(platform) eq "windows"} {
file rename $sourcefolder/_build/$vfsname $sourcefolder/_build/${vfsname}.exe file rename $buildfolder/$vfsname $sourcefolder/_build/${vfsname}.exe
} }
after 200 after 200
@ -181,13 +197,13 @@ foreach vfs $vfs_folders {
puts stdout "copying.." puts stdout "copying.."
puts stdout "$sourcefolder/_build/$targetexe" puts stdout "$buildfolder/$targetexe"
puts stdout "to:" puts stdout "to:"
puts stdout "$deployment_folder/$targetexe" puts stdout "$deployment_folder/$targetexe"
after 500 after 500
file copy $sourcefolder/_build/$targetexe $deployment_folder/$targetexe file copy $buildfolder/$targetexe $deployment_folder/$targetexe
} }
cd $startdir
puts stdout "done" puts stdout "done"
exit 0 exit 0

11
src/modules/punk/mix/templates/layouts/project/src/modules/README.md

@ -0,0 +1,11 @@
Tcl Module Source files for the project.
Consider using the punkshell pmix facility to create and manage these.
pmix::newmodule <name> will create a basic .tm module template and assist in versioning.
Tcl modules can be namespaced.
For example
> pmix::newmodule mymodule::utils
will create the new module under src/modules/mymodule/utils

3
src/modules/punk/mix/templates/layouts/project/src/runtime/Readme.md

@ -0,0 +1,3 @@
Install a tclkit runtime here by running the appropriate fetchruntime script in ../src
Alternatively the runtime can be downloaded from: https://www.gitea1.intx.com.au/jn/punkbin

20
src/modules/punk/mix/templates/layouts/project/src/scriptapps/README.md

@ -0,0 +1,20 @@
Create multishell scripts from your .tcl .sh and .ps1 scripts that are stored here.
Use the pmix wrap functions to generate a multishell .cmd file from your scripts.
This .cmd is a 'polyglot' script - it should run when called from any of the target interpreters.
A multishell .cmd file is a cross-platform script that can easily be run on Windows and unix-like platforms.
The .cmd extension is primarily a convenience so that it can be run easily by name on windows but it is ok to either leave it as that on other platforms, or rename it appropriately.
On unix-like platforms it can be called with a bourne shell such as sh or bash.
On windows, it can also be called with sh or bash if they are available - but the usual method would be to run it under cmd.exe initially just by opening a cmd prompt and running it.
This will run some windows batch script to automatically generate a corresponding .ps1 file and execution will switch to powershell 5 or powershell 7 (pwsh) if available.
Subsequently the command can be run directly from powershell.
Whether called from Bourne shell, or cmd.exe or powershell - the usual payload would be your wrapped Tcl code - but it's also possible for powershell or sh/bash to be the primary payload script.
Any of these languages could easily be used to detect and launch other scripts/utilities that you may distribute with your app.

8
src/modules/punk/mix/templates/layouts/project/src/vendorlib/README.md

@ -0,0 +1,8 @@
Tcl library dependencies
Any pkgIndex based libraries that are external to the project but which the project owners wish to distribute with the project and keep under source control.
These should generally be kept to a minimum
- with dependency and version numbers being tracked instead; along with the provision of a mechanism for the project end-users to update.

7
src/modules/punk/mix/templates/layouts/project/src/vendormodules/README.md

@ -0,0 +1,7 @@
Tcl module dependencies
Any .tm files that are external to the project but which the project owners wish to distribute with the project and keep under source control.
These should generally be kept to a minimum
- with dependency and version numbers being tracked instead; along with the provision of a mechanism for the project end-users to update.

264
src/modules/punk/mix/templates/utility/multishell.cmd

@ -0,0 +1,264 @@
set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide s {proc $s args {}}; Hide :;rename set s2;Hide set;s2 1 list]"; set -- : "$@"; $1 = @'
: heredoc1 - hide from powershell (close sqote for unix shells) ' \
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \
: "[Hide @ECHO; Hide ); Hide (;Hide echo]#not necessary but can help avoid errs in testing"
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
@REM {
@REM DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required and will reduce functionality.
@REM Even comment lines can be part of the functionality of this script - modify with care.
@REM Change the value of nextshell in the next line if desired, and code within payload sections as appropriate.
@SET "nextshell=pwsh"
@REM nextshell set to pwsh,sh,bash or tclsh
@REM @ECHO nextshell is %nextshell%
@SET "validshells=pwsh,sh,bash,tclsh"
@CALL SET keyRemoved=%%validshells:%nextshell%=%%
@REM Note that 'powershell' e.g v5 is just a fallback for when pwsh is not available
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@REM -- cmd/batch file section (ignored on unix)
@REM -- This section intended only to launch the next shell
@REM -- Avoid customising this if possible. cmd/batch script is probably the least expressive language.
@REM -- custom windows payloads should be in powershell,tclsh or sh/bash code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@IF %nextshell%==pwsh (
CALL pwsh -nop -c set-executionpolicy -Scope CurrentUser RemoteSigned
COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL
REM test availability of preferred option of powershell7+ pwsh
CALL pwsh -nop -nol -c write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
IF !pwshtest_exitcode!==0 CALL pwsh -nop -nol "%~dp0%~n0.ps1" %* & SET task_exitcode=!errorlevel!
REM fallback to powershell if pwsh failed
IF NOT !pwshtest_exitcode!==0 (
REM CALL powershell -nop -nol -c write-host powershell-found
CALL powershell -nop -nol -file "%~dp0%~n0.ps1" %*
SET task_exitcode=!errorlevel!
)
) ELSE (
IF %nextshell%==bash (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
CALL %nextshell% "!wslpath!%fname%" %* & SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl
REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx
CALL %nextshell% "%~dp0%fname%" %* & SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value %nextshell% valid options are %validshells%
SET task_exitcode=66
GOTO :exit
)
)
)
@GOTO :endlib
:getWslPath
@SETLOCAL
@SET "_path=%~p1"
@SET "name=%~nx1"
@SET "drive=%~d1"
@SET "rtrn=%~2"
@SET "result=/mnt/%drive:~0,1%%_path:\=/%%name%"
@ENDLOCAL & (
@if "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
ECHO %result%
)
)
@GOTO :eof
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit
@GOTO :exit
# }
# rem call %nextshell% "%~dp0%~n0.cmd" %*
# -*- tcl -*-
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- tcl script section
# -- This is a punk multishell file
# -- Primary payload target is Tcl, with sh,bash,powershell as helpers
# -- but it may equally be used with any of these being the primary script.
# -- It is tuned to run when called as a batch file, a tcl script a sh/bash script or a pwsh/powershell script
# -- i.e it is a polyglot file.
# -- The specific layout including some lines that appear just as comments is 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.polypunk.cmd in sh or bash
# -- e.g tclsh filename.cmd
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
rename set ""; rename s2 set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup
Hide :exit;Hide {<#};Hide '@
namespace eval ::punk::multishell {
set last_script_root [file dirname [file normalize ${argv0}/__]]
set last_script [file dirname [file normalize [info script]/__]]
if {[info exists argv0] &&
$last_script eq $last_script_root
} {
set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode
} else {
set ::punk::multishell::is_main($last_script) 0 ;#sourced - likely to be being used as a library - no launch, no exit. Can use return.
}
if {"::punk::multishell::is_main" ni [info commands ::punk::multishell::is_main]} {
proc ::punk::multishell::is_main {{script_name {}}} {
if {$script_name eq ""} {
set script_name [file dirname [file normalize [info script]/--]]
}
return [set ::punk::multishell::is_main($script_name)]
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload
#puts "script : [info script]"
#puts "argcount : $::argc"
#puts "argvalues: $::argv"
#puts "argv0 : $::argv0"
# -- --- --- --- --- --- --- --- --- --- --- ---
#<tcl-payload>
#</tcl-payload>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- Best practice is to always return or exit above, or just by leaving the below defaults in place.
# -- If the multishell script is modified to have Tcl below the Tcl Payload section,
# -- then Tcl bracket balancing needs to be carefully managed in the shell and powershell sections below.
# -- Only the # in front of the two relevant if statements below needs to be removed to enable Tcl below
# -- but the sh/bash 'then' and 'fi' would also need to be uncommented.
# -- This facility left in place for experiments on whether configuration payloads etc can be appended
# -- to tail of file - possibly binary with ctrl-z char - but utility is dependent on which other interpreters/shells
# -- can be made to ignore/cope with such data.
if {[::punk::multishell::is_main]} {
exit 0
} else {
return
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload
# end hide from unix shells \
HEREDOC1B_HIDE_FROM_BASH_AND_SH
# sh/bash \
shift && set -- "${@:1:$#-1}"
#------------------------------------------------------
# -- This if block only needed if Tcl didn't exit or return above.
if false==false # else {
then
:
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- sh/bash script section
# -- leave as is if all that is required is launching the Tcl payload"
# --
# -- Note that sh/bash script isn't called when running a .bat/.cmd from cmd.exe on windows by default
# -- adjust @call line above ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate
# -- if sh/bash scripting needs to run on windows too.
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload
#printf "start of bash or sh code"
#<shell-payload-pre-tcl>
#</shell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<shell-launch-tcl>
exitcode=0 ;#default assumption
#-- sh/bash launches Tcl here instead of shebang line at top
#-- use exec to use exitcode (if any) directly from the tcl script
#exec /usr/bin/env tclsh "$0" "$@"
#-- alternative - can run sh/bash script after the tcl call.
/usr/bin/env tclsh "$0" "$@"
exitcode=$?
#echo "tcl exitcode: ${exitcode}"
#-- override exitcode example
#exit 66
#</shell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<shell-payload-post-tcl>
#</shell-payload-post-tcl>
#printf "sh/bash done \n"
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload
#------------------------------------------------------
fi
exit ${exitcode}
# end hide sh/bash block from Tcl
# This comment with closing brace should stay in place whether if commented or not }
#------------------------------------------------------
# begin hide powershell-block from Tcl - only needed if Tcl didn't exit or return above
if 0 {
: end heredoc1 - end hide from powershell \
'@
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- powershell/pwsh section
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = getScriptName
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin powershell Payload
#"Timestamp : {0,10:yyyy-MM-dd HH:mm:ss}" -f $(Get-Date) | write-host
#"Script Name : {0}" -f $scriptname | write-host
#"Powershell Version: {0}" -f $PSVersionTable.PSVersion.Major | write-host
#"powershell args : {0}" -f ($args -join ", ") | write-host
# -- --- --- ---
#<powershell-payload-pre-tcl>
#</powershell-payload-pre-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-launch-tcl>
tclsh $scriptname $args
#</powershell-launch-tcl>
# -- --- --- --- --- --- --- ---
#<powershell-payload-post-tcl>
#</powershell-payload-post-tcl>
# unbal }
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: cmd exit label - return exitcode
:exit
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@EXIT /B !task_exitcode!
# cmd has exited
: end heredoc2 \
'@
<#
# id:tailblock0
# -- powershell multiline comment
#>
<#
# id:tailblock1
# <ctrl-z>

# </ctrl-z>
# -- unreachable by tcl directly if ctrl-z character is in the <ctrl-z> section above. (but file can be read and split on \x1A)
# -- Potential for zip and/or base64 contents, but we can't stop pwsh parser from slurping in the data
# -- so for example a plain text tar archive could cause problems depending on the content.
# -- final line in file must be the powershell multiline comment terminator or other data it can handle.
# -- e.g plain # comment lines will work too
# -- (for example a powershell digital signature is a # commented block of data at the end of the file)
#>

22
src/modules/punk/mix/templates/utility/shellbat.txt

@ -1,8 +1,8 @@
if (true=="shellbat") #;#\ : "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows.
: <<'HIDE_FROM_BASH_AND_SH' : <<'HIDE_FROM_BASH_AND_SH'
::lindex tcl;# leading colons hide from .bat, trailing slash hides next line from tcl \ : ;# leading colon hides from .bat, trailing slash hides next line from tcl \
@call tclsh "%~dp0%~n0.bat" %* @call tclsh "%~dp0%~n0.bat" %*
::lindex tcl;#\ : ;#\
@set taskexitcode=%errorlevel% & goto :exit @set taskexitcode=%errorlevel% & goto :exit
# -*- tcl -*- # -*- tcl -*-
# ################################################################################################# # #################################################################################################
@ -24,6 +24,7 @@ if (true=="shellbat") #;#\
#puts "argcount : $::argc" #puts "argcount : $::argc"
#puts "argvalues: $::argv" #puts "argvalues: $::argv"
#<tcl-payload> #<tcl-payload>
# --- --- --- --- --- --- --- --- --- --- --- --- --- # --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -39,10 +40,9 @@ printf "etc"
#-- #--
#-- END marker for hide_from_bash_and_sh\ #-- END marker for hide_from_bash_and_sh\
HIDE_FROM_BASH_AND_SH HIDE_FROM_BASH_AND_SH
#\
then
#--------------------------------------------------------- #---------------------------------------------------------
#-- This if statement hides(mostly) a sh/bash code block from Tcl
if false==false # else { if false==false # else {
then then
: :
@ -72,9 +72,11 @@ then
#printf "No need for trailing slashes for sh/bash code here\n" #printf "No need for trailing slashes for sh/bash code here\n"
#--------------------------------------------------------- #---------------------------------------------------------
fi fi
# } # closing brace for Tcl }
#--------------------------------------------------------- #---------------------------------------------------------
#-- tcl and shell script now both active
#-- comment for line sample 1 with trailing continuation slash \ #-- comment for line sample 1 with trailing continuation slash \
#printf "tcl-invisible sh/bash line sample 1 \n" #printf "tcl-invisible sh/bash line sample 1 \n"
@ -90,17 +92,13 @@ fi
#exit 42 #exit 42
#---------------------------------------------------------
#-- end if true==shellbat on very first line\
fi
#---------------------------------------------------------
#-- make sure sh/bash/tcl all skip over .bat style exit \ #-- make sure sh/bash/tcl all skip over .bat style exit \
: <<'shell_end' : <<'shell_end'
#-- .bat exit with exitcode from tcl process \ #-- .bat exit with exitcode from tcl process \
:exit :exit
::lindex tcl;#\ : ;# \
@exit /B %taskexitcode% @exit /B %taskexitcode%
#\ # .bat has exited \
shell_end shell_end

106
src/modules/punk/mix/templates/utility/shellbat_v1.txt

@ -0,0 +1,106 @@
if (true=="shellbat") #;#\
: <<'HIDE_FROM_BASH_AND_SH'
::lindex tcl;# leading colons hide from .bat, trailing slash hides next line from tcl \
@call tclsh "%~dp0%~n0.bat" %*
::lindex tcl;#\
@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>
# --- --- --- --- --- --- --- --- --- --- --- --- ---
# 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
#\
then
#---------------------------------------------------------
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"
#-- sh/bash launches Tcl here instead of shebang line at top
#-- use exec to use exitcode (if any) directly from the tcl script
exec /usr/bin/env tclsh "$0" "$@"
#-- alternative - if sh/bash script required to run after the tcl call.
#/usr/bin/env tclsh "$0" "$@"
#tcl_exitcode=$?
#echo "tcl_exitcode: ${tcl_exitcode}"
#-- override exitcode example
#exit 66
#printf "No need for trailing slashes for sh/bash code here\n"
#---------------------------------------------------------
fi
# }
#---------------------------------------------------------
#-- 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
#---------------------------------------------------------
#-- end if true==shellbat on very first line\
fi
#---------------------------------------------------------
#-- make sure sh/bash/tcl all skip over .bat style exit \
: <<'shell_end'
#-- .bat exit with exitcode from tcl process \
:exit
::lindex tcl;#\
@exit /B %taskexitcode%
#\
shell_end

420
src/modules/punk/repo-999999.0a1.0.tm

@ -24,7 +24,15 @@
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#
# path/repo functions
#
package require punk::winpath
package require cksum ;#tcllib
package require fileutil; #tcllib
namespace eval punk::repo { namespace eval punk::repo {
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance
proc is_fossil {{path {}}} { proc is_fossil {{path {}}} {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
@ -34,6 +42,20 @@ namespace eval punk::repo {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
return [expr {[find_git $path] ne {}}] return [expr {[find_git $path] ne {}}]
} }
#tracked repo - but may not be a project
proc is_repo {{path {}}} {
if {$path eq {}} { set path [pwd] }
return [expr {[isfossil] || [is_git]}]
}
proc is_candidate {{path {}}} {
if {$path eq {}} { set path [pwd] }
return [expr {[find_candidate $path] ne {}}]
}
proc is_project {{path {}}} {
if {$path eq {}} { set path [pwd] }
return [expr {[find_project $path] ne {}}]
}
proc find_fossil {{path {}}} { proc find_fossil {{path {}}} {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
@ -43,6 +65,37 @@ namespace eval punk::repo {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
scanup $path is_git_root scanup $path is_git_root
} }
proc find_candidate {{path {}}} {
if {$path eq {}} { set path [pwd] }
scanup $path is_candidate_root
}
proc find_repo {{path {}}} {
if {$path eq {}} { set path [pwd] }
#find the closest (lowest in dirtree) repository
set f_root [find_fossil $path]
set g_root [find_git $path]
if {[string length $f_root]} {
if {[string length $g_root]} {
if {[path_a_below_b $f_root $g_root]} {
return $f_root
} else {
return $g_root
}
} else {
return $f_root
}
} else {
if {[string length $g_root]} {
return $g_root
} else {
return ""
}
}
}
proc find_project {{path {}}} {
if {$path eq {}} { set path [pwd] }
scanup $path is_project_root
}
proc is_fossil_root {{path {}}} { proc is_fossil_root {{path {}}} {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
@ -62,13 +115,64 @@ namespace eval punk::repo {
set control $path/.git set control $path/.git
expr {[file exists $control] && [file isdirectory $control]} expr {[file exists $control] && [file isdirectory $control]}
} }
proc is_repo_root {{path {}}} {
if {$path eq {}} { set path [pwd] }
expr {[is_fossil_root $path] || [is_git_root $path]}
}
#require a minimum of /src and /modules - and that it's otherwise sensible
proc is_candidate_root {{path {}}} {
if {$path eq {}} { set path [pwd] }
if {$::tcl_platform(platform) eq "windows"} {
set normpath [punk::repo::norm [punk::winpath::winpath $path]]
} else {
set normpath [punk::repo::norm $path]
}
set unwise_paths [list "/" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"]
if {[string tolower $normpath] in $unwise_paths} {
return 0
}
if {[file pathtype [string trimright $normpath /]] eq "volumerelative"} {
#tcl 8.6/8.7 cd command doesn't preserve the windows "ProviderPath" (per drive current working directory)
return 0
}
#review - adjust to allow symlinks to folders?
foreach required {
src
src/lib
src/modules
lib
modules
} {
set req $path/$required
if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0}
}
return 1
}
proc is_project_root {path} {
#review - find a reliable simple mechanism. Noting we have projects based on different templates.
#Should there be a specific required 'project' file of some sort?
#test for file/folder items indicating fossil or git workdir base
if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} {
return 0
}
#exclude some known places we wouldn't want to put a project
if {![is_candidate_root $path]} {
return 0
}
return 1
}
proc git_revision {{path {}}} { proc git_revision {{path {}}} {
if {$path eq {}} { set path [pwd] } if {$path eq {}} { set path [pwd] }
# ::kettle::path::revision.git # ::kettle::path::revision.git
do_in_path $path { do_in_path $path {
try { try {
set v [::exec {*}[auto_execok git] describe] #git describe will error with 'No names found' if repo has no tags
#set v [::exec {*}[auto_execok git] describe]
set v [::exec {*}[auto_execok git] rev-parse HEAD] ;# consider 'git rev-parse --short HEAD'
} on error {e o} { } on error {e o} {
set v [lindex [split [dict get $o -errorinfo] \n] 0] set v [lindex [split [dict get $o -errorinfo] \n] 0]
} }
@ -90,6 +194,91 @@ namespace eval punk::repo {
} }
} }
proc cksum_path_content {path args} {
dict set args -cksum_content 1
dict set args -cksum_meta 0
tailcall cksum_path $path {*}args
}
#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} {
set base [file dirname [file normalize $path]]
set startdir [pwd]
set defaults [list -cksum_content 1 -cksum_meta 1 -cksum_acls 0 -use_tar 1]
set opts [dict merge $defaults $args]
if {![file exists $path]} {
return [list cksum "" opts $opts]
}
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]
if {$opt_cksum_meta} {
} else {
if {[file type $path] ne "file"} {
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"
return [list error unsupported opts $opts]
}
}
set opt_use_tar [dict get $opts -use_tar]
if {$opt_use_tar} {
package require tar ;#from tcllib
} else {
if {[file type $path] eq "directory"} {
puts stderr "cksum_path doesn't yet support -use_tar 0 for folders"
return [list error unsupported opts $opts]
}
}
if {$path eq $base} {
#attempting to cksum at root/volume level of a filesystem.. extra work
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)"
return [list error unsupported opts $opts]
}
set cksum ""
if {$opt_use_tar} {
set target [file tail $path]
set tmplocation [tmpdir]
set archivename $tmplocation/[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 at: $archivename .."
tar::create $archivename $target
puts stdout "cksum_path: calculating cksum for $target (size [file size $target])..."
set cksum [crc::cksum -format 0x%X -file $archivename]
puts stdout "cksum_path: cleaning up.. "
file delete -force $archivename
cd $startdir
} else {
#todo
if {[file type $path] eq "file"} {
if {$opt_cksum_meta} {
return [list error unsupported opts $opts]
} else {
set cksum [crc::cksum -format 0x%X -file $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
return $result
}
#temporarily cd to workpath to run script - return to correct path even on failure #temporarily cd to workpath to run script - return to correct path even on failure
proc do_in_path {path script} { proc do_in_path {path script} {
#from ::kettle::path::in #from ::kettle::path::in
@ -121,7 +310,10 @@ namespace eval punk::repo {
} }
return {} return {}
} }
#get content part of content/zip delimited by special \x1a (ctrl-z) char as used in tarjr and kettle::path::c/z
proc c/z {content} {
return [lindex [split $content \x1A] 0]
}
proc grep {pattern data} { proc grep {pattern data} {
set data [string map [list \r\n \n] $data] set data [string map [list \r\n \n] $data]
return [lsearch -all -inline -glob [split $data \n] $pattern] return [lsearch -all -inline -glob [split $data \n] $pattern]
@ -132,6 +324,230 @@ namespace eval punk::repo {
return [lsearch -all -inline -regexp [split $data \n] $pattern] return [lsearch -all -inline -regexp [split $data \n] $pattern]
} }
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 .punkrepo_$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 {TMPDIR TEMP TMP} {
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]"
}
#todo - review
proc ensure-cleanup {path} {
#::atexit [lambda {path} {
#file delete -force $path
#} [norm $path]]
file delete -force $path
}
proc path_relative {base dst} {
#see also kettle
# Modified copy of ::fileutil::relative (tcllib)
# Adapted to 8.5 ({*}).
#
# Taking two _directory_ paths, a base and a destination, computes the path
# of the destination relative to the base.
#
# Arguments:
# base The path to make the destination relative to.
# dst The destination path
#
# Results:
# The path of the destination, relative to the base.
# Ensure that the link to directory 'dst' is properly done relative to
# the directory 'base'.
if {[file pathtype $base] ne [file pathtype $dst]} {
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
}
set base [norm $base]
set dst [norm $dst]
set save $dst
set base [file split $base]
set dst [file split $dst]
while {[lindex $dst 0] eq [lindex $base 0]} {
set dst [lrange $dst 1 end]
set base [lrange $base 1 end]
if {![llength $dst]} {break}
}
set dstlen [llength $dst]
set baselen [llength $base]
if {($dstlen == 0) && ($baselen == 0)} {
# Cases:
# (a) base == dst
set dst .
} else {
# Cases:
# (b) base is: base/sub = sub
# dst is: base = {}
# (c) base is: base = {}
# dst is: base/sub = sub
while {$baselen > 0} {
set dst [linsert $dst 0 ..]
incr baselen -1
}
set dst [file join {*}$dst]
}
return $dst
}
#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]}]
}
proc norm {path {platform env}} {
#kettle::path::norm
#see also wiki
#full path normalization
set platform [string tolower $platform]
if {$platform eq "env"} {
set platform $::tcl_platform(platform)
}
if {$platform eq "windows"} {
return [file dirname [file normalize [punk::winpath::winpath $path]/__]]
} else {
return [file dirname [file normalize $path/__]]
}
}
#This taken from kettle::path::strip
#It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan
#renamed to better indicate its behaviour
proc path_strip_prefixdepth {path prefix} {
return [file join \
{*}[lrange \
[file split [norm $path]] \
[llength [file split [norm $prefix]]] \
end]]
}
proc fcat {args} {
if {$::tcl_platform(platform) ne "windows"} {
return [fileutil::cat {*}$args]
}
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) != 0} {
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"
set finalpaths [list]
foreach p $paths {
if {[punk::winpath::illegalname_test $p]} {
lappend finalpaths [punk::winpath::illegalname_fix $p]
} else {
lappend finalpaths $p
}
}
fileutil::cat {*}$opts {*}$finalpaths
}
interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil {} ::punk::repo::is_fossil
interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root
interp alias {} find_fossil {} ::punk::repo::find_fossil interp alias {} find_fossil {} ::punk::repo::find_fossil

4
src/modules/punk/winpath-999999.0a1.0.tm

@ -59,8 +59,10 @@ namespace eval punk::winpath {
if {[regexp $re_slash_x_slash $path _ letter]} { if {[regexp $re_slash_x_slash $path _ letter]} {
#upper case appears to be windows canonical form #upper case appears to be windows canonical form
set path [string toupper $letter]:/[string range $path 3 end] set path [string toupper $letter]:/[string range $path 3 end]
} elseif {[regexp {^/mnt|MNT/([[:alpha:]]){1}/.*} $path _ letter]} { } elseif {[regexp {^/mnt/([[:alpha:]]){1}/.*} [string tolower $path] _ letter]} {
set path [string toupper $letter]:/[string range $path 7 end] set path [string toupper $letter]:/[string range $path 7 end]
} elseif {[regexp {^/mnt/([[:alpha:]]){1}$} [string tolower $path] _ letter]} {
set path [string toupper $letter]:/
} elseif {[regexp $re_slash_else $path _ firstpart remainder]} { } elseif {[regexp $re_slash_else $path _ firstpart remainder]} {
#could be for example /c or /something/users #could be for example /c or /something/users
if {[string length $firstpart] == 1} { if {[string length $firstpart] == 1} {

28
src/scriptapps/dtplite.tcl

@ -0,0 +1,28 @@
#! /usr/bin/env tclsh
# -*- tcl -*-
# @@ Meta Begin
# Application dtplite 1.0.5
# Meta platform tcl
# Meta summary Lightweight DocTools Processor
# Meta description This application is a simple processor
# Meta description for documents written in the doctools
# Meta description markup language. It covers the most
# Meta description common use cases, but is not as
# Meta description configurable as its big brother dtp.
# Meta category Processing doctools documents
# Meta subject doctools doctoc docidx
# Meta require {dtplite 1.0.5}
# Meta author Andreas Kupries
# Meta license BSD
# @@ Meta End
package require dtplite 1.0.5
# dtp lite - Lightweight DocTools Processor
# ======== = ==============================
exit [dtplite::do $argv]
# ### ### ### ######### ######### #########
exit

0
src/fetchruntime.ps1 → src/scriptapps/fetchruntime.ps1

0
src/deps/dictutils-0.2.tm → src/vendormodules/dictutils-0.2.tm

0
src/deps/metaface-1.2.5.tm → src/vendormodules/metaface-1.2.5.tm

1883
src/vendormodules/natsort-0.1.1.5.tm

File diff suppressed because it is too large Load Diff

195
src/vendormodules/oolib-0.1.tm

@ -0,0 +1,195 @@
#JMN - api should be kept in sync with package patternlib where possible
#
package provide oolib [namespace eval oolib {
variable version
set version 0.1
}]
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]} {
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 [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?
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 {} {
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
}
}
}

0
src/deps/pattern-1.2.4.tm → src/vendormodules/pattern-1.2.4.tm

0
src/deps/patterncmd-1.2.4.tm → src/vendormodules/patterncmd-1.2.4.tm

0
src/deps/patternlib-1.2.6.tm → src/vendormodules/patternlib-1.2.6.tm

0
src/deps/patternpredator2-1.2.4.tm → src/vendormodules/patternpredator2-1.2.4.tm

Loading…
Cancel
Save