Browse Source

template system changes, overtype, blocktext, fossil, pmix to deck

master
Julian Noble 11 months ago
parent
commit
e994ec51b6
  1. 6
      src/bootsupport/include_modules.config
  2. 40
      src/bootsupport/modules/mime-1.7.1.tm
  3. 8
      src/bootsupport/modules/natsort-0.1.1.5.tm
  4. 442
      src/bootsupport/modules/overtype-1.5.1.tm
  5. 1037
      src/bootsupport/modules/overtype-1.5.3.tm
  6. 43
      src/bootsupport/modules/punk/cap-0.1.0.tm
  7. 637
      src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  8. 4
      src/bootsupport/modules/punk/du-0.1.0.tm
  9. 437
      src/bootsupport/modules/punk/encmime-0.1.0.tm
  10. 7
      src/bootsupport/modules/punk/mix-0.2.tm
  11. 71
      src/bootsupport/modules/punk/mix/base-0.1.tm
  12. 50
      src/bootsupport/modules/punk/mix/cli-0.3.tm
  13. 9
      src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  14. 198
      src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm
  15. 2
      src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm
  16. 195
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  17. 143
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  18. 328
      src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm
  19. 1150
      src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  20. 24
      src/bootsupport/modules/punk/mix/templates-0.1.0.tm
  21. 0
      src/bootsupport/modules/punk/mix/templates/layout_refs/project@vendor+punk+project-0.1.ref
  22. 3
      src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt
  23. 10
      src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt
  24. 7
      src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat
  25. 0
      src/bootsupport/modules/punk/mix/templates/utility/multishell.cmd
  26. 256
      src/bootsupport/modules/punk/mix/templates/utility/multishell.ps1
  27. 270
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd
  28. 0
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat
  29. 661
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  30. 524
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd
  31. 270
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell-old.cmd
  32. 661
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd
  33. 524
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell1.cmd
  34. 112
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat
  35. 104
      src/bootsupport/modules/punk/mix/templates/utility/shellbat.txt
  36. 106
      src/bootsupport/modules/punk/mix/templates/utility/shellbat_v1.txt
  37. 3
      src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt
  38. 8
      src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat
  39. 19
      src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat
  40. 19
      src/bootsupport/modules/punk/mix/util-0.1.0.tm
  41. 38
      src/bootsupport/modules/punk/ns-0.1.0.tm
  42. 74
      src/bootsupport/modules/punk/path-0.1.0.tm
  43. 357
      src/bootsupport/modules/punk/repo-0.1.1.tm
  44. 35
      src/bootsupport/modules/punkcheck-0.1.0.tm
  45. 1508
      src/bootsupport/modules/smtp-1.5.1.tm
  46. 2
      src/build.tcl
  47. 0
      src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.shell-0.1.ref
  48. 0
      src/decktemplates/custom/_project/layout_refs/test1@vendor+punk+sample-0.1.ref
  49. 0
      src/decktemplates/vendor/_project/layout_refs/@vendor+_project+punk.shell-0.1.ref
  50. 0
      src/decktemplates/vendor/_project/layout_refs/test2@vendor+punk+sample-0.1.ref
  51. 0
      src/decktemplates/vendor/punk/layout_refs/@vendor+punk+basic.ref
  52. 0
      src/decktemplates/vendor/punk/layout_refs/@vendor+punk+minimal.ref
  53. 0
      src/decktemplates/vendor/punk/layout_refs/@vendor+punk+sample-0.1.ref
  54. 0
      src/decktemplates/vendor/punk/layout_refs/project@vendor+punk+project-0.1.ref
  55. 9
      src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
  56. 140
      src/make.tcl
  57. 1
      src/mixtemplates/layouts/basic/src/bootsupport/README.md
  58. 200
      src/mixtemplates/layouts/basic/src/bootsupport/modules/cksum-1.1.4.tm
  59. 933
      src/mixtemplates/layouts/basic/src/bootsupport/modules/cmdline-1.5.2.tm
  60. 2311
      src/mixtemplates/layouts/basic/src/bootsupport/modules/fileutil-1.16.1.tm
  61. 5457
      src/mixtemplates/layouts/basic/src/bootsupport/modules/http-2.10b1.tm
  62. 1886
      src/mixtemplates/layouts/basic/src/bootsupport/modules/natsort-0.1.1.5.tm
  63. 195
      src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm
  64. 663
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm
  65. 52
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm
  66. 52
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm
  67. 145
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  68. 71
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/docgen-0.1.0.tm
  69. 1284
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/du-0.1.0.tm
  70. 21
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm
  71. 910
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm
  72. 925
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/cli-0.3.tm
  73. 152
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm
  74. 92
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm
  75. 286
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  76. 188
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm
  77. 529
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm
  78. 419
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  79. 983
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  80. 92
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm
  81. 681
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  82. 84
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm
  83. 350
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/util-0.1.0.tm
  84. 1698
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/ns-0.1.0.tm
  85. 159
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm
  86. 397
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/path-0.1.0.tm
  87. 1267
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/repo-0.1.1.tm
  88. 104
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/tdl-0.1.0.tm
  89. 266
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/winpath-0.1.0.tm
  90. 1962
      src/mixtemplates/layouts/basic/src/bootsupport/modules/punkcheck-0.1.0.tm
  91. 189
      src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/set-2.2.3.tm
  92. 189
      src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets.tcl
  93. 93
      src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_c.tcl
  94. 452
      src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_tcl.tcl
  95. 80
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil-0.9.tm
  96. 761
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/adjust-0.7.3.tm
  97. 902
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/dehypht.tex
  98. 1104
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/eshyph_vo.tex
  99. 1122
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/expander-1.3.1.tm
  100. 223
      src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/ithyph.tex
  101. Some files were not shown because too many files have changed in this diff Show More

6
src/bootsupport/include_modules.config

@ -1,4 +1,5 @@
#each entry - base module
set bootsupport_modules [list\
src/vendormodules cksum\
src/vendormodules natsort\
@ -30,11 +31,12 @@ set bootsupport_modules [list\
modules punk::mix::commandset::scriptwrap\
modules punk::overlay\
modules punk::repo\
modules punk::encmime\
modules punk::tdl\
modules punk::winpath\
]
#Don't include punk/mix/templates - recursive bootsupport problem!
#each entry - base subpath
set bootsupport_module_folders [list\
modules punk/mix/templates
]

40
src/mixtemplates/layouts/basic/src/bootsupport/modules/mime-1.7.0.tm → src/bootsupport/modules/mime-1.7.1.tm

@ -23,7 +23,7 @@
# new string features and inline scan are used, requiring 8.3.
package require Tcl 8.5
package provide mime 1.7.0
package provide mime 1.7.1
package require tcl::chan::memchan
@ -681,7 +681,7 @@ proc ::mime::parsepart {token} {
}
if {!$blankP && [string match *\r $line]} {
set line [string range $line 0 $x-2]]
set line [string range $line 0 $x-2]
if {$x == 1} {
set blankP 1
}
@ -1340,12 +1340,19 @@ proc ::mime::getsize {token} {
proc ::mime::getContentType token {
variable $token
upvar 0 $token state
set boundary {}
set res $state(content)
set boundary {}
foreach {k v} $state(params) {
set boundary $v
if {$k eq {boundary}} {
set boundary $v
}
append res ";\n $k=\"$v\""
}
# Save boundary separate from the params
set state(boundary) $boundary
if {([string match multipart/* $state(content)]) \
&& ($boundary eq {})} {
# we're doing everything in one pass...
@ -1356,6 +1363,8 @@ proc ::mime::getContentType token {
}
set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
set state(boundary) $boundary
append res ";\n boundary=\"$boundary\""
}
return $res
@ -1397,7 +1406,7 @@ proc ::mime::getheader {token {key {}}} {
lappend result MIME-Version $state(version)
foreach lower $state(lowerL) mixed $state(mixedL) {
foreach value $header($lower) {
lappend result $mixed $value
lappend result $mixed $value
}
}
set tencoding [getTransferEncoding $token]
@ -1878,18 +1887,12 @@ proc ::mime::copymessageaux {token channel} {
array set header $state(header)
set boundary {}
set result {}
foreach {mixed value} [getheader $token] {
puts $channel "$mixed: $value"
}
foreach {k v} $state(params) {
if {$k eq {boundary}} {
set boundary $v
}
}
set boundary $state(boundary) ;# computed by `getheader`
set converter {}
set encoding {}
@ -1916,17 +1919,6 @@ proc ::mime::copymessageaux {token channel} {
}
}
}
} elseif {([string match multipart/* $state(content)]) \
&& ($boundary eq {})} {
# we're doing everything in one pass...
set key [clock seconds]$token[info hostname][array get state]
set seqno 8
while {[incr seqno -1] >= 0} {
set key [md5 -- $key]
}
set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
puts $channel ";\n boundary=\"$boundary\""
}
if {[info exists state(error)]} {
@ -2072,7 +2064,7 @@ proc ::mime::copymessageaux {token channel} {
# token The MIME token to parse.
#
# Results:
# The message.
# The message.
proc ::mime::buildmessage token {
global errorCode errorInfo

8
src/bootsupport/modules/natsort-0.1.1.5.tm

@ -238,8 +238,13 @@ namespace eval natsort {
#considered using hex to make large numbers more compact for viewing in debug output - but it's not that much shorter and probably obscures more than it helps.
proc hex2dec {largeHex} {
#todo - use punk::lib::hex2dec - (scan supports ll so can do larger hex values directly)
set res 0
set largeHex [string map [list _ ""] $largeHex]
if {[string length $largeHex] <=7} {
#scan can process up to FFFFFFF and does so quickly
return [scan $largeHex %x]
}
foreach hexDigit [split $largeHex {}] {
set new 0x$hexDigit
set res [expr {16*$res + $new}]
@ -249,6 +254,8 @@ namespace eval natsort {
proc dec2hex {decimalNumber} {
format %4.4llX $decimalNumber
}
#punk::lib::trimzero
proc trimzero {number} {
set trimmed [string trimleft $number 0]
if {[string length $trimmed] == 0} {
@ -382,6 +389,7 @@ namespace eval natsort {
}
proc get_char_count {str char} {
#faster than lsearch on split for str of a few K
expr {[string length $str]-[string length [string map [list $char {}] $str]]}
}

442
src/vendormodules/overtype-1.5.0.tm → src/bootsupport/modules/overtype-1.5.1.tm

@ -7,23 +7,69 @@
# (C) Julian Noble 2003-2023
#
# @@ Meta Begin
# Application overtype 1.5.0
# Application overtype 1.5.1
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin overtype_module_overtype 0 1.5.1]
#[copyright "2024"]
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}]
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}]
#[require overtype]
#[keywords module text ansi]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of overtype
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by overtype
#[list_begin itemized]
package require Tcl 8.6
package require textutil
package require punk::ansi ;#required to detect, split, strip and calculate lengths
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package textutil]
#[item] [package punk::ansi]
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes
#[item] [package punk::char]
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
#Julian Noble <julian@precisium.com.au> - 2003
#Released under standard 'BSD license' conditions.
@ -83,183 +129,69 @@ namespace eval overtype {
}
#candidate for zig/c implementation?
proc overtype::stripansi {text} {
variable escape_terminals ;#dict
variable ansi_2byte_codes_dict
#important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
if {[string first \033 $text] <0 && [string first \009c $text] <0} {
#\033 same as \x1b
return $text
}
set text [convert_g0 $text]
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
#line endings can theoretically occur within an ansi escape sequence (review e.g title?)
set inputlist [split $text ""]
set outputlist [list]
set 2bytecodes [dict values $ansi_2byte_codes_dict]
set in_escapesequence 0
#assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
set i 0
foreach u $inputlist {
set v [lindex $inputlist $i+1]
set uv ${u}${v}
if {$in_escapesequence eq "2b"} {
#2nd byte - done.
set in_escapesequence 0
} elseif {$in_escapesequence != 0} {
set escseq [dict get $escape_terminals $in_escapesequence]
if {$u in $escseq} {
set in_escapesequence 0
} elseif {$uv in $escseq} {
set in_escapseequence 2b ;#flag next byte as last in sequence
}
} else {
#handle both 7-bit and 8-bit CSI and OSC
if {[regexp {^(?:\033\[|\u009b)} $uv]} {
set in_escapesequence CSI
} elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
set in_escapesequence OSC
} elseif {$uv in $2bytecodes} {
#self-contained e.g terminal reset - don't pass through.
set in_escapesequence 2b
} else {
lappend outputlist $u
}
}
incr i
}
return [join $outputlist ""]
}
#review
#todo - map other chars to unicode equivs
proc overtype::convert_g0 {text} {
#using not \033 inside to stop greediness - review how does it compare to ".*?"
set re {\033\(0[^\033]*\033\(B}
set re2 {\033\(0(.*)\033\(B} ;#capturing
set parts [ta::_perlish_split $re $text]
set out ""
foreach {pt g} $parts {
append out $pt
if {$g ne ""} {
#puts --$g--
#box sample
#lqk
#x x
#mqj
#m = boxd_lur
#set map [list l \u250f k \u2513] ;#heavy
set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light
regexp $re2 $g _match contents
append out [string map $map $contents]
}
}
return $out
}
#todo - convert esc(0 graphics sequences to single char unicode equivalents e.g box drawing set
# esc) ??
proc overtype::stripansi_gx {text} {
#e.g "\033(0" - select VT100 graphics for character set G0
#e.g "\033(B" - reset
#e.g "\033)0" - select VT100 graphics for character set G1
#e.g "\033)X" - where X is any char other than 0 to reset ??
return [convert_g0 $text]
}
#This shouldn't be called on text containing ansi codes!
proc overtype::strip_nonprinting_ascii {str} {
#review - some single-byte 'control' chars have visual representations e.g ETX as heart
#It is currently used for screen display width calculations
#equivalent for various unicode combining chars etc?
set map [list\
\007 ""\
[format %c 0] ""\
[format %c 0x7f] ""\
]
return [string map $map $str]
}
#length of text for printing characters only
#review - unicode and other non-printing chars and combining sequences?
#certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names
#review - is there an existing library or better method? print to a terminal and query cursor position?
#Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first
#If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string.
proc overtype::printing_length {line} {
if {[string first \n $line] >= 0} {
error "line_print_length must not contain newline characters"
}
#proc overtype::stripansi {text} {
# variable escape_terminals ;#dict
# variable ansi_2byte_codes_dict
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway
# if {[string first \033 $text] <0 && [string first \009c $text] <0} {
# #\033 same as \x1b
# return $text
# }
#
# set text [convert_g0 $text]
#
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character.
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?)
# set inputlist [split $text ""]
# set outputlist [list]
#
# set 2bytecodes [dict values $ansi_2byte_codes_dict]
#
# set in_escapesequence 0
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls
# set i 0
# foreach u $inputlist {
# set v [lindex $inputlist $i+1]
# set uv ${u}${v}
# if {$in_escapesequence eq "2b"} {
# #2nd byte - done.
# set in_escapesequence 0
# } elseif {$in_escapesequence != 0} {
# set escseq [dict get $escape_terminals $in_escapesequence]
# if {$u in $escseq} {
# set in_escapesequence 0
# } elseif {$uv in $escseq} {
# set in_escapseequence 2b ;#flag next byte as last in sequence
# }
# } else {
# #handle both 7-bit and 8-bit CSI and OSC
# if {[regexp {^(?:\033\[|\u009b)} $uv]} {
# set in_escapesequence CSI
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} {
# set in_escapesequence OSC
# } elseif {$uv in $2bytecodes} {
# #self-contained e.g terminal reset - don't pass through.
# set in_escapesequence 2b
# } else {
# lappend outputlist $u
# }
# }
# incr i
# }
# return [join $outputlist ""]
#}
#review -
set line [stripansi $line]
set line [strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi
#backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter
#(* more correctly - moves cursor back)
#backspace will not move beyond a preceding newline - but we have disallowed newlines for this function already
#leading backspaces will eat into any string (even prompt in non-standard tclsh shell) that is prepended to the line
# - but for the purposes of overtype we wouldn't want that - so we strip it here in the length calculation and should strip leading backspaces in the actual data concatenation operations too.
#curiously - a backspace sequence at the end of a string also doesn't reduce the printing width - so we can also strip from RHS
#Note that backspace following a \t will only shorten the string by one (ie it doesn't move back the whole tab width like it does interactively in the terminal)
#for this reason - it would seem best to normalize the tabs to spaces prior to performing the backspace calculation - otherwise we won't account for the 'short' tabs it effectivley produces
#normalize tabs to an appropriate* width
#*todo - handle terminal/context where tabwidth != the default 8 spaces
set line [textutil::tabify::untabify2 $line]
set bs [format %c 0x08]
#set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect
set line [string trim $line $bs]
set n 0
set chars [split $line ""]
#build an output
set idx 0
set outchars [list]
set outsizes [list]
foreach c $chars {
if {$c eq $bs} {
if {$idx > 0} {
incr idx -1
}
} elseif {$c eq "\r"} {
set idx 0
} else {
priv::printing_length_addchar $idx $c
incr idx
}
}
set line2 [join $outchars ""]
return [punk::char::string_width $line2]
}
proc overtype::string_columns {text} {
if {[punk::ansi::ta::detect $text]} {
error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with overtype::stripansi. Alternatively try overtype::printing_length"
error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length"
}
return [punk::char::string_width $text]
}
namespace eval overtype::priv {
proc printing_length_addchar {i c} {
upvar outchars outc
upvar outsizes outs
set nxt [llength $outc]
if {$i < $nxt} {
lset outc $i $c
} else {
lappend outc $c
}
}
}
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r
proc overtype::left {args} {
@ -299,13 +231,13 @@ proc overtype::left {args} {
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set undertext_printlen [printing_length $undertext]
set overlen [printing_length $overtext]
set undertext_printlen [punk::ansi::printing_length $undertext]
set overlen [punk::ansi::printing_length $overtext]
set diff [expr {$overlen - $colwidth}]
#review
@ -387,46 +319,53 @@ proc overtype::centre {args} {
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set olen [printing_length $overtext]
set ulen [printing_length $undertext]
#set olen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
}
#review
append overtext "\033\[0m"
#append overtext "\033\[0m"
set diff [expr {$colwidth - $olen}]
if {$diff > 0} {
set under_exposed [expr {$colwidth - $overblock_width}]
if {$under_exposed > 0} {
#background block is wider
set half [expr {round(int($diff / 2))}]
if {[string match right [dict get $opts -bias]]} {
if {[expr {2 * $half}] < $diff} {
incr half
if {$under_exposed % 2 == 0} {
#even left/right exposure
set left_exposed [expr {$under_exposed / 2}]
} else {
set beforehalf [expr {$under_exposed / 2}] ;#1 less than half due to integer division
if {[string tolower [dict get $opts -bias]] eq "left"} {
set left_exposed $beforehalf
} else {
#bias to the right
set left_exposed [expr {$beforehalf + 1}]
}
}
if 0 {
set rhs [expr {$diff - $half - 1}]
set lhs [expr {$half - 1}]
set rhsoffset [expr {$rhs +1}]
if 0 {
set a [string range $undertext 0 $lhs]
set background [string range $undertext $lhs+1 end-$rhsoffset]
set b [renderline -transparent $opt_transparent $background $overtext]
set c [string range $undertext end-$rhs end]
lappend outputlines $a$b$c
}
lappend outputlines [renderline -start $lhs -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
lappend outputlines [renderline -start $left_exposed -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext]
} else {
#overlay wider or equal
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext]
if {$diff < 0} {
if {$under_exposed < 0} {
#overlay is wider - trim if overflow not specified in opts
if {![dict get $opts -overflow]} {
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]]
@ -436,7 +375,7 @@ proc overtype::centre {args} {
}
}
} else {
#widths match
#zero under_exposed - widths match
}
lappend outputlines $rendered
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext]
@ -485,13 +424,13 @@ proc overtype::right {args} {
set overblock [string map $norm $overblock]
set underlines [split $underblock \n]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {printing_length $v}]]
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]]
set overlines [split $overblock \n]
set outputlines [list]
foreach undertext $underlines overtext $overlines {
set olen [printing_length $overtext]
set ulen [printing_length $undertext]
set olen [punk::ansi::printing_length $overtext]
set ulen [punk::ansi::printing_length $undertext]
if {$ulen < $colwidth} {
set udiff [expr {$colwidth - $ulen}]
set undertext "$undertext[string repeat { } $udiff]"
@ -547,7 +486,7 @@ namespace eval overtype::piper {
interp alias "" piper_renderline "" overtype::piper::renderline
#-returnextra to enable returning of overflow and length
# todo - use ta::detect to short-circuit processing and do simple string calcs as an optimisation?
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation?
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements
#todo - review transparency issues with single/double width characters!
proc overtype::renderline {args} {
@ -905,9 +844,10 @@ namespace eval overtype::priv {
# -- --- --- --- --- --- --- --- --- --- ---
if 0 {
namespace eval overtype::ta {
namespace path ::overtype
#*based* on but not identical to:
# *based* on but not identical to:
#https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#handle both 7-bit and 8-bit csi
@ -934,45 +874,28 @@ namespace eval overtype::ta {
#detect any ansi escapes
#review - only detect 'complete' codes - or just use the opening escapes for performance?
proc detect {text} {
variable re_ansi_detect
#variable re_csi_open
#variable re_esc_osc1
#variable re_esc_osc2
#todo - other escape sequences
#expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]}
expr {[regexp $re_ansi_detect $text]}
}
#proc detect {text} {
# variable re_ansi_detect
# #variable re_csi_open
# #variable re_esc_osc1
# #variable re_esc_osc2
# #todo - other escape sequences
# #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]}
# expr {[regexp $re_ansi_detect $text]}
#}
#not in perl ta
proc detect_csi {text} {
variable re_csi_colour
expr {[regexp $re_csi_colour $text]}
}
#proc detect_csi {text} {
# variable re_csi_colour
# expr {[regexp $re_csi_colour $text]}
#}
proc strip {text} {
tailcall stripansi $text
tailcall punk::ansi::stripansi $text
}
#note this is character length after stripping ansi codes - not the printing length
proc length {text} {
string length [overtype::stripansi $text]
}
#todo - handle newlines
#not in perl ta
proc printing_length {text} {
string length [punk::ansi::stripansi $text]
}
proc trunc {text width args} {
}
#not in perl ta
#returns just the plaintext portions in a list
proc split_at_codes {text} {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
textutil::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
}
# -- --- --- --- --- ---
#Split $text to a list containing alternating ANSI color codes and text.
@ -987,43 +910,41 @@ namespace eval overtype::ta {
#ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"}
#ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"}
#
proc split_codes {text} {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+"
return [_perlish_split $re $text]
}
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds)
proc split_codes_single {text} {
variable re_esc_osc1
variable re_esc_osc2
variable re_csi_code
set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
return [_perlish_split $re $text]
}
#review - tcl greedy expressions may match multiple in one element
proc _perlish_split {re text} {
if {[string length $text] == 0} {
return {}
}
set list [list]
set start 0
while {[regexp -start $start -indices -- $re $text match]} {
lassign $match matchStart matchEnd
lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd]
set start [expr {$matchEnd+1}]
}
lappend list [string range $text $start end]
return $list
}
proc _ws_split {text} {
regexp -all -inline {(?:\S+)|(?:\s+)} $text
}
# -- --- --- --- --- ---
#proc split_codes {text} {
# variable re_esc_osc1
# variable re_esc_osc2
# variable re_csi_code
# set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+"
# return [_perlish_split $re $text]
#}
##like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds)
#proc split_codes_single {text} {
# variable re_esc_osc1
# variable re_esc_osc2
# variable re_csi_code
# set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}"
# return [_perlish_split $re $text]
#}
##review - tcl greedy expressions may match multiple in one element
#proc _perlish_split {re text} {
# if {[string length $text] == 0} {
# return {}
# }
# set list [list]
# set start 0
# while {[regexp -start $start -indices -- $re $text match]} {
# lassign $match matchStart matchEnd
# lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd]
# set start [expr {$matchEnd+1}]
# }
# lappend list [string range $text $start end]
# return $list
#}
## -- --- --- --- --- ---
}
} ;# end if 0
# -- --- --- --- --- --- --- --- --- --- ---
namespace eval overtype {
@ -1034,6 +955,9 @@ namespace eval overtype {
## Ready
package provide overtype [namespace eval overtype {
variable version
set version 1.5.0
set version 1.5.1
}]
return
return
#*** !doctools
#[manpage_end]

1037
src/bootsupport/modules/overtype-1.5.3.tm

File diff suppressed because it is too large Load Diff

43
src/bootsupport/modules/punk/cap-0.1.0.tm

@ -232,6 +232,7 @@ namespace eval punk::cap {
#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
@ -245,7 +246,8 @@ namespace eval punk::cap {
#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 ""} {
error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr"
puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr"
return
}
#assert: 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.
dict set caps $capname handler $capnamespace
@ -262,7 +264,13 @@ namespace eval punk::cap {
if {$cn ne $capname} {
continue
}
set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist]
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 [dict get $pkgcapsaccepted $pkg]
if {$do_register} {
if {$capspec ni $list_accepted} {
@ -337,7 +345,7 @@ namespace eval punk::cap {
}
#register package with arbitrary capnames from capabilitylist
#The registered pkg is a module that provides some service to that capname. Possibly just data members, that the capability will use.
#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
@ -370,6 +378,10 @@ namespace eval punk::cap {
#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
@ -379,16 +391,23 @@ namespace eval punk::cap {
}
}
if {[llength $capname] !=1} {
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'"
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 [dict create msg $reason capspec $capspec]
continue
}
if {[expr {[llength $capdict] %2 != 0}]} {
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'"
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 [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 [dict create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec]
continue
}
if {[dict exists $caps $capname]} {
@ -424,6 +443,14 @@ namespace eval punk::cap {
} else {
dict set pkgcapsdeclared $pkg $capabilitylist
}
set resultdict [list num_capabilities $capabilitylist_count num_accepted $accepted_count]
if {[llength $errorlist]} {
dict set resultdict errors $errorlist
}
if {[llength $warninglist]} {
dict set resultdict warnings $warninglist
}
return $resultdict
}
#todo!
@ -460,7 +487,7 @@ namespace eval punk::cap {
}
}
proc pkgcap {pkg} {
proc pkgcap {pkg {capsearch}} {
variable pkgcapsdeclared
variable pkgcapsaccepted
if {[string match ::* $pkg]} {
@ -469,9 +496,9 @@ namespace eval punk::cap {
if {[dict exists $pkgcapsdeclared $pkg]} {
set accepted ""
if {[dict exists $pkgcapsaccepted $pkg]} {
set accepted [dict get $pkgcapsaccepted $pkg]
set accepted [lsearch -all -inline -glob -index 0 [dict get $pkgcapsaccepted $pkg] $capsearch]
}
return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted]
return [dict create declared [lsearch -all -inline -glob -index 0 [dict get $pkgcapsdeclared $pkg] $capsearch] accepted $accepted]
} else {
return
}

637
src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -18,7 +18,7 @@
## Requirements
##e.g package require frobz
package require punk::repo
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -43,39 +43,163 @@ namespace eval punk::cap::handlers::templates {
# -- --- --- --- --- --- --- ---- ---
# validation of capdict
# -- --- --- --- --- --- --- ---- ---
if {![dict exists $capdict relpath]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key"
if {![dict exists $capdict vendor]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'vendor' key"
return 0
}
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {![file exists $tmfile]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
if {![dict exists $capdict path] || ![dict exists $capdict pathtype]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'path' or 'pathtype' key"
return 0
}
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
if {![file isdirectory $tpath]} {
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
set pathtype [dict get $capdict pathtype]
set vendor [dict get $capdict vendor]
set known_pathtypes [list adhoc currentproject_multivendor currentproject shellproject_multivendor shellproject module absolute]
if {$pathtype ni $known_pathtypes} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but 'pathtype' value '$pathtype' is not recognised. Known type: $known_pathtypes"
return 0
}
set path [dict get $capdict path]
set cname [string map [list . _] $capname]
set multivendor_package_whitelist [list punk::mix::templates]
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called
#for template pathtype absolute - we can do the same.
#There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change.
#adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time.
#not all template item types will need projectbase information - as the item data may be self-contained within the template structure -
#but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly.
if {$pathtype eq "adhoc"} {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
} elseif {$pathtype eq "module"} {
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {![file exists $tmfile]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
return 0
}
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
}
set tmfolder [file dirname $tmfile]
#todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately
#set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
set projectinfo [punk::repo::find_repos $tmfolder]
set projectbase [dict get $projectinfo closest]
#store the projectbase even if it's empty string
set extended_capdict $capdict
set resolved_path [file join $tmfolder $path]
dict set extended_capdict resolved_path $resolved_path
dict set extended_capdict projectbase $projectbase
} elseif {$pathtype eq "currentproject_multivendor"} {
#currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense
if {$pkg ni $multivendor_package_whitelist} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but package is not in whitelist $multivendor_package_whitelist - 3rd party _multivendor tree not supported"
return 0
}
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set extended_capdict $capdict
dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor?
} elseif {$pathtype eq "currentproject"} {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
#verify that the relative path is within the relative path of a currentproject_multivendor tree
#todo - api for the _multivendor tree controlling package to validate
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
} elseif {$pathtype eq "shellproject"} {
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set projectinfo [punk::repo::find_repos $shellbase]
set projectbase [dict get $projectinfo closest]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
} elseif {$pathtype eq "shellproject_multivendor"} {
#currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense
if {$pkg ni $multivendor_package_whitelist} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but package is not in whitelist $multivendor_package_whitelist - 3rd party _multivendor tree not supported"
return 0
}
if {[file pathtype $path] ne "relative"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path"
return 0
}
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
set projectinfo [punk::repo::find_repos $shellbase]
set projectbase [dict get $projectinfo closest]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
} elseif {$pathtype eq "absolute"} {
if {[file pathtype $path] ne "absolute"} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be absolute"
return 0
}
set normpath [file normalize $path]
if {!file exists $normpath} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist"
return 0
}
set projectinfo [punk::repo::find_repos $normpath]
set projectbase [dict get $projectinfo closest]
#todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder
set extended_capdict $capdict
dict set extended_capdict resolved_path $normpath
dict set extended_capdict vendor $vendor
dict set extended_capdict projectbase $projectbase
} else {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype"
return 0
}
# -- --- --- --- --- --- --- ---- ---
# update package internal data
# -- --- --- --- --- --- --- ---- ---
upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info
if {$capname ni $::punk::cap::handlers::templates::handled_caps} {
lappend ::punk::cap::handlers::templates::handled_caps $capname
}
set cname [string map [list . _] $capname]
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders
dict lappend pfolders $pkg $tpath
if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} {
#this checks for duplicates from the same provider - but not if other providers already added the path
#review -
dict lappend provider_info $pkg $extended_capdict
}
# -- --- --- --- --- --- --- ---- ---
# instantiation of api at punk::cap::handlers::templates::api_$capname
# -- --- --- --- --- --- --- ---- ---
if {[info commands ::punk::cap::handlers::templates::$capname] eq ""} {
punk::cap::handlers::templates::class::api create ::punk::cap::handlers::templates::api_$capname $capname
set apicmd "::punk::cap::handlers::templates::api_$capname"
if {[info commands $apicmd] eq ""} {
punk::cap::handlers::templates::class::api create $apicmd $capname
}
return 1
@ -84,8 +208,8 @@ namespace eval punk::cap::handlers::templates {
upvar ::punk::cap::handlers::templates::handled_caps hcaps
foreach capname $hcaps {
set cname [string map [list . _] $capname]
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders
dict unset pfolders $pkg
upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info
dict unset my_provider_info $pkg
#destroy api objects?
}
}
@ -109,24 +233,491 @@ namespace eval punk::cap::handlers::templates {
set cname [string map [list . _] $capname]
set capabilityname $capname
}
method folders {} {
method folders {args} {
lassign [punk::args::opts_values {
-startdir -default ""
} $args -maxvalues 0] _o opts
set opt_startdir [dict get $opts -startdir]
if {$opt_startdir eq ""} {
set startdir [pwd]
} else {
if {[file pathtype $opt_startdir] eq "relative"} {
set startdir [file join [pwd] $opt_startdir]
} else {
set startdir $opt_startdir
}
}
variable capabilityname
variable cname
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders
upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info
package require punk::cap
set capinfo [punk::cap::capability $capabilityname]
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}}
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package
set pkgs [dict get $capinfo providers]
set providerpkg [dict get $capinfo providers]
set folderdict [dict create]
foreach pkg $pkgs {
foreach pfolder [dict get $pkg_folders $pkg] {
dict set folderdict $pfolder [list source $pkg sourcetype package]
#maintain separate paths for different override levels - all keyed on vendor (or pseudo-vendor '_project')
set found_paths_adhoc [dict create]
set found_paths_module [dict create]
set found_paths_currentproject_multivendor [dict create]
set found_paths_currentproject [dict create]
set found_paths_shellproject_multivendor [dict create]
set found_paths_shellproject [dict create]
set found_paths_absolute [list]
foreach pkg $providerpkg {
set found_paths [list]
#set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted]
foreach capdecl_extended [dict get $my_provider_info $pkg] {
#basic validation and extension was done when accepted - so we can trust the capdecl_extended dictionary has the right entries
set path [dict get $capdecl_extended path]
set pathtype [dict get $capdecl_extended pathtype]
set vendor [dict get $capdecl_extended vendor]
# projectbase not present in capdecl_extended for all template pathtypes
if {$pathtype eq "adhoc"} {
#e.g (cwd)/templates
set targetpath [file join $startdir [dict get $capdecl_extended path]]
if {[file isdirectory $targetpath]} {
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype]
}
} elseif {$pathtype eq "module"} {
set module_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot]
} elseif {$pathtype eq "currentproject_multivendor"} {
set searchbase $startdir
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
if {$pwd_projectroot ne ""} {
set deckbase [file join $pwd_projectroot $path]
if {![file exists $deckbase]} {
continue
}
#add vendor/x folders first - earlier in list is lower priority
set vendorbase [file join $deckbase vendor]
if {[file isdirectory $vendorbase]} {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype]
}
}
set custombase [file join $deckbase custom]
if {[file isdirectory $custombase]} {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype]
}
}
}
} elseif {$pathtype eq "currentproject"} {
set searchbase $startdir
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
if {$pwd_projectroot ne ""} {
#path relative to projectroot already validated by handler as being within a currentproject_multivendor tree
set targetfolder [file join $pwd_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype]
}
}
} elseif {$pathtype eq "shellproject_multivendor"} {
#review - consider also [info script] - but it can be empty if we just start a tclsh, load packages and start a repl
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
if {$shell_projectroot ne ""} {
set deckbase [file join $shell_projectroot $path]
if {![file exists $deckbase]} {
continue
}
#add vendor/x folders first - earlier in list is lower priority
set vendorbase [file join $deckbase vendor]
if {[file isdirectory $vendorbase]} {
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *]
foreach vf $vendorfolders {
if {$vf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot]
}
}
if {[file isdirectory [file join $vendorbase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot]
}
}
set custombase [file join $deckbase custom]
if {[file isdirectory $custombase]} {
set customfolders [glob -nocomplain -dir $custombase -type d -tails *]
foreach cf $customfolders {
if {$cf ne "_project"} {
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot]
}
}
if {[file isdirectory [file join $custombase _project]]} {
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot]
}
}
}
} elseif {$pathtype eq "shellproject"} {
#review - consider also [info script] - but it can be empty if we just start a tclsh, load packages and start a repl
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review
#set pathinfo [punk::repo::find_repos $shellbase]
#set pwd_projectroot [dict get $pathinfo closest]
set shell_projectroot [dict get $capdecl_extended projectbase]
if {$shell_projectroot ne ""} {
set targetfolder [file join $shell_projectroot $path]
if {[file isdirectory $targetfolder]} {
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot]
}
}
} elseif {$pathtype eq "absolute"} {
#lappend found_paths [dict get $capdecl_extended resolved_path]
set abs_projectroot [dict get $capdecl_extended projectbase]
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot]
}
}
#todo - ensure vendor pkg capdict elements such source and allowupdates override any existing entry from a _multivendor pkg?
#currently relying on order in which loaded? review
#foreach pfolder $found_paths {
# dict set folderdict $pfolder [list source $pkg sourcetype package]
#}
}
#add in order of preference low priority to high
dict for {vendor pathinfolist} $found_paths_module {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
}
}
#Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD)
dict for {vendor pathinfolist} $found_paths_shellproject_multivendor {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_shellproject {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_currentproject_multivendor {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_currentproject {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor]
}
}
dict for {vendor pathinfolist} $found_paths_absolute {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor]
}
}
#adhoc paths relative to cwd (or specified -startdir) can override any
dict for {vendor pathinfolist} $found_paths_adhoc {
foreach pathinfo $pathinfolist {
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor]
}
}
return $folderdict
}
method get_itemdict_projectlayouts {args} {
lassign [punk::args::opts_values {
-startdir -default ""
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
} $args -maxvalues -1 -anyopts 1] _o opts _v values
set opt_startdir [dict get $opts -startdir]
if {$opt_startdir eq ""} {
set searchbase [pwd]
} else {
set searchbase $opt_startdir
}
set refdict [my get_itemdict_projectlayoutrefs {*}$args]
set layoutdict [dict create]
set projectinfo [punk::repo::find_repos $searchbase]
set projectroot [dict get $projectinfo closest]
dict for {layoutname refinfo} $refdict {
set templatepathtype [dict get $refinfo sourceinfo pathtype]
set sourceinfo [dict get $refinfo sourceinfo]
set path [dict get $refinfo path]
set reftail [file tail $path]
set atparts [split [file rootname $reftail] @]
#may be two @s if referencing a renamed layout override?
# e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1
#there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @
#trim off first @ part
set tailats [join [lrange $atparts 1 end] @]
# @ parts after the first are part of the path within the project_layouts structure
set subpathlist [split $tailats +]
if {[dict exists $refinfo sourceinfo projectbase]} {
#some template pathtypes refer to the projectroot from the template - not the cwd
set projectroot [dict get $refinfo sourceinfo projectbase]
}
if {$projectroot ne ""} {
set layoutroot [file join $projectroot src/project_layouts]
set layoutfolder [file join $layoutroot {*}$subpathlist]
if {[file isdirectory $layoutfolder]} {
#todo - check if layoutname already in layoutdict append .ref path to list of refs that linked to this layout?
set layoutinfo [list path $layoutfolder basefolder $layoutroot sourceinfo $sourceinfo]
dict set layoutdict $layoutname $layoutinfo
}
}
}
return $layoutdict
}
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\
-command_get_items_from_base {apply {{base} {
set matched_files [glob -nocomplain -dir $base -type f *@*.ref]
set items [list]
foreach rf $matched_files {
#puts stderr "--> $rf"
if {[string match ignore* $rf]} {
continue
}
#we silently skip .ref files that don't match - todo - more verification - and warn of invalid .refs?
if {[string match *@vendor+* $rf] || [string match *@custom+* $rf]} {
lappend items $rf
}
}
return $items
}}}\
-command_get_item_name {apply {{vendor basefolder itempath} {
set itemtail [file rootname [file tail $itempath]]
set alias [lindex [split $itemtail @] 0]
if {$alias eq ""} {
set itemname [lindex [split $itemtail +] end]
} else {
set itemname $alias
}
if {$vendor ne "_project"} {
set itemname $vendor.$itemname
}
return $itemname
}}}
}
set arglist [concat $config $args]
my _get_itemdict {*}$arglist
}
method get_itemdict_scriptappwrappers {args} {
set config {
-templatefolder_subdir "utility/scriptappwrappers"\
-command_get_items_from_base {apply {{base} {
set matched_files [punk::path::treefilenames -dir $base *]
set wrappers [list]
foreach tf $matched_files {
if {[string match ignore* $tf]} {
continue
}
set ext [file extension $tf]
if {[string tolower $ext] in [list "" ".bat" ".cmd" ".sh" ".bash" ".pl" ".ps1" ".tcl"]} {
lappend wrappers $tf
}
}
return $wrappers
}}}\
-command_get_item_name {apply {{vendor basefolder itempath} {
set relativepath [punk::path::relative $basefolder $itempath]
set ftail [file tail $itempath]
set tname $relativepath
if {$vendor ne "_project"} {
set tname ${vendor}.$tname
}
return $tname
}}}
}
set arglist [concat $config $args]
my _get_itemdict {*}$arglist
}
method get_itemdict_moduletemplates {args} {
set config {
-templatefolder_subdir "modules"\
-command_get_items_from_base {apply {{base} {
set matched_files [punk::path::treefilenames -dir $base template_*.tm]
set tfiles [list]
foreach tf $matched_files {
if {[string match ignore* $tf]} {
continue
}
set ext [file extension $tf]
if {[string tolower $ext] in [list ".tm"]} {
#we will ignore any .tm files that don't have versions that tcl understands - but warn
#this reduces the cases we have to test later
set fname [file tail $tf]
lassign [split [punk::mix::cli::lib::split_modulename_version $fname]] mname ver
if {[catch {punk::mix::cli::lib::validate_modulename $mname} errM]} {
puts stderr "Invalid module name/version $tf - please rename with standard Tcl .tm module name and version (or leave out version)"
if {[string match *-* $mname]} {
puts stderr "Tcl module name cannot contain dash character - except between name and version"
}
} else {
lappend tfiles $tf
}
}
}
return $tfiles
}}}\
-command_get_item_name {apply {{vendor basefolder itempath} {
set relativepath [punk::path::relative $basefolder $itempath]
set dirs [file dirname $relativepath]
if {$dirs eq "."} {
set dirs ""
}
set moduleprefix [join $dirs ::]
set ftail [file rootname [file tail $itempath]]
set tname [string range $ftail [string length template_] end]
if {$moduleprefix ne ""} {
set tname ${moduleprefix}::$tname
}
if {$vendor ne "_project"} {
set tname ${vendor}.$tname
}
return $tname
}}}
}
set arglist [concat $config $args]
my _get_itemdict {*}$arglist
}
#shared algorithm for get_itemdict_* methods
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search
#and a file selection mechanism command -command_get_items_from_base
#and a name determining command -command_get_item_name
method _get_itemdict {args} {
lassign [punk::args::opts_values {
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
globsearches -default * -multiple 1
} $args -maxvalues -1] _o opts _v values
set globsearches [dict get $values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
# -- --- --- --- --- --- --- --- ---
set opt_startdir [dict get $opts -startdir]
set opt_templatefolder_subdir [dict get $opts -templatefolder_subdir]
if {[file pathtype $opt_templatefolder_subdir] ne "relative"} {
error templates::_get_itemdict
}
# -- --- --- --- --- --- --- --- ---
set opt_command_get_items_from_base [dict get $opts -command_get_items_from_base]
set opt_command_get_item_name [dict get $opts -command_get_item_name]
set opt_not [dict get $opts -not]
# -- --- --- --- --- --- --- --- ---
set itembases [list]
#set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_startdir]
set tbasedict [my folders -startdir $opt_startdir ]
#turn the dict into a list we can temporarily reverse sort while we expand the items from within each path
dict for {tbase folderinfo} $tbasedict {
lappend itembases [list basefolder [file join $tbase $opt_templatefolder_subdir] sourceinfo $folderinfo]
}
set items [list]
set itemdict [dict create]
set seen_dict [dict create]
#flip the priority order for layout folders encountered so we can set the trailing #<int> dup/overridden indicators
foreach baseinfo [lreverse $itembases] {
set basefolder [dict get $baseinfo basefolder]
set sourceinfo [dict get $baseinfo sourceinfo]
set vendor [dict get $sourceinfo vendor]
#call the custom script from our caller which determines resultset of files we are interested in
set matches [{*}$opt_command_get_items_from_base $basefolder]
set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only
foreach itempath $matches {
set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath]
dict set items_here $itemname [list item $itempath baseinfo $baseinfo]
#lappend items [list item $itempath baseinfo $baseinfo]
}
set ordered_names [lsort [dict keys $items_here]]
#add to the outer items list
foreach nm $ordered_names {
set iteminfo [dict get $items_here $nm]
lappend items [list originalname $nm iteminfo $iteminfo]
}
}
#append #n instance/duplicate name indicators based on cyling through entire list of found items
foreach itemrecord $items {
set oname [dict get $itemrecord originalname]
set iteminfo [dict get $itemrecord iteminfo]
set itempath [dict get $iteminfo item]
set baseinfo [dict get $iteminfo baseinfo]
if {![dict exists $seen_dict $oname]} {
dict set seen_dict $oname 1
dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number
} else {
set n [dict get $seen_dict $oname]
incr n
dict incr seen_dict $oname
dict set itemdict ${oname}#$n [list path $itempath {*}$baseinfo]
}
}
#assert path is first key of itemdict {callers are allowed to rely on it being first}
#assert itemdict has keys path,basefolder,sourceinfo
set result [dict create]
set keys [lreverse [dict keys $itemdict]]
foreach k $keys {
set maybe ""
foreach g $globsearches {
if {[string match $g $k]} {
set maybe $k
break
}
}
set not ""
if {$maybe ne ""} {
foreach n $opt_not {
if {[string match $n $k]} {
set not $k
break
}
}
}
if {$maybe ne "" && $not eq ""} {
dict set result $k [dict get $itemdict $k]
}
}
return $result
}
}
}

4
src/bootsupport/modules/punk/du-0.1.0.tm

@ -825,7 +825,7 @@ namespace eval punk::du {
]
set errors [dict create]
set known_opts [dict keys $defaults]
foreach k [dict keys $args] {
dict for {k -} $args {
if {$k ni $known_opts} {
error "du_dirlisting_generic unknown-option $k"
}
@ -1250,7 +1250,7 @@ namespace eval punk::du {
#experiment with csv as easy way to get column like format..
#The /r is somewhat cheating however.. as it messes up redirected output .. e.g if redirected to text file
interp alias {} du {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines <args|
interp alias {} du {} .=args>* punk::du::du |> .=>1 natsort::sort -cols 1 -outputformat csv -outputformatoptions {\r\t\t\t} |> list_as_lines -- <args|
}

437
src/bootsupport/modules/punk/encmime-0.1.0.tm

@ -0,0 +1,437 @@
# -*- 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]

7
src/bootsupport/modules/punk/mix-0.2.tm

@ -5,7 +5,12 @@ package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
punk::mix::templates::provider register *
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
}
package require punk::mix::base
package require punk::mix::cli

71
src/bootsupport/modules/punk/mix/base-0.1.tm

@ -69,6 +69,8 @@ namespace eval punk::mix::base {
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} {
@ -93,6 +95,16 @@ namespace eval punk::mix::base {
}
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
}
}
@ -269,7 +281,9 @@ namespace eval punk::mix::base {
}
#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 {
@ -357,59 +371,24 @@ namespace eval punk::mix::base {
}
#get_template_basefolders
# scriptpath - file or folder
# It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any
# 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 {{scriptpath ""}} {
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap)
set folderdict [dict create]
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]
dict for {dir folderinfo} $template_folder_dict {
dict set folderdict $dir $folderinfo
}
}
#2 middle precedence - mixtemplates folder relative to cwd
set searchbase [pwd]
set fld [file join $searchbase mixtemplates]
if {[file isdirectory $fld]} {
if {![dict exists $folderdict $fld]} {
dict set folderdict $fld [list source $searchbase sourcetype cwd]
}
}
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
if {$pwd_projectroot ne ""} {
set fld [file join $pwd_projectroot src/mixtemplates]
if {![dict exists $folderdict $fld]} {
dict set folderdict $fld [list source $pwd_projectroot sourcetype project]
}
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"
}
#3 highest precedence - mixtemplates relative to scriptpath argument
if {$scriptpath ne ""} {
if {[file type $scriptpath] eq "file"} {
set searchbase [file dirname $scriptpath]
} else {
set searchbase $scriptpath
}
if {[file isdirectory [file join $searchbase mixtemplates]]} {
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch]
}
set pathinfo [punk::repo::find_repos $searchbase]
set scriptpath_projectroot [dict get $pathinfo closest]
if {$scriptpath_projectroot ne ""} {
set fld [file join $scriptpath_projectroot src/mixtemplates]
if {[file isdirectory $fld]} {
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project]
}
}
}
#don't sort - order in which encountered defines the precedence - with later overriding earlier
return $folderdict
return $template_folder_dict
}
proc module_subpath {modulename} {

50
src/bootsupport/modules/punk/mix/cli-0.3.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
# 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.
@ -128,7 +128,7 @@ namespace eval punk::mix::cli {
#review - why can't we be anywhere in the project?
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} {
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])"
puts stderr "deck make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])"
if {[string length $project_base]} {
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} {
puts stderr "Try cd to $project_base/src"
@ -210,7 +210,7 @@ namespace eval punk::mix::cli {
proc validate_modulename {modulename args} {
set defaults [list\
-name_description modulename\
-errorprefix validate_modulename\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
@ -221,18 +221,18 @@ namespace eval punk::mix::cli {
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
set opt_errorprefix [dict get $opts -errorprefix]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description
validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix
set testname [string map [list :: ""] $modulename]
if {[string first : $testname] >=0} {
error "$opt_name_description '$modulename' can only contain paired colons"
error "$opt_errorprefix '$modulename' can only contain paired colons"
}
set badchars [list - "$" "?" "*"]
foreach bc $badchars {
if {[string first $bc $modulename] >= 0} {
error "$opt_name_description '$modulename' can not contain character '$bc'"
error "$opt_errorprefix '$modulename' can not contain character '$bc'"
}
}
return $modulename
@ -240,7 +240,7 @@ namespace eval punk::mix::cli {
proc validate_projectname {projectname args} {
set defaults [list\
-name_description projectname\
-errorprefix projectname\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
@ -251,21 +251,21 @@ namespace eval punk::mix::cli {
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
set opt_errorprefix [dict get $opts -errorprefix]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description
validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build]
if {$projectname in $reserved_words } {
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words"
error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words"
}
if {[string first "::" $projectname] >= 0} {
error "$opt_name_description '$projectname' cannot contain namespace separator '::'"
error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'"
}
return $projectname
}
proc validate_name_not_empty_or_spaced {name args} {
set defaults [list\
-name_description projectname\
-errorprefix projectname\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
@ -276,13 +276,13 @@ namespace eval punk::mix::cli {
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
set opt_errorprefix [dict get $opts -errorprefix]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
if {![string length $name]} {
error "$opt_name_description cannot be empty"
error "$opt_errorprefix cannot be empty"
}
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} {
error "$opt_name_description cannot contain whitespace"
error "$opt_errorprefix cannot contain whitespace"
}
return $name
}
@ -364,7 +364,7 @@ namespace eval punk::mix::cli {
if {"project" in $repotypes} {
#punk project
if {![catch {package require textblock; package require patternpunk}]} {
set result [textblock::join [textblock::join [>punk . logo] " "] $result]
set result [textblock::join [>punk . logo] " " $result]
append result \n
}
}
@ -727,8 +727,8 @@ namespace eval punk::mix::cli {
proc kettle_reinit {} {
variable kettle_reset_bodies
variable kettle_reset_args
foreach p [dict keys $kettle_reset_bodies] {
set b [dict get $kettle_reset_bodies $p]
dict for {p b} $kettle_reset_bodies {
#set b [dict get $kettle_reset_bodies $p]
set argl [dict get $kettle_reset_args $p]
uplevel 1 [list ::proc $p $argl $b]
}
@ -751,7 +751,7 @@ namespace eval punk::mix::cli {
gui\
]
#set ::kettle::recipe::recipe [dict create]
foreach r [dict keys $::kettle::recipe::recipe] {
dict for {r -} $::kettle::recipe::recipe {
if {$r ni $standard_recipes} {
dict unset ::kettle::recipe::recipe $r
}
@ -760,14 +760,14 @@ namespace eval punk::mix::cli {
proc kettle_call {calltype args} {
variable kettle_reset_bodies
if {$calltype ni [list lib shell]} {
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process"
error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process"
}
if {$calltype eq "shell"} {
set kettleappfile [file dirname [info nameofexecutable]]/kettle
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} {
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)"
error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)"
}
if {[file exists $kettleappfile]} {
set kettlescript $kettleappfile
@ -780,7 +780,7 @@ namespace eval punk::mix::cli {
}
set startdir [pwd]
if {![file exists $startdir/build.tcl]} {
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])"
error "deck kettle must be run from a folder containing build.tcl (cwd: [pwd])"
}
if {[package provide kettle] eq ""} {
puts stdout "Loading kettle package - may be delay on first load ..."
@ -797,7 +797,7 @@ namespace eval punk::mix::cli {
}
set first [lindex $args 0]
if {[string match @* $first]} {
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly"
error "deck kettle doesn't support special operations - try calling tclsh kettle directly"
}
if {$first eq "-f"} {
set args [lassign $args __ path]
@ -839,7 +839,7 @@ namespace eval punk::mix::cli {
--* {
#instead of using: kettle option known
if {$o ni $knownopts} {
error "Unable to process unknown option $o." {} [list KETTLE (pmix)]
error "Unable to process unknown option $o." {} [list KETTLE (deck)]
}
lappend opts $o [lindex $args 1]
#::kettle::option set $o [lindex $args 1]

9
src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm

@ -44,7 +44,7 @@ namespace eval punk::mix::commandset::doc {
}
#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 $projectdir/src/doc _module_*.man]
set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man]
foreach maybedoomed $oldfiles {
set fd [open $maybedoomed r]
set data [read $fd]
@ -93,7 +93,10 @@ namespace eval punk::mix::commandset::doc {
# -- --- --- --- --- ---
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
@ -213,7 +216,7 @@ namespace eval punk::mix::commandset::doc {
}
file mkdir $output_base
set matched_paths [punk::path::treefilenames $codesource_path *.tm -antiglob_paths {**/mix/templates/** **/mixtemplates/**}]
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/**} *.tm]
set count 0
set newdocs [list]
set docgen_header_comments ""

198
src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm

@ -18,6 +18,7 @@
## 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
@ -28,6 +29,7 @@ package require punk::mix::base
namespace eval punk::mix::commandset::layout {
namespace export *
#per layout functions
proc files {layout} {
set allfiles [lib::layout_all_files $layout]
@ -38,25 +40,17 @@ namespace eval punk::mix::commandset::layout {
return [join $templatefiles \n]
}
proc templatefiles.relative {layout} {
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set bases_containing_layout [list]
dict for {tbase folderinfo} $template_base_dict {
if {[file exists $tbase/layouts/$layout]} {
lappend bases_containing_layout $tbase
}
}
if {![llength $bases_containing_layout]} {
puts stderr "Unable to locate folder for layout '$layout'"
puts stderr "searched [dict size $template_base_dict] template folders"
set layoutdict [lib::layouts_dict]
if {![dict exists $layoutdict $layout]} {
puts stderr "layout '$layout' not found."
return
}
set tpldir [lindex $bases_containing_layout end]
set layoutinfo [dict get $layoutdict $layout]
set layoutfolder [dict get $layoutinfo path]
set layout_base $tpldir/layouts
set layout_dir [file join $layout_base $layout]
set stripprefix [file normalize $layout_dir]
set stripprefix [file normalize $layoutfolder]
set templatefiles [lib::layout_scan_for_template_files $layout]
set tails [list]
foreach templatefullpath $templatefiles {
@ -68,46 +62,150 @@ namespace eval punk::mix::commandset::layout {
#layout collection functions - to be imported with punk::overlay::import_commandset separately
namespace eval collection {
namespace export *
proc _default {{glob {}}} {
proc _defaultx {{glob {}}} {
if {![string length $glob]} {
set glob *
}
set layouts [list]
#set tplfolderdict [punk::cap::call_handler punk.templates folders]
set tplfolderdict [punk::mix::base::lib::get_template_basefolders]
dict for {tdir folderinfo} $tplfolderdict {
set layout_base $tdir/layouts
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names)
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]]
foreach match [lsearch -all -inline $all_layouts $glob] {
lappend layouts [list $match $folderinfo]
}
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]
}
proc _default {args} {
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 widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]]
set col(path) [string repeat " " $widest(path)]
set title(pathtype) "[a+ green]Path Type[a]"
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]]
set col(pathtype) [string repeat " " $widest(pathtype)]
set title(name) "Layout Name"
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]]
set col(name) [string repeat " " $widest(name)]
set vsep " | "
set vsep_w [string length $vsep] ;#unicode?
set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[textblock::join [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n
append table [string repeat - $tablewidth] \n
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
}
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]
}
return [join [lsort -index 0 $layouts] \n]
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 widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]]
set col(path) [string repeat " " $widest(path)]
set title(pathtype) "[a+ green]Path Type[a]"
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]]
set col(pathtype) [string repeat " " $widest(pathtype)]
set title(name) "Layout Name"
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]]
set col(name) [string repeat " " $widest(name)]
set vsep " | "
set vsep_w [string length $vsep] ;#unicode?
set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[textblock::join [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n
append table [string repeat - $tablewidth] \n
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
}
return $table
}
proc as_dict {args} {
tailcall 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} {
set tplbasedict [punk::mix::base::lib::get_template_basefolders]
set layouts_found [list]
dict for {tplbase folderinfo} $tplbasedict {
if {[file isdirectory $tplbase/layouts/$layout]} {
lappend layouts_found $tplbase/layouts/$layout
}
}
if {![llength $layouts_found]} {
#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."
puts stderr "searched [dict size $tplbasedict] template folders"
dict for {tplbase pkg} $tplbasedict {
puts stderr " - $tplbase $pkg"
}
return
}
set layoutfolder [lindex $layouts_found end]
set layoutinfo [dict get $layoutdict $layout]
set layoutfolder [dict get $layoutinfo path]
if {![file isdirectory $layoutfolder]} {
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)"
puts stderr "layout '$layout' points to path $layoutfolder - but it doesn't seem to exist"
}
set file_list [list]
util::foreach-file $layoutfolder path {
@ -118,25 +216,15 @@ namespace eval punk::mix::commandset::layout {
}
#
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ??
proc layout_scan_for_template_files {layout {tags {}}} {
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath ""
set tplbasedict [punk::mix::base::lib::get_template_basefolders]
set layouts_found [list]
dict for {tpldir pkg} $tplbasedict {
if {[file isdirectory $tpldir/layouts/$layout]} {
lappend layouts_found $tpldir/layouts/$layout
}
}
if {![llength $layouts_found]} {
#todo JMN
set layoutdict [layouts_dict]
if {![dict exists $layoutdict $layout]} {
puts stderr "layout '$layout' not found."
puts stderr "searched [dict size $tplbasedict] template folders"
dict for {tpldir pkg} $tplbasedict {
puts stderr " - $tpldir $pkg"
}
return
}
set layoutfolder [lindex $layouts_found end]
set layoutinfo [dict get $layoutdict $layout]
set layoutfolder [dict get $layoutinfo path]
#use last matching layout found. review silent if multiple?
if {![llength $tags]} {

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

@ -419,7 +419,7 @@ namespace eval punk::mix::commandset::loadedlib {
if {![file exists $source_file]} {
error "Unable to verify source file existence at: $source_file"
}
set source_data [fcat $source_file -translation binary]
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

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

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
# 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.
@ -9,7 +9,7 @@
# @@ Meta Begin
# Application punk::mix::commandset::module 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# Meta license BSD
# @@ Meta End
@ -17,8 +17,8 @@
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::repo
# depends on punk,punk::mix::base,punk::mix::cli
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -76,45 +76,69 @@ namespace eval punk::mix::commandset::module {
}
#require current dir when calling to be the projectdir, or
proc templates {args} {
set tdict [templates_dict {*}$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
package require overtype
set paths [dict values $tdict]
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 widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]]
set col(path) [string repeat " " $widest(path)]
set title1 "Path"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title(pathtype) "[a+ green]Path Type[a]"
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {string length $v}]]
set col(pathtype) [string repeat " " $widest(pathtype)]
set title2 "Template Name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set title(name) "Template Name"
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {string length $v}]]
set col(name) [string repeat " " $widest(name)]
set tablewidth [expr {$widest1 + 1 + $widest2}]
set tablewidth [expr {$widest(name) + 1 + $widest(pathtype) + 1 + $widest(name)}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n
append table "[textblock::join [overtype::left $col(name) $title(name)] " " [overtype::left $col(pathtype) $title(pathtype)] " " [overtype::left $col(path) $title(path)]]" \n
append table [string repeat - $tablewidth] \n
foreach p $paths n $names {
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n
foreach n $names pt $pathtypes p $paths {
append table "[overtype::left $col(name) $n] [overtype::left $col(pathtype) $pt] [overtype::left $col(path) $p]" \n
}
return $table
}
#return all module templates with repeated ones suffixed with .2 .3 etc
proc templates_dict {args} {
tailcall lib::templates_dict {*}$args
}
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"
}
}
proc new {module args} {
set year [clock format [clock seconds] -format %Y]
set defaults [list\
-project \uFFFF\
-version \uFFFF\
-license <unspecified>\
-template module-0.0.1.tm\
-template punk.module\
-type \uFFFF\
-force 0\
-quiet 0\
]
set opts [dict merge $defaults $args]
@ -133,7 +157,7 @@ namespace eval punk::mix::commandset::module {
} else {
set opt_version $opt_version_supplied
if {![util::is_valid_tm_version $opt_version]} {
error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version"
error "deck module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version"
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -144,7 +168,7 @@ namespace eval punk::mix::commandset::module {
#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 "pmix module.new error - unable to determine modulename-version from supplied value '$module'"
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]
@ -163,15 +187,15 @@ namespace eval punk::mix::commandset::module {
} else {
set modulename $module
}
punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name"
punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#options
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_project [dict get $opts -project]
set opt_project [dict get $opts -project]
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 [punkc::repo::is_candidate_root_requirements_msg]
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"
}
}
@ -187,13 +211,60 @@ namespace eval punk::mix::commandset::module {
set opt_license [dict get $opts -license]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
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] ;#possibly suffixed with .2 .3 etc
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc
if {![dict exists $templates_dict $opt_template]} {
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]"
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 templatefile [dict get $templates_dict $opt_template]
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -205,6 +276,8 @@ namespace eval punk::mix::commandset::module {
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]"
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_quiet [dict get $opts -quiet]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -253,6 +326,8 @@ namespace eval punk::mix::commandset::module {
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
@ -273,7 +348,19 @@ namespace eval punk::mix::commandset::module {
set infile_version $build_version
}
set template_filedata [string map [list %project% $projectname %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata]
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 litera %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 version $infile_version]
set strmap [list]
dict for {tag val} $tagnames {
lappend strmap %$tag% $val
}
set template_filedata [string map $strmap $template_filedata]
set modulefile $modulefolder/${moduletail}-$infile_version.tm
if {[file exists $modulefile]} {
@ -330,7 +417,9 @@ namespace eval punk::mix::commandset::module {
}
}
if {!$opt_quiet} {
puts stdout "Creating $modulefile from template $moduletemplate"
}
set fd [open $modulefile w]
fconfigure $fd -translation binary
puts -nonewline $fd $template_filedata
@ -347,50 +436,8 @@ namespace eval punk::mix::commandset::module {
}
namespace eval lib {
proc templates_dict {args} {
set defaults [list -scriptpath ""]
set opts [dict merge $defaults $args]
set opt_scriptpath [dict get $opts -scriptpath]
set module_template_bases [list]
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath]
dict for {tbase folderinfo} $tbasedict {
lappend module_template_bases [file join $tbase modules]
}
set template_files [list]
foreach basefld $module_template_bases {
set matched_files [glob -nocomplain -dir $basefld -type f template_*]
foreach tf $matched_files {
if {[string match ignore* $tf]} {
continue
}
set ext [file extension $tf]
if {$ext in [list ".tm"]} {
lappend template_files $tf
}
}
}
set tdict [dict create]
set seen_dict [dict create]
foreach fullpath $template_files {
set ftail [file tail $fullpath]
set tname [string range $ftail [string length template_] end]
if {![dict exists $seen_dict $tname]} {
dict set seen_dict $tname 1
dict set tdict $tname $fullpath ; #first seen of filename gets no number
} else {
set n [dict get $seen_dict $tname]
incr n
dict incr seen_dict $tname
dict set tdict ${tname}.$n $fullpath
}
}
return $tdict
}
}

143
src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
# 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.
@ -19,8 +19,8 @@
#*** !doctools
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0]
#[copyright "2023"]
#[titledesc {pmix commandset - project}] [comment {-- Name section and table of contents description --}]
#[moddesc {pmix CLI commandset - project}] [comment {-- Description at end of page heading --}]
#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}]
#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}]
#[require punk::mix::commandset::project]
#[description]
@ -129,7 +129,7 @@ namespace eval punk::mix::commandset::project {
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'"
}
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new"
punk::mix::cli::lib::validate_projectname $projectname -errorprefix "punk mix project.new"
set defaults [list\
@ -139,7 +139,7 @@ namespace eval punk::mix::commandset::project {
-update 0\
-confirm 1\
-modules \uFFFF\
-layout project
-layout punk.project
] ;#todo
set known_opts [dict keys $defaults]
foreach {k v} $args {
@ -151,7 +151,7 @@ namespace eval punk::mix::commandset::project {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_type [dict get $opts -type]
if {$opt_type ni [punk::mix::cli::lib::module_types]} {
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]"
error "deck new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]"
}
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_force [dict get $opts -force]
@ -170,10 +170,10 @@ namespace eval punk::mix::commandset::project {
set fossil_prog [auto_execok fossil]
if {![string length $fossil_prog]} {
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features."
puts stderr "The fossil program was not found. A fossil executable is required to use most deck features."
if {[string length [set scoop_prog [auto_execok scoop]]]} {
#restrict to windows?
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"]
set answer [util::askuser "scoop detected. Would you like deck to install fossil now using scoop? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
@ -216,23 +216,31 @@ namespace eval punk::mix::commandset::project {
puts stdout "This project will be searched for templates"
puts stdout "-------------------------------------------"
}
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set template_bases_containing_layout [list]
dict for {tbase folderinfo} $template_base_dict {
if {[file exists $tbase/layouts/$opt_layout]} {
lappend template_bases_containing_layout $tbase
}
package require punk::cap
if {[punk::cap::capability_has_handler punk.templates]} {
set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts]
} else {
put stderr "commandset::project::new WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide layout locations"
return
}
if {![llength $template_bases_containing_layout]} {
puts stderr "layout '$opt_layout' was not found in template dirs"
puts stderr "searched [dict size $template_base_dict] template folders"
dict for {tbase folderinfo} $template_base_dict {
puts stderr " - $tbase $folderinfo"
}
if {[dict exists $layout_dict $opt_layout]} {
set layout_name $opt_layout
set layout_info [dict get $layout_dict $layout_name]
set layout_path [dict get $layout_info path]
set layout_sourceinfo [dict get $layout_info sourceinfo]
} else {
puts stderr "commandset::project::new - no exact match for specified layout-name $opt_layout found"
puts stderr "layout names found: [dict keys $layout_dict]"
return
#todo - pick highest version layout that matches opt_layout if version not specified but multiple exist
#set layout_name ...
#set layout_info ..
#set layout_path ...
}
#review: silently use last entry which had the layout (?)
set templatebase [lindex $template_bases_containing_layout end]
@ -275,7 +283,7 @@ namespace eval punk::mix::commandset::project {
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template"
return
} elseif {$project_dir_exists && $opt_force} {
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template"
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $layout_path using -force option to overwrite from template"
if {$opt_confirm ni [list 0 no false]} {
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"]
if {[string tolower $answer] ne "y"} {
@ -284,7 +292,7 @@ namespace eval punk::mix::commandset::project {
}
}
} elseif {$project_dir_exists && $opt_update} {
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items"
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $layout_path using -update option to add missing items"
}
set fossil_repo_file ""
@ -325,29 +333,38 @@ namespace eval punk::mix::commandset::project {
}
}
#
file mkdir $projectdir
set layout_dir $templatebase/layouts/$opt_layout
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir"
puts stdout ">>> about to call punkcheck::install $layout_path $projectdir"
set resultdict [dict create]
set antipaths [list\
src/doc/*\
src/doc/include/*\
src/PROJECT_LAYOUTS_*\
]
#set antiglob_dir [list\
# _ignore_*\
#]
set antiglob_dir [list\
]
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized
if {$opt_force} {
puts stdout "copying layout files - with force applied - overwrite all-targets"
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths]
#file copy -force $layout_dir $projectdir
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir]
} else {
puts stdout "copying layout files - (if source file changed)"
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir]
}
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
puts stdout "copying layout src/doc files (if target missing)"
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS]
set resultdict [punkcheck::install $layout_path/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence.
@ -355,33 +372,33 @@ namespace eval punk::mix::commandset::project {
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"]
set override_antiglob_dir_core [list #* _aside .git]
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
set resultdict [punkcheck::install $layout_path/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
#lappend substfiles $projectdir/README.md
#lappend substfiles $projectdir/src/README.md
#lappend substfiles $projectdir/src/doc/main.man
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames?
#scan all files in template
#
#TODO - pmix command to substitute templates?
#TODO - deck command to substitute templates?
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout]
set stripprefix [file normalize $layout_dir]
set stripprefix [file normalize $layout_path]
set tagmap [list [lib::template_tag project] $projectname]
if {[llength $templatefiles]} {
puts stdout "Filling template file placeholders with the following tag map:"
dict for {placeholder value} $tagmap {
puts stdout " $placeholder -> $value"
}
}
foreach templatefullpath $templatefiles {
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix]
set fpath [file join $projectdir $templatetail]
if {[file exists $fpath]} {
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd
set data2 [string map [list [lib::template_tag project] $projectname] $data]
set data2 [string map $tagmap $data]
if {$data2 ne $data} {
puts stdout "updated template file: $fpath"
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout
@ -392,12 +409,12 @@ namespace eval punk::mix::commandset::project {
}
#todo - tag substitutions in src/doc tree
::cd $projectdir
if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules {
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} {
#todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc
punk::mix::commandset::module::new $m -project $projectname -type $opt_type
} else {
if {$opt_force} {
@ -531,7 +548,7 @@ namespace eval punk::mix::commandset::project {
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set title3 "Checkouts"
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]]
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}]
@ -617,19 +634,19 @@ namespace eval punk::mix::commandset::project {
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set title3 "Checkouts"
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]]
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]]
set col3 [string repeat " " $widest3]
set title4 "Project Name"
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]]
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {string length $v}]]
set col4 [string repeat " " $widest4]
set title5 "Project Code"
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]]
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {string length $v}]]
set col5 [string repeat " " $widest5]
set title6 "Dup"
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]]
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {string length $v}]]
set col6 [string repeat " " $widest6]
set title7 "Description"
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]]
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $v}]]
set widest7 35
set col7 [string repeat " " $widest7]
@ -766,7 +783,12 @@ namespace eval punk::mix::commandset::project {
puts stderr "Result is from a single repo db [dict keys $fosdb_cache]"
}
if {$opt_detail} {
puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). Use -detail 0 to omit file state"
if {!$opt_detail_explicit_zero} {
set detailmsg "Use -detail 0 to omit file state"
} else {
set detailmsg ""
}
puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). $detailmsg"
set c_rev [list]
set c_rev_iso [list]
set c_unchanged [list]
@ -881,7 +903,7 @@ namespace eval punk::mix::commandset::project {
set index [expr {$answer - 1}]
set workingdir [lindex $workdirs $index]
::cd $workingdir
puts stdout [pmix stat]
puts stdout [deck stat]
return $workingdir
}
}
@ -907,23 +929,8 @@ namespace eval punk::mix::commandset::project {
}
set fossil_prog [auto_execok fossil]
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo]
if {[llength $matching_lines] != 1} {
puts stderr "Unable to find config-db info from fossil. Check your fossil installation."
puts stderr "Fossil output was:"
puts stderr "-------------"
puts stderr "$fossilinfo"
puts stderr "-------------"
puts stderr "config-db info:"
puts stderr "$matching_lines"
return
}
set ln [lindex $matching_lines 0]
set configdb [string trim [string range $ln [string length "config-db: "] end]]
if {![file exists $configdb]} {
error "config-db not found at path $configdb"
}
set configdb [punk::repo::fossil_get_configdb]
package require sqlite3
::sqlite3 fosconf $configdb
#set testresult [fosconf eval {select name,value from global_config;}]

328
src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm

@ -68,6 +68,334 @@ namespace eval punk::mix::commandset::repo {
}
return $result
}
proc fossil-move-repository {{path ""}} {
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-"
}
}
}

1150
src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm

File diff suppressed because it is too large Load Diff

24
src/bootsupport/modules/punk/mix/templates-0.1.0.tm

@ -26,19 +26,28 @@ namespace eval punk::mix::templates {
variable pkg punk::mix::templates
variable cap_provider
#punk::cap::register_package punk::mix::templates [list\
# {punk.templates {relpath ../templates}}\
#]
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 punk.templates {relpath ../templates2}]
lappend decls [list punk.test {something blah}]
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
}
}
@ -62,6 +71,7 @@ namespace eval punk::mix::templates {
#provider api
# -- ---
#none - declarations only
#todo - template folder install/update/status methods?
}

0
src/modules/punk/mix/templates/layouts/project/src/_vfscommon/lib/common_vfs_libs → src/bootsupport/modules/punk/mix/templates/layout_refs/project@vendor+punk+project-0.1.ref

3
src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt

@ -0,0 +1,3 @@
%Major.Minor.Level%
#First line must be a semantic version number
#all other lines are ignored.

10
src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt

@ -0,0 +1,10 @@
Identifier: %package%
Version: %version%
Title: %title%
Creator: %name% <%email%>
Description: %description%
Rights: BSD
URL: %url%
Available:
Architecture: tcl
Subject:

7
src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat

@ -0,0 +1,7 @@
::lindex tcl;#\
@call tclsh "%~dp0%~n0.bat" %* & goto :eof
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl
puts stdout "script: [info script]"
puts stdout "argv: $::argc"
puts stdout "args: '$::argv'"

0
src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-multishell.cmd → src/bootsupport/modules/punk/mix/templates/utility/multishell.cmd

256
src/bootsupport/modules/punk/mix/templates/utility/multishell.ps1

@ -0,0 +1,256 @@
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>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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>
# -- --- --- --- --- --- --- ---
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-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>
# -- --- --- --- --- --- --- ---
tclsh $scriptname $args
# -- --- --- --- --- --- --- ---
#<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)
#>

270
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/multishell-old.cmd

@ -0,0 +1,270 @@
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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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)
#>

0
src/modules/punk/mix/templates/layouts/project/src/scriptapps/wrappers/sample_punk-shellbat.bat → src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/basic/shellbat.bat

661
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd

@ -0,0 +1,661 @@
: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^
set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \
: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" +
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section.
: shebang line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@GOTO :skip_perl_pod_start ^;
=begin excludeperl
: skip_perl_pod_start
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: deck scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh' (^14^) 'perl'"
@SET "shells[10]=pwsh"
@SET "shells[11]=sh"
@set "shells[12]=bash"
@SET "shells[13]=tclsh"
@SET "shells[14]=perl"
: <nextshell>
@SET "nextshell=13"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM nextshell set to index for validshells .eg 10 for pwsh
@REM @ECHO nextshell is %nextshell%
@SET "selected=!shells[%nextshell%]!"
@REM @ECHO selected %selected%
@CALL SET "keyRemoved=%%validshells:'!selected!'=%%"
@REM @ECHO keyremoved %keyRemoved%
@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 but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- deck scriptwrap.checkfile <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using deck scriptwrap.checkfile is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and deck scriptwrap.checkfile doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@IF "%1"=="PUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@GOTO skip_privileges
:getPrivileges
@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "%1"=="PUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "!shells[%nextshell%]!"=="pwsh" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "!shells[%nextshell%]!"=="bash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
!shells[%nextshell%]! "!wslpath!%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh on windows 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
!shells[%nextshell%]! "%~dp0%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells%
SET task_exitcode=66
@REM boundary padding
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@REM boundary padding
@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%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (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) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- 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 s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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-pre-launch-subprocess>
#</tcl-pre-launch-subprocess>
#<tcl-launch-subprocess>
#</tcl-launch-subproces>
#<tcl-post-launch-subprocess>
#</tcl-post-launch-subproces>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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 the %nextshell% value above
# -- if sh/bash scripting needs to run on windows too.
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload
exitcode=0
#printf "start of bash or sh code"
#<shell-pre-launch-subprocess>
#</shell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-launch-subprocess>
#-- 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 "sh/bash reporting tcl exitcode: ${exitcode}"
#-- override exitcode example
#exit 66
#</shell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-post-launch-subprocess>
#</shell-post-launch-subproces>
#printf "sh/bash done \n"
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload
#------------------------------------------------------
fi
exit ${exitcode}
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- Perl script section
# -- leave the script below as is, if all that is required is launching the Tcl payload"
# --
# -- Note that perl script isn't called by default when simply running this script by name
# -- adjust the nextshell value at the top of the script to point to perl
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
=cut
#!/user/bin/perl
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload
my $exit_code = 0;
#use ExtUtils::Installed;
#my $installed = ExtUtils::Installed->new();
#my @modules = $installed->modules();
#print "Modules:\n";
#foreach my $m (@modules) {
# print "$m\n";
#}
# -- --- ---
my $scriptname = $0;
print "perl $scriptname\n";
my $i =1;
foreach my $a(@ARGV) {
print "Arg # $i: $a\n";
}
#<perl-pre-launch-subprocess>
#</perl-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-launch-subprocess>
$exit_code=system("tclsh", $scriptname, @ARGV);
#print "perl reporting tcl exitcode: $exit_code";
#</perl-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-post-launch-subprocess>
#</perl-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload
exit $exit_code;
__END__
# end hide sh/bash/perl 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
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# -- custom script should generally go below the begin_powershell_payload line
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = GetScriptName
function GetDynamicParamDictionary {
[CmdletBinding()]
param(
[Parameter(ValueFromPipeline=$true, Mandatory=$true)]
[string] $CommandName
)
begin {
# Get a list of params that should be ignored (they're common to all advanced functions)
$CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) |
Get-Member -MemberType Properties |
Select-Object -ExpandProperty Name
}
process {
# Create the dictionary that this scriptblock will return:
$DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary
# Convert to object array and get rid of Common params:
(Get-Command $CommandName | select -exp Parameters).GetEnumerator() |
Where-Object { $CommonParameterNames -notcontains $_.Key } |
ForEach-Object {
$DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter (
$_.Key,
$_.Value.ParameterType,
$_.Value.Attributes
)
$DynParamDictionary.Add($_.Key, $DynamicParameter)
}
# Return the dynamic parameters
return $DynParamDictionary
}
}
# GetDynamicParamDictionary
# - This can make it easier to share a single set of param definitions between functions
# - sample usage
#function ParameterDefinitions {
# param(
# [Parameter(Mandatory)][string] $myargument
# )
#}
#function psmain {
# [CmdletBinding()]
# param()
# dynamicparam { GetDynamicParamDictionary ParameterDefinitions }
# process {
# #called once with $PSBoundParameters dictionary
# #can be used to validate arguments, or set a simpler variable name for access
# switch ($PSBoundParameters.keys) {
# 'myargumentname' {
# Set-Variable -Name $_ -Value $PSBoundParameters."$_"
# }
# #...
# }
# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) {
# #...
# }
# }
# end {
# #Main function logic
# Write-Host "myargumentname value is: $myargumentname"
# #myotherfunction @PSBoundParameters
# }
#}
#psmain @args
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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-pre-launch-subprocess>
#</powershell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-launch-subprocess>
tclsh $scriptname $args
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
#</powershell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-post-launch-subprocess>
#</powershell-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment end heredoc2 \
'@
<#
# id:tailblock0
# -- powershell multiline comment
#>
<#
no script engine should try to run me
# 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)
#>

524
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell1.cmd

@ -0,0 +1,524 @@
: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^
set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. (close sqote for unix shells) ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \
: "[Hide @ECHO; Hide ); Hide (;Hide echo; Hide @REM]#not necessary but can help avoid errs in testing"
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: pmix scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'"
@SET "shells[10]=pwsh"
@SET "shells[11]=sh"
@set "shells[12]=bash"
@SET "shells[13]=tclsh"
: <nextshell>
@SET "nextshell=13"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM nextshell set to index for validshells .eg 10 for pwsh
@REM @ECHO nextshell is %nextshell%
@SET "selected=!shells[%nextshell%]!"
@REM @ECHO selected %selected%
@CALL SET "keyRemoved=%%validshells:'!selected!'=%%"
@REM @ECHO keyremoved %keyRemoved%
@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 but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- pmix scriptwrap.checkfile <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using pmix scriptwrap.checkfile is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and pmix scriptwrap.checkfile doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@IF "%1"=="PUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@GOTO skip_privileges
:getPrivileges
@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0.cmd", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "%1"=="PUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "!shells[%nextshell%]!"=="pwsh" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "!shells[%nextshell%]!"=="bash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
!shells[%nextshell%]! "!wslpath!%fname%" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh on windows 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
!shells[%nextshell%]! "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells%
SET task_exitcode=66
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@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%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (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) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- 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 s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
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>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment 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)
#>

270
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell-old.cmd

@ -0,0 +1,270 @@
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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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)
#>

661
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell.cmd

@ -0,0 +1,661 @@
: "punk MULTISHELL - shebangless polyglot for Tcl Perl sh bash cmd pwsh powershell" + "[rename set s;proc Hide x {proc $x args {}};Hide :]" + "\$(function : {<#pwsh#>})" + "perlhide" + qw^
set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. close sqote for unix shells + ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl + \
: "[Hide @GOTO; Hide =begin; Hide @REM] #not necessary but can help avoid errs in testing" +
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT - except for first double quoted section.
: shebang line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@GOTO :skip_perl_pod_start ^;
=begin excludeperl
: skip_perl_pod_start
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: pmix scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh' (^14^) 'perl'"
@SET "shells[10]=pwsh"
@SET "shells[11]=sh"
@set "shells[12]=bash"
@SET "shells[13]=tclsh"
@SET "shells[14]=perl"
: <nextshell>
@SET "nextshell=13"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM nextshell set to index for validshells .eg 10 for pwsh
@REM @ECHO nextshell is %nextshell%
@SET "selected=!shells[%nextshell%]!"
@REM @ECHO selected %selected%
@CALL SET "keyRemoved=%%validshells:'!selected!'=%%"
@REM @ECHO keyremoved %keyRemoved%
@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 but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- pmix scriptwrap.checkfile <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using pmix scriptwrap.checkfile is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and pmix scriptwrap.checkfile doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@IF "%1"=="PUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@GOTO skip_privileges
:getPrivileges
@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0%~x0", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "%1"=="PUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0%~x0" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "!shells[%nextshell%]!"=="pwsh" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "!shells[%nextshell%]!"=="bash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
!shells[%nextshell%]! "!wslpath!%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh on windows 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
!shells[%nextshell%]! "%~dp0%fname%" %arglist%
SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells%
SET task_exitcode=66
@REM boundary padding
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@REM boundary padding
@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%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (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) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- 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 s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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-pre-launch-subprocess>
#</tcl-pre-launch-subprocess>
#<tcl-launch-subprocess>
#</tcl-launch-subproces>
#<tcl-post-launch-subprocess>
#</tcl-post-launch-subproces>
# -- --- --- --- --- --- --- --- --- --- --- ---
# -- 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 the %nextshell% value above
# -- if sh/bash scripting needs to run on windows too.
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin sh Payload
exitcode=0
#printf "start of bash or sh code"
#<shell-pre-launch-subprocess>
#</shell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-launch-subprocess>
#-- 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 "sh/bash reporting tcl exitcode: ${exitcode}"
#-- override exitcode example
#exit 66
#</shell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<shell-post-launch-subprocess>
#</shell-post-launch-subproces>
#printf "sh/bash done \n"
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end sh Payload
#------------------------------------------------------
fi
exit ${exitcode}
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
# -- Perl script section
# -- leave the script below as is, if all that is required is launching the Tcl payload"
# --
# -- Note that perl script isn't called by default when simply running this script by name
# -- adjust the nextshell value at the top of the script to point to perl
# --
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
=cut
#!/user/bin/perl
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---begin perl Payload
my $exit_code = 0;
#use ExtUtils::Installed;
#my $installed = ExtUtils::Installed->new();
#my @modules = $installed->modules();
#print "Modules:\n";
#foreach my $m (@modules) {
# print "$m\n";
#}
# -- --- ---
my $scriptname = $0;
print "perl $scriptname\n";
my $i =1;
foreach my $a(@ARGV) {
print "Arg # $i: $a\n";
}
#<perl-pre-launch-subprocess>
#</perl-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-launch-subprocess>
$exit_code=system("tclsh", $scriptname, @ARGV);
#print "perl reporting tcl exitcode: $exit_code";
#</perl-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<perl-post-launch-subprocess>
#</perl-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end perl Payload
exit $exit_code;
__END__
# end hide sh/bash/perl 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
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# -- custom script should generally go below the begin_powershell_payload line
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
function GetScriptName { $myInvocation.ScriptName }
$scriptname = GetScriptName
function GetDynamicParamDictionary {
[CmdletBinding()]
param(
[Parameter(ValueFromPipeline=$true, Mandatory=$true)]
[string] $CommandName
)
begin {
# Get a list of params that should be ignored (they're common to all advanced functions)
$CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) |
Get-Member -MemberType Properties |
Select-Object -ExpandProperty Name
}
process {
# Create the dictionary that this scriptblock will return:
$DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary
# Convert to object array and get rid of Common params:
(Get-Command $CommandName | select -exp Parameters).GetEnumerator() |
Where-Object { $CommonParameterNames -notcontains $_.Key } |
ForEach-Object {
$DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter (
$_.Key,
$_.Value.ParameterType,
$_.Value.Attributes
)
$DynParamDictionary.Add($_.Key, $DynamicParameter)
}
# Return the dynamic parameters
return $DynParamDictionary
}
}
# GetDynamicParamDictionary
# - This can make it easier to share a single set of param definitions between functions
# - sample usage
#function ParameterDefinitions {
# param(
# [Parameter(Mandatory)][string] $myargument
# )
#}
#function psmain {
# [CmdletBinding()]
# param()
# dynamicparam { GetDynamicParamDictionary ParameterDefinitions }
# process {
# #called once with $PSBoundParameters dictionary
# #can be used to validate arguments, or set a simpler variable name for access
# switch ($PSBoundParameters.keys) {
# 'myargumentname' {
# Set-Variable -Name $_ -Value $PSBoundParameters."$_"
# }
# #...
# }
# foreach ($boundparam in $PSBoundParameters.GetEnumerator()) {
# #...
# }
# }
# end {
# #Main function logic
# Write-Host "myargumentname value is: $myargumentname"
# #myotherfunction @PSBoundParameters
# }
#}
#psmain @args
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---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-pre-launch-subprocess>
#</powershell-pre-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-launch-subprocess>
tclsh $scriptname $args
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
#</powershell-launch-subprocess>
# -- --- --- --- --- --- --- ---
#<powershell-post-launch-subprocess>
#</powershell-post-launch-subprocess>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment end heredoc2 \
'@
<#
# id:tailblock0
# -- powershell multiline comment
#>
<#
no script engine should try to run me
# 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)
#>

524
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-multishell1.cmd

@ -0,0 +1,524 @@
: "[rename set s;proc Hide x {proc $x args {}};Hide :]" "\$(function : {<#pwsh#>})" ^
set -- "$@" "a=[list shebangless punk MULTISHELL tclsh sh bash cmd pwsh powershell;proc Hide x {proc $x args {}}; Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
: heredoc1 - hide from powershell using @ and squote above. (close sqote for unix shells) ' \
: .bat/.cmd launch section, leading colon hides from cmd, trailing slash hides next line from tcl \
: "[Hide @ECHO; Hide ); Hide (;Hide echo; Hide @REM]#not necessary but can help avoid errs in testing"
: << 'HEREDOC1B_HIDE_FROM_BASH_AND_SH'
: Continuation char at end of this line and rem with curly-braces used to exlude Tcl from the whole cmd block \
: {
: STRONG SUGGESTION: DO NOT MODIFY FIRST LINE OF THIS SCRIPT. shebang #! line is not required on unix or windows and will reduce functionality and/or portability.
: Even comment lines can be part of the functionality of this script (both on unix and windows) - modify with care.
@REM ############################################################################################################################
@REM THIS IS A POLYGLOT SCRIPT - supporting payloads in Tcl, bash, sh and/or powershelll (powershell.exe or pwsh.exe)
@REM It should remain portable between unix-like OSes & windows if the proper structure is maintained.
@REM ############################################################################################################################
@REM On windows, change the value of nextshell to one of the listed 2 digit values if desired, and add code within payload sections for tcl,sh,bash,powershell as appropriate.
@REM This wrapper can be edited manually (carefully!) - or sh,bash,tcl,powershell scripts can be wrapped using the Tcl-based punkshell system
@REM e.g from within a running punkshell: pmix scriptwrap.multishell <inputfilepath> -outputfolder <folderpath>
@REM On unix-like systems, call with sh, bash or tclsh. (powershell untested on unix - and requires wscript if security elevation is used)
@REM Due to lack of shebang (#! line) Unix-like systems will probably (hopefully) default to sh if the script is called without an interpreter - but it may depend on the shell in use when called.
@REM If you find yourself really wanting/needing to add a shebang line - do so on the basis that the script will exist on unix-like systems only.
@SETLOCAL EnableExtensions EnableDelayedExpansion
@SET "validshells= ^(10^) 'pwsh' ^(11^) 'sh' (^12^) 'bash' (^13^) 'tclsh'"
@SET "shells[10]=pwsh"
@SET "shells[11]=sh"
@set "shells[12]=bash"
@SET "shells[13]=tclsh"
: <nextshell>
@SET "nextshell=13"
: </nextshell>
@rem asadmin is for automatic elevation to administrator. Separate window will be created (seems unavoidable with current elevation mechanism) and user will still get security prompt (probably reasonable).
: <asadmin>
@SET "asadmin=0"
: </asadmin>
@REM nextshell set to index for validshells .eg 10 for pwsh
@REM @ECHO nextshell is %nextshell%
@SET "selected=!shells[%nextshell%]!"
@REM @ECHO selected %selected%
@CALL SET "keyRemoved=%%validshells:'!selected!'=%%"
@REM @ECHO keyremoved %keyRemoved%
@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 but should be left in place)
@REM -- This section intended mainly to launch the next shell (and to escalate privileges if necessary)
@REM -- Avoid customising this if you are not familiar with batch scripting. cmd/batch script can be useful, but is probably the least expressive language and most error prone.
@REM -- For example - as this file needs to use unix-style lf line-endings - the label scanner is susceptible to the 512Byte boundary issue: https://www.dostips.com/forum/viewtopic.php?t=8988#p58888
@REM -- This label issue can be triggered/abused in files with crlf line endings too - but it is less likely to happen accidentaly.
@REm -- See also: https://stackoverflow.com/questions/4094699/how-does-the-windows-command-interpreter-cmd-exe-parse-scripts/4095133#4095133
@REM ############################################################################################################################
@REM -- Due to this issue -seemingly trivial edits of the batch file section can break the script! (for Windows anyway)
@REM -- Even something as simple as adding or removing an @REM
@REM -- From within punkshell - use:
@REM -- pmix scriptwrap.checkfile <filepath>
@REM -- to check your templates or final wrapped scripts for byte boundary issues
@REM -- It will report any labels that are on boundaries
@REM -- This is why the nextshell value above is a 2 digit key instead of a string - so that editing the value doesn't change the byte offsets.
@REM -- Editing your sh,bash,tcl,pwsh payloads is much less likely to cause an issue. There is the possibility of the final batch :exit_multishell label spanning a boundary - so testing using pmix scriptwrap.checkfile is still recommended.
@REM -- Alternatively, as you should do anyway - test the final script on windows
@REM -- Aside from adding comments/whitespace to tweak the location of labels - you can try duplicating the label (e.g just add the label on a line above) but this is not guaranteed to work in all situations.
@REM -- '@REM' is a safer comment mechanism than a leading colon - which is used sparingly here.
@REM -- A colon anywhere in the script that happens to land on a 512 Byte boundary (from file start or from a callsite) could be misinterpreted as a label
@REM -- It is unknown what versions of cmd interpreters behave this way - and pmix scriptwrap.checkfile doesn't check all such boundaries.
@REm -- For this reason, batch labels should be chosen to be relatively unlikely to collide with other strings in the file, and simple names such as :exit or :end should probably be avoided
@REM ############################################################################################################################
@REM -- custom windows payloads should be in powershell,tclsh (or sh/bash if available) code sections
@REM ## ### ### ### ### ### ### ### ### ### ### ### ### ###
@SET "winpath=%~dp0"
@SET "fname=%~nx0"
@REM @ECHO fname %fname%
@REM @ECHO winpath %winpath%
@REM @ECHO commandlineascalled %0
@REM @ECHO commandlineresolved %~f0
@CALL :getNormalizedScriptTail nftail
@REM @ECHO normalizedscripttail %nftail%
@CALL :getFileTail %0 clinetail
@REM @ECHO clinetail %clinetail%
@CALL :stringToUpper %~nx0 capscripttail
@REM @ECHO capscriptname: %capscripttail%
@IF "%nftail%"=="%capscripttail%" (
@ECHO forcing asadmin=1 due to file name on filesystem being uppercase
@SET "asadmin=1"
) else (
@CALL :stringToUpper %clinetail% capcmdlinetail
@REM @ECHO capcmdlinetail !capcmdlinetail!
IF "%clinetail%"=="!capcmdlinetail!" (
@ECHO forcing asadmin=1 due to cmdline scriptname in uppercase
@set "asadmin=1"
)
)
@SET "vbsGetPrivileges=%temp%\punk_bat_elevate_%fname%.vbs"
@SET arglist=%*
@IF "%1"=="PUNK-ELEVATED" (
GOTO :gotPrivileges
)
@IF !asadmin!==1 (
net file 1>NUL 2>NUL
@IF '!errorlevel!'=='0' ( GOTO :gotPrivileges ) else ( GOTO :getPrivileges )
)
@GOTO skip_privileges
:getPrivileges
@IF '%1'=='PUNK-ELEVATED' (echo PUNK-ELEVATED & shift /1 & goto :gotPrivileges )
@ECHO Set UAC = CreateObject^("Shell.Application"^) > "%vbsGetPrivileges%"
@ECHO args = "PUNK-ELEVATED " >> "%vbsGetPrivileges%"
@ECHO For Each strArg in WScript.Arguments >> "%vbsGetPrivileges%"
@ECHO args = args ^& strArg ^& " " >> "%vbsGetPrivileges%"
@ECHO Next >> "%vbsGetPrivileges%"
@ECHO UAC.ShellExecute "%~dp0%~n0.cmd", args, "", "runas", 1 >> "%vbsGetPrivileges%"
@ECHO Launching script in new windows due to administrator elevation
@"%SystemRoot%\System32\WScript.exe" "%vbsGetPrivileges%" %*
@EXIT /B
:gotPrivileges
@REM setlocal & pushd .
@PUSHD .
@cd /d %~dp0
@IF "%1"=="PUNK-ELEVATED" (
@DEL "%vbsGetPrivileges%" 1>nul 2>nul
@SET arglist=%arglist:~14%
)
:skip_privileges
@SET need_ps1=0
@REM we want the ps1 to exist even if the nextshell isn't powershell
@if not exist "%~dp0%~n0.ps1" (
@SET need_ps1=1
) ELSE (
fc "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >nul || goto different
@REM @ECHO "files same"
@SET need_ps1=0
)
@GOTO :pscontinue
:different
@REM @ECHO "files differ"
@SET need_ps1=1
:pscontinue
@IF !need_ps1!==1 (
COPY "%~dp0%~n0.cmd" "%~dp0%~n0.ps1" >NUL
)
@REM avoid using CALL to launch pwsh,tclsh etc - it will intercept some args such as /?
@IF "!shells[%nextshell%]!"=="pwsh" (
REM pws vs powershell hasn't been tested because we didn't need to copy cmd to ps1 this time
REM test availability of preferred option of powershell7+ pwsh
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; write-host "statusmessage: pwsh-found" >NUL
SET pwshtest_exitcode=!errorlevel!
REM ECHO pwshtest_exitcode !pwshtest_exitcode!
REM fallback to powershell if pwsh failed
IF !pwshtest_exitcode!==0 (
pwsh -nop -nol -c set-executionpolicy -Scope Process Unrestricted; "%~dp0%~n0.ps1" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
REM CALL powershell -nop -nol -c write-host powershell-found
REM powershell -nop -nol -file "%~dp0%~n0.ps1" %*
powershell -nop -nol -c set-executionpolicy -Scope Process Unrestricted; %~dp0%~n0.ps1" %arglist%
SET task_exitcode=!errorlevel!
)
) ELSE (
IF "!shells[%nextshell%]!"=="bash" (
CALL :getWslPath %winpath% wslpath
REM ECHO wslfullpath "!wslpath!%fname%"
!shells[%nextshell%]! "!wslpath!%fname%" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
REM probably tclsh or sh
IF NOT "x%keyRemoved%"=="x%validshells%" (
REM sh on windows 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
!shells[%nextshell%]! "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel!
) ELSE (
ECHO %fname% has invalid nextshell value ^(%nextshell%^) !shells[%nextshell%]! valid options are %validshells%
SET task_exitcode=66
GOTO :exit_multishell
)
)
)
@REM batch file library functions
@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%
)
)
@EXIT /B
:getFileTail
@REM return tail of file without any normalization e.g c:/punkshell/bin/Punk.cmd returns Punk.cmd even if file is punk.cmd
@REM we can't use things such as %~nx1 as it can change capitalisation
@REM This function is designed explicitly to preserve capitalisation
@REM accepts full paths with either / or \ as delimiters - or
@SETLOCAL
@SET "rtrn=%~2"
@SET "arg=%~1"
@REM @SET "result=%_arg:*/=%"
@REM @SET "result=%~1"
@SET LF=^
: The above 2 empty lines are important. Don't remove
@CALL :stringContains "!arg!" "\" hasBackSlash
@IF "!hasBackslash!"=="true" (
@for %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:\=%%~A!") do @set "result=%%B"
)
) ELSE (
@CALL :stringContains "!arg!" "/" hasForwardSlash
@IF "!hasForwardSlash!"=="true" (
@FOR %%A in ("!LF!") do @(
@FOR /F %%B in ("!arg:/=%%~A!") do @set "result=%%B"
)
) ELSE (
@set "result=%arg%"
)
)
@ENDLOCAL & (
@if "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
@REM boundary padding
:getNormalizedScriptTail
@SETLOCAL
@SET "result=%~nx0"
@SET "rtrn=%~1"
@ENDLOCAL & (
@IF "%~1" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:getNormalizedFileTailFromPath
@REM warn via echo, and do not set return variable if path not found
@REM note that %~nx1 does not preserve case of provided path - hence the name 'normalized'
@REM boundary padding
@REM boundary padding
@SETLOCAL
@CALL :stringContains %~1 "\" hasBackSlash
@CALL :stringContains %~1 "/" hasForwardSlash
@IF "%hasBackslash%-%hasForwardslash%"=="false-false" (
@SET "P=%cd%%~1"
@CALL :getNormalizedFileTailFromPath "!P!" ftail2
@SET "result=!ftail2!"
) else (
@IF EXIST "%~1" (
@SET "result=%~nx1"
) else (
@ECHO error getNormalizedFileTailFromPath file not found: %~1
@EXIT /B 1
)
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
SET "%rtrn%=%result%"
) ELSE (
@ECHO getNormalizedFileTailFromPath %1 result: %result%
)
)
@EXIT /B
:stringContains
@REM usage: @CALL:stringContains string needle returnvarname
@SETLOCAL
@SET "rtrn=%~3"
@SET "string=%~1"
@SET "needle=%~2"
@IF "!string:%needle%=!"=="!string!" @(
@SET "result=false"
) ELSE (
@SET "result=true"
)
@ENDLOCAL & (
@IF "%~3" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringContains %string% %needle% result: %result%
)
)
@EXIT /B
:stringToUpper
@SETLOCAL
@SET "rtrn=%~2"
@SET "string=%~1"
@SET "capstring=%~1"
@FOR %%A in (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) DO @(
@SET "capstring=!capstring:%%A=%%A!"
)
@SET "result=!capstring!"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO stringToUpper %string% result: %result%
)
)
@EXIT /B
:isNumeric
@SETLOCAL
@SET "notnumeric="&FOR /F "delims=0123456789" %%i in ("%1") do set "notnumeric=%%i"
@IF defined notnumeric (
@SET "result=false"
) else (
@SET "result=true"
)
@SET "rtrn=%~2"
@ENDLOCAL & (
@IF "%~2" neq "" (
@SET "%rtrn%=%result%"
) ELSE (
@ECHO %result%
)
)
@EXIT /B
:endlib
: \
@REM @SET taskexit_code=!errorlevel! & goto :exit_multishell
@GOTO :exit_multishell
# }
# -*- 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 s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore
Hide :exit_multishell;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]/--]]
}
if {![info exists ::punk::multishell::is_main($script_name)]} {
#e.g a .dll or something else unanticipated
puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting"
puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]"
return 0
}
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
# -- Do not edit if current file is the .ps1
# -- Edit the corresponding .cmd and it will autocopy
# -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
# ## ### ### ### ### ### ### ### ### ### ### ### ### ###
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>
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---end powershell Payload
#"powershell reporting exitcode: {0}" -f $LASTEXITCODE | write-host
Exit $LASTEXITCODE
# heredoc2 for powershell to ignore block below
$1 = @'
'
: comment end hide powershell-block from Tcl \
# This comment with closing brace should stay in place whether 'if' commented or not }
: multishell doubled-up cmd exit label - return exitcode
:exit_multishell
:exit_multishell
: \
@REM @ECHO exitcode: !task_exitcode!
: \
@IF "%1"=="PUNK-ELEVATED" (echo. & @cmd /k echo elevated prompt: type exit to quit)
: \
@EXIT /B !task_exitcode!
# cmd has exited
: comment 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)
#>

112
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/punk-shellbat.bat

@ -0,0 +1,112 @@
: "[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

104
src/bootsupport/modules/punk/mix/templates/utility/shellbat.txt

@ -0,0 +1,104 @@
: "[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>
# --- --- --- --- --- --- --- --- --- --- --- --- ---
# 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"
#-- 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
# 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

106
src/bootsupport/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

3
src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt

@ -0,0 +1,3 @@
::lindex tcl;#\
@call tclsh "%~dp0%~n0.bat" %* & goto :eof
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl

8
src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat

@ -0,0 +1,8 @@
::lindex tcl;#\
@call tclsh "%~dp0%~n0.bat" %* & goto :eof
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl
puts stdout "exe: [info nameof]"
puts stdout "scr: [info script]"
puts stdout "argc: $::argc"
puts stdout "argv: '$::argv'"

19
src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat

@ -0,0 +1,19 @@
::set - {
@goto start
# -- tcl bat
:start
@echo off
set script=%0
echo %*
if exist %script%.bat set script=%script%.bat
tclsh %script% %*
goto end of BAT file
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl
puts stdout "exe: [info nameof]"
puts stdout "scr: [info script]"
puts stdout "argc: $::argc"
puts stdout "argv: '$::argv'"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\
:end of BAT file

19
src/bootsupport/modules/punk/mix/util-0.1.0.tm

@ -35,13 +35,10 @@ namespace eval punk::mix::util {
namespace export *
#NOTE fileutil::cat seems to silently ignore options if passed at end instead of before file!
proc fcat {args} {
variable has_winpath
if {$::tcl_platform(platform) ne "windows"} {
return [fileutil::cat {*}$args]
}
set knownopts [list -eofchar -translation -encoding --]
set last_opt 0
@ -73,7 +70,21 @@ namespace eval punk::mix::util {
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]} {

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

@ -17,7 +17,7 @@
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::args
namespace eval ::punk_dynamic::ns {
@ -356,8 +356,8 @@ namespace eval punk::ns {
}
return [list_as_lines [lsort $result]]
#.= lsort $result |> list_as_lines
return [list_as_lines -- [lsort $result]]
#.= lsort $result |> list_as_lines --
}
proc nsglob_as_re {glob} {
@ -1601,23 +1601,33 @@ namespace eval punk::ns {
}
interp alias "" use "" punk::ns::pkguse
proc nsimport_noclobber {pattern {ns ""}} {
set source_ns [namespace qualifiers $pattern]
proc nsimport_noclobber {args} {
set argspecs {
-targetnamespace -default "" -optional 1
-prefix -default "" -optional 1
sourcepattern -type string -optional 0
}
lassign [punk::args::opts_values $argspecs $args -minvalues 1 -maxvalues 1] _o opts _v values
set sourcepattern [dict get $values sourcepattern]
set source_ns [namespace qualifiers $sourcepattern]
if {![namespace exists $source_ns]} {
error "nsimport_noclobber error namespace $source_ns not found"
}
if {$ns eq ""} {
set ns [uplevel 1 {namespace current}]
} elseif {![string match ::* $ns]} {
set nscaller [uplevel 1 {namespace current}]
set ns [punk::nsjoin $nscaller $ns]
set target_ns [dict get $opts -targetnamespace]
set nscaller [uplevel 1 {namespace current}]
if {$target_ns eq ""} {
set target_ns $nscaller
} elseif {![string match ::* $target_ns]} {
set target_ns [punk::nsjoin $nscaller $target_ns]
}
set a_export_patterns [namespace eval $source_ns {namespace export}]
set a_commands [info commands $pattern]
set a_commands [info commands $sourcepattern]
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 epattern $a_export_patterns {
set matches [lsearch -all -inline $a_tails $epattern]
foreach m $matches {
if {$m ni $a_exported_tails} {
lappend a_exported_tails $m
@ -1626,7 +1636,7 @@ namespace eval punk::ns {
}
set imported_commands [list]
foreach e $a_exported_tails {
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] {
set imported [namespace eval $target_ns [string map [list <func> $e <a> $source_ns] {
set cmd ""
if {![catch {namespace import <a>::<func>}]} {
set cmd <func>

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

@ -198,29 +198,47 @@ namespace eval punk::path {
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {basepath tailglob args} {
proc treefilenames {args} {
#*** !doctools
#[call [fun treefilenames] [arg basepath] [arg tailglob] [opt {option value...}]]
#basic (glob based) list of filenames matching tailglob - recursive
#no natsorting - so order is dependent on filesystem
set defaults [dict create\
-call-depth-internal 0\
-antiglob_paths {}\
]
set opts [dict merge $defaults $args]
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]]
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive
#[para] options:
#[para] [opt -dir] <path>
#[para] defaults to [lb]pwd[rb] - base path for tree to search
#[para] [opt -antiglob_paths] <list>
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/**
#[para]no natsorting - so order is dependent on filesystem
lassign [punk::get_leading_opts_and_values {
-directory "\uFFFF"
-call-depth-internal 0
-antiglob_paths {}
} $args] _o opts _v tailglobs
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]
set CALLDEPTH [dict get $opts -call-depth-internal]
# -- --- --- --- --- --- ---
set opt_dir [dict get $opts -directory]
if {$opt_dir eq "\uFFFF"} {
set opt_dir [pwd]
}
# -- --- --- --- --- --- ---
set files [list]
if {$CALLDEPTH == 0} {
if {![file isdirectory $basepath]} {
if {![file isdirectory $opt_dir]} {
return [list]
}
set opts [dict merge $opts [list -directory $opt_dir]]
if {![llength $tailglobs]} {
lappend tailglobs *
}
}
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $basepath]} {
if {[globmatchpath $anti $opt_dir]} {
set skip 1
break
}
@ -230,9 +248,9 @@ namespace eval punk::path {
}
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [glob -nocomplain -dir $basepath -type f $tailglob]
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]]
lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $basepath -type d *]
set dirdirs [glob -nocomplain -dir $opt_dir -type d *]
foreach dir $dirdirs {
set skip 0
foreach anti $opt_antiglob_paths {
@ -244,8 +262,8 @@ namespace eval punk::path {
if {$skip} {
continue
}
set nextargs [dict merge $args [list -call-depth-internal [incr CALLDEPTH]]]
lappend files {*}[treefilenames $dir $tailglob {*}$nextargs]
set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]]
lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs]
}
return $files
}
@ -270,14 +288,30 @@ namespace eval punk::path {
#[item]
#[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie relative /etc /etC
#[para] Case sensitive. ie punk::path::relative /etc /etC
# will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive
#[para] ie relative c:/etc C:/etc returns .
#[para] but relative c:/etc C:/Etc returns ../Etc
#[example_begin]
# P% punk::path::relative c:/etc C:/etc
# - .
#[example_end]
#[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail
#[example_begin]
# P% punk::path::relative c:/etc C:/Etc
# - ../Etc
#[example_end]
#[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned.
# ie relative c:/etc d:/etc/blah
# returns d:/etc/blah
#[example_begin]
# P% punk::path::relative c:/etc d:/etc/blah
# - d:/etc/blah
#[example_end]
#[para] Unix-like examples:
#[example_begin]
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below
# - somewhere/below
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here
# - ../../lib/here
#[example_end]
#[list_end]
#see also kettle

357
src/bootsupport/modules/punk/repo-0.1.1.tm

@ -779,10 +779,10 @@ namespace eval punk::repo {
package require overtype
set title1 "Path"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]]
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {lib::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "Repo-type(s)"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]]
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]]
set col2 [string repeat " " $widest2]
set tablewidth [expr {$widest1 + 1 + $widest2}]
@ -827,19 +827,61 @@ namespace eval punk::repo {
}
}
proc fossil_get_repository_folder_for_project {projectname args} {
set defaults [list -parentfolder \uFFFF -extrachoice \uFFFF]
set defaults [list\
-parentfolder \uFFFF\
-extrachoices \uFFFF\
-askpath 0\
-ansi \uFFFF\
-ansi_prompt \uFFFF\
-ansi_warning \uFFFF\
]
if {[llength $args] % 2 != 0} {
error "fossil_get_repository_folder requires args to be option-value pairs. Received '$args'"
}
dict for {k v} $args {
if {$k ni [dict keys $defaults]} {
error "fossil_get_repository_folder unrecognised option $k. Known options: [dict keys $defaults]"
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- ---
set opt_parentfolder [dict get $opts -parentfolder]
if {$opt_parentfolder eq "\uFFFF"} {
set opt_parentfolder [pwd]
}
set opt_extrachoice [dict get $opts -extrachoice]
set extrachoice ""
if {$opt_extrachoice ne "\uFFFF"} {
set extrachoice $opt_extrachoice
# -- --- --- --- --- ---
set opt_extrachoices [dict get $opts -extrachoices]
set extrachoices [list]
if {$opt_extrachoices ne "\uFFFF"} {
set extrachoices $opt_extrachoices
}
# -- --- --- --- --- ---
set opt_askpath [dict get $opts -askpath]
# -- --- --- --- --- ---
set opt_ansi [dict get $opts -ansi]
set opt_ansi_prompt [dict get $opts -ansi_prompt]
set opt_ansi_warning [dict get $opts -ansi_warning]
if {$opt_ansi eq "\uFFFF"} {
set opt_ansi 1
}
if {$opt_ansi} {
if {$opt_ansi_prompt eq "\uFFFF"} {
set ansiprompt [a+ green bold]
} else {
set ansiprompt [$opt_ansi_prompt]
}
if {$opt_ansi_warning eq "\uFFFF"} {
set ansiwarn [a+ red bold]
} else {
set ansiwarn [$opt_ansi_warning]
}
set ansireset [a]
} else {
set ansiprompt ""
set ansiwarn ""
set ansireset ""
}
# -- --- --- --- --- ---
set startdir $opt_parentfolder
@ -849,25 +891,8 @@ namespace eval punk::repo {
return
}
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo]
if {[llength $matching_lines] != 1} {
puts stderr "Unable to find config-db info from fossil. Check your fossil installation."
puts stderr "Fossil output was:"
puts stderr "-------------"
puts stderr "$fossilinfo"
puts stderr "-------------"
puts stderr "config-db info:"
puts stderr "$matching_lines"
return
}
set trimmedline [string trim [lindex $matching_lines 0]]
set firstcolon [string first : $trimmedline]
set config_db_path [string trim [string range $trimmedline $firstcolon+1 end]]
if {![file exists $config_db_path]} {
puts stderr "Unable to verify fossil global configuration info at path: $config_db_path"
return
}
set config_db_path [fossil_get_configdb]
set config_db_folder [file dirname $config_db_path]
#NOTE: we could use fossil all info to detect all locations of .fossil files - but there may be many that are specific to projects if the user wasn't in the habit of using a default location
@ -914,10 +939,11 @@ namespace eval punk::repo {
if {$tp ni $testpaths} {
lappend testpaths $tp
}
if {[string length $extrachoice]} {
set tp $extrachoice
if {$tp ni $testpaths} {
lappend testpaths $tp
if {[llength $extrachoices]} {
foreach tp $extrachoices {
if {$tp ni $testpaths} {
lappend testpaths $tp
}
}
}
@ -956,7 +982,7 @@ namespace eval punk::repo {
set existingfossils "( no existing .fossil files found )"
}
if {"$projectname.fossil" in $existing_fossils} {
set conflict "CONFLICT - $projectname.fossil already exists in this folder"
set conflict "${ansiwarn}CONFLICT - $projectname.fossil already exists in this folder${ansireset}"
} else {
set conflict ""
}
@ -975,9 +1001,9 @@ namespace eval punk::repo {
set menu_message ""
if {[llength $choice_folders]} {
append menu_message "Select the number of the folder to use to store the .fossil repository file" \n
append menu_message "${ansiprompt}Select the number of the folder to use to store the .fossil repository file${ansireset}" \n
} else {
append menu_message "--- NO suitable writable folders or locations found for .fossil file. Consider setting FOSSIL_HOME environment variable and check that folders are writable.--" \n
append menu_message "${ansiwarn}--- NO suitable writable folders or locations found for .fossil file. Consider setting FOSSIL_HOME environment variable and check that folders are writable.--${ansireset}" \n
}
set conflicted_options [list]
@ -1003,7 +1029,7 @@ namespace eval punk::repo {
if {[llength $readonly_repo_folder_locations]} {
append menu_message "--------------------------------------------------" \n
foreach readonly $readonly_repo_folder_locations {
append menu_message "<unavailable not writable> $readonly" \n
append menu_message "${ansiwarn}<unavailable not writable> $readonly${ansireset}" \n
}
append menu_message "--------------------------------------------------" \n
}
@ -1011,11 +1037,11 @@ namespace eval punk::repo {
#see if we can reasonably use the only available option and not bug the user
#Todo - option to always prompt?
#we will not auto-select if there is even one conflicted_option - as that seems like something you should know about
if {![llength $conflicted_options] && ([llength $choice_folders] == 1)} {
if {![llength $conflicted_options] && ([llength $choice_folders] == 1) && !$opt_askpath} {
set repo_folder_choice [lindex $choice_folders 0]
set repository_folder [dict get $repo_folder_choice folder]
} else {
if {[llength $choice_folders]} {
if {[llength $choice_folders] || $opt_askpath} {
puts stdout $menu_message
set max [llength $choice_folders]
if {$max == 1} {
@ -1023,24 +1049,73 @@ namespace eval punk::repo {
} else {
set rangemsg "a number from 1 to $max"
}
set answer [askuser "Enter $rangemsg to select location. (or N to abort)"]
if {![string is integer -strict $answer]} {
puts stderr "Aborting"
return
set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}"
if {$opt_askpath} {
set askpathprompt "${ansiprompt}Enter the word: path followed by an absolute path to a folder if you would like to manually enter a folder${ansireset}"
append menuprompt \n $askpathprompt
}
set answer [askuser $menuprompt]
if {$opt_askpath && [string match "path*" [string tolower $answer]]} {
set is_done 0
set repository_folder [string trim [string range $answer 4 end]]
while {!$is_done} {
if {![file isdirectory $repository_folder]} {
puts stderr "${ansiwarn}Sorry - unable to find entered location '$repository_folder'${ansireset}"
if {[file isdirectory [file dirname $repository_folder]]} {
set answer [askuser "${ansiprompt}Do you want to create this folder? Type just the word mkdir to create it, or N for no${ansireset}"]
if {[string equal mkdir [string tolower $answer]]} {
if {[catch {file mkdir $repository_folder} errM]} {
puts stderr "Failed to create folder $repository_folder. Error $errM"
}
}
} else {
puts stderr "${ansiwarn}Not offering to create directory because parent folder not found${ansireset}"
}
}
set index [expr {int($answer) -1}]
if {$index >= 0 && $index <= $max-1} {
set repo_folder_choice [lindex $choice_folders $index]
set repository_folder [dict get $repo_folder_choice folder]
puts stdout "Selected fossil location $repository_folder"
if {![file isdirectory $repository_folder]} {
set answer [askuser "${ansiprompt}Try again? (Y|N)${ansireset}"]
if {[string match y* [string tolower $answer]]} {
set answer [askuser $askpathprompt]
if {[string match "path*" [string tolower $answer]]} {
set repository_folder [string trim [string range $answer 4 end]]
} else {
puts stderr "Answer didn't begin with the word path"
set is_done 1
}
} else {
set is_done 1
}
} else {
set is_done 1
}
}
if {$is_done && ![file isdirectory $repository_folder]} {
puts stderr "Aborting"
return
}
} else {
puts stderr " No menu number matched - aborting."
return
if {![string is integer -strict $answer]} {
puts stderr "Aborting"
return
}
set index [expr {int($answer) -1}]
if {$index >= 0 && $index <= $max-1} {
set repo_folder_choice [lindex $choice_folders $index]
set repository_folder [dict get $repo_folder_choice folder]
puts stdout "Selected fossil location $repository_folder"
} else {
puts stderr " No menu number matched - aborting."
return
}
}
} else {
puts stdout $menu_message
set answer [askuser "Hit enter to exit"]
set answer [askuser "${ansiprompt}Hit enter to exit${ansireset}"]
return
}
}
@ -1053,26 +1128,26 @@ namespace eval punk::repo {
if {$path eq {}} { set path [pwd] }
# ::kettle::path::revision.git
do_in_path $path {
try {
#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} {
set v [lindex [split [dict get $o -errorinfo] \n] 0]
}
try {
#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} {
set v [lindex [split [dict get $o -errorinfo] \n] 0]
}
}
return [string trim $v]
}
proc git_remote {{path {{}}}} {
if {$path eq {}} { set path [pwd] }
do_in_path $path {
try {
#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] -remote -v] ;# consider 'git rev-parse --short HEAD'
} on error {e o} {
set v [lindex [split [dict get $o -errorinfo] \n] 0]
}
try {
#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] -remote -v] ;# consider 'git rev-parse --short HEAD'
} on error {e o} {
set v [lindex [split [dict get $o -errorinfo] \n] 0]
}
}
return [string trim $v]
}
@ -1104,6 +1179,148 @@ namespace eval punk::repo {
return Unknown
}
}
proc fossil_get_configdb {{path {}}} {
#fossil info will *usually* give us the necessary config-db info whether in a project folder or not but..
#a) It's expensive to shell-out and call it
#b) it won't give us a result if we are in a checkout folder which has had its repository moved
#this fairly extensive mechanism is designed to find it even if the environment has some weird goings-on regarding the filesystem/environment variables
#This is unlikely to be necessary in most scenarios, where the location is related to the user's home directory
#attempt 1 - environment vars and well-known locations
#This is first because it's faster - but hopefully it's aligned with how fossil does it
if {"windows" eq $::tcl_platform(platform)} {
foreach varname [list FOSSIL_HOME LOCALAPPDATA APPDATA USERPROFILES] {
if {[info exists ::env($varname)]} {
set testfile [file join $::env($varname) _fossil]
if {[file exists $testfile]} {
return $testfile
}
}
}
if {[info exists ::env(HOMEDRIVE)] && [info exists ::env(HOMEPATH)]} {
set testfile $::env(HOMEDRIVE)$::env(HOMEPATH)\\_fossil"
if {[file exists $testfile]} {
return $testfile
}
}
} else {
foreach varname [list FOSSIL_HOME HOME ] {
if {[info exists ::env($varname)]} {
set testfile [file join $::env($varname) .fossil]
if {[file exists $testfile]} {
return $testfile
}
}
}
if {[info exists ::env(XDG_CONFIG_HOME)]} {
set testfile [file join $::env(XDG_CONFIG_HOME) fossil.db]
if {[file exists $testfile]} {
return $testfile
}
set testfile [file join $::env(XDG_CONFIG_HOME) .config fossil.db]
if {[file exists $testfile]} {
return $testfile
}
}
if {[info exists ::env(HOME)]} {
set testfile [file join $::env(HOME) .config fossil.db]
if {[file exists $testfile]} {
return $testfile
}
}
}
set original_cwd [pwd]
#attempt2 - let fossil do it for us - hopefully based on current folder
if {$path eq {}} {set path [pwd]}
set fossilcmd [auto_execok fossil]
if {![llength $fossilcmd]} {
set fossil_ok 0
} else {
set fossil_ok 1
}
try {
while {$fossil_ok} {
cd $path
if {[catch {exec {*}$fossilcmd info} fossilinfo]} {
#a detached repo above us can result in an error from fossil info
set next [file dirname $path]
} else {
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo]
if {[llength $matching_lines] == 1} {
set trimmedline [string trim [lindex $matching_lines 0]]
set firstcolon [string first : $trimmedline]
set config_db_path [string trim [string range $trimmedline $firstcolon+1 end]]
if {[file exists $config_db_path]} {
return $config_db_path
}
}
set next [file dirname $path]
}
if {$next eq $path || $next eq ""} {
break
}
set path $next
}
} on error {errmsg options} {
#puts "errmsg:$errmgs options:$options"
} finally {
cd $original_cwd
}
#attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result
if {$fossil_ok} {
#It should be extremely rare to need to resort to sqlite on the databases to find other potential repo paths
#Conceivably only on some weird VFS or where some other filesystem strangeness is going on with our original path - or if the root volume itself is a broken fossil checkout
#Examining the other repos gives us a chance at discovering some other filesystem/paths where things may not be broken
if {![catch {package require sqlite3} errPackage]} {
#use fossil all ls and sqlite
if {[catch {exec {*}$fossilcmd all ls} repolines]} {
error "fossil_get_configdb cannot find repositories"
} else {
set repolines [string map [list \r\n \n] $repolines]
set repolist [split $repolines \n]
set dbcmd "fossil_get_configdb_tempdb"
foreach repodb $repolist {
catch {rename $dbcmd ""}
if {[file exists $repodb]} {
if {![catch {sqlite3 $dbcmd $repodb}]} {
set ckoutrecords [$dbcmd eval {select name from config where name like 'ckout:%'}]
catch {$dbcmd close}
foreach ck $ckoutrecords {
set ckfolder [string range $ck 6 end]
#puts stdout "ckfolder $ckfolder"
if {[file isdirectory $ckfolder]} {
set result ""
do_in_path $ckfolder {
if {![catch {exec {*}$fossilcmd info} fossilinfo]} {
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo]
if {[llength $matching_lines] == 1} {
set trimmedline [string trim [lindex $matching_lines 0]]
set firstcolon [string first : $trimmedline]
set config_db_path [string trim [string range $trimmedline $firstcolon+1 end]]
if {[file exists $config_db_path]} {
set result $config_db_path
}
}
}
}
if {$result ne ""} {
return $result
}
}
}
}
}
}
}
}
}
error "fossil_get_configdb exhausted search options"
}
#------------------------------------
#temporarily cd to workpath to run script - return to correct path even on failure
@ -1256,7 +1473,19 @@ namespace eval punk::repo {
interp alias {} gconf {} git config --global -l
}
namespace eval punk::repo::lib {
#-----------------------------------------------------------------------------------
#strlen is important for testing issues with string representationa and shimmering.
#This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed
#It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour
#The use of this function instead of string length can make a difference in certain circumstances with 'path' object representations
proc strlen {str} {
append str2 $str {}
string length $str2
}
#-----------------------------------------------------------------------------------
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready

35
src/bootsupport/modules/punkcheck-0.1.0.tm

@ -1,5 +1,5 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
# 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.
@ -36,6 +36,7 @@ namespace eval punkcheck {
uuid\
start_installer_event installfile_*
#antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators
variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"]
variable default_antiglob_file_core ""
proc uuid {} {
@ -1155,15 +1156,15 @@ namespace eval punkcheck {
-installer punkcheck::install\
]
set opts [dict merge $defaults $args]
if {([llength $args] %2) != 0} {
error "punkcheck::install requires option-style arguments to be in pairs. Received args: $args"
}
foreach k [dict keys $args] {
foreach {k -} $args {
if {$k ni [dict keys $defaults]} {
error "punkcheck::install unrecognised option '$k' known options: '[dict keys $defaults]'"
}
}
set opts [dict merge $defaults $args]
#The choice to recurse using the original values of srcdir & tgtdir, and passing the subpath down as a list in -subdirlist seems an odd one.
#(as opposed to a more 'standard' mechanism of adjusting srcdir & tgtdir as we move down the tree)
@ -1194,6 +1195,12 @@ namespace eval punkcheck {
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_file [dict get $opts -antiglob_file]
#validate no path seps
foreach af $opt_antiglob_file {
if {[llength [file split $af]] > 1} {
error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators"
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core]
if {$opt_antiglob_dir_core eq "\uFFFF"} {
@ -1202,8 +1209,15 @@ namespace eval punkcheck {
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_dir [dict get $opts -antiglob_dir]
#validate no path seps
foreach ad $opt_antiglob_dir {
if {[llength [file split $ad]] > 1} {
error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators"
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?)
#antiglob_paths will usually contain file separators - and may contain glob patterns within each segment
set antiglob_paths_matched [list]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set known_whats [list no-targets newer-targets older-targets all-targets installedsourcechanged-targets synced-targets]
@ -1586,6 +1600,21 @@ namespace eval punkcheck {
continue
}
set relative_source_path [file join $relative_source_dir $d]
set is_antipath 0
foreach antipath $opt_antiglob_paths {
#puts "testing folder - globmatchpath $antipath vs $relative_source_path"
if {[punk::path::globmatchpath $antipath $relative_source_path]} {
lappend antiglob_paths_matched [file join $current_source_dir $d]
puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath "
set is_antipath 1
break
}
}
if {$is_antipath} {
continue
}
if {![file exists $current_target_dir/$d]} {
file mkdir $current_target_dir/$d

1508
src/bootsupport/modules/smtp-1.5.1.tm

File diff suppressed because it is too large Load Diff

2
src/build.tcl

@ -1,6 +1,6 @@
#!/bin/sh
# -*- tcl -*- \
# 'build.tcl' name as required by kettle
# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...`\
# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\
exec ./kettle -f "$0" "${1+$@}"
kettle doc

0
src/modules/punk/mix/templates/layouts/project/src/buildsuites/samplesuite1/tcl/empty_project_source.txt → src/decktemplates/custom/_project/layout_refs/@custom+_project+punk.shell-0.1.ref

0
src/modules/punk/mix/templates/layouts/project/src/buildsuites/samplesuite1/tk/empty_project_source.txt → src/decktemplates/custom/_project/layout_refs/test1@vendor+punk+sample-0.1.ref

0
src/decktemplates/vendor/_project/layout_refs/@vendor+_project+punk.shell-0.1.ref vendored

0
src/decktemplates/vendor/_project/layout_refs/test2@vendor+punk+sample-0.1.ref vendored

0
src/decktemplates/vendor/punk/layout_refs/@vendor+punk+basic.ref vendored

0
src/decktemplates/vendor/punk/layout_refs/@vendor+punk+minimal.ref vendored

0
src/decktemplates/vendor/punk/layout_refs/@vendor+punk+sample-0.1.ref vendored

0
src/decktemplates/vendor/punk/layout_refs/project@vendor+punk+project-0.1.ref vendored

9
src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm vendored

@ -108,10 +108,15 @@ namespace eval %pkg% {
#proc sample1 {p1 args} {
#proc sample1 {p1 n args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {option value...}]]
# #[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"
#}

140
src/make.tcl

@ -339,28 +339,28 @@ if {$::punkmake::command eq "bootsupport"} {
}
}
foreach folder $bootsupport_module_folders {
#explicitly ignore punk/mix/templates folder even if specified in config.
#punk/mix/templates contains modules including punk/mix/templates itself - the actual templates aren't needed for the bootsupport system,
# as make.tcl shouldn't be building new projects from the one being made.
#review.
#should we be autodetecting such recursive folder structures - (or is the bootsupport copying in need of a rethink?)
if {[string trim $folder /] eq "punk/mix/templates"} {
puts stderr "IGNORING punk/mix/templates - not needed/desirable in bootsupport"
continue
}
set src [file join $projectroot/modules $folder]
if {![file isdirectory $src]} {
puts stderr "bootsupport folder not found: $src"
continue
}
set tgt [file join $targetroot $folder]
file mkdir $tgt
if {[llength $bootsupport_module_folders] % 2 != 0} {
#todo - change include_modules.config structure to be line based? we have no way of verifying paired entries because we accept a flat list
puts stderr "WARNING - Skipping bootsupport_module_folders - list should be a list of base subpath pairs"
} else {
foreach {base subfolder} $bootsupport_module_folders {
#user should be careful not to include recursive/cyclic structures e.g module that has a folder which contains other modules from this project
#It will probably work somewhat.. but may make updates confusing.. or worse - start making deeper and deeper copies
set src [file join $projectroot $base $subfolder]
if {![file isdirectory $src]} {
puts stderr "bootsupport folder not found: $src"
continue
}
#subfolder is the common relative path - so don't include the base in the target path
set tgt [file join $targetroot $subfolder]
file mkdir $tgt
puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)"
set overwrite "installedsourcechanged-targets"
set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)"
set overwrite "installedsourcechanged-targets"
set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
}
}
@ -370,13 +370,13 @@ if {$::punkmake::command eq "bootsupport"} {
#/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself.
set layout_bases [list\
$sourcefolder/mixtemplates/layouts\
$sourcefolder/modules/punk/mix/templates/layouts\
$sourcefolder/project_layouts/custom/_project\
]
foreach project_layout_base $layout_bases {
if {[file exists $project_layout_base]} {
set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *]
foreach layoutname $project_layouts {
#don't auto-create src/bootsupport - just update it if it exists
if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} {
set antipaths [list\
README.md\
@ -451,61 +451,67 @@ if {[file exists $sourcefolder/vendormodules]} {
#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync
#src to src/modules/punk/mix/templates/layouts/project/src
set layout_update_list [list\
set old_layout_update_list [list\
[list project $sourcefolder/modules/punk/mix/templates]\
[list basic $sourcefolder/mixtemplates]\
]
set layout_bases [list\
$sourcefolder/project_layouts/custom/_project\
]
foreach layoutinfo $layout_update_list {
lassign $layoutinfo layout templatebase
if {![file exists $templatebase]} {
foreach layoutbase $layout_bases {
if {![file exists $layoutbase]} {
continue
}
set config [dict create\
-make-step sync_templates\
]
#----------
set tpl_installer [punkcheck::installtrack new make.tcl $templatebase/.punkcheck]
$tpl_installer set_source_target $sourcefolder $templatebase
set tpl_event [$tpl_installer start_event $config]
#----------
set pairs [list]
set pairs [list\
[list $sourcefolder/build.tcl $templatebase/layouts/$layout/src/build.tcl]\
[list $sourcefolder/make.tcl $templatebase/layouts/$layout/src/make.tcl]\
]
foreach filepair $pairs {
lassign $filepair srcfile tgtfile
file mkdir [file dirname $tgtfile]
set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *]
foreach layoutname $project_layouts {
set config [dict create\
-make-step sync_layouts\
]
#----------
$tpl_event targetset_init INSTALL $tgtfile
$tpl_event targetset_addsource $srcfile
set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck]
$tpl_installer set_source_target $sourcefolder $layoutbase
set tpl_event [$tpl_installer start_event $config]
#----------
if {\
[llength [dict get [$tpl_event targetset_source_changes] changed]]\
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\
} {
$tpl_event targetset_started
# -- --- --- --- --- ---
puts stdout "punk module templates: Copying from $srcfile to $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$tpl_event targetset_end FAILED -note "copy failed with err: $errM"
set pairs [list]
set pairs [list\
[list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\
[list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\
]
foreach filepair $pairs {
lassign $filepair srcfile tgtfile
file mkdir [file dirname $tgtfile]
#----------
$tpl_event targetset_init INSTALL $tgtfile
$tpl_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$tpl_event targetset_source_changes] changed]]\
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\
} {
$tpl_event targetset_started
# -- --- --- --- --- ---
puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM"
} else {
$tpl_event targetset_end OK -note "layout:$layoutname"
}
# -- --- --- --- --- ---
} else {
$tpl_event targetset_end OK -note "test"
puts stderr "."
$tpl_event targetset_end SKIPPED
}
# -- --- --- --- --- ---
} else {
puts stderr "."
$tpl_event targetset_end SKIPPED
}
}
$tpl_event end
$tpl_event destroy
$tpl_installer destroy
$tpl_event end
$tpl_event destroy
$tpl_installer destroy
}
}
########################################################
@ -658,7 +664,7 @@ if {[file exists $mapfile]} {
set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs]
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs)
foreach vfs [dict keys $vfs_runtime_map] {
dict for {vfs -} $vfs_runtime_map {
if {$vfs ni $vfs_folders} {
lappend vfs_folders $vfs
}

1
src/mixtemplates/layouts/basic/src/bootsupport/README.md

@ -1 +0,0 @@
bootsupport libs and modules

200
src/mixtemplates/layouts/basic/src/bootsupport/modules/cksum-1.1.4.tm

@ -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:

933
src/mixtemplates/layouts/basic/src/bootsupport/modules/cmdline-1.5.2.tm

@ -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
}

2311
src/mixtemplates/layouts/basic/src/bootsupport/modules/fileutil-1.16.1.tm

File diff suppressed because it is too large Load Diff

5457
src/mixtemplates/layouts/basic/src/bootsupport/modules/http-2.10b1.tm

File diff suppressed because it is too large Load Diff

1886
src/mixtemplates/layouts/basic/src/bootsupport/modules/natsort-0.1.1.5.tm

File diff suppressed because it is too large Load Diff

195
src/mixtemplates/layouts/basic/src/bootsupport/modules/oolib-0.1.tm

@ -1,195 +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
}]
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
}
}
}

663
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap-0.1.0.tm

@ -1,663 +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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::cap {
variable pkgcapsdeclared [dict create]
variable pkgcapsaccepted [dict create]
variable caps [dict create]
namespace eval class {
if {[info commands [namespace current]::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 [namespace current]::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 [namespace current]::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 [namespace current]::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 [namespace current]::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 [list "" "::"]} {
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 {[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"
}
set provider_pkg [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} {
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 {![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 ""} {
error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr"
}
#assert: 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.
dict set caps $capname handler $capnamespace
if {![dict exists $caps $capname providers]} {
dict set caps $capname providers [list]
}
if {[llength [set providers [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 [dict get $pkgcapsdeclared $pkg]
foreach capspec $fullcapabilitylist {
lassign $capspec cn capdict
if {$cn ne $capname} {
continue
}
set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist]
set list_accepted [dict get $pkgcapsaccepted $pkg]
if {$do_register} {
if {$capspec ni $list_accepted} {
dict lappend pkgcapsaccepted $pkg $capspec
}
} else {
set posn [lsearch $list_accepted $capspec]
if {$posn >=0} {
set list_accepted [lreplace $list_accepted $posn $posn]
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 [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]
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 [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 {[dict exists $caps $capname handler] && [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 {[dict exists $caps $capname]} {
return [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 {[dict exists $caps $capname]} {
return [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, that the capability will use.
proc register_package {pkg capabilitylist args} {
variable pkgcapsdeclared
variable pkgcapsaccepted
variable caps
set defaults [dict create\
-nowarnings false
]
dict for {k v} $args {
if {$k ni $defaults} {
error "Unrecognized option $k. Known options [dict keys $defaults]"
}
}
set opts [dict merge $defaults $args]
set warnings [expr {! [dict get $opts -nowarnings]}]
if {[string match ::* $pkg]} {
set pkg [string range $pkg 2 end]
}
if {[dict exists $pkgcapsaccepted $pkg]} {
set pkg_already_accepted [dict get $pkgcapsaccepted $pkg]
} else {
set pkg_already_accepted [list]
}
package require $pkg
set providerapi ::${pkg}::provider
if {[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
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} {
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'"
}
if {[expr {[llength $capdict] %2 != 0}]} {
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'"
}
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"
}
continue
}
if {[dict exists $caps $capname]} {
set cap_pkgs [dict get $caps $capname providers]
} else {
dict set caps $capname [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
dict set caps $capname providers $cap_pkgs
}
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 {[dict exists $pkgcapsdeclared $pkg]} {
set capspecs [dict get $pkgcapsdeclared $pkg]
foreach spec $capspecs {
if {$spec ni $capspecs} {
lappend capspecs $spec
}
}
dict set pkgcapsdeclared $pkg $capspecs
} else {
dict set pkgcapsdeclared $pkg $capabilitylist
}
}
#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} {
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 [dict get $pkgcapsaccepted $pkg]
}
return [dict create declared [dict get $pkgcapsdeclared $pkg] 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]

52
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm

@ -1,52 +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::handlers::caphandler 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::cap::handlers::caphandler {
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler {
variable pkg punk::cap::handlers::caphandler
variable version
set version 0.1.0
}]
return

52
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/scriptlibs-0.1.0.tm

@ -1,52 +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::handlers::scriptlibs 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::cap::handlers::scriptlibs {
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs {
variable pkg punk::cap::handlers::scriptlibs
variable version
set version 0.1.0
}]
return

145
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -1,145 +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::handlers::templates 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#register using:
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it.
# (even if it tends to be done immediately after package require anyway)
# registering capability handlers can involve validating existing provider data and is best done explicitly as required.
# It is also possible for a capability handler to be registered to handle more than one capabilityname
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::cap::handlers::templates {
namespace eval capsystem {
#interfaces for punk::cap to call into
if {[info commands caphandler.registry] eq ""} {
punk::cap::class::interface_caphandler.registry create caphandler.registry
oo::objdefine caphandler.registry {
method pkg_register {pkg capname capdict caplist} {
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?)
# -- --- --- --- --- --- --- ---- ---
# validation of capdict
# -- --- --- --- --- --- --- ---- ---
if {![dict exists $capdict relpath]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key"
return 0
}
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
if {![file exists $tmfile]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
return 0
}
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder
if {![file isdirectory $tpath]} {
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
return 0
}
# -- --- --- --- --- --- --- ---- ---
# update package internal data
# -- --- --- --- --- --- --- ---- ---
if {$capname ni $::punk::cap::handlers::templates::handled_caps} {
lappend ::punk::cap::handlers::templates::handled_caps $capname
}
set cname [string map [list . _] $capname]
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders
dict lappend pfolders $pkg $tpath
# -- --- --- --- --- --- --- ---- ---
# instantiation of api at punk::cap::handlers::templates::api_$capname
# -- --- --- --- --- --- --- ---- ---
if {[info commands ::punk::cap::handlers::templates::$capname] eq ""} {
punk::cap::handlers::templates::class::api create ::punk::cap::handlers::templates::api_$capname $capname
}
return 1
}
method pkg_unregister {pkg} {
upvar ::punk::cap::handlers::templates::handled_caps hcaps
foreach capname $hcaps {
set cname [string map [list . _] $capname]
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders
dict unset pfolders $pkg
#destroy api objects?
}
}
}
}
}
variable handled_caps [list]
#variable pkg_folders [dict create]
# -- --- --- --- --- --- ---
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args?
# -- --- --- --- --- --- ---
namespace export *
namespace eval class {
oo::class create api {
#return a dict keyed on folder with source pkg as value
constructor {capname} {
variable capabilityname
variable cname
set cname [string map [list . _] $capname]
set capabilityname $capname
}
method folders {} {
variable capabilityname
variable cname
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders
package require punk::cap
set capinfo [punk::cap::capability $capabilityname]
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}}
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package
set pkgs [dict get $capinfo providers]
set folderdict [dict create]
foreach pkg $pkgs {
foreach pfolder [dict get $pkg_folders $pkg] {
dict set folderdict $pfolder [list source $pkg sourcetype package]
}
}
return $folderdict
}
}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates {
variable pkg punk::cap::handlers::templates
variable version
set version 0.1.0
}]
return

71
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/docgen-0.1.0.tm

@ -1,71 +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]
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
}
}
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

1284
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/du-0.1.0.tm

File diff suppressed because it is too large Load Diff

21
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix-0.2.tm

@ -1,21 +0,0 @@
package require punk::cap
package require punk::cap::handlers::templates ;#handler for templates cap
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap
punk::mix::templates::provider register *
package require punk::mix::base
package require punk::mix::cli
namespace eval punk::mix {
}
package provide punk::mix [namespace eval punk::mix {
variable version
set version 0.2
}]

910
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/base-0.1.tm

@ -1,910 +0,0 @@
package provide punk::mix::base [namespace eval punk::mix::base {
variable version
set version 0.1
}]
package require punk::path
#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 dirctly as punk::mix::base::_cli
if {![llength $args]} {
set args "help"
}
set extension [namespace current]
}
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 {
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'
set helpstr ""
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]
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm]
if {[llength $tmfiles]} {
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
# scriptpath - file or folder
# It represents the base point from which to search for mixtemplates 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 {{scriptpath ""}} {
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap)
set folderdict [dict create]
package require punk::cap
if {[punk::cap::capability_has_handler punk.templates]} {
set template_folder_dict [punk::cap::call_handler punk.templates folders]
dict for {dir folderinfo} $template_folder_dict {
dict set folderdict $dir $folderinfo
}
}
#2 middle precedence - mixtemplates folder relative to cwd
set searchbase [pwd]
set fld [file join $searchbase mixtemplates]
if {[file isdirectory $fld]} {
if {![dict exists $folderdict $fld]} {
dict set folderdict $fld [list source $searchbase sourcetype cwd]
}
}
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
if {$pwd_projectroot ne ""} {
set fld [file join $pwd_projectroot src/mixtemplates]
if {![dict exists $folderdict $fld]} {
dict set folderdict $fld [list source $pwd_projectroot sourcetype project]
}
}
#3 highest precedence - mixtemplates relative to scriptpath argument
if {$scriptpath ne ""} {
if {[file type $scriptpath] eq "file"} {
set searchbase [file dirname $scriptpath]
} else {
set searchbase $scriptpath
}
if {[file isdirectory [file join $searchbase mixtemplates]]} {
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch]
}
set pathinfo [punk::repo::find_repos $searchbase]
set scriptpath_projectroot [dict get $pathinfo closest]
if {$scriptpath_projectroot ne ""} {
set fld [file join $scriptpath_projectroot src/mixtemplates]
if {[file isdirectory $fld]} {
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project]
}
}
}
#don't sort - order in which encountered defines the precedence - with later overriding earlier
return $folderdict
}
proc module_subpath {modulename} {
set modulename [string trim $modulename :]
set nsq [namespace qualifiers $modulename]
return [string map [list :: /] $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
proc cksum_default_opts {} {
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1]
}
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?)
#sha1 is performant - 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 good default
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} {
package require zlib; #should be builtin anyway
set data [punk::mix::util::fcat -translation binary $filename]
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names
zlib adler32 $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]
}
if {$ftype ni [list file directory]} {
#review - links?
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]
}
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]
if {$ftype eq "file"} {
if {$opt_use_tar eq "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
}
} elseif {$opt_use_tar eq "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
}
} else {
#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
}
}
} elseif {$ftype eq "directory"} {
if {$opt_use_tar eq "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]
}
} elseif {$opt_use_tar eq "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]
} else {
#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]
}
if {$opt_cksum_algorithm eq "sha1"} {
package require sha1
set cksum_command [list sha1::sha1 -hex -file]
} elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} {
package require sha256
set cksum_command [list sha2::sha256 -hex -file]
} elseif {$opt_cksum_algorithm eq "md5"} {
package require md5
set cksum_command [list md5::md5 -hex -file]
} elseif {$opt_cksum_algorithm eq "cksum"} {
package require cksum ;#tcllib
set cksum_command [list crc::cksum -format 0x%X -file]
} elseif {$opt_cksum_algorithm eq "adler32"} {
set cksum_command [list cksum_adler32_file]
} elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} {
#todo - replace with something that doesn't call another process
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}]
set cksum_command [list $sha3_implementation 256]
} elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-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 stdout " at: $archivename .."
tar::create $archivename $target
if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])"
} else {
set sizeinfo "(file type $ftype - size unknown)"
}
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..."
set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. "
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
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 {
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
}
set ckopts [cksum_filter_opts {*}$pathinfo]
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]
dict for {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 ignore valid-looking prefilled cksum values
#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 type $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) != 0} {
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
dict set keyvals cksum [dict get $ckinfo cksum]
dict set keyvals cksum_all_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} {
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 ""]
}
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]
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
}
}
}

925
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/cli-0.3.tm

@ -1,925 +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::cli 0.3
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::repo
package require punkcheck ;#checksum and/or timestamp records
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::cli {
namespace eval temp_import {
}
namespace ensemble create
package require punk::overlay
catch {
punk::overlay::import_commandset module . ::punk::mix::commandset::module
}
punk::overlay::import_commandset debug . ::punk::mix::commandset::debug
punk::overlay::import_commandset repo . ::punk::mix::commandset::repo
punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib
catch {
package require punk::mix::commandset::project
punk::overlay::import_commandset project . ::punk::mix::commandset::project
punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
}
if {[catch {
package require punk::mix::commandset::layout
punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout
punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection
} errM]} {
puts stderr "error loading punk::mix::commandset::layout"
puts stderr $errM
}
if {[catch {
package require punk::mix::commandset::buildsuite
punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite
punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection
} errM]} {
puts stderr "error loading punk::mix::commandset::buildsuite"
puts stderr $errM
}
punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap
if {[catch {
package require punk::mix::commandset::doc
punk::overlay::import_commandset doc . ::punk::mix::commandset::doc
punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection
} errM]} {
puts stderr "error loading punk::mix::commandset::doc"
puts stderr $errM
}
proc help {args} {
#set basehelp [punk::mix::base::help -extension [namespace current] {*}$args]
set basehelp [punk::mix::base help {*}$args]
#puts stdout "punk::mix help"
return $basehelp
}
proc stat {{workingdir ""} args} {
dict set args -v 0
punk::mix::cli::lib::get_status $workingdir {*}$args
}
proc status {{workingdir ""} args} {
dict set args -v 1
punk::mix::cli::lib::get_status $workingdir {*}$args
}
}
namespace eval punk::mix::cli {
#interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new
proc make {args} {
set startdir [pwd]
set project_base "" ;#empty for unknown
if {[punk::repo::is_git $startdir]} {
set project_base [punk::repo::find_git]
set sourcefolder $project_base/src
} elseif {[punk::repo::is_fossil $startdir]} {
set project_base [punk::repo::find_fossil]
set sourcefolder $project_base/src
} else {
if {[punk::repo::is_candidate $startdir]} {
set project_base [punk::repo::find_candidate]
set sourcefolder $project_base/src
puts stderr "WARNING - project not under git or fossil control"
puts stderr "Using base folder $project_base"
} else {
set sourcefolder $startdir
}
}
#review - why can't we be anywhere in the project?
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} {
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])"
if {[string length $project_base]} {
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} {
puts stderr "Try cd to $project_base/src"
}
} else {
if {[file exists $startdir/Makefile]} {
puts stdout "A Makefile exists at $startdir/Makefile."
if {"windows" eq $::tcl_platform(platform)} {
puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\""
} else {
puts stdout "Try runing: make build"
}
}
}
return false
}
if {![string length $project_base]} {
puts stderr "WARNING no git or fossil repository detected."
puts stderr "Using base folder $startdir"
set project_base $startdir
}
set lc_this_exe [string tolower [info nameofexecutable]]
set lc_proj_bin [string tolower $project_base/bin]
set lc_build_bin [string tolower $project_base/src/_build]
if {"project" in $args} {
set is_own_exe 0
if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} {
set is_own_exe 1
puts stderr "WARNING - running make using executable that may be created by the project being built"
set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
}
}
}
cd $sourcefolder
#use run so that stdout visible as it goes
if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} {
#todo - notify if exit because of timeout!
puts stderr "exitinfo: $exitinfo"
set exitcode [dict get $exitinfo exitcode]
} else {
puts stderr "Error unable to determine exitcode. err: $exitinfo"
cd $startdir
return false
}
cd $startdir
if {$exitcode != 0} {
puts stderr "FAILED with exitcode $exitcode"
return false
} else {
puts stdout "OK make finished "
return true
}
}
proc Kettle {args} {
tailcall lib::kettle_call lib {*}$args
}
proc KettleShell {args} {
tailcall lib::kettle_call shell {*}$args
}
namespace eval lib {
namespace path ::punk::mix::util
proc module_types {} {
#first in list is default for unspecified -type when creating new module
return [list plain tarjar zipkit]
}
proc validate_modulename {modulename args} {
set defaults [list\
-name_description modulename\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
foreach k [dict keys $args] {
if {$k ni $known_opts} {
error "validate_modulename error: unknown option $k. known options: $known_opts"
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description
set testname [string map [list :: ""] $modulename]
if {[string first : $testname] >=0} {
error "$opt_name_description '$modulename' can only contain paired colons"
}
set badchars [list - "$" "?" "*"]
foreach bc $badchars {
if {[string first $bc $modulename] >= 0} {
error "$opt_name_description '$modulename' can not contain character '$bc'"
}
}
return $modulename
}
proc validate_projectname {projectname args} {
set defaults [list\
-name_description projectname\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
foreach k [dict keys $args] {
if {$k ni $known_opts} {
error "validate_modulename error: unknown option $k. known options: $known_opts"
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build]
if {$projectname in $reserved_words } {
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words"
}
if {[string first "::" $projectname] >= 0} {
error "$opt_name_description '$projectname' cannot contain namespace separator '::'"
}
return $projectname
}
proc validate_name_not_empty_or_spaced {name args} {
set defaults [list\
-name_description projectname\
]
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"}
set known_opts [dict keys $defaults]
foreach k [dict keys $args] {
if {$k ni $known_opts} {
error "validate_modulename error: unknown option $k. known options: $known_opts"
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_name_description [dict get $opts -name_description]
# -- --- --- --- --- --- --- --- --- --- --- --- --- ---
if {![string length $name]} {
error "$opt_name_description cannot be empty"
}
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} {
error "$opt_name_description cannot contain whitespace"
}
return $name
}
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path
#ignore trailing .tm .TM if present
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error
#Up to caller to validate.
proc split_modulename_version {modulename} {
set lastpart [namespace tail $modulename]
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components
if {[string equal -nocase [file extension $modulename] ".tm"]} {
set fileparts [split [file rootname $lastpart] -]
} else {
set fileparts [split $lastpart -]
}
if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} {
set versionsegment [lindex $fileparts end]
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch
} else {
#
set namesegment [join $fileparts -]
set versionsegment ""
}
return [list $namesegment $versionsegment]
}
proc get_status {{workingdir ""} args} {
set result ""
if {$workingdir ne ""} {
if {[file pathtype $workingdir] ne "absolute"} {
set workingdir [file normalize $workingdir]
}
set active_dir $workingdir
} else {
set active_dir [pwd]
}
set defaults [dict create\
-v 1\
]
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- ---
set opt_v [dict get $opts -v]
# -- --- --- --- --- --- --- --- ---
set repopaths [punk::repo::find_repos [pwd]]
set repos [dict get $repopaths repos]
if {![llength $repos]} {
append result [dict get $repopaths warnings]
} else {
append result [dict get $repopaths warnings]
lassign [lindex $repos 0] repopath repotypes
if {"fossil" in $repotypes} {
#review - multiple process launches to fossil a bit slow on windows..
#could we query global db in one go instead?
#
set fossil_prog [auto_execok fossil]
append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n
set fosinfo [exec {*}$fossil_prog info]
append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n
set fosrem [exec {*}$fossil_prog remote ls]
if {[string length $fosrem]} {
append result "Remotes:\n"
append result " " $fosrem \n
}
append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n
set dbinfo [exec {*}$fossil_prog dbstat]
append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n
append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n
append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n
append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n
append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n
append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n
if {"project" in $repotypes} {
#punk project
if {![catch {package require textblock; package require patternpunk}]} {
set result [textblock::join [textblock::join [>punk . logo] " "] $result]
append result \n
}
}
set timeline [exec fossil timeline -n 5 -t ci]
set timeline [string map [list \r\n \n] $timeline]
append result $timeline
if {$opt_v} {
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil]
append result \n [punk::repo::workingdir_state_summary $repostate]
}
}
#repotypes *could* be both git and fossil - so report both if so
if {"git" in $repotypes} {
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n
if {[string length [set git_prog [auto_execok git]]]} {
set git_remotes [exec {*}$git_prog remote -v]
append result $git_remotes
if {$opt_v} {
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git]
append result \n [punk::repo::workingdir_state_summary $repostate]
}
}
}
}
return $result
}
proc build_modules_from_source_to_base {srcdir basedir args} {
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in.
set defaults [list\
-installer punk::mix::cli::build_modules_from_source_to_base\
-call-depth-internal 0\
-max_depth 1000\
-subdirlist {}\
-punkcheck_eventobj "\uFFFF"\
-glob *.tm\
]
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set installername [dict get $opts -installer]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set CALLDEPTH [dict get $opts -call-depth-internal]
set max_depth [dict get $opts -max_depth]
set subdirlist [dict get $opts -subdirlist]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set fileglob [dict get $opts -glob]
if {![string match "*.tm" $fileglob]} {
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules."
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj]
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing
set module_list [list]
if {[file tail [file dirname $srcdir]] ne "src"} {
puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory"
puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root"
puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist."
puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib"
puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}"
exit 2
}
set srcdirname [file tail $srcdir]
set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir
if {[llength $subdirlist] == 0} {
set target_module_dir $basedir
set current_source_dir $srcdir
} else {
set target_module_dir $basedir/[file join {*}$subdirlist]
set current_source_dir $srcdir/[file join {*}$subdirlist]
}
if {![file exists $target_module_dir]} {
error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty"
}
if {![file exists $current_source_dir]} {
error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty"
}
#----------------------------------------
set punkcheck_file [file join $basedir/.punkcheck]
if {$CALLDEPTH == 0} {
set config [dict create\
-glob $fileglob\
-max_depth 0\
]
#lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list
# -- ---
set installer [punkcheck::installtrack new $installername $punkcheck_file]
$installer set_source_target $srcdir $basedir
set event [$installer start_event $config]
# -- ---
} else {
set event $opt_punkcheck_eventobj
}
#----------------------------------------
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob]
set did_skip 0 ;#flag for stdout/stderr formatting only
foreach m $src_modules {
set is_interesting 0
if {[string match "foobar" $current_source_dir]} {
set is_interesting 1
}
if {$is_interesting} {
puts "build_modules_from_source_to_base >>> module $current_source_dir/$m"
}
set fileparts [split [file rootname $m] -]
set tmfile_versionsegment [lindex $fileparts end]
if {$tmfile_versionsegment eq $magicversion} {
#rebuild the .tm from the #tarjar
set basename [join [lrange $fileparts 0 end-1] -]
set versionfile $current_source_dir/$basename-buildversion.txt
set versionfiledata ""
if {![file exists $versionfile]} {
puts stderr "\nWARNING: Missing buildversion text file: $versionfile"
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n"
set module_build_version "0.1"
} else {
set fd [open $versionfile r]
set versionfiledata [read $fd]; close $fd
set ln0 [lindex [split $versionfiledata \n] 0]
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r]
if {![util::is_valid_tm_version $ln0]} {
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file"
exit 3
}
set module_build_version $ln0
}
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} {
#TODO
file mkdir $buildfolder
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} {
} else {
}
#REVIEW - should be in same structure/depth as $target_module_dir in _build?
set tmfile $basedir/_build/$basename-$module_build_version.tm
file mkdir $basedir/_build
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version
file delete -force $tmfile
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version
#
#bsdtar doesn't seem to work.. or I haven't worked out the right options?
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version
package require tar
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version
if {![file exists $tmfile]} {
puts stdout "ERROR: Failed to build tarjar file $tmfile"
exit 4
}
#copy the file?
#set target $target_module_dir/$basename-$module_build_version.tm
#file copy -force $tmfile $target
lappend module_list $tmfile
} else {
#assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred.
if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} {
puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt"
}
#------------------------------
#
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm]
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid]
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm
$event targetset_addsource $versionfile
$event targetset_addsource $current_source_dir/$m
#set changed_list [list]
## -- --- --- --- --- ---
#set source_relpath [punkcheck::lib::path_relative $basedir $versionfile]
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record]
## -- --- --- --- --- ---
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m]
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record]
## -- --- --- --- --- ---
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]]
#set changed_list [dict get $changed_unchanged changed]
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
#set file_record [punkcheck::installfile_started_install $basedir $file_record]
$event targetset_started
# -- --- --- --- --- ---
set target $target_module_dir/$basename-$module_build_version.tm
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])"
set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd
set data [string map [list $magicversion $module_build_version] $data]
set fdout [open $target w]
fconfigure $fdout -translation binary
puts -nonewline $fdout $data
close $fdout
#file copy -force $srcdir/$m $target
lappend module_list $target
# -- --- --- --- --- ---
#set file_record [punkcheck::installfile_finished_install $basedir $file_record]
$event targetset_end OK
} else {
if {$is_interesting} {
puts stdout "skipping module $current_source_dir/$m - no change in sources detected"
}
puts -nonewline stderr "."
set did_skip 1
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$event targetset_end SKIPPED
}
#------------------------------
}
continue
}
if {![util::is_valid_tm_version $tmfile_versionsegment]} {
#last segment doesn't look even slightly versiony - fail.
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING."
exit 1
}
##------------------------------
##
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m]
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid]
#set changed_list [list]
## -- --- --- --- --- ---
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m]
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record]
## -- --- --- --- --- ---
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]]
#set changed_list [dict get $changed_unchanged changed]
#----------
$event targetset_init INSTALL $target_module_dir/$m
$event targetset_addsource $current_source_dir/$m
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\
} {
#set file_record [punkcheck::installfile_started_install $basedir $file_record]
$event targetset_started
# -- --- --- --- --- ---
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n}
lappend module_list $current_source_dir/$m
file copy -force $current_source_dir/$m $target_module_dir
puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir"
# -- --- --- --- --- ---
#set file_record [punkcheck::installfile_finished_install $basedir $file_record]
$event targetset_end OK -note "already versioned module"
} else {
puts -nonewline stderr "."
set did_skip 1
if {$is_interesting} {
puts stderr "$current_source_dir/$m [$event targetset_source_changes]"
}
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$event targetset_end SKIPPED
}
}
if {$CALLDEPTH >= $max_depth} {
set subdirs [list]
} else {
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *]
}
#puts stderr "subdirs: $subdirs"
foreach d $subdirs {
set skipdir 0
foreach dg $antidir {
if {[string match $dg $d]} {
set skipdir 1
continue
}
}
if {$skipdir} {
continue
}
if {![file exists $target_module_dir/$d]} {
file mkdir $target_module_dir/$d
}
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\
-call-depth-internal [expr {$CALLDEPTH +1}]\
-subdirlist [list {*}$subdirlist $d]\
-punkcheck_eventobj $event\
-glob $fileglob\
]
}
if {$did_skip} {
puts -nonewline stdout \n
}
if {$CALLDEPTH == 0} {
$event destroy
$installer destroy
}
return $module_list
}
variable kettle_reset_bodies [dict create]
variable kettle_reset_args [dict create]
#We are abusing kettle to run in-process.
# when we change to another project we need recipes to be reloaded.
# Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders
#kettle_init stores the original proc bodies & args
proc kettle_init {} {
variable kettle_reset_bodies ;#dict
variable kettle_reset_args
set reset_procs [list\
::kettle::benchmarks\
::kettle::doc\
::kettle::figures\
::kettle::meta::scan\
::kettle::testsuite\
]
foreach p $reset_procs {
set b [info body $p]
if {[string match "*Overwrite self*" $b]} {
dict set kettle_reset_bodies $p $b
set argnames [info args $p]
set arglist [list]
foreach a $argnames {
if {[info default $p $a dval]} {
lappend arglist [list $a $dval]
} else {
lappend arglist $a
}
}
dict set kettle_reset_args $p $arglist
}
}
}
#call kettle_reinit to ensure recipes point to current project
proc kettle_reinit {} {
variable kettle_reset_bodies
variable kettle_reset_args
foreach p [dict keys $kettle_reset_bodies] {
set b [dict get $kettle_reset_bodies $p]
set argl [dict get $kettle_reset_args $p]
uplevel 1 [list ::proc $p $argl $b]
}
#todo - determine standard recipes by examining standard.tcl instead of hard coding?
set standard_recipes [list\
null\
forever\
list-recipes\
help-recipes\
help-dump\
help-recipes\
help\
list\
list-options\
help-options\
show-configuration\
show-state\
show\
meta-status\
gui\
]
#set ::kettle::recipe::recipe [dict create]
foreach r [dict keys $::kettle::recipe::recipe] {
if {$r ni $standard_recipes} {
dict unset ::kettle::recipe::recipe $r
}
}
}
proc kettle_call {calltype args} {
variable kettle_reset_bodies
if {$calltype ni [list lib shell]} {
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process"
}
if {$calltype eq "shell"} {
set kettleappfile [file dirname [info nameofexecutable]]/kettle
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} {
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)"
}
if {[file exists $kettleappfile]} {
set kettlescript $kettleappfile
}
if {$::tcl_platform(platform) eq "windows"} {
if {[file exists $kettlebatfile]} {
set kettlescript $kettlebatfile
}
}
}
set startdir [pwd]
if {![file exists $startdir/build.tcl]} {
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])"
}
if {[package provide kettle] eq ""} {
puts stdout "Loading kettle package - may be delay on first load ..."
package require kettle
kettle_init ;#store original procs for those kettle procs that rewrite themselves
} else {
if {[dict size $kettle_reset_bodies] == 0} {
#presumably package require kettle was called without calling our kettle_init hack.
kettle_init
} else {
#undo proc rewrites
kettle_reinit
}
}
set first [lindex $args 0]
if {[string match @* $first]} {
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly"
}
if {$first eq "-f"} {
set args [lassign $args __ path]
} else {
set path $startdir/build.tcl
}
set opts [list]
if {[lindex $args 0] eq "-trace"} {
set args [lrange $args 1 end]
lappend opts --verbose on
}
set goals [list]
if {$calltype eq "lib"} {
file mkdir ~/.kettle
set dotfile ~/.kettle/config
if {[file exists $dotfile] &&
[file isfile $dotfile] &&
[file readable $dotfile]} {
::kettle io trace {Loading dotfile $dotfile ...}
set args [list {*}[::kettle path cat $dotfile] {*}$args]
}
}
#hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names
#This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW)
#REVIEW - needs to be updated to keep in sync with kettle.
set knownopts [list\
--exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \
--ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \
--log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \
--iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \
]
while {[llength $args]} {
set o [lindex $args 0]
switch -glob -- $o {
--* {
#instead of using: kettle option known
if {$o ni $knownopts} {
error "Unable to process unknown option $o." {} [list KETTLE (pmix)]
}
lappend opts $o [lindex $args 1]
#::kettle::option set $o [lindex $args 1]
set args [lrange $args 2 end]
}
default {
lappend goals $o
set args [lrange $args 1 end]
}
}
}
if {![llength $goals]} {
lappend goals help
}
if {"--prefix" ni [dict keys $opts]} {
dict set opts --prefix [file dirname $startdir]
}
if {$calltype eq "lib"} {
::kettle status clear
::kettle::option::set @kettle $startdir
foreach {o v} $opts {
::kettle option set $o $v
}
::kettle option set @srcscript $path
::kettle option set @srcdir [file dirname $path]
::kettle option set @goals $goals
#load standard recipes as listed in build.tcl
::source $path
puts stderr "recipes: [::kettle recipe names]"
::kettle recipe run {*}[::kettle option get @goals]
set state [::kettle option get --state]
if {$state ne {}} {
puts stderr "saving kettle state: $state"
::kettle status save $state
}
} else {
#shell
puts stdout "Running external kettle process with args: $opts $goals"
run -n tclsh $kettlescript -f $path {*}$opts {*}$goals
}
}
proc kettle_punk_recipes {} {
set txtdst ...
}
}
}
namespace eval punk::mix::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
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::cli [namespace eval punk::mix::cli {
variable version
set version 0.3
}]
return

152
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm

@ -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

92
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm

@ -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

286
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm

@ -1,286 +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 punk::mix::util ;#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"
}
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 $projectdir/src/doc _module_*.man]
foreach maybedoomed $oldfiles {
set fd [open $maybedoomed r]
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 {
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 {} {
#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
dtplite validate $docroot
#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 $codesource_path *.tm -antiglob_paths {**/mix/templates/** **/mixtemplates/**}]
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 {
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
set target_docname [md5::md5 -hex $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

188
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm

@ -1,188 +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
#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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::layout {
namespace export *
#per layout functions
proc files {layout} {
set allfiles [lib::layout_all_files $layout]
return [join $allfiles \n]
}
proc templatefiles {layout} {
set templatefiles [lib::layout_scan_for_template_files $layout]
return [join $templatefiles \n]
}
proc templatefiles.relative {layout} {
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set bases_containing_layout [list]
dict for {tbase folderinfo} $template_base_dict {
if {[file exists $tbase/layouts/$layout]} {
lappend bases_containing_layout $tbase
}
}
if {![llength $bases_containing_layout]} {
puts stderr "Unable to locate folder for layout '$layout'"
puts stderr "searched [dict size $template_base_dict] template folders"
return
}
set tpldir [lindex $bases_containing_layout end]
set layout_base $tpldir/layouts
set layout_dir [file join $layout_base $layout]
set stripprefix [file normalize $layout_dir]
set templatefiles [lib::layout_scan_for_template_files $layout]
set tails [list]
foreach templatefullpath $templatefiles {
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix]
}
return [join $tails \n]
}
#layout collection functions - to be imported with punk::overlay::import_commandset separately
namespace eval collection {
namespace export *
proc _default {{glob {}}} {
if {![string length $glob]} {
set glob *
}
set layouts [list]
#set tplfolderdict [punk::cap::call_handler punk.templates folders]
set tplfolderdict [punk::mix::base::lib::get_template_basefolders]
dict for {tdir folderinfo} $tplfolderdict {
set layout_base $tdir/layouts
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names)
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]]
foreach match [lsearch -all -inline $all_layouts $glob] {
lappend layouts [list $match $folderinfo]
}
}
return [join [lsort -index 0 $layouts] \n]
}
}
namespace eval lib {
proc layout_all_files {layout} {
set tplbasedict [punk::mix::base::lib::get_template_basefolders]
set layouts_found [list]
dict for {tplbase folderinfo} $tplbasedict {
if {[file isdirectory $tplbase/layouts/$layout]} {
lappend layouts_found $tplbase/layouts/$layout
}
}
if {![llength $layouts_found]} {
puts stderr "layout '$layout' not found."
puts stderr "searched [dict size $tplbasedict] template folders"
dict for {tplbase pkg} $tplbasedict {
puts stderr " - $tplbase $pkg"
}
return
}
set layoutfolder [lindex $layouts_found end]
if {![file isdirectory $layoutfolder]} {
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)"
}
set file_list [list]
util::foreach-file $layoutfolder path {
lappend file_list $path
}
return $file_list
}
#
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ??
proc layout_scan_for_template_files {layout {tags {}}} {
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath ""
set tplbasedict [punk::mix::base::lib::get_template_basefolders]
set layouts_found [list]
dict for {tpldir pkg} $tplbasedict {
if {[file isdirectory $tpldir/layouts/$layout]} {
lappend layouts_found $tpldir/layouts/$layout
}
}
if {![llength $layouts_found]} {
puts stderr "layout '$layout' not found."
puts stderr "searched [dict size $tplbasedict] template folders"
dict for {tpldir pkg} $tplbasedict {
puts stderr " - $tpldir $pkg"
}
return
}
set layoutfolder [lindex $layouts_found end]
#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 %]
}
}
set file_list [list]
util::foreach-file $layoutfolder path {
set fd [open $path r]
fconfigure $fd -translation binary
set data [read $fd]
close $fd
foreach tag $tags {
if {[string match "*$tag*" $data]} {
lappend file_list $path
}
}
}
return $file_list
}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout {
variable version
set version 0.1.0
}]
return

529
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm

@ -1,529 +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::loadedlib 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::ns
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::loadedlib {
namespace export *
#search automatically wrapped in * * - can contain inner * ? globs
proc search {searchstring} {
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
if {[regexp {[?*]} $searchstring]} {
#caller has specified specific glob pattern - use it
#todo - respect supplied case only if uppers present? require another flag?
set matches [lsearch -all -inline -nocase [package names] $searchstring]
} else {
#make it easy to search for anything
set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"]
}
set matchinfo [list]
foreach m $matches {
set versions [package versions $m]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
lappend matchinfo [list $m $versions]
}
return [join [lsort $matchinfo] \n]
}
proc loaded.search {searchstring} {
set search_result [search $searchstring]
set all_libs [split $search_result \n]
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} {
if {[catch {package require natsort}]} {
set has_natsort 0
} else {
set has_natsort 1
}
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything
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]]
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $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 frobznodule666} ;#ensure pkg system has loaded/searched for everything
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]
foreach k [list modules vendormodules] {
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"} {
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]]
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 [list \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 [list \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 "---"
puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N"
set stdin_state [fconfigure stdin]
fconfigure stdin -blocking 1
set answer [string tolower [gets stdin]]
fconfigure stdin -blocking [dict get $stdin_state -blocking]
if {$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} {
puts stdout "Copy anyway? Y|N"
set stdin_state [fconfigure stdin]
fconfigure stdin -blocking 1
set answer [string tolower [gets stdin]]
fconfigure stdin -blocking [dict get $stdin_state -blocking]
if {$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

419
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -1,419 +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::module 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::module {
namespace export *
proc paths {} {
set roots [punk::repo::find_repos ""]
set project [lindex [dict get $roots project] 0]
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
proc templates {args} {
set tdict [templates_dict {*}$args]
package require overtype
set paths [dict values $tdict]
set names [dict keys $tdict]
set title1 "Path"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "Template Name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set tablewidth [expr {$widest1 + 1 + $widest2}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n
append table [string repeat - $tablewidth] \n
foreach p $paths n $names {
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n
}
return $table
}
#return all module templates with repeated ones suffixed with .2 .3 etc
proc templates_dict {args} {
tailcall lib::templates_dict {*}$args
}
proc new {module args} {
set year [clock format [clock seconds] -format %Y]
set defaults [list\
-project \uFFFF\
-version \uFFFF\
-license <unspecified>\
-template module-0.0.1.tm\
-type \uFFFF\
-force 0\
]
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/zipkit 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]
if {$opt_version_supplied eq "\uFFFF"} {
set opt_version "0.1.0"
} else {
set opt_version $opt_version_supplied
if {![util::is_valid_tm_version $opt_version]} {
error "pmix 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 "pmix 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 {$opt_version_supplied ne "\uFFFF"} {
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 -name_description "mix module.new name"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#options
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_project [dict get $opts -project]
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 [punkc::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 {$opt_project == "\uFFFF"} {
set projectname [file tail $projectdir]
} else {
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_template [dict get $opts -template]
set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc
if {![dict exists $templates_dict $opt_template]} {
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]"
}
set templatefile [dict get $templates_dict $opt_template]
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]
if {$opt_type eq "\uFFFF"} {
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain
}
if {$opt_type ni [punk::mix::cli::lib::module_types]} {
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]"
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
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 template_filedata [string map [list %project% $projectname %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata]
set modulefile $modulefolder/${moduletail}-$infile_version.tm
if {[file exists $modulefile]} {
set errmsg "module.new error: module file $modulefile already exists - aborting"
if {[string match "*$magicversion*" $modulefile]} {
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
}
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 {[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_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
if {[llength $existing_versions]} {
set name_version_pairs [list]
lappend name_version_pairs [list $moduletail $infile_version]
foreach existing $existing_versions {
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored
}
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] *]"
}
}
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 {
proc templates_dict {args} {
set defaults [list -scriptpath ""]
set opts [dict merge $defaults $args]
set opt_scriptpath [dict get $opts -scriptpath]
set module_template_bases [list]
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath]
dict for {tbase folderinfo} $tbasedict {
lappend module_template_bases [file join $tbase modules]
}
set template_files [list]
foreach basefld $module_template_bases {
set matched_files [glob -nocomplain -dir $basefld -type f template_*]
foreach tf $matched_files {
if {[string match ignore* $tf]} {
continue
}
set ext [file extension $tf]
if {$ext in [list ".tm"]} {
lappend template_files $tf
}
}
}
set tdict [dict create]
set seen_dict [dict create]
foreach fullpath $template_files {
set ftail [file tail $fullpath]
set tname [string range $ftail [string length template_] end]
if {![dict exists $seen_dict $tname]} {
dict set seen_dict $tname 1
dict set tdict $tname $fullpath ; #first seen of filename gets no number
} else {
set n [dict get $seen_dict $tname]
incr n
dict incr seen_dict $tname
dict set tdict ${tname}.$n $fullpath
}
}
return $tdict
}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module {
variable version
set version 0.1.0
}]
return

983
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -1,983 +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::project 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0]
#[copyright "2023"]
#[titledesc {pmix commandset - project}] [comment {-- Name section and table of contents description --}]
#[moddesc {pmix CLI commandset - project}] [comment {-- Description at end of page heading --}]
#[require punk::mix::commandset::project]
#[description]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::mix::commandset::project
#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g
#[example {
# namespace eval myproject::cli {
# namespace export *
# namespace ensemble create
# package require punk::overlay
#
# package require punk::mix::commandset::project
# punk::overlay::import_commandset project . ::punk::mix::commandset::project
# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
# }
#}]
#[para] Where the . in the above example is the prefix/command separator
#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets.
#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new
#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as <ensemblecommand> projects.<procname>
#[para]
#[subsection Concepts]
#[para] see punk::overlay
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::mix::commandset::project
#[list_begin itemized]
package require Tcl 8.6
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package punk::ns]
#[item] [package sqlite3] (binary)
#[item] [package overtype]
#[item] [package textutil] (tcllib)
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::project {
namespace export *
#*** !doctools
#[subsection {Namespace punk::mix::commandset::project}]
#[para] core commandset functions for punk::mix::commandset::project
#[list_begin definitions]
proc _default {} {
package require punk::ns
set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project
set dispatch_tail [punk::ns::nstail $dispatched_to]
set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli
set sibling_commands [namespace eval $dispatch_ensemble {namespace export}]
#todo - get separator?
set sep "."
set result [list]
foreach sib $sibling_commands {
if {[string match ${dispatch_tail}${sep}* $sib]} {
lappend result $sib
}
}
return [lsort $result]
}
proc new {newprojectpath_or_name args} {
#*** !doctools
# [call [fun new] [arg newprojectpath_or_name] [opt args]]
#new project structure - may be dedicated to one module, or contain many.
#create minimal folder structure only by specifying in args: -modules {}
if {[file pathtype $newprojectpath_or_name] eq "absolute"} {
set projectfullpath [file normalize $newprojectpath_or_name]
set projectname [file tail $projectfullpath]
set projectparentdir [file dirname $newprojectpath_or_name]
} else {
set projectfullpath [file join [pwd] $newprojectpath_or_name]
set projectname [file tail $projectfullpath]
set projectparentdir [file dirname $projectfullpath]
}
if {[file type $projectparentdir] ne "directory"} {
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'"
}
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new"
set defaults [list\
-type plain\
-empty 0\
-force 0\
-update 0\
-confirm 1\
-modules \uFFFF\
-layout project
] ;#todo
set known_opts [dict keys $defaults]
foreach {k v} $args {
if {$k ni $known_opts} {
error "project.new error: option '$k' not known. Known options: $known_opts"
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_type [dict get $opts -type]
if {$opt_type ni [punk::mix::cli::lib::module_types]} {
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]"
}
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_force [dict get $opts -force]
set opt_confirm [string tolower [dict get $opts -confirm]]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_modules [dict get $opts -modules]
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} {
#if not specified - add a single module matching project name
set opt_modules [list $projectname]
}
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set fossil_prog [auto_execok fossil]
if {![string length $fossil_prog]} {
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features."
if {[string length [set scoop_prog [auto_execok scoop]]]} {
#restrict to windows?
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
}
#we don't assume 'unknown' is configured to run shell commands
if {[string length [package provide shellrun]]} {
set exitinfo [run {*}$scoop_prog install fossil]
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use.
puts stdout "scoop install fossil ran with result: $exitinfo"
} else {
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )"
set result [exec {*}$scoop_prog install fossil]
puts stdout $result
}
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"')
if {![string length [auto_execok fossil]]} {
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell."
return
}
#todo - ask user if they want to configure fosssil first..
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."]
if {[string tolower $answer] ne "continue"} {
return
}
} else {
puts stdout "See: https://fossil-scm.org/home/uv/download.html"
if {"windows" eq $::tcl_platform(platform)} {
puts stdout "Consider using a package manager such as scoop: https://scoop.sh"
puts stdout "(Then: scoop install fossil)"
}
return
}
}
set startdir [pwd]
if {[set in_project [punk::repo::find_project $startdir]] ne ""} {
# use this project as source of templates
puts stdout "-------------------------------------------"
puts stdout "Currently in a project directory '$in_project'"
puts stdout "This project will be searched for templates"
puts stdout "-------------------------------------------"
}
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set template_bases_containing_layout [list]
dict for {tbase folderinfo} $template_base_dict {
if {[file exists $tbase/layouts/$opt_layout]} {
lappend template_bases_containing_layout $tbase
}
}
if {![llength $template_bases_containing_layout]} {
puts stderr "layout '$opt_layout' was not found in template dirs"
puts stderr "searched [dict size $template_base_dict] template folders"
dict for {tbase folderinfo} $template_base_dict {
puts stderr " - $tbase $folderinfo"
}
return
}
#review: silently use last entry which had the layout (?)
set templatebase [lindex $template_bases_containing_layout end]
#todo - detect whether inside cwd-project or inside a different project
set projectdir $projectparentdir/$projectname
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} {
puts stderr "Target location for new project is already within a project: $target_in_project"
error "Nested projects not yet supported aborting"
}
if {[punk::repo::is_git $projectparentdir]} {
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]"
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)"
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues"
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
}
}
set is_nested_fossil 0 ;#default assumption
if {[punk::repo::is_fossil $projectparentdir]} {
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository"
if {$opt_confirm ni [list 0 no false]} {
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag"
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
}
set is_nested_fossil 1
}
}
set project_dir_exists [file exists $projectdir]
if {$project_dir_exists && !($opt_force || $opt_update)} {
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template"
return
} elseif {$project_dir_exists && $opt_force} {
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template"
if {$opt_confirm ni [list 0 no false]} {
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts."
return
}
}
} elseif {$project_dir_exists && $opt_update} {
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items"
}
set fossil_repo_file ""
set is_fossil_root 0
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} {
set is_fossil_root 1
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir]
if {$fossil_repo_file ne ""} {
set repodb_folder [file dirname $fossil_repo_file]
}
}
if {$fossil_repo_file eq ""} {
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir]
if {![string length $repodb_folder]} {
puts stderr "No usable repository database folder selected for $projectname.fossil file"
return
}
}
if {[file exists $repodb_folder/$projectname.fossil]} {
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists"
if {!($opt_force || $opt_update)} {
puts stderr "-force 1 or -update 1 not specified - aborting"
return
}
}
if {$fossil_repo_file eq ""} {
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil"
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname]
if {[dict get $fossilinit exitcode] != 0} {
puts stderr "fossil init failed:"
puts stderr [dict get $fossilinit stderr]
return
} else {
puts stdout "fossil init result:"
puts stdout [dict get $fossilinit stdout]
}
}
file mkdir $projectdir
set layout_dir $templatebase/layouts/$opt_layout
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir"
set resultdict [dict create]
set antipaths [list\
src/doc/*\
src/doc/include/*\
]
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized
if {$opt_force} {
puts stdout "copying layout files - with force applied - overwrite all-targets"
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths]
#file copy -force $layout_dir $projectdir
} else {
puts stdout "copying layout files - (if source file changed)"
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
}
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
puts stdout "copying layout src/doc files (if target missing)"
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence.
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized.
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"]
set override_antiglob_dir_core [list #* _aside .git]
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
#lappend substfiles $projectdir/README.md
#lappend substfiles $projectdir/src/README.md
#lappend substfiles $projectdir/src/doc/main.man
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames?
#scan all files in template
#
#TODO - pmix command to substitute templates?
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout]
set stripprefix [file normalize $layout_dir]
foreach templatefullpath $templatefiles {
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix]
set fpath [file join $projectdir $templatetail]
if {[file exists $fpath]} {
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd
set data2 [string map [list [lib::template_tag project] $projectname] $data]
if {$data2 ne $data} {
puts stdout "updated template file: $fpath"
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout
}
} else {
puts stderr "warning: Missing template file $fpath"
}
}
#todo - tag substitutions in src/doc tree
::cd $projectdir
if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules {
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} {
punk::mix::commandset::module::new $m -project $projectname -type $opt_type
} else {
if {$opt_force} {
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1
}
}
}
} else {
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project"
}
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation
if {[file exists $projectdir/src]} {
::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}]
$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 src/embedded from src/doc"
if {[catch {
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 $projectdir
if {![punk::repo::is_fossil_root $projectdir]} {
set first_fossil 1
#-k = keep. (only modify the manifest file(s))
if {$is_nested_fossil} {
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir]
} else {
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir]
}
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} {
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout
}
if {[dict get $fossilopen exitcode] != 0} {
puts stderr "fossil open in project workdir '$projectdir' FAILED:"
puts stderr [dict get $fossilopen stderr]
return
} else {
puts stdout "fossil open in project workdir '$projectdir' OK:"
puts stdout [dict get $fossilopen stdout]
}
} else {
set first_fossil 0
}
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir]
if {[dict get $fossiladd exitcode] != 0} {
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:"
puts stderr [dict get $fossiladd stderr]
return
} else {
puts stdout "fossil add workfiles in workdir '$projectdir' OK:"
puts stdout [dict get $fossiladd stdout]
}
if {$first_fossil} {
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts
util::do_in_path $projectdir {
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"]
}
if {[dict get $fossilcommit exitcode] != 0} {
puts stderr "fossil commit in workdir '$projectdir' FAILED"
return
} else {
puts stdout "fossil commit in workdir '$projectdir' OK"
}
}
puts stdout "-done- project:$projectname projectdir: $projectdir"
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}]
namespace eval collection {
#*** !doctools
#[subsection {Namespace punk::mix::commandset::project::collection}]
#[para] commandset functions for operating with multiple projects.
#[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: <ensemblecommand> projects.detail
#[list_begin definitions]
namespace export *
namespace path [namespace parent]
#e.g imported as 'projects'
proc _default {{glob {}} args} {
#*** !doctools
#[call [fun _default] [arg glob] [opt {option value...}]]
#[para]List projects under fossil management, showing fossil db location and number of checkouts
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s
#[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset.
#[para]e.g
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection
#[para]Will result in the command being available as <ensemblecommand> projects
package require overtype
set db_projects [lib::get_projects $glob]
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
set col3items [lmap v $checkouts {llength $v}]
set title1 "Fossil Repo DB"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "File Name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set title3 "Checkouts"
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]]
set col3 [string repeat " " $widest3]
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}]
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n
append msg [string repeat "=" $tablewidth] \n
foreach p $col1items n $col2items c $col3items {
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n
}
return $msg
#return [list_as_lines [lib::get_projects $glob]]
}
proc detail {{glob {}} args} {
package require overtype
package require textutil
set defaults [dict create\
-description 0\
]
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- ---
set opt_description [dict get $opts -description]
# -- --- --- --- --- --- ---
set db_projects [lib::get_projects $glob]
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *]
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *]
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *]
set col3items [lmap v $checkouts {llength $v}]
set col4_pnames [list]
set col5_pcodes [list]
set col6_dupids [list]
set col7_pdescs [list]
set codes [dict create]
foreach dbfile $col1_dbfiles {
set project_name ""
set project_code ""
set project_desc ""
sqlite3 dbp $dbfile
dbp eval {select name,value from config where name like 'project-%';} r {
if {$r(name) eq "project-name"} {
set project_name $r(value)
} elseif {$r(name) eq "project-code"} {
set project_code $r(value)
} elseif {$r(name) eq "project-description"} {
set project_desc $r(value)
}
}
dbp close
lappend col4_pnames $project_name
lappend col5_pcodes $project_code
dict lappend codes $project_code $dbfile
lappend col7_pdescs $project_desc
}
set setid 1
set codeset [dict create]
dict for {code dbs} $codes {
if {[llength $dbs]>1} {
dict set codeset $code setid $setid
dict set codeset $code count [llength $dbs]
dict set codeset $code seen 0
incr setid
}
}
set dupid 1
foreach pc $col5_pcodes {
if {[dict exists $codeset $pc]} {
set seen [dict get $codeset $pc seen]
set this_seen [expr {$seen + 1}]
dict set codeset $pc seen $this_seen
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]"
} else {
lappend col6_dupids ""
}
}
set title1 "Fossil Repo DB"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "File Name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set title3 "Checkouts"
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]]
set col3 [string repeat " " $widest3]
set title4 "Project Name"
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]]
set col4 [string repeat " " $widest4]
set title5 "Project Code"
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]]
set col5 [string repeat " " $widest5]
set title6 "Dup"
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]]
set col6 [string repeat " " $widest6]
set title7 "Description"
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]]
set widest7 35
set col7 [string repeat " " $widest7]
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}]
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]"
if {!$opt_description} {
append msg \n
} else {
append msg "[overtype::left $col7 $title7]" \n
set tablewidth [expr {$tablewidth + 1 + $widest7}]
}
append msg [string repeat "=" $tablewidth] \n
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs {
set desclines [split [textutil::adjust $desc -length $widest7] \n]
set desc1 [lindex $desclines 0]
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]"
if {!$opt_description} {
append msg \n
} else {
append msg " [overtype::left $col7 $desc1]" \n
foreach dline [lrange $desclines 1 end] {
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n
}
}
}
return $msg
#return [list_as_lines [lib::get_projects $glob]]
}
proc cd {{glob {}} args} {
dict set args -cd 1
work $glob {*}$args
}
proc work {{glob {}} args} {
package require sqlite3
set db_projects [lib::get_projects $glob]
if {[llength $db_projects] == 0} {
puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'"
return ""
}
#list of lists of the form:
#{fosdb fname workdirlist}
set defaults [dict create\
-cd 0\
-detail "\uFFFF"\
]
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- ---
set opt_cd [dict get $opts -cd]
# -- --- --- --- --- --- ---
set opt_detail [dict get $opts -detail]
set opt_detail_explicit_zero 1 ;#default assumption only
if {$opt_detail eq "\uFFFF"} {
set opt_detail_explicit_zero 0
set opt_detail 0; #default
}
# -- --- --- --- --- --- ---
set workdir_dict [dict create]
set all_workdirs [list]
foreach pinfo $db_projects {
lassign $pinfo fosdb name workdirs
foreach wdir $workdirs {
dict set workdir_dict $wdir $pinfo
lappend all_workdirs $wdir
}
}
set col_rowids [list]
set workdirs [lsort -index 0 $all_workdirs]
set col_dupids [list]
set col_fnames [list]
set col_pnames [list]
set col_pcodes [list]
set col_dupids [list]
set fosdb_count [dict create]
set fosdb_dupset [dict create]
set fosdb_cache [dict create]
set dupset 0
set rowid 1
foreach wd $workdirs {
set wdinfo [dict get $workdir_dict $wd]
lassign $wdinfo fosdb nm siblingworkdirs
dict incr fosdb_count $fosdb
set dbcount [dict get $fosdb_count $fosdb]
if {[llength $siblingworkdirs] > 1} {
if {![dict exists $fosdb_dupset $fosdb]} {
#first time this multi-checkout fosdb seen
dict set fosdb_dupset $fosdb [incr dupset]
}
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]"
} else {
set dupid ""
}
if {$dbcount == 1} {
set pname ""
set pcode ""
if {[file exists $fosdb]} {
if {[catch {
sqlite3 fdb $fosdb
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0]
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0]
fdb close
dict set fosdb_cache $fosdb [list name $pname code $pcode]
} errM]} {
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd"
puts stderr "!!! error: $errM"
}
} else {
puts stderr "!!! missing fossil db $fosdb"
}
} else {
set info [dict get $fosdb_cache $fosdb]
lassign $info _name pname _code pcode
}
lappend col_rowids $rowid
lappend col_fnames $nm
lappend col_dupids $dupid
lappend col_pnames $pname
lappend col_pcodes [string range $pcode 0 9]
incr rowid
}
set col_states [list]
set state_title ""
#if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co
if {([llength [dict keys $fosdb_cache]] == 1)} {
if {!$opt_detail_explicit_zero} {
set opt_detail 1
}
puts stderr "Result is from a single repo db [dict keys $fosdb_cache]"
}
if {$opt_detail} {
puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). Use -detail 0 to omit file state"
set c_rev [list]
set c_rev_iso [list]
set c_unchanged [list]
set c_changed [list]
set c_new [list]
set c_missing [list]
set c_extra [list]
foreach wd $workdirs {
set wd_state [punk::repo::workingdir_state $wd]
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state]
lappend c_rev [string range [dict get $state_dict revision] 0 9]
lappend c_rev_iso [dict get $state_dict revision_iso8601]
lappend c_unchanged [dict get $state_dict unchanged]
lappend c_changed [dict get $state_dict changed]
lappend c_new [dict get $state_dict new]
lappend c_missing [dict get $state_dict missing]
lappend c_extra [dict get $state_dict extra]
puts -nonewline stderr "."
}
puts -nonewline stderr \n
set t0 "Revision"
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]]
set c0 [string repeat " " $w0]
set t0b "Revision iso8601"
set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]]
set c0b [string repeat " " $w0b]
set t1 "Unch"
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]]
set c1 [string repeat " " $w1]
set t2 "Chgd"
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]]
set c2 [string repeat " " $w2]
set t3 "New"
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]]
set c3 [string repeat " " $w3]
set t4 "Miss"
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]]
set c4 [string repeat " " $w4]
set t5 "Extr"
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]]
set c5 [string repeat " " $w5]
set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]"
foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra {
lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]"
}
}
set msg ""
if {$opt_cd} {
set title0 "CD"
} else {
set title0 ""
}
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]]
set col0 [string repeat " " $widest0]
set title1 "Checkout dir"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "Repo DB name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]]
set col2 [string repeat " " $widest2]
set title3 "CO dup"
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]]
set col3 [string repeat " " $widest3]
set title4 "Project Name"
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]]
set col4 [string repeat " " $widest4]
set title5 "Project Code"
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]]
set col5 [string repeat " " $widest5]
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}]
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]"
if {[llength $col_states]} {
set title6 $state_title
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]]
set col6 [string repeat " " $widest6]
incr tablewidth [expr {$widest6 + 1}]
append msg " [overtype::left $col6 $title6]" \n
} else {
append msg \n
}
append msg [string repeat "=" $tablewidth] \n
if {[llength $col_states]} {
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states {
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n
}
} else {
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes {
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n
}
}
set numrows [llength $col_rowids]
if {$opt_cd && $numrows >= 1} {
puts stdout $msg
if {$numrows == 1} {
set workingdir [lindex $workdirs 0]
puts stdout "1 result. Changing dir to $workingdir"
if {[file exists $workingdir]} {
::cd $workingdir
return $workingdir
} else {
puts stderr "path $workingdir doesn't appear to exist"
return [pwd]
}
} else {
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."]
if {[string trim $answer] in $col_rowids} {
set index [expr {$answer - 1}]
set workingdir [lindex $workdirs $index]
::cd $workingdir
puts stdout [pmix stat]
return $workingdir
}
}
}
return $msg
}
#*** !doctools
#[list_end] [comment {-- end collection namespace definitions --}]
}
namespace eval lib {
proc template_tag {tagname} {
#todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc.
#we need to detect presence of tags intended for punk::mix system
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run
return [string cat % $tagname %]
}
#get project info only by opening the central confg-db
#(will not have proper project-name etc)
proc get_projects {{globlist {}} args} {
if {![llength $globlist]} {
set globlist [list *]
}
set fossil_prog [auto_execok fossil]
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo]
if {[llength $matching_lines] != 1} {
puts stderr "Unable to find config-db info from fossil. Check your fossil installation."
puts stderr "Fossil output was:"
puts stderr "-------------"
puts stderr "$fossilinfo"
puts stderr "-------------"
puts stderr "config-db info:"
puts stderr "$matching_lines"
return
}
set ln [lindex $matching_lines 0]
set configdb [string trim [string range $ln [string length "config-db: "] end]]
if {![file exists $configdb]} {
error "config-db not found at path $configdb"
}
package require sqlite3
::sqlite3 fosconf $configdb
#set testresult [fosconf eval {select name,value from global_config;}]
#puts stderr $testresult
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}]
set paths_and_names [list]
foreach pr $project_repos {
set path [string trim [string range $pr 5 end]]
set nm [file rootname [file tail $path]]
set ckouts [fosconf eval {select name from global_config where value = $path;}]
set checkout_paths [list]
#strip "ckout:"
foreach ck $ckouts {
lappend checkout_paths [string trim [string range $ck 6 end]]
}
lappend paths_and_names [list $path $nm $checkout_paths]
}
set filtered_list [list]
foreach glob $globlist {
set matches [lsearch -all -inline -index 1 $paths_and_names $glob]
foreach m $matches {
if {$m ni $filtered_list} {
lappend filtered_list $m
}
}
}
set projects [lsort -index 1 $filtered_list]
return $projects
}
}
}
#*** !doctools
#[manpage_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project {
variable version
set version 0.1.0
}]
return

92
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm

@ -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::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 *
proc tickets {{project ""}} {
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
}
proc fossilize { args} {
#check if project already managed by fossil.. initialise and check in if not.
puts stderr "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 [dict get $repopaths warnings]
} else {
append result [dict get $repopaths warnings]
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
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo {
variable version
set version 0.1.0
}]
return

681
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm

@ -1,681 +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::scriptwrap 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::mix
package require punk::mix::base
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::scriptwrap {
namespace export *
#scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath
#it may or may not be within a project
#by using the same folder or path, the same project root will be discovered. REVIEW.
proc templates_dict {args} {
set defaults [list -scriptpath ""]
set opts [dict merge $defaults $args]
set opt_scriptpath [dict get $opts -scriptpath]
set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath]
set wrapper_templates [list]
foreach fld $wrapper_folders {
set templates [glob -nocomplain -dir $fld -type f *]
foreach tf $templates {
if {[string match ignore* $tf]} {
continue
}
set ext [file extension $tf]
if {$ext in [list "" ".bat" ".cmd" ".sh"]} {
lappend wrapper_templates $tf
}
}
}
set tdict [dict create]
set seen_dict [dict create]
foreach fullpath $wrapper_templates {
set ftail [file tail $fullpath]
if {![dict exists $seen_dict $ftail]} {
dict set seen_dict $ftail 1
dict set tdict $ftail $fullpath ; #first seen of filename gets no number
} else {
set n [dict get $seen_dict $ftail]
incr n
dict incr seen_dict $ftail
dict set tdict ${ftail}.$n $fullpath
}
}
return $tdict
}
proc templates {args} {
package require overtype
set tdict [templates_dict {*}$args]
set paths [dict values $tdict]
set names [dict keys $tdict]
set title1 "Path"
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]]
set col1 [string repeat " " $widest1]
set title2 "Template Name"
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]]
set col2 [string repeat " " $widest2]
set tablewidth [expr {$widest1 + 1 + $widest2}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n
append table [string repeat - $tablewidth] \n
foreach p $paths n $names {
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n
}
return $table
}
#specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf
proc multishell {filepath_or_scriptset args} {
set defaults [dict create\
-askme 1\
-outputfolder "\uFFFF"\
-template "\uFFFF"\
]
set known_opts [dict keys $defaults]
dict for {k v} $args {
if {$k ni $known_opts} {
error "punk::mix::commandset::scriptwrap error. Unrecognized option '$k'. Known-options: $known_opts"
}
}
set usage ""
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n
if {![string length $filepath_or_scriptset]} {
puts stderr "No filepath_or_scriptset specified"
puts stderr $usage
return false
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_askme [dict get $opts -askme]
set opt_template [dict get $opts -template]
set opt_outputfolder [dict get $opts -outputfolder]
# -- --- --- --- --- --- --- --- --- --- --- ---
set ext [file extension $filepath_or_scriptset]
set startdir [pwd]
#first check if relative or absolute path matches a file
if {[file pathtype $filepath_or_scriptset] eq "absolute"} {
set specified_path $filepath_or_scriptset
} else {
set specified_path [file join $startdir $filepath_or_scriptset]
}
set ext [string trim [file extension $filepath_or_scriptset] .]
set allowed_extensions [list wrapconfig tcl ps1 sh bash]
#set allowed_extensions [list tcl]
set found_script 0
if {[file exists $specified_path]} {
set found_script 1
} else {
foreach e $allowed_extensions {
if {[file exists $filepath_or_scriptset.$e]} {
set found_script 1
break
}
}
}
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function
set scriptset [file rootname [file tail $specified_path]]
if {$found_script} {
if {[file type $specified_path] eq "file"} {
set specified_root [file dirname $specified_path]
set pathinfo [punk::repo::find_repos [file dirname $specified_path]]
set projectroot [dict get $pathinfo closest]
if {[string length $projectroot]} {
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder
set scriptroot [file dirname $specified_path]
if {[file exists $scriptroot/wrappers]} {
set customwrapper_folder $scriptroot/wrappers
} else {
set customwrapper_folder $projectroot/src/scriptapps/wrappers
}
} else {
#outside of any project
set scriptroot [file dirname $specified_path]
if {[file exists $scriptroot/wrappers]} {
set customwrapper_folder $scriptroot/wrappers
} else {
#no customwrapper folder available
set customwrapper_folder ""
}
}
} else {
puts stderr "wrap_in_multishell doesn't currently support a directory as the path."
puts stderr $usage
return false
}
} else {
set pathinfo [punk::repo::find_repos $startdir]
set projectroot [dict get $pathinfo closest]
if {[string length $projectroot]} {
if {[llength [file split $filepath_or_scriptset]] > 1} {
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file"
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory"
puts stderr $usage
return false
} else {
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension
set scriptroot $projectroot/src/scriptapps
set customwrapper_folder $projectroot/src/scriptapps/wrappers
#check something matches the scriptset..
set something_found ""
if {[file exists $scriptroot/$scriptset]} {
set found_script 1
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too
} else {
foreach e $allowed_extensions {
if {[file exists $scriptroot/$scriptset.$e]} {
set found_script 1
set something_found $scriptroot/$scriptset.$e
break
}
}
}
if {!$found_script} {
puts stderr "Searched within $scriptroot"
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions"
puts stderr $usage
return false
} else {
if {[file type $something_found] ne "file"} {
puts stderr "Found '$something_found'"
puts stderr "wrap_in_multishell doesn't currently support a directory as the path."
puts stderr $usage
return false
}
}
}
} else {
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined"
puts stderr $usage
return false
}
}
#assert - customwrapper_folder var exists - but might be empty
if {[string length $ext]} {
#If there was an explicitly supplied extension - then that file should exist
if {![file exists $scriptroot/$scriptset.$ext]} {
puts stderr "Explicit extension .$ext was supplied - but matching file not found."
puts stderr $usage
return false
} else {
if {$ext eq "wrapconfig"} {
set process_extensions ALLFOUNDORCONFIGURED
} else {
set process_extensions $ext
}
}
} else {
#no explicit extension - process all for scriptset
set process_extensions ALLFOUNDORCONFIGURED
}
#process_extensions - either a single one - or all found or as per .wrapconfig
if {$opt_template eq "\uFFFF"} {
set templatename punk-multishell.cmd
} else {
set templatename $opt_template
}
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set tpldirs [list]
dict for {tdir tsourceinfo} $template_base_dict {
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} {
lappend tpldirs $tdir
}
}
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} {
set wrapper_template [file join $customwrapper_folder $templatename]
} else {
if {![llength $tpldirs]} {
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages"
append msg \n "Searched [dict size $template_base_dict] template dirs"
error $msg
}
#last pkg with templates cap which was loaded has highest precedence
set wrapper_template ""
foreach tdir [lreverse $tpldirs] {
set ftest [file join $tdir utility scriptappwrappers $templatename]
if {[file exists $ftest]} {
set wrapper_template $ftest
break
}
}
}
if {$wrapper_template eq "" || ![file exists $wrapper_template]} {
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]"
}
if {$opt_outputfolder eq "\uFFFF"} {
#outputfolder not explicitly specified by caller
if {[string length $projectroot]} {
set output_folder [file join $projectroot/bin]
} else {
set output_folder $startdir
}
} else {
if {[file pathtype $opt_outputfolder] eq "relative"} {
if {[string length $projectroot]} {
set output_folder [file join $projectroot $opt_outputfolder]
} else {
set output_folder [file join $startdir $opt_outputfolder]
}
} else {
set output_folder $opt_outputfolder
}
}
if {![file isdirectory $output_folder]} {
error "wrap_in_multishell: output folder '$output_folder' not found. Please ensure target directory exists"
}
#todo
#output_file extension may also depend on the template being used.. and/or the .wrapconfig
if {$::tcl_platform(platform) eq "windows"} {
set output_extension cmd
} else {
set output_extension sh
}
set output_file [file join $output_folder $scriptset.$output_extension]
if {[file exists $output_file]} {
error "wrap_in_multishell: target file $output_file already exists.. aborting"
}
set fdt [open $wrapper_template r]
fconfigure $fdt -translation binary
set template_data [read $fdt]
close $fdt
puts stdout "Read [string length $template_data] bytes of template data.."
set template_lines [split $template_data \n]
puts stdout "Displaying first 3 lines of template between dashed lines..."
puts stdout "-----------------------------------------------"
foreach ln [lrange $template_lines 0 3] {
puts stdout $ln
}
puts stdout "-----------------------------------------------\n"
#foreach ln $template_lines {
#}
set list_input_files [list]
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} {
#todo - look for .wrapconfig or all extensions for the scriptset
puts stderr "Sorry - only single input file supported. Supply a file extension or use a .wrapconfig with a single input file for now - implementation incomplete"
return false
} else {
lappend list_input_files $scriptroot/$scriptset.$ext
}
#todo - split template at each <ext-payload> etc marker and build a dict of parts
#hack - process one input
set filepath [lindex $list_input_files 0]
set fdscript [open $filepath r]
fconfigure $fdscript -translation binary
set script_data [read $fdscript]
close $fdscript
puts stdout "Read [string length $script_data] bytes of template data.."
set script_lines [split $script_data \n]
puts stdout "Displaying first 3 lines of your script between dashed lines..."
puts stdout "-----------------------------------------------"
foreach ln [lrange $script_lines 0 3] {
puts stdout $ln
}
puts stdout "-----------------------------------------------\n"
puts stdout "Target for above data is '$output_file'"
if {$opt_askme} {
set answer [util::askuser "Does this look correct? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts."
return
}
}
set start_idx 0
set end_idx 0
set line_idx 0
set existing_payload [list]
foreach ln $template_lines {
if {[string match "#<tcl-payload>*" $ln]} {
set start_idx $line_idx
} elseif {[string match "#</tcl-payload>*" $ln]} {
set end_idx $line_idx
break
} elseif {$start_idx > 0} {
if {$end_idx > 0} {
lappend existing_payload [string trim $ln]
}
} else {
}
incr line_idx
}
if {($start_idx == 0) || ($end_idx == 0)} {
error "wrap_in_multishell was unable to find payload area in template marked with #<tcl-payload> and #</tcl-payload> on separate lines"
}
set existing_string [join $existing_payload \n]
if {[string length [string trim $existing_string]]} {
puts stdout "EXISTING PAYLOAD!!"
puts stdout "-----------------------------------------------\n"
puts stdout $existing_string
puts stdout "-----------------------------------------------\n"
error "wrap_in_multishell found existing payload.. aborting."
#todo - allow overwrite only in files outside of punkshell distribution?
if 0 {
puts stderr "Found existing payload.. overwrite?"
if {$opt_askme} {
set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"]
if {[string tolower $answer] ne "y"} {
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts."
return
}
}
}
}
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line
set tpl_tail_lines [lrange $template_lines $end_idx end]
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n]
puts stdout "New script is [string length $newscript] bytes"
puts stdout $newscript
set fdtarget [open $output_file w]
fconfigure $fdtarget -translation binary
puts -nonewline $fdtarget $newscript
close $fdtarget
puts stdout "Wrote script file at $output_file"
#even though chmod might exist on windows - we will leave permissions alone
if {$::tcl_platform(platform) ne "windows"} {
catch {exec chmod +x $output_file}
}
puts stdout "-done-"
return $output_file
}
namespace eval lib {
#get_wrapper_folders
# scriptpath - file or folder
# It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any
# The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list)
proc get_wrapper_folders {{scriptpath ""}} {
set wrapper_folders [list]
if {$scriptpath ne ""} {
if {[file type $scriptpath] eq "file"} {
set searchbase [file dirname $scriptpath]
} else {
set searchbase $scriptpath
}
if {[file isdirectory [file join $searchbase wrappers]]} {
lappend wrapper_folders [file join $searchbase wrappers]
}
set pathinfo [punk::repo::find_repos $searchbase]
set scriptpath_projectroot [dict get $pathinfo closest]
if {$scriptpath_projectroot ne ""} {
set fld [file join $scriptpath_projectroot src/scriptapps/wrappers]
if {[file isdirectory $fld]} {
if {$fld ni $wrapper_folders} {
lappend wrapper_folders $fld
}
}
}
}
set searchbase [pwd]
set fld [file join $searchbase wrappers]
if {[file isdirectory $fld]} {
if {$fld ni $wrapper_folders} {
lappend wrapper_folders $fld
}
}
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
if {$pwd_projectroot ne ""} {
set fld [file join $pwd_projectroot src/scriptapps/wrappers]
if {[file isdirectory $fld]} {
if {$fld ni $wrapper_folders} {
lappend wrapper_folders $fld
}
}
}
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
set tpldirs [list]
dict for {tdir tsourceinfo} $template_base_dict {
if {[file exists $tdir/utility/scriptappwrappers]} {
lappend tpldirs $tdir
}
}
foreach tpldir $tpldirs {
set fld [file join $tpldir utility scriptappwrappers]
if {[file isdirectory $fld]} {
if {$fld ni $wrapper_folders} {
lappend wrapper_folders $fld
}
}
}
return $wrapper_folders
}
proc _scriptapp_tag_from_line {line} {
set result [list istag 0 raw ""] ;#default assumption. All
#----
set startc [string first "#" $line] ;#tags must be commented
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname>
# @REM # etc < blah # <tagname> etc
#---
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really.
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway.
dict set result indent [string length $indent]
set starttag [string first "<" $line]
set pretag [string range $line $startc $starttag-1]
if {[string match "*>*" $pretag]} {
return [list istag 0 raw $line reason pretag_contents]
}
set closetag [string first ">" $line]
set inelement [string range $line $starttag+1 $closetag-1]
if {[string match "*<*" $inelement]} {
return [list istag 0 raw $line reason tag_malformed_angles]
}
set elementchars [split $inelement ""]
set numslashes [llength [lsearch -all $elementchars "/"]]
if {$numslashes == 0} {
dict set result type "open"
} elseif {$numslashes == 1} {
if {[lindex $elementchars 0] eq "/"} {
dict set result type "close"
} elseif {[lindex $elementchars end] eq "/"} {
dict set result type "openclose"
} else {
return [list istag 0 raw $line reason tag_malformed_slashes]
}
} else {
return [list istag 0 raw $line reason tag_malformed_extraslashes]
}
if {[dict get $result type] eq "open"} {
dict set result name $inelement
} elseif {[dict get $result type] eq "close"} {
dict set result name [string range $inelement 1 end]
} else {
dict set result name [string range $inelement 0 end-1]
}
dict set result istag 1
dict set result raw $line
return $result
}
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #)
#we don't verify 'something' against known tags - as custom templates can have own tags
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line
#
#e.g for the line:
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/>
#The .wrapconfig might contain
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>}
#
proc scriptapp_wrapper_get_tags {wrapperdata} {
set wrapperdata [string map [list \r\n \n] $wrapperdata]
set lines [split $wrapperdata \n]
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags
set status 0
set tags [dict create]
set errors [list]
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result.
foreach ln $lines {
set lntrim [string trim $ln]
if {![string length $lntrim]} {
incr linenum
continue
}
if {[string match "*#*<*>*" $lntrim]} {
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent
if {[dict get $taginfo istag]} {
set nm [dict get $taginfo name]
if {[dict exists $errortags $nm]} {
#tag is already in error condition -
} else {
set tp [dict get $taginfo type] ;# type singular - related to just one line
#set raw [dict get $taginfo raw] #equivalent to $ln
if {[dict exists $tags $nm]} {
#already seen tag name
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags)
if {[dict get $tags $nm types] ne "open"} {
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]"
dict incr errortags $nm
} else {
#we already have open - expect only close
if {$tp ne "close"} {
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]"
dict incr errortags $nm
} else {
#close after open
dict set tags $nm types [list open close]
dict set tags $nm end $linenum
set taglines [dict get $tags $nm taglines]
if {[llength $taglines] != 1} {
error "Unexpected result when closing tag $nm. Existing taglines length not 1."
}
dict set tags $nm taglines [concat $taglines $ln]
}
}
} else {
#first seen of tag name
if {$tp eq "close"} {
lappend errors "line: $linenum tag $nm encountered type $p close first"
dict incr errortags $nm
} else {
dict set tags $nm types $tp
dict set tags $nm indent [dict get $taginfo indent]
if {$tp eq "open"} {
dict set tags $nm start $linenum
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag
} elseif {$tp eq "openclose"} {
dict set tags $nm start $linenum
dict set tags $nm end $linenum
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag
}
}
}
}
} else {
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]"
}
}
#whether the line is tag or not append to any tags_in_data
#foreach t [dict keys $tags_in_data] {
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data
#}
incr linenum
}
#assert [expr {$linenum -1 == [llength $lines]}]
if {[llength $errors]} {
set status 0
} else {
set status 1
}
if {$linenum == 0} {
}
return [dict create ok $status linecount [llength $lines] data $tags errors $errors]
}
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap {
variable version
set version 0.1.0
}]
return

84
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/templates-0.1.0.tm

@ -1,84 +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
#punk::cap::register_package punk::mix::templates [list\
# {punk.templates {relpath ../templates}}\
#]
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 punk.templates {relpath ../templates2}]
lappend decls [list punk.test {something blah}]
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
}
method capabilities {} {
next
}
}
}
# -- ---
#provider api
# -- ---
#none - declarations only
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::templates [namespace eval punk::mix::templates {
variable version
set version 0.1.0
}]
return

350
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/mix/util-0.1.0.tm

@ -1,350 +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 *
proc fcat {args} {
variable has_winpath
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 {$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} {
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
}
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
}
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

1698
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/ns-0.1.0.tm

File diff suppressed because it is too large Load Diff

159
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/overlay-0.1.tm

@ -1,159 +0,0 @@
package require punk::mix::util
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 {![string match ::* $routine]} {
set resolved [uplevel 1 [list ::namespace which $routine]]
if {$resolved eq {}} {
error [list {no such routine} $routine]
}
set routine $resolved
}
set routinens [namespace qualifiers $routine]
if {$routinens eq {::}} {
set routinens {}
}
set routinetail [namespace tail $routine]
if {![string match ::* $base]} {
set base [uplevel 1 [
list [namespace which namespace] current]]::$base
}
if {![namespace exists $base]} {
error [list {no such namespace} $base]
}
set base [namespace eval $base [
list [namespace which namespace] current]]
#while 1 {
# set renamed ${routinens}::${routinetail}_[info cmdcount]
# if {[namespace which $renamed] eq {}} break
#}
namespace eval $routine [
list 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::*
#}]
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] {
if {[namespace exists <base>::lib]} {
set current_paths [namespace path]
if {"<routine>" ni $current_paths} {
lappend current_paths <routine>
}
namespace path $current_paths
}
}]
namespace eval $routine {
set exportlist [list]
foreach cmd [info commands [namespace current]::*] {
set c [namespace tail $cmd]
if {![string match _* $c]} {
lappend exportlist $c
}
}
namespace export {*}$exportlist
}
return $routine
}
#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'"
}
#namespace may or may not be a package
# allow with or without leading ::
if {[string range $cmdnamespace 0 1] eq "::"} {
set cmdpackage [string range $cmdnamespace 2 end]
} else {
set cmdpackage $cmdnamespace
set cmdnamespace ::$cmdnamespace
}
if {![namespace exists $cmdnamespace]} {
#only do package require if the namespace not already present
catch {package require $cmdpackage} pkg_load_info
#recheck
if {![namespace exists $cmdnamespace]} {
set prov [package provide $cmdpackage]
if {[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
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] {
set nspaths [namespace path]
if {"<cmdns>" ni $nspaths} {
lappend nspaths <cmdns>
}
namespace path $nspaths
}]
set imported_commands [list]
set nscaller [uplevel 1 [list namespace current]]
if {[catch {
#review - noclobber?
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*]
foreach cmd [info commands ${nscaller}::temp_import::*] {
set cmdtail [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
}
} errM]} {
puts stderr "Error loading commandset $prefix $separator $cmdnamespace"
puts stderr "err: $errM"
}
return $imported_commands
}
}
package provide punk::overlay [namespace eval punk::overlay {
variable version
set version 0.1
}]

397
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/path-0.1.0.tm

@ -1,397 +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::path 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::path 0 0.1.0]
#[copyright "2023"]
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}]
#[require punk::path]
#[description]
#[keywords module path filesystem]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::path
#[para] Filesystem path utility functions
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::path
#[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::path::class {
#*** !doctools
#[subsection {Namespace punk::path::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::path {
namespace export *
#variable xyz
#*** !doctools
#[subsection {Namespace punk::path}]
#[para] Core API functions for punk::path
#[list_begin definitions]
proc pathglob_as_re {pathglob} {
#*** !doctools
#[call [fun pathglob_as_re] [arg pathglob]]
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure
#[para] ** matches any number of subdirectories.
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself)
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc
#[para] any segment that does not contain ** must match exactly one segment in the path
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified.
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? *
# - would require counting immediately-preceding backslashes
set pats [list]
foreach seg [file split $pathglob] {
if {[string range $seg end end] eq "/"} {
set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up
}
if {$seg eq "*"} {
lappend pats {[^/]*}
} elseif {$seg eq "**"} {
lappend pats {.*}
} else {
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals
set seg [string map [list . {[.]}] $seg]
if {[regexp {[*?]} $seg]} {
set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg]
lappend pats "$pat"
} else {
lappend pats "$seg"
}
}
}
return "^[join $pats /]\$"
}
proc globmatchpath {pathglob path args} {
#*** !doctools
#[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]]
#[para] Return true if the pathglob matches the path
#[para] see [fun pathglob_as_re] for pathglob description
#[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows)
#[para]
#[para] Known options:
#[para] -nocase 0|1 (default 0 - case sensitive)
#[para] If -nocase is not supplied - default to case sensitive *except for driveletter*
#[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah)
#[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter.
set defaults [dict create\
-nocase \uFFFF\
]
set known_opts [dict keys $defaults]
set opts [dict merge $defaults $args]
dict for {k v} $args {
if {$k ni $known_opts} {
error "Unrecognised options $k - known options: $known_opts"
}
}
# -- --- --- --- --- ---
set opt_nocase [dict get $opts -nocase]
set explicit_nocase 1 ;#default to disprove
if {$opt_nocase eq "\uFFFF"} {
set opt_nocase 0
set explicit_nocase 0
}
# -- --- --- --- --- ---
if {$opt_nocase} {
return [regexp -nocase [pathglob_as_re $pathglob] $path]
} else {
set re [pathglob_as_re $pathglob]
if {$explicit_nocase} {
set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter
} else {
#caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter.
set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc}
set first_seg [lindex $re_segments 0]
if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} {
#first part of re is like "^c:" i.e a drive letter
set chars [string tolower $driveletter][string toupper $driveletter]
set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment.
}
#puts stderr "-->re: $re"
set ismatch [regexp $re $path]
}
}
return $ismatch
}
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase)
proc treefilenames {basepath tailglob args} {
#*** !doctools
#[call [fun treefilenames] [arg basepath] [arg tailglob] [opt {option value...}]]
#basic (glob based) list of filenames matching tailglob - recursive
#no natsorting - so order is dependent on filesystem
set defaults [dict create\
-call-depth-internal 0\
-antiglob_paths {}\
]
set opts [dict merge $defaults $args]
set opt_antiglob_paths [dict get $opts -antiglob_paths]
set CALLDEPTH [dict get $opts -call-depth-internal]
set files [list]
if {$CALLDEPTH == 0} {
if {![file isdirectory $basepath]} {
return [list]
}
}
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $basepath]} {
set skip 1
break
}
}
if {$skip} {
return [list]
}
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match?
set dirfiles [glob -nocomplain -dir $basepath -type f $tailglob]
lappend files {*}$dirfiles
set dirdirs [glob -nocomplain -dir $basepath -type d *]
foreach dir $dirdirs {
set skip 0
foreach anti $opt_antiglob_paths {
if {[globmatchpath $anti $dir]} {
set skip 1
break
}
}
if {$skip} {
continue
}
set nextargs [dict merge $args [list -call-depth-internal [incr CALLDEPTH]]]
lappend files {*}[treefilenames $dir $tailglob {*}$nextargs]
}
return $files
}
#maint warning - also in punkcheck
proc relative {reference location} {
#*** !doctools
#[call [fun relative] [arg reference] [arg location]]
#[para] Taking two directory paths, a reference and a location, computes the path
# of the location relative to the reference.
#[list_begin itemized]
#[item]
#[para] Arguments:
# [list_begin arguments]
# [arg_def string reference] The path from which the relative path to location is determined.
# [arg_def string location] The location path which may be above or below the reference path
# [list_end]
#[item]
#[para] Results:
#[para] The relative path of the location to the reference path.
#[para] Will return a single dot "." if the paths are the same
#[item]
#[para] Notes:
#[para] Both paths must be the same type - ie both absolute or both relative
#[para] Case sensitive. ie relative /etc /etC
# will return ../etC
#[para] On windows, the drive-letter component (only) is not case sensitive
#[para] ie relative c:/etc C:/etc returns .
#[para] but relative c:/etc C:/Etc returns ../Etc
#[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned.
# ie relative c:/etc d:/etc/blah
# returns d:/etc/blah
#[list_end]
#see also kettle
# Modified copy of ::fileutil::relative (tcllib)
# Adapted to 8.5 ({*}).
#review - check volume info on windows.. UNC paths?
if {[file pathtype $reference] ne [file pathtype $location]} {
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)"
}
#avoid normalizing if possible (file normalize *very* expensive on windows)
set do_normalize 0
if {[file pathtype $reference] eq "relative"} {
#if reference is relative so is location
if {[regexp {[.]{2}} [list $reference $location]]} {
set do_normalize 1
}
if {[regexp {[.]/} [list $reference $location]]} {
set do_normalize 1
}
} else {
set do_normalize 1
}
if {$do_normalize} {
set reference [file normalize $reference]
set location [file normalize $location]
}
set save $location
set reference [file split $reference]
set location [file split $location]
while {[lindex $location 0] eq [lindex $reference 0]} {
set location [lrange $location 1 end]
set reference [lrange $reference 1 end]
if {![llength $location]} {break}
}
set location_len [llength $location]
set reference_len [llength $reference]
if {($location_len == 0) && ($reference_len == 0)} {
# Cases:
# (a) reference == location
set location .
} else {
# Cases:
# (b) ref is: ref/sub = sub
# loc is: ref = {}
# (c) ref is: ref = {}
# loc is: ref/sub = sub
while {$reference_len > 0} {
set location [linsert $location 0 ..]
incr reference_len -1
}
set location [file join {*}$location]
}
return $location
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::path ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::path::lib {
namespace export *
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::path::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::path::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::path::system {
#*** !doctools
#[subsection {Namespace punk::path::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::path [namespace eval punk::path {
variable pkg punk::path
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

1267
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/repo-0.1.1.tm

File diff suppressed because it is too large Load Diff

104
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/tdl-0.1.0.tm

@ -1,104 +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 iocage
guest -name p1 -vmmanager bhyve
}
}
proc prettyparse {script} {
set i [interp create -safe]
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

266
src/mixtemplates/layouts/basic/src/bootsupport/modules/punk/winpath-0.1.0.tm

@ -1,266 +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::objclone $path]
set strcopy_path [string map [list \\ /] $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 [list "//?/" "//./"]} {
#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::objclone $path]
set strcopy_path [string map [list \\ /] $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 [list "//?/" "//./"]} {
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 *strictly* a UNC 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 $path]} {
#//?/UNC/server/etc
set strcopy_path [punk::objclone $path]
set trimmedpath [string range $strcopy_path 7 end]
file pathtype $trimmedpath ;#shimmer it to path rep
return $trimmedpath
} elseif {is_unc_path_plain $path} {
#plain unc //server
set strcopy_path [punk::objclone $path]
set trimmedpath [string range $strcopy_path 2 end]
file pathtype $trimmedpath
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::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 test_ntfs_tunneling {f1 f2 args} {
file mkdir $f1
puts stderr "waiting 15secs..."
after 5000 {puts -nonewline stderr .}
after 5000 {puts -nonewline stderr .}
after 5000 {puts -nonewline stderr .}
after 500 {puts stderr \n}
file mkdir $f2
puts stdout "$f1 [file stat $f1]"
puts stdout "$f2 [file stat $f2]"
file delete $f1
puts stdout "renaming $f2 to $f1"
file rename $f2 $f1
puts stdout "$f1 [file stat $f1]"
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::winpath [namespace eval punk::winpath {
variable version
set version 0.1.0
}]
return

1962
src/mixtemplates/layouts/basic/src/bootsupport/modules/punkcheck-0.1.0.tm

File diff suppressed because it is too large Load Diff

189
src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/set-2.2.3.tm

@ -1,189 +0,0 @@
#----------------------------------------------------------------------
#
# sets.tcl --
#
# Definitions for the processing of sets.
#
# Copyright (c) 2004-2008 by Andreas Kupries.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $
#
#----------------------------------------------------------------------
# @mdgen EXCLUDE: sets_c.tcl
package require Tcl 8.5-
namespace eval ::struct::set {}
# ### ### ### ######### ######### #########
## Management of set implementations.
# ::struct::set::LoadAccelerator --
#
# Loads a named implementation, if possible.
#
# Arguments:
# key Name of the implementation to load.
#
# Results:
# A boolean flag. True if the implementation
# was successfully loaded; and False otherwise.
proc ::struct::set::LoadAccelerator {key} {
variable accel
set r 0
switch -exact -- $key {
critcl {
# Critcl implementation of set requires Tcl 8.4.
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
if {[catch {package require tcllibc}]} {return 0}
set r [llength [info commands ::struct::set_critcl]]
}
tcl {
variable selfdir
source [file join $selfdir sets_tcl.tcl]
set r 1
}
default {
return -code error "invalid accelerator/impl. package $key:\
must be one of [join [KnownImplementations] {, }]"
}
}
set accel($key) $r
return $r
}
# ::struct::set::SwitchTo --
#
# Activates a loaded named implementation.
#
# Arguments:
# key Name of the implementation to activate.
#
# Results:
# None.
proc ::struct::set::SwitchTo {key} {
variable accel
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\""
}
}
# Deactivate the previous implementation, if there was any.
if {![string equal $loaded ""]} {
rename ::struct::set ::struct::set_$loaded
}
# Activate the new implementation, if there is any.
if {![string equal $key ""]} {
rename ::struct::set_$key ::struct::set
}
# Remember the active implementation, for deactivation by future
# switches.
set loaded $key
return
}
proc ::struct::set::Loaded {} {
variable loaded
return $loaded
}
# ::struct::set::Implementations --
#
# Determines which implementations are
# present, i.e. loaded.
#
# Arguments:
# None.
#
# Results:
# A list of implementation keys.
proc ::struct::set::Implementations {} {
variable accel
set res {}
foreach n [array names accel] {
if {!$accel($n)} continue
lappend res $n
}
return $res
}
# ::struct::set::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 ::struct::set::KnownImplementations {} {
return {critcl tcl}
}
proc ::struct::set::Names {} {
return {
critcl {tcllibc based}
tcl {pure Tcl}
}
}
# ### ### ### ######### ######### #########
## Initialization: Data structures.
namespace eval ::struct::set {
variable selfdir [file dirname [info script]]
variable accel
array set accel {tcl 0 critcl 0}
variable loaded {}
}
# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.
namespace eval ::struct::set {
variable e
foreach e [KnownImplementations] {
if {[LoadAccelerator $e]} {
SwitchTo $e
break
}
}
unset e
}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::struct {
# Export the constructor command.
namespace export set
}
package provide struct::set 2.2.3

189
src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets.tcl

@ -1,189 +0,0 @@
#----------------------------------------------------------------------
#
# sets.tcl --
#
# Definitions for the processing of sets.
#
# Copyright (c) 2004-2008 by Andreas Kupries.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $
#
#----------------------------------------------------------------------
# @mdgen EXCLUDE: sets_c.tcl
package require Tcl 8.5-
namespace eval ::struct::set {}
# ### ### ### ######### ######### #########
## Management of set implementations.
# ::struct::set::LoadAccelerator --
#
# Loads a named implementation, if possible.
#
# Arguments:
# key Name of the implementation to load.
#
# Results:
# A boolean flag. True if the implementation
# was successfully loaded; and False otherwise.
proc ::struct::set::LoadAccelerator {key} {
variable accel
set r 0
switch -exact -- $key {
critcl {
# Critcl implementation of set requires Tcl 8.4.
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
if {[catch {package require tcllibc}]} {return 0}
set r [llength [info commands ::struct::set_critcl]]
}
tcl {
variable selfdir
source [file join $selfdir sets_tcl.tcl]
set r 1
}
default {
return -code error "invalid accelerator/impl. package $key:\
must be one of [join [KnownImplementations] {, }]"
}
}
set accel($key) $r
return $r
}
# ::struct::set::SwitchTo --
#
# Activates a loaded named implementation.
#
# Arguments:
# key Name of the implementation to activate.
#
# Results:
# None.
proc ::struct::set::SwitchTo {key} {
variable accel
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\""
}
}
# Deactivate the previous implementation, if there was any.
if {![string equal $loaded ""]} {
rename ::struct::set ::struct::set_$loaded
}
# Activate the new implementation, if there is any.
if {![string equal $key ""]} {
rename ::struct::set_$key ::struct::set
}
# Remember the active implementation, for deactivation by future
# switches.
set loaded $key
return
}
proc ::struct::set::Loaded {} {
variable loaded
return $loaded
}
# ::struct::set::Implementations --
#
# Determines which implementations are
# present, i.e. loaded.
#
# Arguments:
# None.
#
# Results:
# A list of implementation keys.
proc ::struct::set::Implementations {} {
variable accel
set res {}
foreach n [array names accel] {
if {!$accel($n)} continue
lappend res $n
}
return $res
}
# ::struct::set::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 ::struct::set::KnownImplementations {} {
return {critcl tcl}
}
proc ::struct::set::Names {} {
return {
critcl {tcllibc based}
tcl {pure Tcl}
}
}
# ### ### ### ######### ######### #########
## Initialization: Data structures.
namespace eval ::struct::set {
variable selfdir [file dirname [info script]]
variable accel
array set accel {tcl 0 critcl 0}
variable loaded {}
}
# ### ### ### ######### ######### #########
## Initialization: Choose an implementation,
## most prefered first. Loads only one of the
## possible implementations. And activates it.
namespace eval ::struct::set {
variable e
foreach e [KnownImplementations] {
if {[LoadAccelerator $e]} {
SwitchTo $e
break
}
}
unset e
}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::struct {
# Export the constructor command.
namespace export set
}
package provide struct::set 2.2.3

93
src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_c.tcl

@ -1,93 +0,0 @@
#----------------------------------------------------------------------
#
# sets_tcl.tcl --
#
# Definitions for the processing of sets. C implementation.
#
# Copyright (c) 2007 by Andreas Kupries.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $
#
#----------------------------------------------------------------------
package require critcl
# @sak notprovided struct_setc
package provide struct_setc 2.1.1
package require Tcl 8.5-
namespace eval ::struct {
# Supporting code for the main command.
catch {
#critcl::cheaders -g
#critcl::debug memory symbols
}
critcl::cheaders sets/*.h
critcl::csources sets/*.c
critcl::ccode {
/* -*- c -*- */
#include <m.h>
}
# Main command, set creation.
critcl::ccommand set_critcl {dummy interp objc objv} {
/* Syntax - dispatcher to the sub commands.
*/
static CONST char* methods [] = {
"add", "contains", "difference", "empty",
"equal","exclude", "include", "intersect",
"intersect3", "size", "subsetof", "subtract",
"symdiff", "union",
NULL
};
enum methods {
S_add, S_contains, S_difference, S_empty,
S_equal,S_exclude, S_include, S_intersect,
S_intersect3, S_size, S_subsetof, S_subtract,
S_symdiff, S_union
};
int m;
if (objc < 2) {
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?");
return TCL_ERROR;
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
0, &m) != TCL_OK) {
return TCL_ERROR;
}
/* Dispatch to methods. They check the #args in detail before performing
* the requested functionality
*/
switch (m) {
case S_add: return sm_ADD (NULL, interp, objc, objv);
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv);
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv);
case S_empty: return sm_EMPTY (NULL, interp, objc, objv);
case S_equal: return sm_EQUAL (NULL, interp, objc, objv);
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv);
case S_include: return sm_INCLUDE (NULL, interp, objc, objv);
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv);
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv);
case S_size: return sm_SIZE (NULL, interp, objc, objv);
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv);
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv);
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv);
case S_union: return sm_UNION (NULL, interp, objc, objv);
}
/* Not coming to this place */
}
}
# ### ### ### ######### ######### #########
## Ready

452
src/mixtemplates/layouts/basic/src/bootsupport/modules/struct/sets_tcl.tcl

@ -1,452 +0,0 @@
#----------------------------------------------------------------------
#
# sets_tcl.tcl --
#
# Definitions for the processing of sets.
#
# Copyright (c) 2004-2008 by Andreas Kupries.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $
#
#----------------------------------------------------------------------
package require Tcl 8.5-
namespace eval ::struct::set {
# Only export one command, the one used to instantiate a new tree
namespace export set_tcl
}
##########################
# Public functions
# ::struct::set::set --
#
# Command that access all set commands.
#
# Arguments:
# cmd Name of the subcommand to dispatch to.
# args Arguments for the subcommand.
#
# Results:
# Whatever the result of the subcommand is.
proc ::struct::set::set_tcl {cmd args} {
# Do minimal args checks here
if { [llength [info level 0]] == 1 } {
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\""
}
::set sub S_$cmd
if { [llength [info commands ::struct::set::$sub]] == 0 } {
::set optlist [info commands ::struct::set::S_*]
::set xlist {}
foreach p $optlist {
lappend xlist [string range $p 17 end]
}
return -code error \
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]"
}
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]]
}
##########################
# Implementations of the functionality.
#
# ::struct::set::S_empty --
#
# Determines emptiness of the set
#
# Parameters:
# set -- The set to check for emptiness.
#
# Results:
# A boolean value. True indicates that the set is empty.
#
# Side effects:
# None.
#
# Notes:
proc ::struct::set::S_empty {set} {
return [expr {[llength $set] == 0}]
}
# ::struct::set::S_size --
#
# Computes the cardinality of the set.
#
# Parameters:
# set -- The set to inspect.
#
# Results:
# An integer greater than or equal to zero.
#
# Side effects:
# None.
proc ::struct::set::S_size {set} {
return [llength [Cleanup $set]]
}
# ::struct::set::S_contains --
#
# Determines if the item is in the set.
#
# Parameters:
# set -- The set to inspect.
# item -- The element to look for.
#
# Results:
# A boolean value. True indicates that the element is present.
#
# Side effects:
# None.
proc ::struct::set::S_contains {set item} {
return [expr {[lsearch -exact $set $item] >= 0}]
}
# ::struct::set::S_union --
#
# Computes the union of the arguments.
#
# Parameters:
# args -- List of sets to unify.
#
# Results:
# The union of the arguments.
#
# Side effects:
# None.
proc ::struct::set::S_union {args} {
switch -exact -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
}
foreach setX $args {
foreach x $setX {::set ($x) {}}
}
return [array names {}]
}
# ::struct::set::S_intersect --
#
# Computes the intersection of the arguments.
#
# Parameters:
# args -- List of sets to intersect.
#
# Results:
# The intersection of the arguments
#
# Side effects:
# None.
proc ::struct::set::S_intersect {args} {
switch -exact -- [llength $args] {
0 {return {}}
1 {return [lindex $args 0]}
}
::set res [lindex $args 0]
foreach set [lrange $args 1 end] {
if {[llength $res] && [llength $set]} {
::set res [Intersect $res $set]
} else {
# Squash 'res'. Otherwise we get the wrong result if res
# is not empty, but 'set' is.
::set res {}
break
}
}
return $res
}
proc ::struct::set::Intersect {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
# This is slower than local vars, but more robust
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
}
# ::struct::set::S_difference --
#
# Compute difference of two sets.
#
# Parameters:
# A, B -- Sets to compute the difference for.
#
# Results:
# A - B
#
# Side effects:
# None.
proc ::struct::set::S_difference {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return $A}
array set tmp {}
foreach x $A {::set tmp($x) .}
foreach x $B {catch {unset tmp($x)}}
return [array names tmp]
}
if {0} {
# Tcllib SF Bug 1002143. We cannot use the implementation below.
# It will treat set elements containing '(' and ')' as array
# elements, and this screws up the storage of elements as the name
# of local vars something fierce. No way around this. Disabling
# this code and always using the other implementation (s.a.) is
# the only possible fix.
if {[package vcompare [package provide Tcl] 8.4] < 0} {
# Tcl 8.[23]. Use explicit array to perform the operation.
} else {
# Tcl 8.4+, has 'unset -nocomplain'
proc ::struct::set::S_difference {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return $A}
# Get the variable B out of the way, avoid collisions
# prepare for "pure list optimization"
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain]
unset B
# unset A early: no local variables left
foreach [lindex [list $A [unset A]] 0] {.} {break}
eval $::struct::set::tmp
return [info locals]
}
}
}
# ::struct::set::S_symdiff --
#
# Compute symmetric difference of two sets.
#
# Parameters:
# A, B -- The sets to compute the s.difference for.
#
# Results:
# The symmetric difference of the two input sets.
#
# Side effects:
# None.
proc ::struct::set::S_symdiff {A B} {
# symdiff == (A-B) + (B-A) == (A+B)-(A*B)
if {[llength $A] == 0} {return $B}
if {[llength $B] == 0} {return $A}
return [S_union \
[S_difference $A $B] \
[S_difference $B $A]]
}
# ::struct::set::S_intersect3 --
#
# Return intersection and differences for two sets.
#
# Parameters:
# A, B -- The sets to inspect.
#
# Results:
# List containing A*B, A-B, and B-A
#
# Side effects:
# None.
proc ::struct::set::S_intersect3 {A B} {
return [list \
[S_intersect $A $B] \
[S_difference $A $B] \
[S_difference $B $A]]
}
# ::struct::set::S_equal --
#
# Compares two sets for equality.
#
# Parameters:
# a First set to compare.
# b Second set to compare.
#
# Results:
# A boolean. True if the lists are equal.
#
# Side effects:
# None.
proc ::struct::set::S_equal {A B} {
::set A [Cleanup $A]
::set B [Cleanup $B]
# Equal if of same cardinality and difference is empty.
if {[::llength $A] != [::llength $B]} {return 0}
return [expr {[llength [S_difference $A $B]] == 0}]
}
proc ::struct::set::Cleanup {A} {
# unset A to avoid collisions
if {[llength $A] < 2} {return $A}
# We cannot use variables to avoid an explicit array. The set
# elements may look like namespace vars (i.e. contain ::), and
# such elements break that, cannot be proc-local variables.
array set S {}
foreach item $A {set S($item) .}
return [array names S]
}
# ::struct::set::S_include --
#
# Add an element to a set.
#
# Parameters:
# Avar -- Reference to the set variable to extend.
# element -- The item to add to the set.
#
# Results:
# None.
#
# Side effects:
# The set in the variable referenced by Avar is extended
# by the element (if the element was not already present).
proc ::struct::set::S_include {Avar element} {
# Avar = Avar + {element}
upvar 1 $Avar A
if {![info exists A] || ![S_contains $A $element]} {
lappend A $element
}
return
}
# ::struct::set::S_exclude --
#
# Remove an element from a set.
#
# Parameters:
# Avar -- Reference to the set variable to shrink.
# element -- The item to remove from the set.
#
# Results:
# None.
#
# Side effects:
# The set in the variable referenced by Avar is shrunk,
# the element remove (if the element was actually present).
proc ::struct::set::S_exclude {Avar element} {
# Avar = Avar - {element}
upvar 1 $Avar A
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"}
while {[::set pos [lsearch -exact $A $element]] >= 0} {
::set A [lreplace [K $A [::set A {}]] $pos $pos]
}
return
}
# ::struct::set::S_add --
#
# Add a set to a set. Similar to 'union', but the first argument
# is a variable.
#
# Parameters:
# Avar -- Reference to the set variable to extend.
# B -- The set to add to the set in Avar.
#
# Results:
# None.
#
# Side effects:
# The set in the variable referenced by Avar is extended
# by all the elements in B.
proc ::struct::set::S_add {Avar B} {
# Avar = Avar + B
upvar 1 $Avar A
if {![info exists A]} {set A {}}
::set A [S_union [K $A [::set A {}]] $B]
return
}
# ::struct::set::S_subtract --
#
# Remove a set from a set. Similar to 'difference', but the first argument
# is a variable.
#
# Parameters:
# Avar -- Reference to the set variable to shrink.
# B -- The set to remove from the set in Avar.
#
# Results:
# None.
#
# Side effects:
# The set in the variable referenced by Avar is shrunk,
# all elements of B are removed.
proc ::struct::set::S_subtract {Avar B} {
# Avar = Avar - B
upvar 1 $Avar A
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"}
::set A [S_difference [K $A [::set A {}]] $B]
return
}
# ::struct::set::S_subsetof --
#
# A predicate checking if the first set is a subset
# or equal to the second set.
#
# Parameters:
# A -- The possible subset.
# B -- The set to compare to.
#
# Results:
# A boolean value, true if A is subset of or equal to B
#
# Side effects:
# None.
proc ::struct::set::S_subsetof {A B} {
# A subset|== B <=> (A == A*B)
return [S_equal $A [S_intersect $A $B]]
}
# ::struct::set::K --
# Performance helper command.
proc ::struct::set::K {x y} {::set x}
# ### ### ### ######### ######### #########
## Ready
namespace eval ::struct {
# Put 'set::set' into the general structure namespace
# for pickup by the main management.
namespace import -force set::set_tcl
}

80
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil-0.9.tm

@ -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

761
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/adjust-0.7.3.tm

@ -1,761 +0,0 @@
# trim.tcl --
#
# Various ways of trimming a string.
#
# Copyright (c) 2000 by Ajuba Solutions.
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com>
# Copyright (c) 2002-2004 by Johannes-Heinrich Vogeler <vogeler@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: adjust.tcl,v 1.16 2011/12/13 18:12:56 andreas_kupries Exp $
# ### ### ### ######### ######### #########
## Requirements
package require Tcl 8.2
package require textutil::repeat
package require textutil::string
namespace eval ::textutil::adjust {}
# ### ### ### ######### ######### #########
## API implementation
namespace eval ::textutil::adjust {
namespace import -force ::textutil::repeat::strRepeat
}
proc ::textutil::adjust::adjust {text args} {
if {[string length [string trim $text]] == 0} {
return ""
}
Configure $args
Adjust text newtext
return $newtext
}
proc ::textutil::adjust::Configure {args} {
variable Justify left
variable Length 72
variable FullLine 0
variable StrictLength 0
variable Hyphenate 0
variable HyphPatterns ; # hyphenation patterns (TeX)
set args [ lindex $args 0 ]
foreach { option value } $args {
switch -exact -- $option {
-full {
if { ![ string is boolean -strict $value ] } then {
error "expected boolean but got \"$value\""
}
set FullLine [ string is true $value ]
}
-hyphenate {
# the word exceeding the length of line is tried to be
# hyphenated; if a word cannot be hyphenated to fit into
# the line processing stops! The length of the line should
# be set to a reasonable value!
if { ![ string is boolean -strict $value ] } then {
error "expected boolean but got \"$value\""
}
set Hyphenate [string is true $value]
if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} {
error "hyphenation patterns not loaded!"
}
}
-justify {
set lovalue [ string tolower $value ]
switch -exact -- $lovalue {
left -
right -
center -
plain {
set Justify $lovalue
}
default {
error "bad value \"$value\": should be center, left, plain or right"
}
}
}
-length {
if { ![ string is integer $value ] } then {
error "expected positive integer but got \"$value\""
}
if { $value < 1 } then {
error "expected positive integer but got \"$value\""
}
set Length $value
}
-strictlength {
# the word exceeding the length of line is moved to the
# next line without hyphenation; words longer than given
# line length are cut into smaller pieces
if { ![ string is boolean -strict $value ] } then {
error "expected boolean but got \"$value\""
}
set StrictLength [ string is true $value ]
}
default {
error "bad option \"$option\": must be -full, -hyphenate, \
-justify, -length, or -strictlength"
}
}
}
return ""
}
# ::textutil::adjust::Adjust
#
# History:
# rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv)
proc ::textutil::adjust::Adjust { varOrigName varNewName } {
variable Length
variable FullLine
variable StrictLength
variable Hyphenate
upvar $varOrigName orig
upvar $varNewName text
set pos 0; # Cursor after writing
set line ""
set text ""
if {!$FullLine} {
regsub -all -- "(\n)|(\t)" $orig " " orig
regsub -all -- " +" $orig " " orig
regsub -all -- "(^ *)|( *\$)" $orig "" orig
}
set words [split $orig]
set numWords [llength $words]
set numline 0
for {set cnt 0} {$cnt < $numWords} {incr cnt} {
set w [lindex $words $cnt]
set wLen [string length $w]
# the word $w doesn't fit into the present line
# case #1: we try to hyphenate
if {$Hyphenate && ($pos+$wLen >= $Length)} {
# Hyphenation instructions
set w2 [textutil::adjust::Hyphenation $w]
set iMax [llength $w2]
if {$iMax == 1 && [string length $w] > $Length} {
# word cannot be hyphenated and exceeds linesize
error "Word \"$w2\" can\'t be hyphenated\
and exceeds linesize $Length!"
} else {
# hyphenating of $w was successfull, but we have to look
# that every sylable would fit into the line
foreach x $w2 {
if {[string length $x] >= $Length} {
error "Word \"$w\" can\'t be hyphenated\
to fit into linesize $Length!"
}
}
}
for {set i 0; set w3 ""} {$i < $iMax} {incr i} {
set syl [lindex $w2 $i]
if {($pos+[string length " $w3$syl-"]) > $Length} {break}
append w3 $syl
}
for {set w4 ""} {$i < $iMax} {incr i} {
set syl [lindex $w2 $i]
append w4 $syl
}
if {[string length $w3] && [string length $w4]} {
# hyphenation was successfull: redefine
# list of words w => {"$w3-" "$w4"}
set x [lreplace $words $cnt $cnt "$w4"]
set words [linsert $x $cnt "$w3-"]
set w [lindex $words $cnt]
set wLen [string length $w]
incr numWords
}
}
# the word $w doesn't fit into the present line
# case #2: we try to cut the word into pieces
if {$StrictLength && ([string length $w] > $Length)} {
# cut word into two pieces
set w2 $w
set over [expr {$pos+2+$wLen-$Length}]
incr Length -1
set w3 [string range $w2 0 $Length]
incr Length
set w4 [string range $w2 $Length end]
set x [lreplace $words $cnt $cnt $w4]
set words [linsert $x $cnt $w3 ]
set w [lindex $words $cnt]
set wLen [string length $w]
incr numWords
}
# continuing with the normal procedure
if {($pos+$wLen < $Length)} {
# append word to current line
if {$pos} {append line " "; incr pos}
append line $w
incr pos $wLen
} else {
# line full => write buffer and begin a new line
if {[string length $text]} {append text "\n"}
append text [Justification $line [incr numline]]
set line $w
set pos $wLen
}
}
# write buffer and return!
if {[string length $text]} {append text "\n"}
append text [Justification $line end]
return $text
}
# ::textutil::adjust::Justification
#
# justify a given line
#
# Parameters:
# line text for justification
# index index for line in text
#
# Returns:
# the justified line
#
# Remarks:
# Only lines with size not exceeding the max. linesize provided
# for text formatting are justified!!!
proc ::textutil::adjust::Justification { line index } {
variable Justify
variable Length
variable FullLine
set len [string length $line]; # length of current line
if { $Length <= $len } then {
# the length of current line ($len) is equal as or greater than
# the value provided for text formatting ($Length) => to avoid
# inifinite loops we leave $line unchanged and return!
return $line
}
# Special case:
# for the last line, and if the justification is set to 'plain'
# the real justification is 'left' if the length of the line
# is less than 90% (rounded) of the max length allowed. This is
# to avoid expansion of this line when it is too small: without
# it, the added spaces will 'unbeautify' the result.
#
set justify $Justify
if { ( "$index" == "end" ) && \
( "$Justify" == "plain" ) && \
( $len < round($Length * 0.90) ) } then {
set justify left
}
# For a left justification, nothing to do, but to
# add some spaces at the end of the line if requested
if { "$justify" == "left" } then {
set jus ""
if { $FullLine } then {
set jus [strRepeat " " [ expr { $Length - $len } ]]
}
return "${line}${jus}"
}
# For a right justification, just add enough spaces
# at the beginning of the line
if { "$justify" == "right" } then {
set jus [strRepeat " " [ expr { $Length - $len } ]]
return "${jus}${line}"
}
# For a center justification, add half of the needed spaces
# at the beginning of the line, and the rest at the end
# only if needed.
if { "$justify" == "center" } then {
set mr [ expr { ( $Length - $len ) / 2 } ]
set ml [ expr { $Length - $len - $mr } ]
set jusl [strRepeat " " $ml]
set jusr [strRepeat " " $mr]
if { $FullLine } then {
return "${jusl}${line}${jusr}"
} else {
return "${jusl}${line}"
}
}
# For a plain justification, it's a little bit complex:
#
# if some spaces are missing, then
#
# 1) sort the list of words in the current line by decreasing size
# 2) foreach word, add one space before it, except if it's the
# first word, until enough spaces are added
# 3) rebuild the line
if { "$justify" == "plain" } then {
set miss [ expr { $Length - [ string length $line ] } ]
# Bugfix tcllib-bugs-860753 (jhv)
set words [split $line]
set numWords [llength $words]
if {$numWords < 2} {
# current line consists of less than two words - we can't
# insert blanks to achieve a plain justification => leave
# $line unchanged and return!
return $line
}
for {set i 0; set totalLen 0} {$i < $numWords} {incr i} {
set w($i) [lindex $words $i]
if {$i > 0} {set w($i) " $w($i)"}
set wLen($i) [string length $w($i)]
set totalLen [expr {$totalLen+$wLen($i)}]
}
set miss [expr {$Length - $totalLen}]
# len walks through all lengths of words of the line under
# consideration
for {set len 1} {$miss > 0} {incr len} {
for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} {
if {$wLen($i) == $len} {
set w($i) " $w($i)"
incr wLen($i)
incr miss -1
}
}
}
set line ""
for {set i 0} {$i < $numWords} {incr i} {
set line "$line$w($i)"
}
# End of bugfix
return "${line}"
}
error "Illegal justification key \"$justify\""
}
proc ::textutil::adjust::SortList { list dir index } {
if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then {
error "$sl"
}
return $sl
}
# Hyphenation utilities based on Knuth's algorithm
#
# Copyright (C) 2001-2003 by Dr.Johannes-Heinrich Vogeler (jhv)
# These procedures may be used as part of the tcllib
# textutil::adjust::Hyphenation
#
# Hyphenate a string using Knuth's algorithm
#
# Parameters:
# str string to be hyphenated
#
# Returns:
# the hyphenated string
proc ::textutil::adjust::Hyphenation { str } {
# if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung"
# use these for hyphenation and return
if {[regexp {[^\\-]*[\\-][.]*} $str]} {
regsub -all {(\\)(-)} $str {-} tmp
return [split $tmp -]
}
# Don't hyphenate very short words! Minimum length for hyphenation
# is set to 3 characters!
if { [string length $str] < 4 } then { return $str }
# otherwise follow Knuth's algorithm
variable HyphPatterns; # hyphenation patterns (TeX)
set w ".[string tolower $str]."; # transform to lower case
set wLen [string length $w]; # and add delimiters
# Initialize hyphenation weights
set s {}
for {set i 0} {$i < $wLen} {incr i} {
lappend s 0
}
for {set i 0} {$i < $wLen} {incr i} {
set kmax [expr {$wLen-$i}]
for {set k 1} {$k < $kmax} {incr k} {
set sw [string range $w $i [expr {$i+$k}]]
if {[info exists HyphPatterns($sw)]} {
set hw $HyphPatterns($sw)
set hwLen [string length $hw]
for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} {
set c [string index $hw $l1]
if {[string is digit $c]} {
set sPos [expr {$i+$l2}]
if {$c > [lindex $s $sPos]} {
set s [lreplace $s $sPos $sPos $c]
}
} else {
incr l2
}
}
}
}
}
# Replace all even hyphenation weigths by zero
for {set i 0} {$i < [llength $s]} {incr i} {
set c [lindex $s $i]
if {!($c%2)} { set s [lreplace $s $i $i 0] }
}
# Don't start with a hyphen! Take also care of words enclosed in quotes
# or that someone has forgotten to put a blank between a punctuation
# character and the following word etc.
for {set i 1} {$i < ($wLen-1)} {incr i} {
set c [string range $w $i end]
if {[regexp {^[:alpha:][.]*} $c]} {
for {set k 1} {$k < ($i+1)} {incr k} {
set s [lreplace $s $k $k 0]
}
break
}
}
# Don't separate the last character of a word with a hyphen
set max [expr {[llength $s]-2}]
if {$max} {set s [lreplace $s $max end 0]}
# return the syllabels of the hyphenated word as a list!
set ret ""
set w ".$str."
for {set i 1} {$i < ($wLen-1)} {incr i} {
if {[lindex $s $i]} { append ret - }
append ret [string index $w $i]
}
return [split $ret -]
}
# textutil::adjust::listPredefined
#
# Return the names of the hyphenation files coming with the package.
#
# Parameters:
# None.
#
# Result:
# List of filenames (without directory)
proc ::textutil::adjust::listPredefined {} {
variable here
return [glob -type f -directory $here -tails *.tex]
}
# textutil::adjust::getPredefined
#
# Retrieve the full path for a predefined hyphenation file
# coming with the package.
#
# Parameters:
# name Name of the predefined file.
#
# Results:
# Full path to the file, or an error if it doesn't
# exist or is matching the pattern *.tex.
proc ::textutil::adjust::getPredefined {name} {
variable here
if {![string match *.tex $name]} {
return -code error \
"Illegal hyphenation file \"$name\""
}
set path [file join $here $name]
if {![file exists $path]} {
return -code error \
"Unknown hyphenation file \"$path\""
}
return $path
}
# textutil::adjust::readPatterns
#
# Read hyphenation patterns from a file and store them in an array
#
# Parameters:
# filNam name of the file containing the patterns
proc ::textutil::adjust::readPatterns { filNam } {
variable HyphPatterns; # hyphenation patterns (TeX)
# HyphPatterns(_LOADED_) is used as flag for having loaded
# hyphenation patterns from the respective file (TeX format)
if {[info exists HyphPatterns(_LOADED_)]} {
unset HyphPatterns(_LOADED_)
}
# the array xlat provides translation from TeX encoded characters
# to those of the ISO-8859-1 character set
set xlat(\"s) \337; # 223 := sharp s "
set xlat(\`a) \340; # 224 := a, grave
set xlat(\'a) \341; # 225 := a, acute
set xlat(\^a) \342; # 226 := a, circumflex
set xlat(\"a) \344; # 228 := a, diaeresis "
set xlat(\`e) \350; # 232 := e, grave
set xlat(\'e) \351; # 233 := e, acute
set xlat(\^e) \352; # 234 := e, circumflex
set xlat(\`i) \354; # 236 := i, grave
set xlat(\'i) \355; # 237 := i, acute
set xlat(\^i) \356; # 238 := i, circumflex
set xlat(\~n) \361; # 241 := n, tilde
set xlat(\`o) \362; # 242 := o, grave
set xlat(\'o) \363; # 243 := o, acute
set xlat(\^o) \364; # 244 := o, circumflex
set xlat(\"o) \366; # 246 := o, diaeresis "
set xlat(\`u) \371; # 249 := u, grave
set xlat(\'u) \372; # 250 := u, acute
set xlat(\^u) \373; # 251 := u, circumflex
set xlat(\"u) \374; # 252 := u, diaeresis "
set fd [open $filNam RDONLY]
set status 0
while {[gets $fd line] >= 0} {
switch -exact $status {
PATTERNS {
if {[regexp {^\}[.]*} $line]} {
# End of patterns encountered: set status
# and ignore that line
set status 0
continue
} else {
# This seems to be pattern definition line; to process it
# we have first to do some editing
#
# 1) eat comments in a pattern definition line
# 2) eat braces and coded linefeeds
set z [string first "%" $line]
if {$z > 0} { set line [string range $line 0 [expr {$z-1}]] }
regsub -all {(\\n|\{|\})} $line {} tmp
set line $tmp
# Now $line should consist only of hyphenation patterns
# separated by white space
# Translate TeX encoded characters to ISO-8859-1 characters
# using the array xlat defined above
foreach x [array names xlat] {
regsub -all {$x} $line $xlat($x) tmp
set line $tmp
}
# split the line and create a lookup array for
# the repective hyphenation patterns
foreach item [split $line] {
if {[string length $item]} {
if {![string match {\\} $item]} {
# create index for hyphenation patterns
set var $item
regsub -all {[0-9]} $var {} idx
# store hyphenation patterns as elements of an array
set HyphPatterns($idx) $item
}
}
}
}
}
EXCEPTIONS {
if {[regexp {^\}[.]*} $line]} {
# End of patterns encountered: set status
# and ignore that line
set status 0
continue
} else {
# to be done in the future
}
}
default {
if {[regexp {^\\endinput[.]*} $line]} {
# end of data encountered, stop processing and
# ignore all the following text ..
break
} elseif {[regexp {^\\patterns[.]*} $line]} {
# begin of patterns encountered: set status
# and ignore that line
set status PATTERNS
continue
} elseif {[regexp {^\\hyphenation[.]*} $line]} {
# some particular cases to be treated separately
set status EXCEPTIONS
continue
} else {
set status 0
}
}
}
}
close $fd
set HyphPatterns(_LOADED_) 1
return
}
#######################################################
# @c The specified <a text>block is indented
# @c by <a prefix>ing each line. The first
# @c <a hang> lines ares skipped.
#
# @a text: The paragraph to indent.
# @a prefix: The string to use as prefix for each line
# @a prefix: of <a text> with.
# @a skip: The number of lines at the beginning to leave untouched.
#
# @r Basically <a text>, but indented a certain amount.
#
# @i indent
# @n This procedure is not checked by the testsuite.
proc ::textutil::adjust::indent {text prefix {skip 0}} {
set text [string trimright $text]
set res [list]
foreach line [split $text \n] {
if {[string compare "" [string trim $line]] == 0} {
lappend res {}
} else {
set line [string trimright $line]
if {$skip <= 0} {
lappend res $prefix$line
} else {
lappend res $line
}
}
if {$skip > 0} {incr skip -1}
}
return [join $res \n]
}
# Undent the block of text: Compute LCP (restricted to whitespace!)
# and remove that from each line. Note that this preverses the
# shaping of the paragraph (i.e. hanging indent are _not_ flattened)
# We ignore empty lines !!
proc ::textutil::adjust::undent {text} {
if {$text == {}} {return {}}
set lines [split $text \n]
set ne [list]
foreach l $lines {
if {[string length [string trim $l]] == 0} continue
lappend ne $l
}
set lcp [::textutil::string::longestCommonPrefixList $ne]
if {[string length $lcp] == 0} {return $text}
regexp "^(\[\t \]*)" $lcp -> lcp
if {[string length $lcp] == 0} {return $text}
set len [string length $lcp]
set res [list]
foreach l $lines {
if {[string length [string trim $l]] == 0} {
lappend res {}
} else {
lappend res [string range $l $len end]
}
}
return [join $res \n]
}
# ### ### ### ######### ######### #########
## Data structures
namespace eval ::textutil::adjust {
variable here [file dirname [info script]]
variable Justify left
variable Length 72
variable FullLine 0
variable StrictLength 0
variable Hyphenate 0
variable HyphPatterns
namespace export adjust indent undent
}
# ### ### ### ######### ######### #########
## Ready
package provide textutil::adjust 0.7.3

902
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/dehypht.tex

@ -1,902 +0,0 @@
% This is `dehypht.tex' as of 03 March 1999.
%
% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum
% [german hyphen patterns]
% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V.
% [macros, adaption for TeX 2]
%
% -----------------------------------------------------------------
% IMPORTANT NOTICE:
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
% -----------------------------------------------------------------
%
%
% This file contains german hyphen patterns following traditional
% hyphenation rules and includes umlauts and sharp s, but without
% `c-k' and triple consonants. It is based on hyphen patterns
% containing 5719 german hyphen patterns with umlauts in the
% recommended version of September 27, 1990.
%
% For use with TeX generated by
%
% Norbert Schwarz
% Rechenzentrum Ruhr-Universitaet Bochum
% Universitaetsstrasse 150
% D-44721 Bochum, FRG
%
%
% Adaption of these patterns for TeX, Version 2.x and 3.x and
% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by
%
% Bernd Raichle
% Stettener Str. 73
% D-73732 Esslingen, FRG
% Email: raichle@Informatik.Uni-Stuttgart.DE
%
%
% Error reports in case of UNCHANGED versions to
%
% DANTE e.V., Koordinator `german.sty'
% Postfach 10 18 40
% D-69008 Heidelberg, FRG
% Email: german@Dante.DE
%
% or one of the addresses given above.
%
%
% Changes:
% 1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz)
% 1991-02-13 PC umlauts changed to ^^xx (Norbert Schwarz)
% 1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro
% definitions and additional logic to select correct
% patterns/encoding (Bernd Raichle)
% 1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle)
% 1999-03-03 Renamed file to `dehypht.tex' according to the
% naming scheme using the ISO country code `de', the
% common part `hyph' for all hyphenation patterns files,
% and the additional postfix `t' for traditional,
% removed wrong catcode change of ^^e (the comment
% character %) and ^^f (the character &),
% do _not_ change \catcode, \lccode, \uccode to avoid
% problems with other hyphenation pattern files,
% changed code to distinguish TeX 2.x/3.x,
% changed license conditions to LPPL (Bernd Raichle)
%
%
% For more information see the additional documentation
% at the end of this file.
%
% -----------------------------------------------------------------
%
\message{German Traditional Hyphenation Patterns %
`dehypht' Version 3.2a <1999/03/03>}
\message{(Formerly known under the name `ghyph31' and `ghyphen'.)}
%
%
% Next we define some commands which are used inside the patterns.
% To keep them local, we enclose the rest of the file in a group
% (The \patterns command globally changes the hyphenation trie!).
%
\begingroup
%
%
% Make sure that doublequote is not active:
\catcode`\"=12
%
%
% Because ^^e4 is used in the following macros which is read by
% TeX 2.x as ^^e or %, the comment character of TeX, some trick
% has to be found to avoid this problem. The same is true for the
% character ^^f or & in the TeX 2.x code.
% Therefore in the code the exclamationmark ! is used instead of
% the circumflex ^ and its \catcode is set appropriately
% (normally \catcode`\!=12, in the code \catcode`\!=7).
%
% The following \catcode, \lccode assignments and macro definitions
% are defined in such a way that the following \pattern{...} list
% can be used for both, TeX 2.x and TeX 3.x.
%
% We first change the \lccode of ^^Y to make sure that we can
% include this character in the hyphenation patterns.
%
\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y
%
% Then we have to define some macros depending on the TeX version.
% Therefore we have to distinguish TeX version 2.x and 3.x:
%
\ifnum`\@=`\^^40 % true => TeX 3.x
%
% For TeX 3:
% ----------
%
% Assign appropriate \catcode and \lccode values for all
% accented characters used in the patterns (\uccode changes are
% not used within \patterns{...} and thus not necessary):
%
\catcode"E4=11 \catcode"C4=11 % \"a \"A
\catcode"F6=11 \catcode"D6=11 % \"o \"O
\catcode"FC=11 \catcode"DC=11 % \"u \"U
\catcode"FF=11 \catcode"DF=11 % \ss SS
%
\lccode"C4="E4 \uccode"C4="C4 \lccode"E4="E4 \uccode"E4="C4
\lccode"D6="F6 \uccode"D6="D6 \lccode"F6="F6 \uccode"F6="D6
\lccode"DC="FC \uccode"DC="DC \lccode"FC="FC \uccode"FC="DC
\lccode"DF="FF \uccode"DF="DF \lccode"FF="FF \uccode"FF="DF
%
% In the following definitions we use ??xy instead of ^^xy
% to avoid errors when reading the following macro definitions
% with TeX 2.x (remember ^^e(4) is the comment character):
%
\catcode`\?=7
%
% Define the accent macro " in such a way that it
% expands to single letters in font encoding T1.
\catcode`\"=13
\def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else
\errmessage{Hyphenation pattern file corrupted!}%
\fi\fi\fi}
%
% - patterns with umlauts are ok
\def\n#1{#1}
%
% For \ss which exists in T1 _and_ OT1 encoded fonts but with
% different glyph codes, duplicated patterns for both encodings
% are included. Thus you can use these hyphenation patterns for
% T1 and OT1 encoded fonts:
% - define \3 to be code `\^^ff (\ss in font encoding T1)
% - define \9 to be code `\^^Y (\ss in font encoding OT1)
\def\3{??ff}
\def\9{??Y}
% - duplicated patterns to support font encoding OT1 are ok
\def\c#1{#1}
% >>>>>> UNCOMMENT the next line, if you do not want
% >>>>>> to use fonts in font encoding OT1
%\def\c#1{}
%
\catcode`\?=12
%
\else
%
% For TeX 2:
% ----------
%
% Define the accent macro " to throw an error message.
\catcode`\"=13
\def"#1{\errmessage{Hyphenation pattern file corrupted!}}
%
% - ignore all patterns with umlauts
\def\n#1{}
%
% With TeX 2 fonts in encoding T1 can be used, but all glyphs
% in positions > 127 can not be used in hyphenation patterns.
% Thus only patterns with glyphs in OT1 positions are included:
% - define \3 to be code ^^Y (\ss in CM font encoding)
% - define \9 to throw an error message
\def\3{^^Y}
\def\9{\errmessage{Hyphenation pattern file corrupted!}}
% - ignore all duplicated patterns with \ss in T1 encoding
\def\c#1{}
%
\fi
%
%
\patterns{%
.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6
.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z
.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s
.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe
.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen
.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban
.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p
.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a
\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e
.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1
.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra}
.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top
.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re
.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be}
\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n
.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1
.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges
.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr
aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr
ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la
5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c
1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw
5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce. a5chal ach5art ach5au a1che
a8chent ach6er. a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu
ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad. a6d5ac ad3ant
ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1
1adv \n{a6d"a} a1e2d ae1r a1er. 1aero 8afa a3fal af1an a5far a5fat
af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re
a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn
ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar
ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu
\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re. a5isch. ais8e a3ismu ais6n
aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm
al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb
a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar
alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur
alu3ta \n{a1l"a} a6mate 8ame. 5a6meise am6m5ei am6mum am2n ampf3a
am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy
an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis
an1e2k 4aner. a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab
5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka
an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no
5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal
an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug
\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t
\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr
\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein
ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony
a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w
\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec
asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc
a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a
ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn
a1to a6t5ops ato6ra a6t5ort. 4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu
atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent
\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge. au4kle aule8s 6aum
au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz
aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x
a2xia a6xio a1ya a1z azi5er. 8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na
ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d
1be be1a be8at. be1ch 8becht 8becke. be5el be1en bee8rei be5eta bef2
8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac
bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u}
be1o2 b8er. be1ra be8rac ber8gab. ber1r \n{be1r"u} bes8c bes5erh
bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2
bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na
bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la.
6b1lad 6blag 8blam 1blat b8latt 3blau. b6lav 3ble. b1leb b1led
8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind
8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc
\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo
bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8
bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh}
\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p
bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin
6b1v 2b1w 1by1 by6te. 8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u}
\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re
ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch. 1chae ch1ah ch3akt cha6mer
8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl
6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie
5cho. 8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha
cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k
2ck. ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o
con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da.
8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce.
dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb
d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d
d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr
5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r
8denge. 8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers
der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul
de5us. 2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn
di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p
di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m
2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h
do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre. 4drech
d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres. 6d5rh 1dria
d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b}
\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha. 5dschik dse8e d8serg
8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti
d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie
8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s
du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r}
\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te}
\n{1d"u} ea4ben e1ac e1ah e1akt e1al. e5alf e1alg e5a8lin e1alk e1all
e5alp e1alt e5alw e1am e1and ea6nim e1ar. e5arf e1ark e5arm e3art
e5at. e6ate e6a5t6l e8ats e5att e6au. e1aus e1b e6b5am ebens5e
eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send
ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t
ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a}
ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha
e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec
e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a}
\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei
ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4
ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor
\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al
eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l
e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm
e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif
e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc
elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu
elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto
e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af
en5all en3alt en1am en3an. en3ant en3anz en1a6p en1ar en1a6s 6e1nat
en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene. en5eck
e8neff e6n5ehr e6n5eim en3eis 6enem. 6enen e4nent 4ener. e8nerd
e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess
e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf
e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid
3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of}
\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on. e3onf e5onk e5onl e5onr
e5opf e5ops e5or. e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent
e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos. ep4p3a e1pr \n{e1p"a} e1q
e1ra. er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e
era5k6l er3all er3amt e3rand e3rane er3ans e5ranz. e1rap er3arc
e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re.
er3eck er5egg er5e2h 2erei e3rei. e8reine er5einr 6eren. e4r3enm
4erer. e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan.
5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind
e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.}
ermen6s er6nab 3ernst 6e1ro. e1rod er1o2f e1rog 6e3roi ero8ide e3rol
e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein
er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa
er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa
esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill
es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs
e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta
et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr
et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw
\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2
e1um. eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s
eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er. e1z \n{e1"a2}
\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el.
fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art
fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim
8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd. ferri8 fe8stof
fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la
ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi
fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in. fi1na 8finf fi8scho fi6u
6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor
\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra
for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram
1f8ran f8ra\3 \c{f8ra\9} f8re. frei1 5frei. f3reic f3rest f1rib
8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str
\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad
ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end
\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug}
\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u}
\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la
6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm
ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c
6gd g1da 1ge ge1a2 ge6an ge8at. ge1e2 ge6es gef2 8geff ge1g2l ge1im
4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf
\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz.
\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei
5ghel. g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me. gi1na
4g3ins gi3str g1j 2g1k 8gl. 1glad g5lag glan4z3 1glas 6glass 5glaub
g3lauf 1gle. g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a
g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss
g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn. 1gna 8gnach 2gnah g1nas g8neu
g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist
go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic
g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3
\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc
gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te
g2t1h 1gu gu5as gu2e 2gue. 6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu
4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u}
\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el. haf6tr 2hal. ha1la
hal4b5a 6hale 8han. ha1na han6dr han6ge. 2hani h5anth 6hanz 6harb
h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d
he2bl he3cho h3echt he5d6s 5heft h5e6he. hei8ds h1eif 2hein he3ism
he5ist. heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end
hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au
h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th
heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2
hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr
5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3
\c{h1la\9} hl1c h1led h3lein h5ler. h2lif h2lim h8linf hl5int h2lip
h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n
hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1
1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn. ho3sl hos1p
ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg
h8rei. h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra
hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob
h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und
\n{h1s"u} h5ta. h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub
h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf
hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess
h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so
h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr. huld5a6 hu8lent
\n{hu8l"a} h5up. h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s}
\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.}
\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t}
\n{h"utte8re} i5adn i1af i5ak. i1al. i1al1a i1alb i1ald i5alei i1alf
i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz
i1an. ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo
i1ar. ia6rab i5arr i1as. i1asm i1ass i5ast. i1at. i5ats i1au i5azz
i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei
i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu
ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot
id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a}
ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei
ie4lek i3ell i1en. i1end ien6e i3enf i5enn ien6ne. i1enp i1enr
i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein
ie6r5eis ier8er i3ern. ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the
ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie
i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot
ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s
ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans
i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e
i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a}
\n{i5m"o} ina5he i1nat in1au inau8s 8ind. in4d3an 5index ind2r 3indus
i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er. 5inj
\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit
5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar}
\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di
ioi8 i1ol. i1om. i1on. i5onb ion2s1 i1ont i5ops i5o8pt i1or.
i3oral io3rat i5orc i1os. i1ot. i1o8x 2ip i1pa i1pi i1p2l i1pr i1q
i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl
ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei
isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind
is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab. i2t1a2m
i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl
itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru
i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5}
\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur
i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r}
\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la
je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s
\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl
ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb
kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein
6k5eis ke6lar ke8leis ke8lo 8kemp k5ente. k3entf 8k5ents 6kentz ke1ra
k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th
\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc
4k3leit k3lek 6k5ler. 5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor
\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de.
ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou
3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig
2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat
k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re
k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5
kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9}
6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o}
\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la.
8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn
5laken 8lamb la6mer 5lampe. 2l1amt la1na 1land lan4d3a lan4d3r lan4gr
8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar. la5ra lar4af
la8rag la8ran la6r5a6s l3arbe la8rei 6larm. la8sa la1sc la8sta lat8i
6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo
lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei
ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br
le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en. 8lends
6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi
le6pip 8lepo 1ler l6er. 8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg
l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s
5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6
6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3
\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5
4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam
livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la
ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a
l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a}
\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch.
l5o4fen 5loge. 5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg
4lort lo1ru 1los. lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn
lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh
l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein
l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o}
lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr
lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol
4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg
lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6
6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on}
\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v}
\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma
8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e
malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa
4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b
mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal
men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th
me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na
\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj
2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums
mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d
m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot
moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste
m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc
msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a}
mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my
2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3}
\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na.
n5ab. 8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el
n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama
na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and. 2n1ang 1nani
1nann n1ans 8nanw 5napf. 1n2ar. na2ra 2n1arc n8ard 1nari n8ark
6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk
na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c
nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi
nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau
ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy
4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb
4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde.
nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers. 6n5ertra
2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l
nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip
ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl
\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik
ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int
n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh
\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh
\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h
nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt
noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony
4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st
8nost. no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac
ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr
n6s5tat. n5s6te. n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art
n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie
n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f
ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s
nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu
nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr
2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar
n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai}
\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol}
\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}}
o5ab. oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru
obe6ser 1obj o1bl o2bli ob5sk 3obst. ob8sta obst5re ob5sz o1che
oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d
o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der. oe8du o1ef o1e2l
o1e2p o1er. o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g
og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm. oh2ni o1ho
oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id. o8idi oi8dr o5ids
o5isch. oiset6 o1ism o3ist. o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a}
1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1
ol8lak ol8lauf. ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym
o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o}
o1na ona8m on1ax on8ent o6n5erb 8oni oni5er. on1k on6n5a6b o1no ono1c
o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli
opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti
\n{o1p"a} \n{o5p"o} o1q o1ra. o3rad o8radd 1oram o6rang o5ras o8rauf
or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re. ore2h o8r5ein
ore5isc or6enn or8fla or8fli 1orga 5orgel. or2gl o1ri 5o6rient or8nan
\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a}
\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr
osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze
o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a
ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu
ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer. o1wi
owid6 o1wo o5wu o1xe oy5al. oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is
\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak
pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n
par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b
8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea
per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s
p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph.
2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2
ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis
pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik
6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra
2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l
ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod
5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as}
\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu
pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py
py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h}
\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr
5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall
ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli
r3angr rans5pa 8ranw r8anz. ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh
r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n
6raus. r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n
r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd
r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re.
re1ak 3reakt re3als re6am. re1as 4reben re6bl rech5a r8edi re3er
8reff 3refl 2reh 5reha r4ei. reich6s5 8reier 6reign re5imp 4r3eina
6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf
2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz
ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl
4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec
\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie
8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8
r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en
ri3er. ri5ers. ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8}
ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst
\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u}
ri5sv r2it 6r5i6tal ri5tr ri6ve. 8r1j 6rk r1ke rkehrs5 r1ki r3klin
r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m
r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei
r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern
6robs ro1ch 3rock. ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc
6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout
r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o}
r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u}
2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p
r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige
r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser
rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg
2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us
ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al
r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc}
\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or}
\n{r"o2sc} \n{3r"ump} 1sa. 1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw
3sack. 6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal
sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl
2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar. 2s1arb 3sarg
s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff
sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch. 3scha. 5schade
3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg
2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}}
6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig
8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o}
\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g
se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid. 2s1eig s8eil 5sein.
sei5n6e 6s5einh 3s8eit 3sel. se4lar selb4 6s3e4lem se8lerl 2s1emp
sen3ac se5nec 6s5ents 4sentz s8er. se8reim ser5inn \n{8serm"a}
8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h
s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en
si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la
sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j
s1k2 6sk. 2skau skel6c skelch5 s6kele 1s2ki. 3s4kin. s6kiz s8kj
6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m
s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope
so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap
s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi
spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra
3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an}
\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st. 1sta 4stafe 2stag
sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te
6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese
8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el
4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll. 4st3ope
6stopf. 6stord 6stp 5stra. 4strai 3s4tral 6s5traum 3stra\3
\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev
5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum
\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun. 2stv 2stw s2tyl
6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.}
1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran
6surte 2s1v 2s1w 1sy 8syl. sy5la syn1 sy2na syne4 s1z s4zend 5s6zene.
8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}}
\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3}
\n{\c{5s"u\9}} taats3 4tab. taba6k ta8ban tab2l ta6bre 4tabs t3absc
8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei
tage4s tag6s5t tah8 tahl3 tai6ne. ta5ir. tak8ta tal3au 1tale ta8leng
tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e
6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe
1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem
ta8sto t5aufb 4taufn 8taus. 5tause 8tausf 6tausg t5ausl 2t1b2 2t1c
t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel
2t1ehr te5id. teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen
8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p
ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar
t5erbe. 6terben 8terbs 4t3erbt t5erde. ter5ebe ter5ein te8rers terf4
\n{8terh"o} \n{6terkl"a} ter8nor ter6re. t8erscha t5e6sel te8stau
t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th. th6a 5tha. 2thaa
6t1hab 6t5haf t5hah 8thak 3thal. 6thals 6t3hand 2t1hau 1the. 3t4hea
t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet
5thi. 2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof
4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u}
ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind
tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a
2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e
6t5o6fen to1in toi6r 5toll. to8mene t2ons 2t1ony to4per 5topf. 6topt
to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha
tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st
3traue t4re. 2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif
8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink
tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man. tro3ny 5tropf
6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh}
\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d
ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i
tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort.
t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf
t8sum. t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser
tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums
8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re. tu4r3er 2t1v 2t1w 1ty1
ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei.
t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an}
\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen}
\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.}
u3al. u5alb u5alf u3alh u5alk u3alp u3an. ua5na u3and u5ans u5ar.
ua6th u1au ua1y u2bab ubi5er. u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc
u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w
uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o
u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re
\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn
ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o}
6ui ui5en u1ig u3ins uin8tes u5isch. u1j 6uk u1ke u1ki u1kl u8klu
u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo
ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f
um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und. 5undein
un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal
\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro
unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os. u1pa u1pi u1p2l u1pr
up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans
u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6
ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry
ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa
usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b
us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au
u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5
uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n
\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n
\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei
va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8
ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le.
8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li
v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z
waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru
war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r
weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk.
wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str
\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma
win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2
w1sk 6w5t 5wunde. wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc}
1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe. x3e4g 1xen xe1ro x1erz
1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d
8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya.
y5an. y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j
y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d
yn1t y1on. y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty
y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange.
8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein
zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a}
zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex
2z1f8 z1g 4z1h 1zi zi1en zi5es. 4z3imp zi1na 6z5inf 6z5inni zin6s5er
8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh
zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al
zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z
2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s
6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le}
\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi}
\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era}
\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h}
\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le}
\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu}
\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j}
\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e}
\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l}
\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq}
\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri}
\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o}
\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4}
\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl}
\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga}
\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z}
\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6}
\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu}
\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl}
\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l}
\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru}
\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w}
\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r}
\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck}
\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4}
\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh}
\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w}
\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c}
\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw}
\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng}
\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n}
\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti}
\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a.
\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d}
1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h}
2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h
\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m}
\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q
\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta}
\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to}
\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w
\c{\91w} \31z \c{\91z}
}%
\endgroup
\relax\endinput
%
% -----------------------------------------------------------------
%
% =============== Additional Documentation ===============
%
%
% Older Versions of German Hyphenation Patterns:
% ----------------------------------------------
%
% All older versions of `ghyphen.tex' distributed as
%
% ghyphen.tex/germhyph.tex as of 1986/11/01
% ghyphen.min/ghyphen.max as of 1988/10/10
% ghyphen3.tex as of 1990/09/27 & 1991/02/13
% ghyph31.tex as of 1994/02/13
%
% are out of date and it is recommended to replace them
% with the new version `dehypht.tex' as of 1999/03/03.
%
% If you are using `ghyphen.min' (a minor version of `ghyphen')
% because of limited trie memory space, try this version and if
% the space is exceeded get a newer TeX implementation with
% larger or configurable trie memory sizes.
%
%
%
% Trie Memory Requirements/Space for Hyphenation Patterns:
% --------------------------------------------------------
%
% To load this set of german hyphenation patterns the parameters
% of TeX has to have at least these values:
%
% TeX 3.x:
% IniTeX: trie_size >= 9733 trie_op_size >= 207
% VirTeX: trie_size >= 8375 trie_op_size >= 207
%
% TeX 2.x:
% IniTeX: trie_size >= 8675 trie_op_size >= 198
% VirTeX: trie_size >= 7560 trie_op_size >= 198
%
% If you want to load more than one set of hyphenation patterns
% (in TeX 3.x), the parameters have to be set to a value larger
% than or equal to the sum of all required values for each set.
%
%
% Setting Trie Memory Parameters:
% -------------------------------
%
% Some implementations allow the user to change the default value
% of a set of the internal TeX parameters including the trie memory
% size parameter specifying the used memory for the hyphenation
% patterns.
%
% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32)
% and newer:
% The used memory size of the true is usually set high enough.
% If needed set the size of the trie using the keyword `trie_size'
% in the configuration file `texmf/web2c/texmf.cnf'. For details
% see the included documentation.
%
% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT):
% You can set the used memory size of the trie using the
% `-mt<number>' option on the command line or in the
% TEXOPTIONS environment variable.
%
% PasTeX (Amiga):
% The values for the parameters can be set using the keywords
% `triesize', `itriesize' and `trieopsize' in the configuration
% file.
%
% others (binaries only):
% See the documentation of the implementation if it is possible
% and how to change these values without recompilation.
%
% others (with sources)
% If the trie memory is too small, you have to recompile TeX
% using larger values for `trie_size' and `trie_op_size'.
% Modify the change file `tex.ch' and recompile TeX.
% For details see the documentation included in the sources.
%
%
%
% Necessary Settings in TeX macro files:
% --------------------------------------
%
% \lefthyphenmin, \righthyphenmin:
% You can set both parameters to 2.
%
% \lccode <char>:
% To get correct hyphenation points within words containing
% umlauts or \ss, it's necessary to assign values > 0 to the
% appropriate \lccode <char> positions.
%
% These changes are _not_ done when reading this file and have to
% be included in the language switching mechanism as is done in,
% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1,
% \left-/\righthyphenmin settings).
%
%
%% \CharacterTable
%% {Upper-case \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
%% Lower-case \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
%% Digits \0\1\2\3\4\5\6\7\8\9
%% Exclamation \! Double quote \" Hash (number) \#
%% Dollar \$ Percent \% Ampersand \&
%% Acute accent \' Left paren \( Right paren \)
%% Asterisk \* Plus \+ Comma \,
%% Minus \- Point \. Solidus \/
%% Colon \: Semicolon \; Less than \<
%% Equals \= Greater than \> Question mark \?
%% Commercial at \@ Left bracket \[ Backslash \\
%% Right bracket \] Circumflex \^ Underscore \_
%% Grave accent \` Left brace \{ Vertical bar \|
%% Right brace \} Tilde \~}
%%
\endinput
%%
%% End of file `dehypht.tex'.

1104
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/eshyph_vo.tex

File diff suppressed because it is too large Load Diff

1122
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/expander-1.3.1.tm

File diff suppressed because it is too large Load Diff

223
src/mixtemplates/layouts/basic/src/bootsupport/modules/textutil/ithyph.tex

@ -1,223 +0,0 @@
%%%%%%%%%%%%%%%%%%%% file ithyph.tex
%%%%%%%%%%%%%%%%%%%%%%%%%%% file ithyph.tex %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Prepared by Claudio Beccari e-mail beccari@polito.it
%
% Dipartimento di Elettronica
% Politecnico di Torino
% Corso Duca degli Abruzzi, 24
% 10129 TORINO
%
% Copyright 1998, 2001 Claudio Beccari
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
%
% \versionnumber{4.8d} \versiondate{2001/11/21}
%
% These hyphenation patterns for the Italian language are supposed to comply
% with the Reccomendation UNI 6461 on hyphenation issued by the Italian
% Standards Institution (Ente Nazionale di Unificazione UNI). No guarantee
% or declaration of fitness to any particular purpose is given and any
% liability is disclaimed.
%
% See comments and loading instructions at the end of the file after the
% \endinput line
%
{\lccode`\'=`\' % Apostrophe has its own lccode so that it is treated
% as a letter
%>> 1998/04/14 inserted grouping
%
%\lccode23=23 % Compound word mark is a letter in encoding T1
%\def\W{^^W} % ^^W =\char23 = \char"17 =\char'27
%
\patterns{
.a3p2n % After the Garzanti dictionary: a-pnea, a-pnoi-co,...
.anti1 .anti3m2n
.bio1
.ca4p3s
.circu2m1
.di2s3cine
%.e2x
.fran2k3
.free3
.narco1
.opto1
.orto3p2
.para1
.poli3p2
.pre1
.p2s
%.ri1a2 .ri1e2 .re1i2 .ri1o2 .ri1u2
.sha2re3
.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t
.su2b3lu .su2b3r
.wa2g3n
.wel2t1
a1ia a1ie a1io a1iu a1uo a1ya 2at.
e1iu e2w
o1ia o1ie o1io o1iu
%u1u
%
%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2
'2
1b 2bb 2bc 2bd 2bf 2bm 2bn 2bp 2bs 2bt 2bv
b2l b2r 2b. 2b'. 2b''
1c 2cb 2cc 2cd 2cf 2ck 2cm 2cn 2cq 2cs 2ct 2cz
2chh c2h 2chb ch2r 2chn c2l c2r 2c. 2c'. 2c'' .c2
1d 2db 2dd 2dg 2dl 2dm 2dn 2dp d2r 2ds 2dt 2dv 2dw
2d. 2d'. 2d'' .d2
1f 2fb 2fg 2ff 2fn f2l f2r 2fs 2ft 2f. 2f'. 2f''
1g 2gb 2gd 2gf 2gg g2h g2l 2gm g2n 2gp g2r 2gs 2gt
2gv 2gw 2gz 2gh2t 2g. 2g'. 2g''
1h 2hb 2hd 2hh hi3p2n h2l 2hm 2hn 2hr 2hv 2h. 2h'. 2h''
1j 2j. 2j'. 2j''
1k 2kg 2kf k2h 2kk k2l 2km k2r 2ks 2kt 2k. 2k'. 2k''
1l 2lb 2lc 2ld 2l3f2 2lg l2h 2lk 2ll 2lm 2ln 2lp
2lq 2lr 2ls 2lt 2lv 2lw 2lz 2l. 2l'. 2l''
1m 2mb 2mc 2mf 2ml 2mm 2mn 2mp 2mq 2mr 2ms 2mt 2mv 2mw
2m. 2m'. 2m''
1n 2nb 2nc 2nd 2nf 2ng 2nk 2nl 2nm 2nn 2np 2nq 2nr
2ns 2nt 2nv 2nz n2g3n 2nheit. 2n. 2n' 2n''
1p 2pd p2h p2l 2pn 3p2ne 2pp p2r 2ps 3p2sic 2pt 2pz 2p. 2p'. 2p''
1q 2qq 2q. 2q'. 2q''
1r 2rb 2rc 2rd 2rf r2h 2rg 2rk 2rl 2rm 2rn 2rp
2rq 2rr 2rs 2rt rt2s3 2rv 2rx 2rw 2rz 2r. 2r'. 2r''
1s2 2shm 2s3s s4s3m 2s3p2n 2stb 2stc 2std 2stf 2stg 2stm 2stn
2stp 2sts 2stt 2stv 2sz 4s. 4s'. 4s''
1t 2tb 2tc 2td 2tf 2tg t2h t2l 2tm 2tn 2tp t2r 2ts
3t2sch 2tt 2tv 2tw t2z 2tzk 2tzs 2t. 2t'. 2t''
1v 2vc v2l v2r 2vv 2v. 2v'. 2v''
1w w2h wa2r 2w1y 2w. 2w'. 2w''
1x 2xt 2xw 2x. 2x'. 2x''
y1ou y1i
1z 2zb 2zd 2zl 2zn 2zp 2zt 2zs 2zv 2zz 2z. 2z'. 2z'' .z2
}} % Pattern end
\endinput
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
LOADING THESE PATTERNS
These patterns, as well as those for any other language, do not become
effective until they are loaded in a special form into a format file; this
task is performed by the TeX initializer; any TeX system has its own
initializer with its special way of being activated. Before loading these
patterns, then, it is necessary to read very carefully the instructions that
come with your TeX system.
Here I describe how to load the patterns with the freeware TeX system named
MiKTeX version 2.x for Windows 9x, NT, 2000, XP; with minor changes the
whole procedure is applicable with other TeX systems, but the details must
be deduced from your TeX system documentation at the section/chapter "How to
build or to rebuild a format file".
With MikTeX:
a) copy this file and replace the existing file ithyph.tex in the directory
\texmf\tex\generic\hyphen if the existing one has an older version date
and number.
b) select Start|Programs|MiKTeX|MiKTeX options.
c) in the Language tab add a check mark to the line concerning the Italian
language.
d) in the Geneal tab click "Update format files".
e) That's all!
For the activation of these patterns with the specific Italian typesetting
features, use the babel package as this:
\documentclass{article} % Or whatever other class
\usepackage[italian]{babel}
...
\begin{document}
...
\end{document}
ON ITALIAN HYPHENATION
I have been working on patterns for the Italian language since 1987; in 1992
I published
C. Beccari, "Computer aided hyphenation for Italian and Modern
Latin", TUG vol. 13, n. 1, pp. 23-33 (1992)
which contained a set of patterns that allowed hyphenation for both Italian
and Latin; a slightly modified version of the patterns published in the
above paper is contained in LAHYPH.TEX available on the CTAN archives.
From the above patterns I extracted the minimum set necessary for
hyphenating Italian that was made available on the CTAN archives with the
name ITHYPH.tex the version number 3.5 on the 16th of August 1994.
The original pattern set required 37 ops; being interested in a local
version of TeX/LaTeX capable of dealing with half a dozen languages, I
wanted to reduce memory occupation and therefore the number of ops.
Th new version (4.0 released in 1996) of ITHYPH.TEX is much simpler than
version 3.5 and requires just 29 ops while it retains all the power of
version 3.5; it contains many more new patterns that allow to hyphenate
unusual words that generally have a root borrowed from a foreign language.
Updated versions 4.x contain minor additions and the number of ops is
increased to 30 (version 4.7 of 1998/06/01).
This new pattern set has been tested with the same set of difficult Italian
words that was used to test version 3.5 and it yields the same results (a
part a minor change that was deliberately introduced so as to reduce the
typographical hyphenation with hyathi, since hyphenated hyathi are not
appreciated by Italian readers). A new enlarged word set for testing
purposes gets correct hyphen points that were missed or wrongly placed with
version 3.5, although no error had been reported, because such words are of
very specialized nature and are seldom used.
As the previous version, this new set of patterns does not contain any
accented character so that the hyphenation algorithm behaves properly in
both cases, that is with cm and with dc/ec fonts. With LaTeXe terminology
the difference is between OT1 and T1 encodings; with the former encoding
fonts do not contain accented characters, while with the latter accented
characters are present and sequences such as \`a map directly to slot "E0
that contains "agrave".
Of course if you use dc/ec fonts (or any other real or virtual font with T1
encoding) you get the full power of the hyphenation algorithm, while if you
use cm fonts (or any other real or virtual font with OT1 encoding) you miss
some possible break points; this is not a big inconvenience in Italian
because:
1) The Regulation UNI 6015 on accents specifies that compulsory accents
appear only on the ending vowel of oxitone words; this means that it is
almost indifferent to have or to miss the dc/ec fonts because the only
difference consists in how TeX evaluates the end of the word; in practice
if you have these special facilities you get "qua-li-t\`a", while if you
miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1).
2) Optional accents are so rare in Italian, that if you absolutely want to
use them in those rare instances, and you miss the T1 encoding
facilities, you should also provide explicit discretionary hyphens as in
"s\'e\-gui\-to".
There is no explicit hyphenation exception list because these patterns
proved to hyphenate correctly a very large set of words suitably chosen in
order to test them in the most heavy circumstances; these patterns were used
in the preparation of a number of books and no errors were discovered.
Nevertheless if you frequently use technical terms that you want hyphenated
differently from what is normally done (for example if you prefer
etymological hyphenation of prefixed and/or suffixed words) you should
insert a specific hyphenation list in the preamble of your document, for
example:
\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri}
Should you find any word that gets hyphenated in a wrong way, please, AFTER
CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably
by e-mail.
Happy multilingual typesetting !

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save