jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

update src/make.tcl and src/bootsupport

master
Julian Noble 3 days ago
parent
1ab0de6cef
commit
c2e6ba71e5
32 changed files with 11484 additions and 30131 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 1028
      src/bootsupport/modules/commandstack-0.3.tm
  2. 567
      src/bootsupport/modules/fauxlink-0.1.0.tm
  3. 21
      src/bootsupport/modules/fauxlink-0.1.1.tm
  4. 12822
      src/bootsupport/modules/metaface-1.2.5.tm
  5. 705
      src/bootsupport/modules/modpod-0.1.0.tm
  6. 697
      src/bootsupport/modules/modpod-0.1.1.tm
  7. 1894
      src/bootsupport/modules/natsort-0.1.1.5.tm
  8. 1288
      src/bootsupport/modules/patterncmd-1.2.4.tm
  9. 1508
      src/bootsupport/modules/patternpredator2-1.2.4.tm
  10. 3
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  11. 65
      src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  12. 972
      src/bootsupport/modules/punk/config-0.1.tm
  13. 5
      src/bootsupport/modules/punk/mix/base-0.1.tm
  14. 20
      src/bootsupport/modules/punk/mix/cli-0.3.1.tm
  15. 2
      src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm
  16. 8
      src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm
  17. 6
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  18. 170
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  19. 38
      src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm
  20. 327
      src/bootsupport/modules/punk/mod-0.1.tm
  21. 21
      src/bootsupport/modules/punk/path-0.1.0.tm
  22. 240
      src/bootsupport/modules/punk/repo-0.1.1.tm
  23. 478
      src/bootsupport/modules/punkapp-0.1.tm
  24. 114
      src/bootsupport/modules/punkcheck-0.1.0.tm
  25. BIN
      src/bootsupport/modules/test/tomlish-1.1.1.tm
  26. BIN
      src/bootsupport/modules/test/tomlish-1.1.3.tm
  27. 7408
      src/bootsupport/modules/textblock-0.1.1.tm
  28. 8520
      src/bootsupport/modules/textblock-0.1.2.tm
  29. 160
      src/bootsupport/modules/tomlish-1.1.2.tm
  30. 2110
      src/bootsupport/modules/tomlish-1.1.3.tm
  31. BIN
      src/bootsupport/modules/zipper-0.11.tm
  32. 418
      src/make.tcl

1028
src/bootsupport/modules/commandstack-0.3.tm
View File

File diff suppressed because it is too large Load Diff

567
src/bootsupport/modules/fauxlink-0.1.0.tm
Unescape View File

@ -1,567 +0,0 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application fauxlink 0.1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0]
#[copyright "2024"]
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}]
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}]
#[require fauxlink]
#[keywords symlink faux fake shortcut toml]
#[description]
#[para] A cross platform shortcut/symlink alternative.
#[para] Unapologetically ugly - but practical in certain circumstances.
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as
#[para] archiving and packaging systems.
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable.
#[para] format of name <nominalname>#<encodedtarget>.fxlnk
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget>
#[para] The + symbol substitutes for forward-slashes.
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !)
#[para] We deliberately treat higher % sequences literally.
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls.
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23
#[para] e.g a link to a file file#A.txt in parent dir could be:
#[para] file%23A.txt#..+file%23A.txt.fxlnk
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk
#[para] The <nominalname> can be unrelated to the actual target
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk
#[para] This system has no filesystem support - and must be completely application driven.
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform.
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined
#[para] Extensions to behaviour should be added in the file as text data in Toml format,
#[para] with custom data being under a single application-chosen table name
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system.
#[para] Aside from the 2 used for delimiting (+ #)
#[para] certain characters which might normally be allowed in filesystems are required to be encoded
#[para] e.g space and tab are required to be %20 %09
#[para] Others that require encoding are: * ? \ / | : ; " < >
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it.
#[para] Control characters and other punctuation is optional to encode.
#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems.
#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character.
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest
#
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it.
#Using fauxlink - a link would be:
# "my-program-files#++server+c+Program%20Files.fxlnk"
#If we needed the old-style literal %20 it would become
# "my-program-files#++server+c+Program%2520Files.fxlnk"
#
# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser)
# e.g
# pfiles#file%3a++++localhost+c+Program%2520files
# The browser will work with literal spaces too though - so it could just as well be:
# pfiles#file%3a++++localhost+c+Program%20files
#windows may default to using explorer.exe instead of a browser for file:// urls though
#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to?
#in a .url shortcut either literal space or %20 will work ie %xx values are decoded
#*** !doctools
#[section Overview]
#[para] overview of fauxlink
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by fauxlink
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6-}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink::class {
#*** !doctools
#[subsection {Namespace fauxlink::class}]
#[para] class definitions
if {[info commands [namespace current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink {
namespace export {[a-z]*}; # Convention: export all lowercase
#todo - enforce utf-8
#literal unicode chars supported by modern filesystems - leave as is - REVIEW
variable encode_map
variable decode_map
#most filesystems don't allow NULL - map to empty string
#Make sure % is not in encode_map
set encode_map [dict create\
\x00 ""\
{ } %20\
\t %09\
+ %2B\
# %23\
* %2A\
? %3F\
\\ %5C\
/ %2F\
| %7C\
: %3A\
{;} %3B\
{"} %22\
< %3C\
> %3E\
]
#above have some overlap with ctrl codes below.
#no big deal as it's a dict
#must_encode
# + # * ? \ / | : ; " < > <sp> \t
# also NUL to empty string
# also ctrl chars 01 to 1F (1..31)
for {set i 1} {$i < 32} {incr i} {
set ch [format %c $i]
set enc "%[format %02X $i]"
set enc_lower [string tolower $enc]
dict set encode_map $ch $enc
dict set decode_map $enc $ch
dict set decode_map $enc_lower $ch
}
variable must_encode
set must_encode [dict keys $encode_map]
#if they are in
#decode map doesn't include
# %00 (nul)
# %2F "/"
# %2f "/"
# %7f (del)
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention.
#
set decode_map [dict merge $decode_map [dict create\
%09 \t\
%20 { }\
%21 "!"\
%22 {"}\
%23 "#"\
%24 "$"\
%25 "%"\
%26 "&"\
%27 "'"\
%28 "("\
%29 ")"\
%2A "*"\
%2a "*"\
%2B "+"\
%2b "+"\
%2C ","\
%2c ","\
%2D "-"\
%2d "-"\
%2E "."\
%2e "."\
%3A ":"\
%3a ":"\
%3B {;}\
%3b {;}\
%3D "="\
%3C "<"\
%3c "<"\
%3d "="\
%3E ">"\
%3e ">"\
%3F "?"\
%3f "?"\
%40 "@"\
%5B "\["\
%5b "\["\
%5C "\\"\
%5c "\\"\
%5D "\]"\
%5d "\]"\
%5E "^"\
%5e "^"\
%60 "`"\
%7B "{"\
%7b "{"\
%7C "|"\
%7c "|"\
%7D "}"\
%7d "}"\
%7E "~"\
%7e "~"\
]]
#Don't go above 7f
#if we want to specify p
#*** !doctools
#[subsection {Namespace fauxlink}]
#[para] Core API functions for fauxlink
#[list_begin definitions]
proc Segment_mustencode_check {str} {
variable decode_map
variable encode_map ;#must_encode
set idx 0
set err ""
foreach ch [split $str ""] {
if {[dict exists $encode_map $ch]} {
set enc [dict get $encode_map $ch]
if {[dict exists $decode_map $enc]} {
append err " char $idx should be encoded as $enc" \n
} else {
append err " no %xx encoding available. Use %UXX if really required" \n
}
}
incr idx
}
return $err ;#empty string if ok
}
proc resolve {link} {
variable decode_map
variable encode_map
variable must_encode
set ftail [file tail $link]
set extension_name [string range [file extension $ftail] 1 end]
if {$extension_name ni [list fxlnk fauxlink]} {
set is_fauxlink 0
#we'll process anyway - but return the result wrapped
#This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent
#(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens
# to have # characters in it)
#It also means if someone really wants to use the fauxlink semantics on a different file type
# - they can - but just have to access the results differently and take that (minor) risk.
#error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink"
set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate"
} else {
set is_fauxlink 1
set err_extra ""
}
set linkspec [file rootname $ftail]
# - any # or + within the target path or name should have been uri encoded as %23 and %2b
if {[tcl::string::first # $linkspec] < 0} {
set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)"
append err $err_extra
error $err
}
#The 1st 2 parts of split on # are name and target file/dir
#If there are only 3 parts the 3rd part is a comment and there are no 'tags'
#if there are 4 parts - the 3rd part is a tagset where each tag begins with @
#and each subsequent part is a comment. Empty comments are stripped from the comments list
#A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @
#e.g name.txt#path#@tag1@tag2#test###.fxlnk
#has a name, a target, 2 tags and one comment
#check namespec already has required chars encoded
set segments [split $linkspec #]
lassign $segments namespec targetspec
#puts stderr "-->namespec $namespec"
set nametest [tcl::string::map $encode_map $namespec]
#puts stderr "-->nametest $nametest"
#nothing should be changed - if there are unencoded chars that must be encoded it is an error
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} {
set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)"
append err [Segment_mustencode_check $namespec]
append err $err_extra
error $err
}
#see comments below regarding 2 rounds and ordering.
set name [decode_unicode_escapes $namespec]
set name [tcl::string::map $decode_map $name]
#puts stderr "-->name: $name"
set targetsegment [split $targetspec +]
#check each + delimited part of targetspec already has required chars encoded
set pp 0 ;#pathpart index
set targetpath_parts [list]
foreach pathpart $targetsegment {
set targettest [tcl::string::map $encode_map $pathpart]
if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} {
set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)"
append err [Segment_mustencode_check $pathpart]
append err $err_extra
error $err
}
#2 rounds of substitution is possibly asking for trouble..
#We allow anything in the resultant segments anyway (as %UXXXX... allows all)
#so it's not so much about what can be encoded,
# - but it makes it harder to reason about for users
# In particular - if we map %XX first it makes %25 -> % substitution tricky
# if the user requires a literal %UXXX - they can't do %25UXXX
# the double sub would make it %UXXX -> somechar anyway.
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere.
#There is still the opportunity to use things like %U00000025 followed by hex-chars
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW
set pathpart [decode_unicode_escapes $pathpart]
set pathpart [tcl::string::map $decode_map $pathpart]
lappend targetpath_parts $pathpart
incr pp
}
set targetpath [join $targetpath_parts /]
if {$name eq ""} {
set name [lindex $targetpath_parts end]
}
#we do the same encoding checks on tags and comments to increase chances of portability
set tags [list]
set comments [list]
switch -- [llength $segments] {
2 {
#no tags or comments
}
3 {
#only 3 sections - last is comment - even if looks like tags
#to make the 3rd part a tagset, an extra # would be needed
set comments [list [lindex $segments 2]]
}
default {
set tagset [lindex $segments 2]
if {$tagset eq ""} {
#ok - no tags
} else {
if {[string first @ $tagset] != 0} {
set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment"
append err \n " - must begin with @"
append err $err_extra
error $err
} else {
set tagset [string range $tagset 1 end]
set rawtags [split $tagset @]
set tags [list]
foreach t $rawtags {
if {$t eq ""} {
lappend tags ""
} else {
set tagtest [tcl::string::map $encode_map $t]
if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} {
set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]"
append err [Segment_mustencode_check $t]
append err $err_extra
error $err
}
lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]]
}
}
}
}
set rawcomments [lrange $segments 3 end]
#set comments [lsearch -all -inline -not $comments ""]
set comments [list]
foreach c $rawcomments {
if {$c eq ""} {continue}
set commenttest [tcl::string::map $encode_map $c]
if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} {
set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]"
append err [Segment_mustencode_check $c]
append err $err_extra
error $err
}
lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]]
}
}
}
set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name]
if {$is_fauxlink} {
#standard .fxlnk or .fauxlink
return $data
} else {
#custom extension - or called in error on wrong type of file but happened to parse.
#see comments at top regarding is_fauxlink
#make sure no keys in common at top level.
return [dict create\
linktype $extension_name\
note "nonstandard extension returning nonstandard dict with result in data key"\
data $data\
]
}
}
variable map
#default exclusion of / (%U2f and equivs)
#this would allow obfuscation of intention - when we have + for that anyway
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} {
variable map
set ucstart [string first %U $str 0]
if {$ucstart < 0} {
return $str
}
set max 8
set map [list]
set strend [expr {[string length $str]-1}]
while {$ucstart >= 0} {
set s $ucstart
set i [expr {$s +2}] ;#skip the %U
set hex ""
while {[tcl::string::length $hex] < 8 && $i <= $strend} {
set in [string index $str $i]
if {[tcl::string::is xdigit -strict $in]} {
append hex $in
} else {
break
}
incr i
}
if {$hex ne ""} {
incr i -1
lappend map $s $i $hex
}
set ucstart [tcl::string::first %U $str $i]
}
set out ""
set lastidx -1
set e 0
foreach {s e hex} $map {
append out [string range $str $lastidx+1 $s-1]
set sub [format %c 0x$hex]
if {$sub in $exclusions} {
append out %U$hex ;#put it back
} else {
append out $sub
}
set lastidx $e
}
if {$e < [tcl::string::length $str]-1} {
append out [string range $str $e+1 end]
}
return $out
}
proc link_as {name target} {
}
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace fauxlink ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink::lib {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace fauxlink::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace fauxlink::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval fauxlink::system {
#*** !doctools
#[subsection {Namespace fauxlink::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide fauxlink [namespace eval fauxlink {
variable pkg fauxlink
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

21
src/bootsupport/modules/fauxlink-0.1.1.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin fauxlink_module_fauxlink 0 0.1.1]
#[copyright "2024"]
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}]
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}]
#[moddesc {.fauxlink .fxlnk}] [comment {-- Description at end of page heading --}]
#[require fauxlink]
#[keywords symlink faux fake shortcut toml]
#[description]
@ -29,18 +29,19 @@
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as
#[para] archiving and packaging systems.
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable.
#[para] format of name <nominalname>#<encodedtarget>.fxlnk
#[para] format of name <nominalname>#<encodedtarget>.fauxlink
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget>
#[para] The file extension must be .fauxlink or .fxlnk
#[para] The + symbol substitutes for forward-slashes.
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !)
#[para] We deliberately treat higher % sequences literally.
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [lb]heart[rb]) can remain literal for linking to urls.
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23
#[para] e.g a link to a file file#A.txt in parent dir could be:
#[para] file%23A.txt#..+file%23A.txt.fxlnk
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk
#[para] file%23A.txt#..+file%23A.txt.fauxlink
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fauxlink
#[para] The <nominalname> can be unrelated to the actual target
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk
#[para] e.g datafile.dat#..+file%23A.txt.fauxlink
#[para] This system has no filesystem support - and must be completely application driven.
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform.
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined
@ -63,9 +64,9 @@
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it.
#Using fauxlink - a link would be:
# "my-program-files#++server+c+Program%20Files.fxlnk"
# "my-program-files#++server+c+Program%20Files.fauxlink"
#If we needed the old-style literal %20 it would become
# "my-program-files#++server+c+Program%2520Files.fxlnk"
# "my-program-files#++server+c+Program%2520Files.fauxlink"
#
# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser)
# e.g
@ -296,12 +297,12 @@ namespace eval fauxlink {
set is_fauxlink 0
#we'll process anyway - but return the result wrapped
#This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent
#(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens
#(e.g blindly processing all files in a folder that is normally only .fauxlink files - but then something added that happens
# to have # characters in it)
#It also means if someone really wants to use the fauxlink semantics on a different file type
# - they can - but just have to access the results differently and take that (minor) risk.
#error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink"
set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate"
set err_extra "\nnonstandard extension '$extension_name' for fauxlink. (expected .fxlnk or .fauxlink) Check that the call to fauxlink::resolve was deliberate"
} else {
set is_fauxlink 1
set err_extra ""
@ -318,7 +319,7 @@ namespace eval fauxlink {
#if there are 4 parts - the 3rd part is a tagset where each tag begins with @
#and each subsequent part is a comment. Empty comments are stripped from the comments list
#A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @
#e.g name.txt#path#@tag1@tag2#test###.fxlnk
#e.g name.txt#path#@tag1@tag2#test###.fauxlink
#has a name, a target, 2 tags and one comment
#check namespec already has required chars encoded

12822
src/bootsupport/modules/metaface-1.2.5.tm
View File

File diff suppressed because it is too large Load Diff

705
src/bootsupport/modules/modpod-0.1.0.tm
Unescape View File

@ -1,705 +0,0 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application modpod 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin modpod_module_modpod 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require modpod]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of modpod
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by modpod
#[list_begin itemized]
package require Tcl 8.6-
package require struct::set ;#review
package require punk::lib
package require punk::args
#*** !doctools
#[item] [package {Tcl 8.6-}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::class {
#*** !doctools
#[subsection {Namespace modpod::class}]
#[para] class definitions
if {[info commands [namespace current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod {
namespace export {[a-z]*}; # Convention: export all lowercase
variable connected
if {![info exists connected(to)]} {
set connected(to) list
}
variable modpodscript
set modpodscript [info script]
if {[string tolower [file extension $modpodscript]] eq ".tcl"} {
set connected(self) [file dirname $modpodscript]
} else {
#expecting a .tm
set connected(self) $modpodscript
}
variable loadables [info sharedlibextension]
variable sourceables {.tcl .tk} ;# .tm ?
#*** !doctools
#[subsection {Namespace modpod}]
#[para] Core API functions for modpod
#[list_begin definitions]
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
-type -default ""
*values -min 1 -max 1
path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
}
set opt_path [dict get $argd values path]
variable connected
set original_connectpath $opt_path
set modpodpath [modpod::system::normalize $opt_path] ;#
if {$modpodpath in $connected(to)} {
return [dict create ok ALREADY_CONNECTED]
}
lappend connected(to) $modpodpath
set connected(connectpath,$opt_path) $original_connectpath
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}]
set connected(location,$modpodpath) [file dirname $modpodpath]
set connected(startdata,$modpodpath) -1
set connected(type,$modpodpath) [dict get $argd-opts -type]
set connected(fh,$modpodpath) ""
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} {
set connected(type,$modpodpath) "unwrapped"
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]]
} else {
#connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)]
if {[file exists $unwrappedFolder]} {
#folder with exact version-match must exist for redirect to 'unwrapped'
set con(type,$modpodpath) "modpod-redirecting"
}
}
}
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm"
set connected(tmfile,$modpodpath)
set tail_segments [list]
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end]
break
}
}
if {[llength $tail_segments]} {
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require
} else {
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)]
}
switch -exact -- $connected(type,$modpodpath) {
"modpod-redirecting" {
#redirect to the unwrapped version
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl]
}
"unwrapped" {
if {[info commands ::thread::id] ne ""} {
set from [pid],[thread::id]
} else {
set from [pid]
}
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath"
return [list ok ""]
}
default {
#autodetect .tm - zip/tar ?
#todo - use vfs ?
#connect to tarball - start at 1st header
set connected(startdata,$modpodpath) 0
set fh [open $modpodpath r]
set connected(fh,$modpodpath) $fh
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {}
if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh]
} else {
#error "cannot verify tar header"
}
}
lpop connected(to) end
set connected(startdata,$modpodpath) -1
unset connected(fh,$modpodpath)
catch {close $fh}
return [dict create err {Does not appear to be a valid modpod}]
}
}
}
proc disconnect {{modpod ""}} {
variable connected
if {![llength $connected(to)]} {
return 0
}
if {$modpod eq ""} {
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]"
set modpod [lindex $connected(to) end]
}
if {[set posn [lsearch $connected(to) $modpod]] == -1} {
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod"
return 0
}
if {[string length $connected(fh,$modpod)]} {
close $connected(fh,$modpod)
}
array unset connected *,$modpod
set connected(to) [lreplace $connected(to) $posn $posn]
return 1
}
proc get {args} {
set argd [punk::args::get_dict {
-from -default "" -help "path to pod"
*values -min 1 -max 1
filename
} $args]
set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename]
variable connected
set modpod [::tarjar::system::connect_if_not $frompod]
set fh $connected(fh,$modpod)
if {$connected(type,$modpod) eq "unwrapped"} {
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder
if {[string range $filename 0 0 eq "/"]} {
#absolute path (?)
set path [file join $connected(location,$modpod) .. [string trim $filename /]]
} else {
#relative path - use #modpod-xxx as base
set path [file join $connected(location,$modpod) $filename]
}
set fd [open $path r]
#utf-8?
#fconfigure $fd -encoding iso8859-1 -translation binary
return [list ok [lindex [list [read $fd] [close $fd]] 0]]
} else {
#read from vfs
puts stderr "get $filename from wrapped pod '$frompod' not implemented"
}
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::lib {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace modpod::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
proc is_valid_tm_version {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionparts $versionparts]]} {
return 1
} else {
return 0
}
}
proc make_zip_modpod {zipfile outfile} {
set mount_stub {
#zip file with Tcl loader prepended.
#generated using modpod::make_zip_modpod
if {[catch {file normalize [info script]} modfile]} {
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)"
}
if {$modfile eq "" || ![file exists $modfile]} {
error "modpod zip stub error. Unable to determine module path"
}
set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#determine module namespace so we can mount appropriately
proc intersect {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
if {[llength $B] > [llength $A]} {
set res $A
set A $B
set B $res
}
set res {}
foreach x $A {set ($x) {}}
foreach x $B {
if {[info exists ($x)]} {
lappend res $x
}
}
return $res
}
set lcase_tmfile_segments [string tolower [file split $moddir]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail
break
}
}
if {[llength $tail_segments]} {
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver
} else {
set fullpackage $moduletail
set mount_at #modpod/#mounted-modpod-$mod_and_ver
}
if {[info commands tcl::zipfs::mount] ne ""} {
#argument order changed to be consistent with vfs::zip::Mount etc
#early versions: zipfs::Mount mountpoint zipname
#since 2023-09: zipfs::Mount zipname mountpoint
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance)
#This is presumably related to // being interpreted as a network path
set mountpoints [dict keys [tcl::zipfs::mount]]
if {"//zipfs:/$mount_at" ni $mountpoints} {
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it
if {[catch {
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?)
#puts "tcl::zipfs::mount $modfile $mount_at"
tcl::zipfs::mount $modfile $mount_at
} errM]} {
#try old api
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} {
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile"
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API"
}
}
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]"
#tcl::zipfs::unmount //zipfs:/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#fallback to slower vfs::zip
#NB. We don't create the intermediate dirs - but the mount still works
if {![file exists $moddir/$mount_at]} {
if {[catch {package require vfs::zip} errM]} {
set msg "Unable to load vfs::zip package to mount module $mod_and_ver"
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place."
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile"
error $msg
} else {
set fd [vfs::zip::Mount $modfile $moddir/$mount_at]
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
vfs::zip::Unmount $fd $moddir/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
}
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
}
}
#zipped data follows
}
#todo - test if zipfile has #modpod-loadcript.tcl before even creating
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
proc make_zip_modpod1 {zipfile outfile} {
set mount_stub {
#zip file with Tcl loader prepended.
#generated using modpod::make_zip_modpod
if {[catch {file normalize [info script]} modfile]} {
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)"
}
if {$modfile eq "" || ![file exists $modfile]} {
error "modpod zip stub error. Unable to determine module path"
}
set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} {
if {[catch {package require vfs::zip} errM]} {
set msg "Unable to load vfs::zip package to mount module $mod_and_ver"
append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place."
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $
}
set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver]
if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver
error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile"
}
}
source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm
}
#zipped data follows
}
#todo - test if zipfile has #modpod-loadcript.tcl before even creating
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
proc make_zip_source_mountable {zipfile outfile} {
set mount_stub {
package require vfs::zip
vfs::zip::Mount [info script] [info script]
}
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval modpod::system {
#*** !doctools
#[subsection {Namespace modpod::system}]
#[para] Internal functions that are not part of the API
#deflate,store only supported
proc make_mountable_zip {zipfile outfile mount_stub} {
set in [open $zipfile r]
fconfigure $in -encoding iso8859-1 -translation binary
set out [open $outfile w+]
fconfigure $out -encoding iso8859-1 -translation binary
puts -nonewline $out $mount_stub
set offset [tell $out]
lappend report "sfx stub size: $offset"
fcopy $in $out
close $in
set size [tell $out]
#Now seek in $out to find the end of directory signature:
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text
if {$size < 65559} {
set seek 0
} else {
set seek [expr {$size - 65559}]
}
seek $out $seek
set data [read $out]
set start_of_end [string last "\x50\x4b\x05\x06" $data]
#set start_of_end [expr {$start_of_end + $seek}]
incr start_of_end $seek
lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]"
seek $out $start_of_end
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
lappend report "End of central directory: [array get eocd]"
seek $out [expr {$start_of_end+16}]
#adjust offset of start of central directory by the length of our sfx stub
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]]
flush $out
seek $out $start_of_end
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
# 0x06054b50 - end of central dir signature
puts stderr "$end_of_ctrl_dir"
puts stderr "comment_len: $eocd(comment_len)"
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]"
lappend report "New dir offset: $eocd(diroffset)"
lappend report "Adjusting $eocd(totalnum) zip file items."
catch {
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies
}
seek $out $eocd(diroffset)
for {set i 0} {$i <$eocd(totalnum)} {incr i} {
set current_file [tell $out]
set fileheader [read $out 46]
puts --------------
puts [ansistring VIEW -lf 1 $fileheader]
puts --------------
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
set ::last_header $fileheader
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])"
puts "ver: $x(version)"
puts "method: $x(method)"
#33639248 dec = 0x02014b50 - central file header signature
if { $x(sig) != 33639248 } {
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]"
}
foreach size $x(lengths) var {filename extrafield comment} {
if { $size > 0 } {
set x($var) [read $out $size]
} else {
set x($var) ""
}
}
set next_file [tell $out]
lappend report "file $i: $x(offset) $x(sizes) $x(filename)"
seek $out [expr {$current_file+42}]
puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]]
#verify:
flush $out
seek $out $current_file
set fileheader [read $out 46]
lappend report "old $x(offset) + $offset"
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
lappend report "new $x(offset)"
seek $out $next_file
}
close $out
#pdict/showdict reuire punk & textlib - ie lots of dependencies
#don't fall over just because of that
catch {
punk::lib::showdict -roottype list -chan stderr $report
}
#puts [join $report \n]
return
}
proc connect_if_not {{podpath ""}} {
upvar ::modpod::connected connected
set podpath [::modpod::system::normalize $podpath]
set docon 0
if {![llength $connected(to)]} {
if {![string length $podpath]} {
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified"
} else {
set docon 1
}
} else {
if {![string length $podpath]} {
set podpath [lindex $connected(to) end]
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]"
} else {
if {$podpath ni $connected(to)} {
set docon 1
}
}
}
if {$docon} {
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} {
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod"
} else {
return $podpath
}
}
#we were already connected
return $podpath
}
proc myversion {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod"
}
set fname [file tail [file rootname [file normalize $script]]]
set scriptdir [file dirname $script]
if {![string match "#modpod-*" $fname]} {
lassign [lrange [split $fname -] end-1 end] _pkgname version
} else {
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version
if {![string length $version]} {
#try again on the name of the containing folder
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version
#todo - proper walk up the directory tree
if {![string length $version]} {
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod)
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version
}
}
}
#tarjar::Log debug "'myversion' determined version for [info script]: $version"
return $version
}
proc myname {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod"
}
return $connected(fullpackage,$script)
}
proc myfullname {} {
upvar ::modpod::connected connected
set script [info script]
#set script [::tarjar::normalize $script]
set script [file normalize $script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar"
}
return $::tarjar::connected(fullpackage,$script)
}
proc normalize {path} {
#newer versions of Tcl don't do tilde sub
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths)
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function.
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes..
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after
set path [file normalize $path]
#set path [string tolower $path] ;#must do this after file normalize
return [string map [list $matilda ~] $path] ;#get our tildes back.
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide modpod [namespace eval modpod {
variable pkg modpod
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

697
src/bootsupport/modules/modpod-0.1.1.tm
Unescape View File

@ -1,697 +0,0 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2024
#
# @@ Meta Begin
# Application modpod 0.1.1
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin modpod_module_modpod 0 0.1.1]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require modpod]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of modpod
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by modpod
#[list_begin itemized]
package require Tcl 8.6-
package require struct::set ;#review
package require punk::lib
package require punk::args
#*** !doctools
#[item] [package {Tcl 8.6-}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::class {
#*** !doctools
#[subsection {Namespace modpod::class}]
#[para] class definitions
if {[info commands [namespace current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod {
namespace export {[a-z]*}; # Convention: export all lowercase
variable connected
if {![info exists connected(to)]} {
set connected(to) list
}
variable modpodscript
set modpodscript [info script]
if {[string tolower [file extension $modpodscript]] eq ".tcl"} {
set connected(self) [file dirname $modpodscript]
} else {
#expecting a .tm
set connected(self) $modpodscript
}
variable loadables [info sharedlibextension]
variable sourceables {.tcl .tk} ;# .tm ?
#*** !doctools
#[subsection {Namespace modpod}]
#[para] Core API functions for modpod
#[list_begin definitions]
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
#old tar connect mechanism - review - not needed?
proc connect {args} {
puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict {
-type -default ""
*values -min 1 -max 1
path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args]
catch {
punk::lib::showdict $argd ;#heavy dependencies
}
set opt_path [dict get $argd values path]
variable connected
set original_connectpath $opt_path
set modpodpath [modpod::system::normalize $opt_path] ;#
if {$modpodpath in $connected(to)} {
return [dict create ok ALREADY_CONNECTED]
}
lappend connected(to) $modpodpath
set connected(connectpath,$opt_path) $original_connectpath
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}]
set connected(location,$modpodpath) [file dirname $modpodpath]
set connected(startdata,$modpodpath) -1
set connected(type,$modpodpath) [dict get $argd opts -type]
set connected(fh,$modpodpath) ""
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} {
set connected(type,$modpodpath) "unwrapped"
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]]
} else {
#connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)]
if {[file exists $unwrappedFolder]} {
#folder with exact version-match must exist for redirect to 'unwrapped'
set con(type,$modpodpath) "modpod-redirecting"
}
}
}
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm"
set connected(tmfile,$modpodpath)
set tail_segments [list]
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end]
break
}
}
if {[llength $tail_segments]} {
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require
} else {
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)]
}
switch -exact -- $connected(type,$modpodpath) {
"modpod-redirecting" {
#redirect to the unwrapped version
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl]
}
"unwrapped" {
if {[info commands ::thread::id] ne ""} {
set from [pid],[thread::id]
} else {
set from [pid]
}
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath"
return [list ok ""]
}
default {
#autodetect .tm - zip/tar ?
#todo - use vfs ?
#connect to tarball - start at 1st header
set connected(startdata,$modpodpath) 0
set fh [open $modpodpath r]
set connected(fh,$modpodpath) $fh
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {}
if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh]
} else {
#error "cannot verify tar header"
}
}
lpop connected(to) end
set connected(startdata,$modpodpath) -1
unset connected(fh,$modpodpath)
catch {close $fh}
return [dict create err {Does not appear to be a valid modpod}]
}
}
}
proc disconnect {{modpod ""}} {
variable connected
if {![llength $connected(to)]} {
return 0
}
if {$modpod eq ""} {
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]"
set modpod [lindex $connected(to) end]
}
if {[set posn [lsearch $connected(to) $modpod]] == -1} {
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod"
return 0
}
if {[string length $connected(fh,$modpod)]} {
close $connected(fh,$modpod)
}
array unset connected *,$modpod
set connected(to) [lreplace $connected(to) $posn $posn]
return 1
}
proc get {args} {
set argd [punk::args::get_dict {
-from -default "" -help "path to pod"
*values -min 1 -max 1
filename
} $args]
set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename]
variable connected
#//review
set modpod [::modpod::system::connect_if_not $frompod]
set fh $connected(fh,$modpod)
if {$connected(type,$modpod) eq "unwrapped"} {
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder
if {[string range $filename 0 0 eq "/"]} {
#absolute path (?)
set path [file join $connected(location,$modpod) .. [string trim $filename /]]
} else {
#relative path - use #modpod-xxx as base
set path [file join $connected(location,$modpod) $filename]
}
set fd [open $path r]
#utf-8?
#fconfigure $fd -encoding iso8859-1 -translation binary
return [list ok [lindex [list [read $fd] [close $fd]] 0]]
} else {
#read from vfs
puts stderr "get $filename from wrapped pod '$frompod' not implemented"
}
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval modpod::lib {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace modpod::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
proc is_valid_tm_version {versionpart} {
#Needs to be suitable for use with Tcl's 'package vcompare'
if {![catch [list package vcompare $versionparts $versionparts]]} {
return 1
} else {
return 0
}
}
#zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} {
set argd [punk::args::get_dict {
-offsettype -default "file" -choices {archive file} -help "Whether zip offsets are relative to start of file or start of zip-data within the file.
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip,
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip)
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative.
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'"
*values -min 2 -max 2
zipfile -type path -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
outfile -type path -minlen 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args]
set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile]
set opt_offsettype [dict get $argd opts -offsettype]
set mount_stub [string map [list %offsettype% $opt_offsettype] {
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped.
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file.
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile>
if {[catch {file normalize [info script]} modfile]} {
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)"
}
if {$modfile eq "" || ![file exists $modfile]} {
error "modpod zip stub error. Unable to determine module path"
}
set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#determine module namespace so we can mount appropriately
proc intersect {A B} {
if {[llength $A] == 0} {return {}}
if {[llength $B] == 0} {return {}}
if {[llength $B] > [llength $A]} {
set res $A
set A $B
set B $res
}
set res {}
foreach x $A {set ($x) {}}
foreach x $B {
if {[info exists ($x)]} {
lappend res $x
}
}
return $res
}
set lcase_tmfile_segments [string tolower [file split $moddir]]
set lcase_modulepaths [string tolower [tcl::tm::list]]
foreach lc_mpath $lcase_modulepaths {
set mpath_segments [file split $lc_mpath]
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} {
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail
break
}
}
if {[llength $tail_segments]} {
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver
} else {
set fullpackage $moduletail
set mount_at #modpod/#mounted-modpod-$mod_and_ver
}
if {[info commands tcl::zipfs::mount] ne ""} {
#argument order changed to be consistent with vfs::zip::Mount etc
#early versions: zipfs::Mount mountpoint zipname
#since 2023-09: zipfs::Mount zipname mountpoint
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance)
#This is presumably related to // being interpreted as a network path
set mountpoints [dict keys [tcl::zipfs::mount]]
if {"//zipfs:/$mount_at" ni $mountpoints} {
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it
if {[catch {
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?)
#puts "tcl::zipfs::mount $modfile $mount_at"
tcl::zipfs::mount $modfile $mount_at
} errM]} {
#try old api
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} {
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile"
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API"
}
}
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]"
#tcl::zipfs::unmount //zipfs:/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
} else {
#fallback to slower vfs::zip
#NB. We don't create the intermediate dirs - but the mount still works
if {![file exists $moddir/$mount_at]} {
if {[catch {package require vfs::zip} errM]} {
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)"
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place."
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile"
error $msg
} else {
set fd [vfs::zip::Mount $modfile $moddir/$mount_at]
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} {
vfs::zip::Unmount $fd $moddir/$mount_at
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage"
}
}
}
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm
}
}
#zipped data follows
}]
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating?
append mount_stub \x1A
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace modpod::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval modpod::system {
#*** !doctools
#[subsection {Namespace modpod::system}]
#[para] Internal functions that are not part of the API
#deflate,store only supported
#zipfile here is plain zip - no script/exe prefix part.
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "file"}} {
set inzip [open $zipfile r]
fconfigure $inzip -encoding iso8859-1 -translation binary
set out [open $outfile w+]
fconfigure $out -encoding iso8859-1 -translation binary
puts -nonewline $out $mount_stub
set stuboffset [tell $out]
lappend report "sfx stub size: $stuboffset"
fcopy $inzip $out
close $inzip
set size [tell $out]
lappend report "tmfile : [file tail $outfile]"
lappend report "output size : $size"
lappend report "offsettype : $offsettype"
if {$offsettype eq "file"} {
#make zip offsets relative to start of whole file including prepended script.
#(same offset structure as Tcl's 'zipfs mkimg' as at 2024-10)
#we aren't adding any new files/folders so we can edit the offsets in place
#Now seek in $out to find the end of directory signature:
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text
if {$size < 65559} {
set tailsearch_start 0
} else {
set tailsearch_start [expr {$size - 65559}]
}
seek $out $tailsearch_start
set data [read $out]
#EOCD - End of Central Directory record
#PK\5\6
set start_of_end [string last "\x50\x4b\x05\x06" $data]
#set start_of_end [expr {$start_of_end + $seek}]
#incr start_of_end $seek
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}]
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn"
seek $out $filerelative_eocd_posn
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
lappend report "End of central directory: [array get eocd]"
seek $out [expr {$filerelative_eocd_posn+16}]
#adjust offset of start of central directory by the length of our sfx stub
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]]
flush $out
seek $out $filerelative_eocd_posn
set end_of_ctrl_dir [read $out]
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len)
# 0x06054b50 - end of central dir signature
puts stderr "$end_of_ctrl_dir"
puts stderr "comment_len: $eocd(comment_len)"
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]"
lappend report "New dir offset: $eocd(diroffset)"
lappend report "Adjusting $eocd(totalnum) zip file items."
catch {
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies
}
seek $out $eocd(diroffset)
for {set i 0} {$i <$eocd(totalnum)} {incr i} {
set current_file [tell $out]
set fileheader [read $out 46]
puts --------------
puts [ansistring VIEW -lf 1 $fileheader]
puts --------------
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
set ::last_header $fileheader
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])"
puts "ver: $x(version)"
puts "method: $x(method)"
#PK\1\2
#33639248 dec = 0x02014b50 - central directory file header signature
if { $x(sig) != 33639248 } {
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]"
}
foreach size $x(lengths) var {filename extrafield comment} {
if { $size > 0 } {
set x($var) [read $out $size]
} else {
set x($var) ""
}
}
set next_file [tell $out]
lappend report "file $i: $x(offset) $x(sizes) $x(filename)"
seek $out [expr {$current_file+42}]
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]]
#verify:
flush $out
seek $out $current_file
set fileheader [read $out 46]
lappend report "old $x(offset) + $stuboffset"
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset)
lappend report "new $x(offset)"
seek $out $next_file
}
}
close $out
#pdict/showdict reuire punk & textlib - ie lots of dependencies
#don't fall over just because of that
catch {
punk::lib::showdict -roottype list -chan stderr $report
}
#puts [join $report \n]
return
}
proc connect_if_not {{podpath ""}} {
upvar ::modpod::connected connected
set podpath [::modpod::system::normalize $podpath]
set docon 0
if {![llength $connected(to)]} {
if {![string length $podpath]} {
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified"
} else {
set docon 1
}
} else {
if {![string length $podpath]} {
set podpath [lindex $connected(to) end]
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]"
} else {
if {$podpath ni $connected(to)} {
set docon 1
}
}
}
if {$docon} {
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} {
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod"
} else {
return $podpath
}
}
#we were already connected
return $podpath
}
proc myversion {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod"
}
set fname [file tail [file rootname [file normalize $script]]]
set scriptdir [file dirname $script]
if {![string match "#modpod-*" $fname]} {
lassign [lrange [split $fname -] end-1 end] _pkgname version
} else {
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version
if {![string length $version]} {
#try again on the name of the containing folder
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version
#todo - proper walk up the directory tree
if {![string length $version]} {
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod)
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version
}
}
}
#tarjar::Log debug "'myversion' determined version for [info script]: $version"
return $version
}
proc myname {} {
upvar ::modpod::connected connected
set script [info script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod"
}
return $connected(fullpackage,$script)
}
proc myfullname {} {
upvar ::modpod::connected connected
set script [info script]
#set script [::tarjar::normalize $script]
set script [file normalize $script]
if {![string length $script]} {
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar"
}
return $::tarjar::connected(fullpackage,$script)
}
proc normalize {path} {
#newer versions of Tcl don't do tilde sub
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths)
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function.
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes..
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after
set path [file normalize $path]
#set path [string tolower $path] ;#must do this after file normalize
return [string map [list $matilda ~] $path] ;#get our tildes back.
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide modpod [namespace eval modpod {
variable pkg modpod
variable version
set version 0.1.1
}]
return
#*** !doctools
#[manpage_end]

1894
src/bootsupport/modules/natsort-0.1.1.5.tm
View File

File diff suppressed because it is too large Load Diff

1288
src/bootsupport/modules/patterncmd-1.2.4.tm
View File

File diff suppressed because it is too large Load Diff

1508
src/bootsupport/modules/patternpredator2-1.2.4.tm
View File

File diff suppressed because it is too large Load Diff

3
src/bootsupport/modules/punk/ansi-0.1.1.tm
Unescape View File

@ -2469,7 +2469,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
if {$pretty} {
#return [pdict -channel none sgr_cache */%str,%ansiview]
return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle]
return [punk::lib::pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle]
}
if {[catch {
@ -5116,6 +5116,7 @@ tcl::namespace::eval punk::ansi::ta {
# arrow keys -> ESC O A, ESC O B, ESC O C, ESC O D
# plus more for auxiliary keypad codes in keypad application mode (and some in numeric mode)
#regexp expanded syntax = ?x
variable re_ansi_detect {(?x)
(?:\x1b(?:\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|c|7|8|M|D|E|H|=|>|<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.))|\((?:0|B)|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|(?:\#(?:3|4|5|6|8))))
|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)

65
src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
Unescape View File

@ -108,8 +108,10 @@ namespace eval punk::cap::handlers::templates {
#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]
#set projectinfo [punk::repo::find_repos $tmfolder] ;#slow - REVIEW
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $tmfolder]
#store the projectbase even if it's empty string
set extended_capdict $capdict
set resolved_path [file join $tmfolder $path]
@ -148,8 +150,9 @@ namespace eval punk::cap::handlers::templates {
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 projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
@ -166,8 +169,9 @@ namespace eval punk::cap::handlers::templates {
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 projectinfo [punk::repo::find_repos $shellbase]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $shellbase]
set extended_capdict $capdict
dict set extended_capdict vendor $vendor
@ -183,8 +187,9 @@ namespace eval punk::cap::handlers::templates {
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]
#set projectinfo [punk::repo::find_repos $normpath]
#set projectbase [dict get $projectinfo closest]
set projectbase [punk::repo::find_project $normpath]
#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
@ -244,6 +249,18 @@ namespace eval punk::cap::handlers::templates {
# -- --- --- --- --- --- ---
namespace export *
namespace eval class {
variable PUNKARGS
#set argd [punk::args::get_dict {
# @id -id "::punk::cap::handlers::templates::class::api folders"
# -startdir -default ""
# @values -max 0
#} $args]
lappend PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
}]
oo::class create api {
#return a dict keyed on folder with source pkg as value
constructor {capname} {
@ -253,11 +270,8 @@ namespace eval punk::cap::handlers::templates {
set capabilityname $capname
}
method folders {args} {
set argd [punk::args::get_dict {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
} $args]
#puts "--folders $args"
set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"]
set opts [dict get $argd opts]
set opt_startdir [dict get $opts -startdir]
@ -270,6 +284,10 @@ namespace eval punk::cap::handlers::templates {
set startdir $opt_startdir
}
}
set searchbase $startdir
#set pathinfo [punk::repo::find_repos $searchbase] ;#relatively slow! REVIEW - pass as arg? cache?
#set pwd_projectroot [dict get $pathinfo closest]
set pwd_projectroot [punk::repo::find_project $searchbase]
variable capabilityname
@ -314,9 +332,9 @@ namespace eval punk::cap::handlers::templates {
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]
#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]} {
@ -349,9 +367,9 @@ namespace eval punk::cap::handlers::templates {
}
}
} elseif {$pathtype eq "currentproject"} {
set searchbase $startdir
set pathinfo [punk::repo::find_repos $searchbase]
set pwd_projectroot [dict get $pathinfo closest]
#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]
@ -489,8 +507,9 @@ namespace eval punk::cap::handlers::templates {
set refdict [my get_itemdict_projectlayoutrefs {*}$args]
set layoutdict [dict create]
set projectinfo [punk::repo::find_repos $searchbase]
set projectroot [dict get $projectinfo closest]
#set projectinfo [punk::repo::find_repos $searchbase]
#set projectroot [dict get $projectinfo closest]
set projectroot [punk::repo::find_project $searchbase]
dict for {layoutname refinfo} $refdict {
set templatepathtype [dict get $refinfo sourceinfo pathtype]
@ -760,6 +779,10 @@ namespace eval punk::cap::handlers::templates {
}
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::cap::handlers::templates ::punk::cap::handlers::templates::class
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready

972
src/bootsupport/modules/punk/config-0.1.tm
Unescape View File

@ -1,487 +1,487 @@
tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable punk_env_vars
variable other_env_vars
variable vars
namespace export {[a-z]*}
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
proc init {} {
variable defaults
variable startup
variable running
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs] ;#~2ms
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
auto_exec_mechanism exec\
auto_noexec 0\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean)
set punk_env_vars_config [dict create \
PUNK_APPS {type pathlist}\
PUNK_CONFIG {type string}\
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\
PUNK_SYSLOG_STDOUT {type string}\
PUNK_SYSLOG_STDERR {type string}\
PUNK_SYSLOG_ACTIVE {type string}\
PUNK_THEME_POSH_OVERRIDE {type string}\
]
set punk_env_vars [dict keys $punk_env_vars_config]
#override with env vars if set
foreach {evar varinfo} $punk_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
if {$vartype eq "pathlist"} {
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief.
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately.
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched.
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting
# - but some programs have been known to split this value on colon anyway, which breaks things on windows.
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set other_env_vars_config [dict create\
NO_COLOR {type string}\
XDG_CONFIG_HOME {type string}\
XDG_DATA_HOME {type string}\
XDG_CACHE_HOME {type string}\
XDG_STATE_HOME {type string}\
XDG_DATA_DIRS {type pathlist}\
POSH_THEME {type string}\
POSH_THEMES_PATH {type string}\
TCLLIBPATH {type string}\
]
lassign [split [info tclversion] .] tclmajorv tclminorv
#don't rely on lseq or punk::lib for now..
set relevant_minors [list]
for {set i 0} {$i <= $tclminorv} {incr i} {
lappend relevant_minors $i
}
foreach minor $relevant_minors {
set vname TCL${tclmajorv}_${minor}_TM_PATH
if {$minor eq $tclminorv || [info exists ::env($vname)]} {
dict set other_env_vars_config $vname {type string}
}
}
set other_env_vars [dict keys $other_env_vars_config]
foreach {evar varinfo} $other_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
if {$vartype eq "pathlist"} {
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
#unset -nocomplain vars
#todo
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo
proc Apply {config} {
puts stderr "punk::config::Apply partially implemented"
set configname [string map {-config ""} $config]
if {$configname in {startup running}} {
upvar ::punk::config::$configname applyconfig
if {[dict exists $applyconfig auto_noexec]} {
set auto [dict get $applyconfig auto_noexec]
if {![string is boolean -strict $auto]} {
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean"
}
if {$auto} {
set ::auto_noexec 1
} else {
#puts "auto_noexec false"
unset -nocomplain ::auto_noexec
}
}
} else {
error "no config named '$config' found"
}
return "apply done"
}
Apply startup
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig {globfor *}} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
set configdata $startup
}
running - running-config - running-configuration {
set configdata $running
}
default {
error "Unknown config name '$whichconfig' - try startup or running"
}
}
if {$globfor eq "*"} {
return $configdata
} else {
set keys [dict keys $configdata [string tolower $globfor]]
set filtered [dict create]
foreach k $keys {
dict set filtered $k [dict get $configdata $k]
}
return $filtered
}
}
proc configure {args} {
set argdef {
@id -id ::punk::config::configure
@cmd -name punk::config::configure -help\
"UNIMPLEMENTED"
@values -min 1 -max 1
whichconfig -type string -choices {startup running stop}
}
set argd [punk::args::get_dict $argdef $args]
return "unimplemented - $argd"
}
proc show {whichconfig {globfor *}} {
#todo - tables for console
set configdata [punk::config::get $whichconfig $globfor]
return [punk::lib::showdict $configdata]
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration
proc copy {args} {
set argdef {
@id -id ::punk::config::copy
@cmd -name punk::config::copy -help\
"Copy a partial or full configuration from one config to another
If a target config has additional settings, then the source config can be considered to be partial with regards to the target.
"
-type -default "" -choices {replace merge} -help\
"Defaults to merge when target is running-config
Defaults to replace when source is running-config"
@values -min 2 -max 2
fromconfig -help\
"running or startup or file name (not fully implemented)"
toconfig -help\
"running or startup or file name (not fully implemented)"
}
set argd [punk::args::get_dict $argdef $args]
set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig]
set toconfig [string map {-config ""} $toconfig]
set copytype [dict get $argd opts -type]
#todo - warn & prompt if doing merge copy to startup
switch -exact -- $fromconfig-$toconfig {
running-startup {
if {$copytype eq ""} {
set copytype replace ;#full configuration
}
if {$copytype eq "replace"} {
error "punk::config::copy error. full configuration copy from running to startup config not yet supported"
} else {
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported"
}
}
startup-running {
#default type merge - even though it's not always what is desired
if {$copytype eq ""} {
set copytype merge ;#load in a partial configuration
}
#warn/prompt either way
if {$copytype eq "replace"} {
#some routers require use of a separate command for this branch.
#presumably to ensure the user doesn't accidentally load partials onto a running system
#
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported"
} else {
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported"
}
}
default {
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported"
}
}
}
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {
variable version
set version 0.1
tcl::namespace::eval punk::config {
variable loaded
variable startup ;#include env overrides
variable running
variable punk_env_vars
variable other_env_vars
variable vars
namespace export {[a-z]*}
#todo - XDG_DATA_HOME etc
#https://specifications.freedesktop.org/basedir-spec/latest/
# see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/
proc init {} {
variable defaults
variable startup
variable running
variable punk_env_vars
variable punk_env_vars_config
variable other_env_vars
variable other_env_vars_config
set exename ""
catch {
#catch for safe interps
#safe base will return empty string, ordinary safe interp will raise error
set exename [tcl::info::nameofexecutable]
}
if {$exename ne ""} {
set exefolder [file dirname $exename]
#default file logs to logs folder at same level as exe if writable, or empty string
set log_folder [file normalize $exefolder/../logs] ;#~2ms
#tcl::dict::set startup scriptlib $exefolder/scriptlib
#tcl::dict::set startup apps $exefolder/../../punkapps
#todo - use punk main.tcl location instead - exefolder doesn't work if system tclsh used etc
set default_scriptlib $exefolder/scriptlib
set default_apps $exefolder/../../punkapps
if {[file isdirectory $log_folder] && [file writable $log_folder]} {
#tcl::dict::set startup logfile_stdout $log_folder/repl-exec-stdout.txt
#tcl::dict::set startup logfile_stderr $log_folder/repl-exec-stderr.txt
set default_logfile_stdout $log_folder/repl-exec-stdout.txt
set default_logfile_stderr $log_folder/repl-exec-stderr.txt
} else {
set default_logfile_stdout ""
set default_logfile_stderr ""
}
} else {
#probably a safe interp - which cannot access info nameofexecutable even if access given to the location via punk::island
#review - todo?
#tcl::dict::set startup scriptlib ""
#tcl::dict::set startup apps ""
set default_scriptlib ""
set default_apps ""
set default_logfile_stdout ""
set default_logfile_stderr ""
}
# auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run
#optional channel transforms on stdout/stderr.
#can sometimes be useful to distinguish eventloop stdout/stderr writes compared to those triggered directly from repl commands
#If no distinction necessary - should use default_color_<chan>
#The counterpart: default_color_<chan>_repl is a transform that is added and removed with each repl evaluation.
#startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default
set default_color_stdout brightwhite ;#stdout colour including background calls (after etc)
set default_color_stdout_repl "" ;#stdout colour applied during direct repl call only
#This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful.
#set default_color_stderr "red bold"
#set default_color_stderr "web-lightsalmon"
set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive
set default_color_stderr_repl "" ;#during repl call only
set homedir ""
if {[catch {
#depending on which build of tcl - some safe interps prior to bugfix https://core.tcl-lang.org/tcl/info/3aa487993f will return a homedir value in an unmodified safe interp
#other 'safe' interps may have explicitly made this available - we shouldn't override that decision here using interp issafe so we can't compensate for versions which shouldn't really be returning this in the safe interp
set homedir [file home]
} errM]} {
#tcl 8.6 doesn't have file home.. try again
if {[info exists ::env(HOME)]} {
set homedir $::env(HOME)
}
}
# per user xdg vars
# ---
set default_xdg_config_home "" ;#config data - portable
set default_xdg_data_home "" ;#data the user likely to want to be portable
set default_xdg_cache_home "" ;#local cache
set default_xdg_state_home "" ;#persistent user data such as logs, but not as important or as portable as those in xdg_data_home
# ---
set default_xdg_data_dirs "" ;#non-user specific
#xdg_config_dirs ?
#xdg_runtime_dir ?
#review. we are assuming if we can't get a home dir - then all the xdg vars including xdg_data_dirs aren't likely to be useful (as presumably filesystem access is absent)
#(safe interp generally won't have access to ::env either)
#This coupling doesn't necessarily hold - its possible the relevant env vars were copied to a safe interp - although that would be a policy that would make disabling 'info home' inconsistent.
if {$homedir ne ""} {
if {"windows" eq $::tcl_platform(platform)} {
#as much as I'd prefer to use ~/.local/share and ~/.config to keep them more consistent with unixlike platforms - the vast majority of apps put them where microsoft wants them.
#we have a choice of LOCALAPPDATA vs APPDATA (local to machine vs potentially roaming/redirected in a corporate environment)
#using the roaming location should not impact users who aren't using a domain controller but is potentially much more convenient for those who do.
if {[info exists ::env(APPDATA)]} {
set default_xdg_config_home $::env(APPDATA)
set default_xdg_data_home $::env(APPDATA)
}
#The xdg_cache_home should be kept local
if {[info exists ::env(LOCALAPPDATA)]} {
set default_xdg_cache_home $::env(LOCALAPPDATA)
set default_xdg_state_home $::env(LOCALAPPDATA)
}
if {[info exists ::env(PROGRAMDATA)]} {
#- equiv env(ALLUSERSPROFILE) ?
set default_xdg_data_dirs $::env(PROGRAMDATA)
}
} else {
#follow defaults as specified on freedesktop.org e.g https://specifications.freedesktop.org/basedir-spec/latest/ar01s03.html
set default_xdg_config_home [file join $homedir .config]
set default_xdg_data_home [file join $homedir .local share]
set default_xdg_cache_home [file join $homedir .cache]
set default_xdg_state_home [file join $homedir .local state]
set default_xdg_data_dirs /usr/local/share
}
}
set defaults [dict create\
apps $default_apps\
config ""\
configset ".punkshell"\
scriptlib $default_scriptlib\
color_stdout $default_color_stdout\
color_stdout_repl $default_color_stdout_repl\
color_stderr $default_color_stderr\
color_stderr_repl $default_color_stderr_repl\
logfile_stdout $default_logfile_stdout\
logfile_stderr $default_logfile_stderr\
logfile_active 0\
syslog_stdout "127.0.0.1:514"\
syslog_stderr "127.0.0.1:514"\
syslog_active 0\
auto_exec_mechanism exec\
auto_noexec 0\
xdg_config_home $default_xdg_config_home\
xdg_data_home $default_xdg_data_home\
xdg_cache_home $default_xdg_cache_home\
xdg_state_home $default_xdg_state_home\
xdg_data_dirs $default_xdg_data_dirs\
theme_posh_override ""\
posh_theme ""\
posh_themes_path ""\
]
set startup $defaults
#load values from saved config file - $xdg_config_home/punk/punk.config ?
#typically we want env vars to override the stored config - as env vars conventionally used on some commandlines.
#that's possibly ok for the PUNK_ vars
#however.. others like the xdg vars and NOCOLOR may apply to other apps.. and we may want to override them from the saved config?
#making some env vars override saved config values and some not would be potentially confusing. may need one/more specific settings or env vars to determine which takes precedence?
#simpler is probably just to let env vars take precedence - and warn when saving or viewing config that the saved values are being overridden
#- requiring user to manually unset any unwanted env vars when launching?
#we are likely to want the saved configs for subshells/decks to override them however.
#todo - load/save config file
#todo - define which configvars are settable in env
#list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean)
set punk_env_vars_config [dict create \
PUNK_APPS {type pathlist}\
PUNK_CONFIG {type string}\
PUNK_CONFIGSET {type string}\
PUNK_SCRIPTLIB {type string}\
PUNK_AUTO_EXEC_MECHANISM {type string}\
PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\
PUNK_COLOR_STDERR {type string help "stderr colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDERR_REPL {type string help "stderr colour transform only while command running (not active during 'after')"}\
PUNK_COLOR_STDOUT {type string help "stdout colour transform. Use 'punk::ansi::a?' to see colour names"}\
PUNK_COLOR_STDOUT_REPL {type string help "stdout colour transform only while command running (not active during 'after')"}\
PUNK_LOGFILE_STDOUT {type string}\
PUNK_LOGFILE_STDERR {type string}\
PUNK_LOGFILE_ACTIVE {type string}\
PUNK_SYSLOG_STDOUT {type string}\
PUNK_SYSLOG_STDERR {type string}\
PUNK_SYSLOG_ACTIVE {type string}\
PUNK_THEME_POSH_OVERRIDE {type string}\
]
set punk_env_vars [dict keys $punk_env_vars_config]
#override with env vars if set
foreach {evar varinfo} $punk_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
#e.g PUNK_SCRIPTLIB -> scriptlib
set varname [tcl::string::tolower [tcl::string::range $evar 5 end]]
if {$vartype eq "pathlist"} {
#colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system
#Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief.
#For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately.
#some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched.
#An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting
# - but some programs have been known to split this value on colon anyway, which breaks things on windows.
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
# https://no-color.org
#if {[info exists ::env(NO_COLOR)]} {
# if {$::env(NO_COLOR) ne ""} {
# set colour_disabled 1
# }
#}
set other_env_vars_config [dict create\
NO_COLOR {type string}\
XDG_CONFIG_HOME {type string}\
XDG_DATA_HOME {type string}\
XDG_CACHE_HOME {type string}\
XDG_STATE_HOME {type string}\
XDG_DATA_DIRS {type pathlist}\
POSH_THEME {type string}\
POSH_THEMES_PATH {type string}\
TCLLIBPATH {type string}\
]
lassign [split [info tclversion] .] tclmajorv tclminorv
#don't rely on lseq or punk::lib for now..
set relevant_minors [list]
for {set i 0} {$i <= $tclminorv} {incr i} {
lappend relevant_minors $i
}
foreach minor $relevant_minors {
set vname TCL${tclmajorv}_${minor}_TM_PATH
if {$minor eq $tclminorv || [info exists ::env($vname)]} {
dict set other_env_vars_config $vname {type string}
}
}
set other_env_vars [dict keys $other_env_vars_config]
foreach {evar varinfo} $other_env_vars_config {
if {[info exists ::env($evar)]} {
set vartype [dict get $varinfo type]
set f [set ::env($evar)]
if {$f ne "default"} {
set varname [tcl::string::tolower $evar]
if {$vartype eq "pathlist"} {
set paths [split $f $::tcl_platform(pathSeparator)]
set final [list]
#eliminate empty values (leading or trailing or extraneous separators)
foreach p $paths {
if {[tcl::string::trim $p] ne ""} {
lappend final $p
}
}
tcl::dict::set startup $varname $final
} else {
tcl::dict::set startup $varname $f
}
}
}
}
#unset -nocomplain vars
#todo
set running [tcl::dict::create]
set running [tcl::dict::merge $running $startup]
}
init
#todo
proc Apply {config} {
puts stderr "punk::config::Apply partially implemented"
set configname [string map {-config ""} $config]
if {$configname in {startup running}} {
upvar ::punk::config::$configname applyconfig
if {[dict exists $applyconfig auto_noexec]} {
set auto [dict get $applyconfig auto_noexec]
if {![string is boolean -strict $auto]} {
error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean"
}
if {$auto} {
set ::auto_noexec 1
} else {
#puts "auto_noexec false"
unset -nocomplain ::auto_noexec
}
}
} else {
error "no config named '$config' found"
}
return "apply done"
}
Apply startup
#todo - consider how to divide up settings, categories, 'devices', decks etc
proc get_running_global {varname} {
variable running
if {[dict exists $running $varname]} {
return [dict get $running $varname]
}
error "No such global configuration item '$varname' found in running config"
}
proc get_startup_global {varname} {
variable startup
if {[dict exists $startup $varname]} {
return [dict get $startup $varname]
}
error "No such global configuration item '$varname' found in startup config"
}
proc get {whichconfig {globfor *}} {
variable startup
variable running
switch -- $whichconfig {
config - startup - startup-config - startup-configuration {
#show *startup* config - different behaviour may be confusing to those used to router startup and running configs
set configdata $startup
}
running - running-config - running-configuration {
set configdata $running
}
default {
error "Unknown config name '$whichconfig' - try startup or running"
}
}
if {$globfor eq "*"} {
return $configdata
} else {
set keys [dict keys $configdata [string tolower $globfor]]
set filtered [dict create]
foreach k $keys {
dict set filtered $k [dict get $configdata $k]
}
return $filtered
}
}
proc configure {args} {
set argdef {
@id -id ::punk::config::configure
@cmd -name punk::config::configure -help\
"UNIMPLEMENTED"
@values -min 1 -max 1
whichconfig -type string -choices {startup running stop}
}
set argd [punk::args::get_dict $argdef $args]
return "unimplemented - $argd"
}
proc show {whichconfig {globfor *}} {
#todo - tables for console
set configdata [punk::config::get $whichconfig $globfor]
return [punk::lib::showdict $configdata]
}
#e.g
# copy running-config startup-config
# copy startup-config test-config.cfg
# copy backup-config.cfg running-config
#review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite
#This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration
proc copy {args} {
set argdef {
@id -id ::punk::config::copy
@cmd -name punk::config::copy -help\
"Copy a partial or full configuration from one config to another
If a target config has additional settings, then the source config can be considered to be partial with regards to the target.
"
-type -default "" -choices {replace merge} -help\
"Defaults to merge when target is running-config
Defaults to replace when source is running-config"
@values -min 2 -max 2
fromconfig -help\
"running or startup or file name (not fully implemented)"
toconfig -help\
"running or startup or file name (not fully implemented)"
}
set argd [punk::args::get_dict $argdef $args]
set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig]
set toconfig [string map {-config ""} $toconfig]
set copytype [dict get $argd opts -type]
#todo - warn & prompt if doing merge copy to startup
switch -exact -- $fromconfig-$toconfig {
running-startup {
if {$copytype eq ""} {
set copytype replace ;#full configuration
}
if {$copytype eq "replace"} {
error "punk::config::copy error. full configuration copy from running to startup config not yet supported"
} else {
error "punk::config::copy error. merge configuration copy from running to startup config not yet supported"
}
}
startup-running {
#default type merge - even though it's not always what is desired
if {$copytype eq ""} {
set copytype merge ;#load in a partial configuration
}
#warn/prompt either way
if {$copytype eq "replace"} {
#some routers require use of a separate command for this branch.
#presumably to ensure the user doesn't accidentally load partials onto a running system
#
error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported"
} else {
error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported"
}
}
default {
error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported"
}
}
}
}
#todo - move to cli?
::tcl::namespace::eval punk::config {
#todo - something better - 'previous' rather than reverting to startup
proc channelcolors {{onoff {}}} {
variable running
variable startup
if {![string length $onoff]} {
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
} else {
if {![string is boolean $onoff]} {
error "channelcolors: invalid value $onoff - expected boolean: true|false|on|off|1|0|yes|no"
}
if {$onoff} {
dict set running color_stdout [dict get $startup color_stdout]
dict set running color_stderr [dict get $startup color_stderr]
} else {
dict set running color_stdout ""
dict set running color_stderr ""
}
}
return [list stdout [dict get $running color_stdout] stderr [dict get $running color_stderr]]
}
}
package provide punk::config [tcl::namespace::eval punk::config {
variable version
set version 0.1
}]

5
src/bootsupport/modules/punk/mix/base-0.1.tm
Unescape View File

@ -767,6 +767,8 @@ namespace eval punk::mix::base {
dict for {path pathinfo} $dict_path_cksum {
puts "fill_relativecksums_from_base_and_relativepathdict-->$path REVIEW"
#review to see if we process same path repeatedly, so could avoid repeated 'file exists $fullpath' below by caching a glob
if {![dict exists $pathinfo cksum]} {
dict set pathinfo cksum ""
} else {
@ -851,7 +853,7 @@ namespace eval punk::mix::base {
}
} else {
if {[file type $specifiedpath] eq "relative"} {
if {[file pathtype $specifiedpath] eq "relative"} {
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage
set targetpath [file normalize $specifiedpath]
set storedpath $targetpath
@ -911,6 +913,7 @@ namespace eval punk::mix::base {
}
#buildruntime.exe obsolete..
puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???"
set fullpath_buildruntime $buildfolder/buildruntime.exe
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime]

20
src/bootsupport/modules/punk/mix/cli-0.3.1.tm
Unescape View File

@ -412,9 +412,9 @@ namespace eval punk::mix::cli {
set repopaths [punk::repo::find_repos [pwd]]
set repos [dict get $repopaths repos]
if {![llength $repos]} {
append result [dict get $repopaths warnings]
append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a]
} else {
append result [dict get $repopaths warnings]
append result [punk::ansi::a+ bold yellow][dict get $repopaths warnings][punk::ansi::a]
lassign [lindex $repos 0] repopath repotypes
if {"fossil" in $repotypes} {
#review - multiple process launches to fossil a bit slow on windows..
@ -739,7 +739,7 @@ namespace eval punk::mix::cli {
}
} else {
puts -nonewline stderr "."
puts -nonewline stderr "P"
set did_skip 1
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$build_event targetset_end SKIPPED
@ -771,7 +771,7 @@ namespace eval punk::mix::cli {
$event targetset_end OK -note "zip modpod"
}
} else {
puts -nonewline stderr "."
puts -nonewline stderr "p"
set did_skip 1
if {$is_interesting} {
puts stderr "$modulefile [$event targetset_source_changes]"
@ -893,7 +893,7 @@ namespace eval punk::mix::cli {
if {$is_interesting} {
puts stdout "skipping module $current_source_dir/$m - no change in sources detected"
}
puts -nonewline stderr "."
puts -nonewline stderr "m"
set did_skip 1
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record]
$event targetset_end SKIPPED
@ -935,7 +935,7 @@ namespace eval punk::mix::cli {
#set file_record [punkcheck::installfile_finished_install $basedir $file_record]
$event targetset_end OK -note "already versioned module"
} else {
puts -nonewline stderr "."
puts -nonewline stderr "f"
set did_skip 1
if {$is_interesting} {
puts stderr "$current_source_dir/$m [$event targetset_source_changes]"
@ -951,7 +951,8 @@ namespace eval punk::mix::cli {
if {$CALLDEPTH >= $max_depth} {
set subdirs [list]
} else {
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *]
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *]
set targets_existing [glob -nocomplain -dir $target_module_dir -type d -tail {*}$subdirs]
}
#puts stderr "subdirs: $subdirs"
foreach d $subdirs {
@ -965,7 +966,10 @@ namespace eval punk::mix::cli {
if {$skipdir} {
continue
}
if {![file exists $target_module_dir/$d]} {
#if {![file exists $target_module_dir/$d]} {
# file mkdir $target_module_dir/$d
#}
if {$d ni $targets_existing} {
file mkdir $target_module_dir/$d
}
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\

2
src/bootsupport/modules/punk/mix/commandset/buildsuite-0.1.0.tm
Unescape View File

@ -49,7 +49,7 @@ namespace eval punk::mix::commandset::buildsuite {
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]} {

8
src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm
Unescape View File

@ -26,7 +26,7 @@ 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
#Except for 'get' - all debug commands should emit to stdout
proc paths {} {
set out ""
puts stdout "find_repos output:"
@ -40,7 +40,7 @@ namespace eval punk::mix::commandset::debug {
set template_base_dict [punk::mix::base::lib::get_template_basefolders]
puts stdout "get_template_basefolders output:"
pdict template_base_dict */*
return
return
}
#call other debug command - but capture stdout as return value
@ -84,9 +84,9 @@ namespace eval punk::mix::commandset::debug {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
## Ready
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug {
variable version
set version 0.1.0
set version 0.1.0
}]
return

6
src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
Unescape View File

@ -26,8 +26,10 @@ namespace eval punk::mix::commandset::module {
namespace export *
proc paths {} {
set roots [punk::repo::find_repos ""]
set project [lindex [dict get $roots project] 0]
#set roots [punk::repo::find_repos ""]
#set project [lindex [dict get $roots project] 0]
set project [punk::repo::find_project ""]
if {$project ne ""} {
set is_project 1
set searchbase $project

170
src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
Unescape View File

@ -20,7 +20,7 @@
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0]
#[copyright "2023"]
#[titledesc {dec commandset - project}] [comment {-- Name section and table of contents description --}]
#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}]
#[moddesc {deck CLI commandset - project}] [comment {-- Description at end of page heading --}]
#[require punk::mix::commandset::project]
#[description]
@ -29,25 +29,25 @@
#*** !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
#[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
# 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]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
#[para] see punk::overlay
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
@ -56,7 +56,7 @@
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::mix::commandset::project
#[para] packages used by punk::mix::commandset::project
#[list_begin itemized]
package require Tcl 8.6-
@ -88,7 +88,7 @@ namespace eval punk::mix::commandset::project {
namespace export *
#*** !doctools
#[subsection {Namespace punk::mix::commandset::project}]
#[para] core commandset functions for punk::mix::commandset::project
#[para] core commandset functions for punk::mix::commandset::project
#[list_begin definitions]
proc _default {} {
@ -133,7 +133,7 @@ namespace eval punk::mix::commandset::project {
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.
#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]
@ -185,7 +185,7 @@ namespace eval punk::mix::commandset::project {
if {$opt_force || $opt_update} {
#generally undesirable to add default project module during an update.
#user can use dev module.new manually or supply module name in -modules
set opt_modules [list]
set opt_modules [list]
} else {
set opt_modules [list [string tolower $projectname]] ;#default modules to lowercase as is the modern (tip 590) recommendation for Tcl
}
@ -207,12 +207,12 @@ namespace eval punk::mix::commandset::project {
}
#we don't assume 'unknown' is configured to run shell commands
if {[string length [package provide shellrun]]} {
set exitinfo [run {*}$scoop_prog install fossil]
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]
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"')
@ -304,7 +304,7 @@ namespace eval punk::mix::commandset::project {
}
}
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"
@ -332,7 +332,7 @@ namespace eval punk::mix::commandset::project {
puts stderr $warnmsg
}
set fossil_repo_file ""
set fossil_repo_file ""
set is_fossil_root 0
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} {
set is_fossil_root 1
@ -356,7 +356,7 @@ namespace eval punk::mix::commandset::project {
return
}
#review
set fossil_repo_file $repodb_folder/$projectname.fossil
set fossil_repo_file $repodb_folder/$projectname.fossil
}
if {$fossil_repo_file eq ""} {
@ -378,7 +378,7 @@ namespace eval punk::mix::commandset::project {
file mkdir $projectdir
puts stdout ">>> about to call punkcheck::install $layout_path $projectdir"
puts stdout ">>> about to call punkcheck::install $layout_path $projectdir"
set resultdict [dict create]
set antipaths [list\
src/doc/*\
@ -394,10 +394,10 @@ namespace eval punk::mix::commandset::project {
#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"
puts stdout "copying layout files - with force applied - overwrite all-targets"
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite ALL-TARGETS -antiglob_paths $antipaths -antiglob_dir $antiglob_dir]
} else {
puts stdout "copying layout files - (if source file changed)"
puts stdout "copying layout files - (if source file changed)"
set resultdict [punkcheck::install $layout_path $projectdir -installer project.new -createempty 1 -overwrite installedsourcechanged-targets -antiglob_paths $antipaths -antiglob_dir $antiglob_dir]
}
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
@ -410,10 +410,10 @@ namespace eval punk::mix::commandset::project {
puts stdout "no src/doc in source template - update not required"
}
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence.
#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]
set override_antiglob_dir_core [list #* _aside .git]
if {[file exists $layout_path/.fossil-custom]} {
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)"
set resultdict [punkcheck::install $layout_path/.fossil-custom $projectdir/.fossil-custom -createdir 1 -createempty 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS]
@ -430,9 +430,9 @@ namespace eval punk::mix::commandset::project {
puts stdout "no .fossil-settings in source template - update not required"
}
#scan all files in template
#scan all files in template
#
#TODO - deck 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_path]
@ -440,7 +440,7 @@ namespace eval punk::mix::commandset::project {
if {[llength $templatefiles]} {
puts stdout "Filling template file placeholders with the following tag map:"
foreach {placeholder value} $tagmap {
puts stdout " $placeholder -> $value"
puts stdout " $placeholder -> $value"
}
}
foreach templatefullpath $templatefiles {
@ -452,7 +452,7 @@ namespace eval punk::mix::commandset::project {
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
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout
}
} else {
puts stderr "warning: Missing template file $fpath"
@ -464,7 +464,7 @@ namespace eval punk::mix::commandset::project {
if {[file exists $projectdir/src/modules]} {
foreach m $opt_modules {
#check if mod-ver.tm file or #modpod-mod-ver folder exist
#check if mod-ver.tm file or #modpod-mod-ver folder exist
set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm
set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm
@ -482,7 +482,7 @@ namespace eval punk::mix::commandset::project {
set overwrite_type zip
} else {
set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"]
set overwrite_type $opt_type
set overwrite_type $opt_type
}
if {[string tolower $answer] eq "y"} {
#REVIEW - all pods zip - for now
@ -503,7 +503,7 @@ namespace eval punk::mix::commandset::project {
$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
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source
#----------
if {\
[llength [dict get [$event targetset_source_changes] changed]]\
@ -535,7 +535,7 @@ namespace eval punk::mix::commandset::project {
if {![punk::repo::is_fossil_root $projectdir]} {
set first_fossil 1
#-k = keep. (only modify the manifest file(s))
#-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 {
@ -600,11 +600,11 @@ namespace eval punk::mix::commandset::project {
#[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]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 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 *]
@ -620,15 +620,15 @@ namespace eval punk::mix::commandset::project {
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}]
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]]
#return [list_as_lines [lib::get_projects $glob]]
}
proc detail {{glob {}} args} {
package require overtype
@ -640,14 +640,14 @@ namespace eval punk::mix::commandset::project {
# -- --- --- --- --- --- ---
set opt_description [dict get $opts -description]
# -- --- --- --- --- --- ---
set db_projects [lib::get_projects $glob]
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]
@ -658,13 +658,13 @@ namespace eval punk::mix::commandset::project {
set project_name ""
set project_code ""
set project_desc ""
set db_error ""
set db_error ""
if {[file exists $dbfile]} {
if {[catch {
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)
set project_name $r(value)
} elseif {$r(name) eq "project-code"} {
set project_code $r(value)
} elseif {$r(name) eq "project-description"} {
@ -687,7 +687,7 @@ namespace eval punk::mix::commandset::project {
}
incr file_idx
}
set setid 1
set codeset [dict create]
dict for {code dbs} $codes {
@ -696,17 +696,17 @@ namespace eval punk::mix::commandset::project {
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 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]"
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]"
} else {
lappend col6_dupids ""
lappend col6_dupids ""
}
}
@ -732,10 +732,10 @@ namespace eval punk::mix::commandset::project {
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {string length $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} {
@ -747,7 +747,7 @@ namespace eval punk::mix::commandset::project {
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 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]"
@ -756,20 +756,20 @@ namespace eval punk::mix::commandset::project {
} 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
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n
}
}
}
return $msg
#return [list_as_lines [lib::get_projects $glob]]
}
return $msg
#return [list_as_lines [lib::get_projects $glob]]
}
proc cd {{glob {}} args} {
dict set args -cd 1
work $glob {*}$args
work $glob {*}$args
}
proc work {{glob {}} args} {
package require sqlite3
set db_projects [lib::get_projects $glob]
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 ""
@ -779,22 +779,22 @@ namespace eval punk::mix::commandset::project {
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
lassign $pinfo fosdb name workdirs
foreach wdir $workdirs {
dict set workdir_dict $wdir $pinfo
lappend all_workdirs $wdir
@ -808,15 +808,15 @@ namespace eval punk::mix::commandset::project {
set col_pcodes [list]
set col_dupids [list]
set fosdb_count [dict create]
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
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]} {
@ -825,7 +825,7 @@ namespace eval punk::mix::commandset::project {
}
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]"
} else {
set dupid ""
set dupid ""
}
if {$dbcount == 1} {
set pname ""
@ -842,7 +842,7 @@ namespace eval punk::mix::commandset::project {
puts stderr "!!! error: $errM"
}
} else {
puts stderr "!!! missing fossil db $fosdb"
puts stderr "!!! missing fossil db $fosdb"
}
} else {
set info [dict get $fosdb_cache $fosdb]
@ -858,7 +858,7 @@ namespace eval punk::mix::commandset::project {
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 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
@ -884,13 +884,13 @@ namespace eval punk::mix::commandset::project {
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_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}]]
@ -913,13 +913,13 @@ namespace eval punk::mix::commandset::project {
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"
@ -948,7 +948,7 @@ namespace eval punk::mix::commandset::project {
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 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}]
@ -965,7 +965,7 @@ namespace eval punk::mix::commandset::project {
set wd [punk::ansi::a+ red]$wd[a]
}
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 {
if {![file exists $wd]} {
@ -973,7 +973,7 @@ namespace eval punk::mix::commandset::project {
set wd [punk::ansi::a+ red]$wd[a]
}
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} {
@ -985,7 +985,7 @@ namespace eval punk::mix::commandset::project {
::cd $workingdir
return $workingdir
} else {
puts stderr "path $workingdir doesn't appear to exist"
puts stderr "path $workingdir doesn't appear to exist"
return [pwd]
}
} else {
@ -1004,12 +1004,12 @@ namespace eval punk::mix::commandset::project {
#*** !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
#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
@ -1032,12 +1032,13 @@ namespace eval punk::mix::commandset::project {
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;}]
#list of entries like "ckout:C:/buildtcl/2024zig/tcl90/"
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]
lappend paths_and_names [list $path $nm $checkout_paths]
}
set filtered_list [list]
foreach glob $globlist {
@ -1045,16 +1046,14 @@ namespace eval punk::mix::commandset::project {
foreach m $matches {
if {$m ni $filtered_list} {
lappend filtered_list $m
}
}
}
}
set projects [lsort -index 1 $filtered_list]
return $projects
}
}
@ -1067,15 +1066,10 @@ namespace eval punk::mix::commandset::project {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
## Ready
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project {
variable version
set version 0.1.0
set version 0.1.0
}]
return

38
src/bootsupport/modules/punk/mix/commandset/repo-0.1.0.tm
Unescape View File

@ -24,6 +24,9 @@
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::repo {
namespace export *
variable PUNKARGS
proc tickets {{project ""}} {
#todo
set result ""
@ -52,9 +55,9 @@ namespace eval punk::mix::commandset::repo {
set repopaths [punk::repo::find_repos [pwd]]
set repos [dict get $repopaths repos]
if {![llength $repos]} {
append result [dict get $repopaths warnings]
append result [a+ bold yellow][dict get $repopaths warnings][a]
} else {
append result [dict get $repopaths warnings]
append result [a+ bold yellow][dict get $repopaths warnings][a]
lassign [lindex $repos 0] repopath repotypes
if {"fossil" in $repotypes} {
append result \n "Fossil repo based at $repopath"
@ -69,6 +72,17 @@ namespace eval punk::mix::commandset::repo {
}
return $result
}
#punk::args
lappend PUNKARGS [list {
@id -id ::punk::mix::commandset::repo::fossil-move-repository
@cmd -name punk::mix::commandset::repo::fossil-move-repository -help\
"Move the fossil repository file (usually named with .fossil extension).
This is an interactive function which will prompt for answers on stdin
before proceeding.
The move can be done even if there are open checkouts and will maintain
the link between checkout databases and the repository file."
}]
proc fossil-move-repository {{path ""}} {
set searchbase [pwd]
set projectinfo [punk::repo::find_repos $searchbase]
@ -281,7 +295,7 @@ namespace eval punk::mix::commandset::repo {
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 "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]
@ -304,11 +318,11 @@ namespace eval punk::mix::commandset::repo {
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 "OK - move performed with result:"
puts stdout $moveresult
}
}
}
}
cd $original_cwd
}
@ -379,7 +393,7 @@ namespace eval punk::mix::commandset::repo {
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 "OK - move performed with result:"
puts stdout $moveresult
}
}
@ -402,10 +416,10 @@ namespace eval punk::mix::commandset::repo {
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::punk::mix::commandset::repo
}
@ -413,9 +427,9 @@ namespace eval punk::mix::commandset::repo {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
## Ready
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo {
variable version
set version 0.1.0
set version 0.1.0
}]
return

327
src/bootsupport/modules/punk/mod-0.1.tm
Unescape View File

@ -1,164 +1,163 @@
#punkapps app manager
# deck cli
namespace eval punk::mod::cli {
namespace export help list run
namespace ensemble create
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown
if 0 {
proc _unknown {ns args} {
puts stderr "punk::mod::cli::_unknown '$ns' '$args'"
puts stderr "punk::mod::cli::help $args"
puts stderr "arglen:[llength $args]"
punk::mod::cli::help {*}$args
}
}
#cli must have _init method - usually used to load commandsets lazily
#
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
#...
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
#namespace export
return $basehelp
}
proc getraw {appname} {
upvar ::punk::config::running running_config
set app_folders [dict get $running_config apps]
#todo search each app folder
set bases [::list]
set versions [::list]
set mains [::list]
set appinfo [::list bases {} mains {} versions {}]
foreach containerfolder $app_folders {
lappend bases $containerfolder
if {[file exists $containerfolder]} {
if {[file exists $containerfolder/$appname/main.tcl]} {
#exact match - only return info for the exact one specified
set namematches $appname
set parts [split $appname -]
} else {
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
}
foreach nm $namematches {
set mainfile $containerfolder/$nm/main.tcl
set parts [split $nm -]
if {[llength $parts] == 1} {
set ver ""
} else {
set ver [lindex $parts end]
}
if {$ver ni $versions} {
lappend versions $ver
lappend mains $ver $mainfile
} else {
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)"
}
}
} else {
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config"
}
}
dict set appinfo versions $versions
#todo - natsort!
set sorted_versions [lsort $versions]
set latest [lindex $sorted_versions 0]
if {$latest eq "" && [llength $sorted_versions] > 1} {
set latest [lindex $sorted_versions 1
}
dict set appinfo latest $latest
dict set appinfo bases $bases
dict set appinfo mains $mains
return $appinfo
}
proc list {{glob *}} {
upvar ::punk::config::running running_config
set apps_folder [dict get $running_config apps]
if {[file exists $apps_folder]} {
if {[file exists $apps_folder/$glob]} {
#tailcall source $apps_folder/$glob/main.tcl
return $glob
}
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob]
if {[llength $apps] == 0} {
if {[string first * $glob] <0 && [string first ? $glob] <0} {
#no glob chars supplied - only launch if exact match for name part
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
if {[llength $namematches] > 0} {
set latest [lindex $namematches end]
lassign $latest nm ver
#tailcall source $apps_folder/$latest/main.tcl
}
}
}
return $apps
}
}
#todo - way to launch as separate process
# solo-opts only before appname - args following appname are passed to the app
proc run {args} {
set nameposn [lsearch -not $args -*]
if {$nameposn < 0} {
error "punkapp::run unable to determine application name"
}
set appname [lindex $args $nameposn]
set controlargs [lrange $args 0 $nameposn-1]
set appargs [lrange $args $nameposn+1 end]
set appinfo [punk::mod::cli::getraw $appname]
if {[llength [dict get $appinfo versions]]} {
set ver [dict get $appinfo latest]
puts stdout "info: $appinfo"
set ::argc [llength $appargs]
set ::argv $appargs
source [dict get $appinfo mains $ver]
if {"-hideconsole" in $controlargs} {
puts stderr "attempting console hide"
#todo - something better - a callback when window mapped?
after 500 {::punkapp::hide_console}
}
return $appinfo
} else {
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]"
}
}
}
namespace eval punk::mod::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command help
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
package provide punk::mod [namespace eval punk::mod {
variable version
set version 0.1
}]
#punkapps app manager
# deck cli
namespace eval punk::mod::cli {
namespace export help list run
namespace ensemble create
# namespace ensemble configure [namespace current] -unknown punk::mod::cli::_unknown
if 0 {
proc _unknown {ns args} {
puts stderr "punk::mod::cli::_unknown '$ns' '$args'"
puts stderr "punk::mod::cli::help $args"
puts stderr "arglen:[llength $args]"
punk::mod::cli::help {*}$args
}
}
#cli must have _init method - usually used to load commandsets lazily
#
variable initialised 0
proc _init {args} {
variable initialised
if {$initialised} {
return
}
#...
set initialised 1
}
proc help {args} {
set basehelp [punk::mix::base help {*}$args]
#namespace export
return $basehelp
}
proc getraw {appname} {
upvar ::punk::config::running running_config
set app_folders [dict get $running_config apps]
#todo search each app folder
set bases [::list]
set versions [::list]
set mains [::list]
set appinfo [::list bases {} mains {} versions {}]
foreach containerfolder $app_folders {
lappend bases $containerfolder
if {[file exists $containerfolder]} {
if {[file exists $containerfolder/$appname/main.tcl]} {
#exact match - only return info for the exact one specified
set namematches $appname
set parts [split $appname -]
} else {
set namematches [glob -nocomplain -dir $containerfolder -type d -tail ${appname}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
}
foreach nm $namematches {
set mainfile $containerfolder/$nm/main.tcl
set parts [split $nm -]
if {[llength $parts] == 1} {
set ver ""
} else {
set ver [lindex $parts end]
}
if {$ver ni $versions} {
lappend versions $ver
lappend mains $ver $mainfile
} else {
puts stderr "punk::apps::app version '$ver' of app '$appname' already encountered at $mainfile. (will use earliest encountered in running-config apps and ignore others of same version)"
}
}
} else {
puts stderr "punk::apps::app missing apps_folder:'$containerfolder' Ensure apps_folder is set in punk::config"
}
}
dict set appinfo versions $versions
#todo - natsort!
set sorted_versions [lsort $versions]
set latest [lindex $sorted_versions 0]
if {$latest eq "" && [llength $sorted_versions] > 1} {
set latest [lindex $sorted_versions 1]
}
dict set appinfo latest $latest
dict set appinfo bases $bases
dict set appinfo mains $mains
return $appinfo
}
proc list {{glob *}} {
upvar ::punk::config::running running_config
set apps_folder [dict get $running_config apps]
if {[file exists $apps_folder]} {
if {[file exists $apps_folder/$glob]} {
#tailcall source $apps_folder/$glob/main.tcl
return $glob
}
set apps [glob -nocomplain -dir $apps_folder -type d -tail $glob]
if {[llength $apps] == 0} {
if {[string first * $glob] <0 && [string first ? $glob] <0} {
#no glob chars supplied - only launch if exact match for name part
set namematches [glob -nocomplain -dir $apps_folder -type d -tail ${glob}-*]
set namematches [lsort $namematches] ;#todo - -ascii? -dictionary? natsort?
if {[llength $namematches] > 0} {
set latest [lindex $namematches end]
lassign $latest nm ver
#tailcall source $apps_folder/$latest/main.tcl
}
}
}
return $apps
}
}
#todo - way to launch as separate process
# solo-opts only before appname - args following appname are passed to the app
proc run {args} {
set nameposn [lsearch -not $args -*]
if {$nameposn < 0} {
error "punkapp::run unable to determine application name"
}
set appname [lindex $args $nameposn]
set controlargs [lrange $args 0 $nameposn-1]
set appargs [lrange $args $nameposn+1 end]
set appinfo [punk::mod::cli::getraw $appname]
if {[llength [dict get $appinfo versions]]} {
set ver [dict get $appinfo latest]
puts stdout "info: $appinfo"
set ::argc [llength $appargs]
set ::argv $appargs
source [dict get $appinfo mains $ver]
if {"-hideconsole" in $controlargs} {
puts stderr "attempting console hide"
#todo - something better - a callback when window mapped?
after 500 {::punkapp::hide_console}
}
return $appinfo
} else {
error "punk::mod::cli unable to run '$appname'. main.tcl not found in [dict get $appinfo bases]"
}
}
}
namespace eval punk::mod::cli {
proc _cli {args} {
#don't use tailcall - base uses info level to determine caller
::punk::mix::base::_cli {*}$args
}
variable default_command help
package require punk::mix::base
package require punk::overlay
punk::overlay::custom_from_base [namespace current] ::punk::mix::base
}
package provide punk::mod [namespace eval punk::mod {
variable version
set version 0.1
}]

21
src/bootsupport/modules/punk/path-0.1.0.tm
Unescape View File

@ -657,6 +657,7 @@ namespace eval punk::path {
**/_aside (exlude files where _aside is last segment)
**/_aside/* (exclude folders one below an _aside folder)
**/_aside/** (exclude all folders with _aside as a segment)"
-antiglob_files -default {}
@values -min 0 -max -1 -optional 1 -type string
tailglobs -default * -multiple 1 -help\
"Patterns to match against filename portion (last segment) of each file path
@ -681,6 +682,7 @@ namespace eval punk::path {
set tailglobs [dict get $values tailglobs]
# -- --- --- --- --- --- ---
set opt_antiglob_paths [dict get $opts -antiglob_paths]
set opt_antiglob_files [dict get $opts -antiglob_files]
set CALLDEPTH [dict get $opts -call-depth-internal]
# -- --- --- --- --- --- ---
# -- --- --- --- --- --- ---
@ -718,7 +720,24 @@ namespace eval punk::path {
puts stderr "treefilenames error while listing files in dir $opt_dir\n $matches"
set dirfiles [list]
} else {
set dirfiles [lsort $matches]
set retained [list]
if {[llength $opt_antiglob_files]} {
foreach m $matches {
set skip 0
set ftail [file tail $m]
foreach anti $opt_antiglob_files {
if {[string match $anti $ftail]} {
set skip 1; break
}
}
if {!$skip} {
lappend retained $m
}
}
} else {
set retained $matches
}
set dirfiles [lsort $retained]
}
lappend files {*}$dirfiles

240
src/bootsupport/modules/punk/repo-0.1.1.tm
Unescape View File

@ -39,16 +39,16 @@ if {$::tcl_platform(platform) eq "windows"} {
}
package require fileutil; #tcllib
package require punk::path
package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path
package require punk::mix::base ;#uses core functions from punk::mix::base::lib namespace e.g cksum_path
package require punk::mix::util ;#do_in_path
# -- --- --- --- --- --- --- --- --- --- ---
# For performance/efficiency reasons - use file functions on paths in preference to string operations
# e.g use file join
# e.g use file join
# branch to avoid unnecessary calls to 'pwd' or 'file normalize' - which can be surprisingly expensive operations (as at tcl 8.7 2023)
# pwd is only expensive if we treat it as a string instead of a list/path
# e.g
# e.g
# > time {set x [pwd]}
# 5 microsoeconds.. no problem
# > time {set x [pwd]}
@ -67,11 +67,11 @@ namespace eval punk::repo {
variable cached_command_paths
set cached_command_paths [dict create]
#anticipating possible removal of buggy caching from auto_execok
#anticipating possible removal of buggy caching from auto_execok
#mentioned in: https://core.tcl-lang.org/tcl/tktview/4dc35e0c0c
#this would leave the application to decide what it wants to cache in that regard.
proc Cached_auto_execok {name} {
return [auto_execok $name]
return [auto_execok $name]
#variable cached_command_paths
#if {[dict exists $cached_command_paths $name]} {
# return [dict get $cached_command_paths $name]
@ -102,14 +102,14 @@ namespace eval punk::repo {
"" {${$othercmds}}
}
}]
return $result
}
#lappend PUNKARGS [list {
# @dynamic
# @id -id ::punk::repo::fossil_proxy
# @id -id ::punk::repo::fossil_proxy
# @cmd -name fossil -help "fossil executable
# "
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}}
@ -117,7 +117,7 @@ namespace eval punk::repo {
lappend PUNKARGS [list {
@dynamic
@id -id ::punk::repo::fossil_proxy
@id -id ::punk::repo::fossil_proxy
@cmd -name fossil -help "fossil executable"
${[punk::repo::get_fossil_usage]}
} ]
@ -128,14 +128,13 @@ namespace eval punk::repo {
lappend PUNKARGS [list {
@dynamic
@id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff" -help "fossil diff
"
@cmd -name "fossil diff" -help "fossil diff"
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""]
lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive
@dynamic
@id -id "::punk::repo::fossil_proxy add"
@dynamic
@id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add
"
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
@ -152,16 +151,16 @@ namespace eval punk::repo {
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"}
#Todo - investigate proper way to install a client-side commit hook in the fossil project
#Todo - investigate proper way to install a client-side commit hook in the fossil project
#Then we may still use this proxy to check the hook - but the required checks will occur when another shell used
proc fossil_proxy {args} {
set start_dir [pwd]
set fosroot [find_fossil $start_dir]
set fosroot [find_fossil $start_dir]
set fossilcmd [lindex $args 0]
set no_warning_commands [list "help" "dbstat" "grep" "diff" "xdiff" "cat" "version"]
if {$fossilcmd ni $no_warning_commands } {
set repostate [find_repos $start_dir]
set repostate [find_repos $start_dir]
}
set no_prompt_commands [list "status" "info" {*}$no_warning_commands]
@ -170,7 +169,7 @@ namespace eval punk::repo {
if {$fossilcmd ni $no_prompt_commands} {
set fossilrepos [dict get $repostate fossil]
if {[llength $fossilrepos] > 1} {
puts stdout [dict get $repostate warnings]
puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a]
puts stdout "Operating on inner fossil repository: [lindex $fossilrepos 0]"
puts stdout "Use FOSSIL instead of fossil to avoid this prompt and warning"
set answer [askuser "Are you sure you want to perform the operation on this repo? Y/N"]
@ -217,7 +216,7 @@ namespace eval punk::repo {
}
} elseif {$fossilcmd in [list "info" "status"]} {
#emit warning whether or not multiple fossil repos
puts stdout [dict get $repostate warnings]
puts stdout [punk::ansi::a+ bold yellow][dict get $repostate warnings][punk::ansi::a]
}
set fossil_prog [Cached_auto_execok fossil]
if {$fossil_prog ne ""} {
@ -234,7 +233,7 @@ namespace eval punk::repo {
#safe interps can't call auto_execok
#At least let them load the package even though much of it may be unusable depending on the safe configuration
#catch {
# if {[auto_execok fossil] ne ""} {
# if {[auto_execok fossil] ne ""} {
# interp alias "" FOSSIL "" {*}[auto_execok fossil]
# }
#}
@ -245,7 +244,7 @@ namespace eval punk::repo {
#uppercase FOSSIL to bypass fossil as alias to fossil_proxy
#only necessary on unix?
#Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway
#Windows filesystem case insensitive so any non-lowercase fossil version goes out to get an ::auto_execs entry anyway
proc establish_FOSSIL {args} {
#review
if {![info exists ::auto_execs(FOSSIL)]} {
@ -298,7 +297,7 @@ namespace eval punk::repo {
if {$path eq {}} { set path [pwd] }
scanup $path is_fossil_root
}
proc find_git {{path {}}} {
if {$path eq {}} { set path [pwd] }
scanup $path is_git_root
@ -330,12 +329,31 @@ namespace eval punk::repo {
}
}
}
lappend PUNKARGS [list {
@id -id "::punk::repo::find_project"
@cmd -name "punk::repo::find_project" -help\
"Find and return the path for the root of
the project to which the supplied path belongs.
If the supplied path is empty, the current
working directory is used as the starting point
for the upwards search.
Returns nothing if there is no project at or
above the specified path."
@values -min 0 -max 1
path -optional 1 -default "" -help\
"May be an absolute or relative path.
The full specified path doesn't have
to exist. The code will walk upwards
along the segments of the supplied path
testing the result of 'is_project_root'."
}]
proc find_project {{path {}}} {
if {$path eq {}} { set path [pwd] }
scanup $path is_project_root
scanup $path is_project_root
}
proc is_fossil_root {{path {}}} {
#detect if path is a fossil root - without consulting fossil databases
proc is_fossil_root2 {{path {}}} {
if {$path eq {}} { set path [pwd] }
#from kettle::path::is.fossil
foreach control {
@ -348,20 +366,51 @@ namespace eval punk::repo {
}
return 0
}
proc is_fossil_root {{path {}}} {
#much faster on windows than 'file exists' checks
if {$path eq {}} { set path [pwd] }
set control [list _FOSSIL_ .fslckout .fos]
#could be marked 'hidden' on windows
if {"windows" eq $::tcl_platform(platform)} {
set files [list {*}[glob -nocomplain -dir $path -types f -tail {*}$control] {*}[glob -nocomplain -dir $path -types {f hidden} -tail {*}$control]]
} else {
set files [glob -nocomplain -dir $path -types f -tail {*}$control]
}
expr {[llength $files] > 0}
}
#review - is a .git folder sufficient?
#consider git rev-parse --git-dir ?
proc is_git_root {{path {}}} {
if {$path eq {}} { set path [pwd] }
set control [file join $path .git]
expr {[file exists $control] && [file isdirectory $control]}
#set control [file join $path .git]
#expr {[file exists $control] && [file isdirectory $control]}
if {"windows" eq $::tcl_platform(platform)} {
#:/
#globbing for dotfiles in tcl is problematic across platforms - windows 'hidden' concept is independent
#we need to find .git whether hidden or not - so need 2 glob operations
#.git may or may not be set with windows 'hidden' attribute
set hiddengitdir [glob -nocomplain -dir $path -types {d hidden} -tail .git]
set nonhiddengitdir [glob -nocomplain -dir $path -types {d} -tail .git] ;#won't return hidden :/
return [expr {[llength [list {*}$hiddengitdir {*}$nonhiddengitdir]] > 0}]
} else {
#:/
#unix returns 'hidden' files even without the hidden type being specified - but only if the pattern explicitly matches
return [expr {[llength [glob -nocomplain -dir $path -types d -tail .git]] > 0}] ;#will return .git even though it is conventionally 'hidden' on unix :/
}
}
proc is_repo_root {{path {}}} {
if {$path eq {}} { set path [pwd] }
expr {[is_fossil_root $path] || [is_git_root $path]}
#expr {[is_fossil_root $path] || [is_git_root $path]}
expr {[is_git_root $path] || [is_fossil_root $path]} ;#is_git_root has less to check
}
#require a minimum of src and src/modules|src/scriptapps|src/*/*.vfs - and that it's otherwise sensible
#we still run a high chance of picking up unintended candidates - but hopefully it's a reasonable balance.
#after excluding undesirables;
#require a minimum of
# - (src and src/modules|src/scriptapps|src/vfs)
# - OR (src and punkproject.toml)
# - and that it's otherwise sensible
#we still run a chance of picking up unintended candidates - but hopefully it's a reasonable balance.
proc is_candidate_root {{path {}}} {
if {$path eq {}} { set path [pwd] }
if {[file pathtype $path] eq "relative"} {
@ -380,24 +429,34 @@ namespace eval punk::repo {
}
#review - adjust to allow symlinks to folders?
foreach required {
src
} {
set req $path/$required
if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0}
#foreach required {
# src
#} {
# set req $path/$required
# if {(![file exists $req]) || ([file type $req] ne "directory") } {return 0}
#}
set required [list src]
set found_required [glob -nocomplain -dir $path -types d -tails {*}$required]
if {[llength $found_required] < [llength $required]} {
return 0
}
set src_subs [glob -nocomplain -dir $path/src -types d -tail *]
#test for $path/src/lib is too common to be a useful indicator
if {"modules" in $src_subs || "scriptapps" in $src_subs} {
if {"modules" in $src_subs || "vfs" in $src_subs || "scriptapps" in $src_subs} {
#bare minimum 1
return 1
}
foreach sub $src_subs {
if {[string match *.vfs $sub]} {
return 1
}
#bare minimum2
# - has src folder and (possibly empty?) punkproject.toml
if {[file exists $path/punkproject.toml]} {
return 1
}
#review - do we need to check if path is already within a project?
#can we have a nested project? Seems like asking for complexity and problems when considering possible effects for git/fossil
#todo - breadth first search with depth limit (say depth 3?) for *.tm or *.tcl as another positive qualifier for this dir to be a project-root
#we probably don't want to deep search a src folder in case the user is accidentally in some other type of project's tree
#such a src tree could be very large, so if we don't find tcl indicators near the root it's a good bet this isn't a candidate
@ -415,14 +474,22 @@ namespace eval punk::repo {
}
proc is_project_root {path} {
#review - find a reliable simple mechanism. Noting we have projects based on different templates.
#review - find a reliable simple mechanism. Noting we have projects based on different templates.
#Should there be a specific required 'project' file of some sort?
#(punkproject.toml is a candidate)
#we don't want to solely rely on such a file being present
# - we may also have punkproject.toml in project_layout template folders for example
#test for file/folder items indicating fossil or git workdir base
if {(![punk::repo::is_fossil_root $path]) && (![punk::repo::is_git_root $path])} {
#the 'dev' mechanism for creating projects automatically creates a fossil project
#(which can be ignored if the user wants to manage it with git - but should probably remain in place? review)
#however - we currently require that for it to be a 'project' there must be some version control.
#REVIEW.
#
if {![punk::repo::is_repo_root $path]} {
return 0
}
#exclude some known places we wouldn't want to put a project
#exclude some known places we wouldn't want to put a project
if {![is_candidate_root $path]} {
return 0
}
@ -456,7 +523,7 @@ namespace eval punk::repo {
if {$abspath in [dict keys $defaults]} {
set args [list $abspath {*}$args]
set abspath ""
}
}
set opts [dict merge $defaults $args]
# -- --- --- --- --- --- --- --- --- --- --- ---
set opt_repotypes [dict get $opts -repotypes]
@ -793,7 +860,7 @@ namespace eval punk::repo {
}
}
if {$repotype eq "git"} {
dict set fieldnames extra "extra (files/folders)"
dict set fieldnames extra "extra (files/folders)"
}
set col1_fields [list]
set col2_values [list]
@ -846,6 +913,7 @@ namespace eval punk::repo {
#determine nature of possibly-nested repositories (of various types) at and above this path
#Treat an untracked 'candidate' folder as a sort of repository
proc find_repos {path} {
puts "find_repos '$path'"
set start_dir $path
#root is a 'project' if it it meets the candidate requrements and is under repo control
@ -860,6 +928,10 @@ namespace eval punk::repo {
while {[string length [set fosroot [punk::repo::find_fossil $fos_search_from]]]} {
lappend fossils_bottom_to_top $fosroot
set fos_search_from [file dirname $fosroot]
if {$fos_search_from eq $fosroot} {
#root of filesystem is repo - unusual case - but without this we would never escape the while loop
break
}
}
dict set root_dict fossil $fossils_bottom_to_top
@ -868,6 +940,9 @@ namespace eval punk::repo {
while {[string length [set gitroot [punk::repo::find_git $git_search_from]]]} {
lappend gits_bottom_to_top $gitroot
set git_search_from [file dirname $gitroot]
if {$git_search_from eq $gitroot} {
break
}
}
dict set root_dict git $gits_bottom_to_top
@ -876,6 +951,9 @@ namespace eval punk::repo {
while {[string length [set candroot [punk::repo::find_candidate $cand_search_from]]]} {
lappend candidates_bottom_to_top $candroot
set cand_search_from [file dirname $candroot]
if {$cand_search_from eq $candroot} {
break
}
}
dict set root_dict candidate $candidates_bottom_to_top
@ -936,14 +1014,14 @@ namespace eval punk::repo {
dict set root_dict closest [lindex $longest_first 0 1] ;#the *path* of the closest to start_dir
dict set root_dict closest_types [lindex $longest_first 0 0]
}
set closest_fossil [lindex [dict get $root_dict fossil] 0]
set closest_fossil_len [llength [file split $closest_fossil]]
set closest_git [lindex [dict get $root_dict git] 0]
set closest_git_len [llength [file split $closest_git]]
set closest_candidate [lindex [dict get $root_dict candidate] 0]
set closest_candidate_len [llength [file split $closest_candidate]]
set closest_fossil [lindex [dict get $root_dict fossil] 0]
set closest_fossil_len [llength [file split $closest_fossil]]
set closest_git [lindex [dict get $root_dict git] 0]
set closest_git_len [llength [file split $closest_git]]
set closest_candidate [lindex [dict get $root_dict candidate] 0]
set closest_candidate_len [llength [file split $closest_candidate]]
if {$closest_candidate_len > $closest_fossil_len && $closest_candidate_len > $closest_git_len} {
#only warn if this candidate is *within* a found repo root
@ -1079,7 +1157,7 @@ namespace eval punk::repo {
}
if {$opt_ansi} {
if {$opt_ansi_prompt eq "\uFFFF"} {
set ansiprompt [a+ green bold]
set ansiprompt [a+ green bold]
} else {
set ansiprompt [$opt_ansi_prompt]
}
@ -1112,15 +1190,15 @@ namespace eval punk::repo {
#Whilst it might detect a central repo folder in a non-standard location - it might also be annoying.
#Todo - a separate environment variable for users to declare one or more locations where they would like to store project .fossil repositories?
set candidate_repo_folder_locations [list]
set candidate_repo_folder_locations [list]
#- choose a sensible default based on where fossil put the global config dir - or on the existence of a .fossils folder in a 'standard' location
#verify with user before creating a .fossils folder
#always check env(FOSSIL_HOME) first - but this is designed to locate the global .fossil (or _fossil) file - .fossils repository folder doesn't have to be at the same location
set usable_repo_folder_locations [list]
#If we find one, but it's not writable - add it to another list
#If we find one, but it's not writable - add it to another list
set readonly_repo_folder_locations [list]
#Examine a few possible locations for .fossils folder set
#Examine a few possible locations for .fossils folder set
#if containing folder is writable add to candidate list
set testpaths [list]
@ -1129,8 +1207,8 @@ namespace eval punk::repo {
if {![catch {package require Tcl 8.7-}]} {
set fossilhome [file normalize [file tildeexpand $fossilhome_raw]]
} else {
#8.6
set fossilhome [file normalize $fossilhome_raw]
#8.6
set fossilhome [file normalize $fossilhome_raw]
}
lappend testpaths [file join $fossilhome .fossils]
@ -1175,13 +1253,13 @@ namespace eval punk::repo {
}
}
}
set startdir_fossils [glob -nocomplain -dir $startdir -type f *.fossil]
if {[llength $startdir_fossils]} {
#user is already keeping .fossil files directly in curent dir - give them the option to easily keep doing this
#(we don't add it if no .fossil files there already - as it is probably a niche requirement - or a sign the user hasn't thought about a better/central location)
if {$startdir ni $usable_repo_folder_locations} {
lappend usable_repo_folder_locations $startdir
lappend usable_repo_folder_locations $startdir
}
}
set choice_folders [list]
@ -1207,7 +1285,7 @@ namespace eval punk::repo {
#no existing writable .fossil folders (and no existing .fossil files in startdir)
#offer the (writable) candidate_repo_folder_locations
foreach fld $candidate_repo_folder_locations {
lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""]
lappend choice_folders [list index $i folder $fld folderexists 0 existingfossils "" conflict ""]
incr i
}
}
@ -1230,7 +1308,7 @@ namespace eval punk::repo {
}
set folderexists [dict get $option folderexists]
if {$folderexists} {
set folderstatus "(existing folder)"
set folderstatus "(existing folder)"
} else {
set folderstatus "(CREATE folder for .fossil repository files)"
}
@ -1238,7 +1316,7 @@ namespace eval punk::repo {
}
#append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice
#append the readonly_repo_folder_locations so that user is aware of them as it may affect their choice
if {[llength $readonly_repo_folder_locations]} {
append menu_message "--------------------------------------------------" \n
foreach readonly $readonly_repo_folder_locations {
@ -1256,11 +1334,11 @@ namespace eval punk::repo {
} else {
if {[llength $choice_folders] || $opt_askpath} {
puts stdout $menu_message
set max [llength $choice_folders]
set max [llength $choice_folders]
if {$max == 1} {
set rangemsg "the number 1"
} else {
set rangemsg "a number from 1 to $max"
set rangemsg "a number from 1 to $max"
}
set menuprompt "${ansiprompt}Enter $rangemsg to select location. (or N to abort)${ansireset}"
if {$opt_askpath} {
@ -1279,7 +1357,7 @@ namespace eval punk::repo {
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"
puts stderr "Failed to create folder $repository_folder. Error $errM"
}
}
} else {
@ -1317,7 +1395,7 @@ namespace eval punk::repo {
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"
puts stdout "Selected fossil location $repository_folder"
} else {
puts stderr " No menu number matched - aborting."
return
@ -1367,7 +1445,7 @@ namespace eval punk::repo {
proc fossil_revision {{path {}}} {
if {$path eq {}} { set path [pwd] }
# ::kettle::path::revision.fossil
# ::kettle::path::revision.fossil
set fossilcmd [Cached_auto_execok fossil]
if {[llength $fossilcmd]} {
do_in_path $path {
@ -1381,7 +1459,7 @@ namespace eval punk::repo {
proc fossil_remote {{path {}}} {
if {$path eq {}} { set path [pwd] }
# ::kettle::path::revision.fossil
# ::kettle::path::revision.fossil
set fossilcmd [Cached_auto_execok fossil]
if {[llength $fossilcmd]} {
do_in_path $path {
@ -1395,11 +1473,11 @@ namespace eval punk::repo {
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
#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
#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)} {
@ -1416,7 +1494,7 @@ namespace eval punk::repo {
if {[file exists $testfile]} {
return $testfile
}
}
}
} else {
foreach varname [list FOSSIL_HOME HOME ] {
if {[info exists ::env($varname)]} {
@ -1435,13 +1513,13 @@ namespace eval punk::repo {
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
}
}
}
}
@ -1484,13 +1562,13 @@ namespace eval punk::repo {
cd $original_cwd
}
#attempt 3 - getting desperate.. find other repos, determine their checkouts and run fossil in them to get a result
#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
#use fossil all ls and sqlite
if {[catch {exec {*}$fossilcmd all ls} repolines]} {
error "fossil_get_configdb cannot find repositories"
} else {
@ -1535,7 +1613,7 @@ namespace eval punk::repo {
error "fossil_get_configdb exhausted search options"
}
#------------------------------------
#temporarily cd to workpath to run script - return to correct path even on failure
proc do_in_path {path script} {
#from ::kettle::path::in
@ -1611,8 +1689,8 @@ namespace eval punk::repo {
set platform $::tcl_platform(platform)
}
#No - don't do this sort of path translation here - leave as option for specific utils only such as ./
#Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work
#No - don't do this sort of path translation here - leave as option for specific utils only such as ./
#Windows volume-relative syntax with specific volume specified is somewhat broken in Tcl - but leading slash volume-relative does work
#We shouldn't break it totally just because accessing WSL/mingw paths is slightly more useful
#if {$platform eq "windows"} {
#return [file dirname [file normalize [punk::unixywindows::towinpath $path]/__]]
@ -1624,7 +1702,7 @@ namespace eval punk::repo {
#This taken from kettle::path::strip
#It doesn't compare the prefix contents presumably for speed when used in kettle::path::scan
#renamed to better indicate its behaviour
proc path_strip_prefixdepth {path prefix} {
if {$prefix eq ""} {
return [norm $path]
@ -1713,9 +1791,9 @@ namespace eval ::punk::args::register {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
## Ready
package provide punk::repo [namespace eval punk::repo {
variable version
set version 0.1.1
set version 0.1.1
}]
return

478
src/bootsupport/modules/punkapp-0.1.tm
Unescape View File

@ -1,239 +1,239 @@
#utilities for punk apps to call
package provide punkapp [namespace eval punkapp {
variable version
set version 0.1
}]
namespace eval punkapp {
variable result
variable waiting "no"
proc hide_dot_window {} {
#alternative to wm withdraw .
#see https://wiki.tcl-lang.org/page/wm+withdraw
wm geometry . 1x1+0+0
wm overrideredirect . 1
wm transient .
}
proc is_toplevel {w} {
if {![llength [info commands winfo]]} {
return 0
}
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
}
proc get_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list {}
if {[is_toplevel $w]} {
lappend list $w
}
foreach w [winfo children $w] {
lappend list {*}[get_toplevels $w]
}
return $list
}
proc make_toplevel_next {prefix} {
set top [get_toplevel_next $prefix]
return [toplevel $top]
}
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase?
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix
proc get_toplevel_next {prefix} {
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> ""
}
proc exit {{toplevel ""}} {
variable waiting
variable result
variable default_result
set toplevels [get_toplevels]
if {[string length $toplevel]} {
set wposn [lsearch $toplevels $toplevel]
if {$wposn > 0} {
destroy $toplevel
}
} else {
#review
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "punkapp::exit called without toplevel - showing console"
show_console
return 0
} else {
puts stderr "punkapp::exit called without toplevel - exiting"
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
set controllable [get_user_controllable_toplevels]
if {![llength $controllable]} {
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
show_console
} else {
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} elseif {[info exists result($toplevel)]} {
set temp [set result($toplevel)]
unset result($toplevel)
set waiting $temp
} elseif {[info exists default_result]} {
set temp $default_result
unset default_result
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
}
proc close_window {toplevel} {
wm withdraw $toplevel
if {![llength [get_user_controllable_toplevels]]} {
punkapp::exit $toplevel
}
destroy $toplevel
}
proc wait {args} {
variable waiting
variable default_result
if {[dict exists $args -defaultresult]} {
set default_result [dict get $args -defaultresult]
}
foreach t [punkapp::get_toplevels] {
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} {
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t]
}
}
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "repl eventloop seems to be running - punkapp::wait not required"
} else {
if {$waiting eq "no"} {
set waiting "waiting"
vwait ::punkapp::waiting
return $::punkapp::waiting
}
}
}
#A window can be 'visible' according to this - but underneath other windows etc
#REVIEW - change name?
proc get_visible_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list [get_toplevels $w]
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
set mapped [concat {*}$mapped] ;#ignore {}
set visible [list]
foreach m $mapped {
if {[wm overrideredirect $m] == 0 } {
lappend visible $m
} else {
if {[winfo height $m] >1 && [winfo width $m] > 1} {
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
lappend visible $m
}
}
}
return $visible
}
proc get_user_controllable_toplevels {{w .}} {
set visible [get_visible_toplevels $w]
set controllable [list]
foreach v $visible {
if {[wm overrideredirect $v] == 0} {
lappend controllable $v
}
}
#only return visible windows with overrideredirect == 0 because there exists some user control.
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
return $controllable
}
proc hide_console {args} {
set opts [dict create -force 0]
if {([llength $args] % 2) != 0} {
error "hide_console expects pairs of arguments. e.g -force 1"
}
#set known_opts [dict keys $defaults]
foreach {k v} $args {
switch -- $k {
-force {
dict set opts $k $v
}
default {
error "Unrecognised options '$k' known options: [dict keys $opts]"
}
}
}
set force [dict get $opts -force]
if {!$force} {
if {![llength [get_user_controllable_toplevels]]} {
puts stderr "Cannot hide console while no user-controllable windows available"
return 0
}
}
if {$::tcl_platform(platform) eq "windows"} {
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway.
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way.
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though.
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call)
package require twapi
set h [twapi::get_console_window]
set pid [twapi::get_window_process $h]
set pinfo [twapi::get_process_info $pid -name]
set pname [dict get $pinfo -name]
set wstyle [twapi::get_window_style $h]
#tclkitsh/tclsh?
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} {
twapi::hide_window $h
return 1
} else {
puts stderr "punkapp::hide_console unable to hide this type of console window"
return 0
}
} else {
#todo
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
return 0
}
}
proc show_console {} {
if {$::tcl_platform(platform) eq "windows"} {
package require twapi
if {![catch {set h [twapi::get_console_window]} errM]} {
twapi::show_window $h -activate -normal
} else {
#no console - assume launched from something like wish?
catch {console show}
}
} else {
#todo
puts stderr "punkapp::show_console unimplemented on this platform"
}
}
}
#utilities for punk apps to call
package provide punkapp [namespace eval punkapp {
variable version
set version 0.1
}]
namespace eval punkapp {
variable result
variable waiting "no"
proc hide_dot_window {} {
#alternative to wm withdraw .
#see https://wiki.tcl-lang.org/page/wm+withdraw
wm geometry . 1x1+0+0
wm overrideredirect . 1
wm transient .
}
proc is_toplevel {w} {
if {![llength [info commands winfo]]} {
return 0
}
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
}
proc get_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list {}
if {[is_toplevel $w]} {
lappend list $w
}
foreach w [winfo children $w] {
lappend list {*}[get_toplevels $w]
}
return $list
}
proc make_toplevel_next {prefix} {
set top [get_toplevel_next $prefix]
return [toplevel $top]
}
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase?
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix
proc get_toplevel_next {prefix} {
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> ""
}
proc exit {{toplevel ""}} {
variable waiting
variable result
variable default_result
set toplevels [get_toplevels]
if {[string length $toplevel]} {
set wposn [lsearch $toplevels $toplevel]
if {$wposn > 0} {
destroy $toplevel
}
} else {
#review
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "punkapp::exit called without toplevel - showing console"
show_console
return 0
} else {
puts stderr "punkapp::exit called without toplevel - exiting"
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
set controllable [get_user_controllable_toplevels]
if {![llength $controllable]} {
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
show_console
} else {
if {$waiting ne "no"} {
if {[info exists result(shell)]} {
set temp [set result(shell)]
unset result(shell)
set waiting $temp
} elseif {[info exists result($toplevel)]} {
set temp [set result($toplevel)]
unset result($toplevel)
set waiting $temp
} elseif {[info exists default_result]} {
set temp $default_result
unset default_result
set waiting $temp
} else {
set waiting ""
}
} else {
::exit
}
}
}
}
proc close_window {toplevel} {
wm withdraw $toplevel
if {![llength [get_user_controllable_toplevels]]} {
punkapp::exit $toplevel
}
destroy $toplevel
}
proc wait {args} {
variable waiting
variable default_result
if {[dict exists $args -defaultresult]} {
set default_result [dict get $args -defaultresult]
}
foreach t [punkapp::get_toplevels] {
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} {
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t]
}
}
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} {
puts stderr "repl eventloop seems to be running - punkapp::wait not required"
} else {
if {$waiting eq "no"} {
set waiting "waiting"
vwait ::punkapp::waiting
return $::punkapp::waiting
}
}
}
#A window can be 'visible' according to this - but underneath other windows etc
#REVIEW - change name?
proc get_visible_toplevels {{w .}} {
if {![llength [info commands winfo]]} {
return [list]
}
set list [get_toplevels $w]
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
set mapped [concat {*}$mapped] ;#ignore {}
set visible [list]
foreach m $mapped {
if {[wm overrideredirect $m] == 0 } {
lappend visible $m
} else {
if {[winfo height $m] >1 && [winfo width $m] > 1} {
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
lappend visible $m
}
}
}
return $visible
}
proc get_user_controllable_toplevels {{w .}} {
set visible [get_visible_toplevels $w]
set controllable [list]
foreach v $visible {
if {[wm overrideredirect $v] == 0} {
lappend controllable $v
}
}
#only return visible windows with overrideredirect == 0 because there exists some user control.
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
return $controllable
}
proc hide_console {args} {
set opts [dict create -force 0]
if {([llength $args] % 2) != 0} {
error "hide_console expects pairs of arguments. e.g -force 1"
}
#set known_opts [dict keys $defaults]
foreach {k v} $args {
switch -- $k {
-force {
dict set opts $k $v
}
default {
error "Unrecognised options '$k' known options: [dict keys $opts]"
}
}
}
set force [dict get $opts -force]
if {!$force} {
if {![llength [get_user_controllable_toplevels]]} {
puts stderr "Cannot hide console while no user-controllable windows available"
return 0
}
}
if {$::tcl_platform(platform) eq "windows"} {
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway.
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way.
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though.
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call)
package require twapi
set h [twapi::get_console_window]
set pid [twapi::get_window_process $h]
set pinfo [twapi::get_process_info $pid -name]
set pname [dict get $pinfo -name]
set wstyle [twapi::get_window_style $h]
#tclkitsh/tclsh?
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} {
twapi::hide_window $h
return 1
} else {
puts stderr "punkapp::hide_console unable to hide this type of console window"
return 0
}
} else {
#todo
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
return 0
}
}
proc show_console {} {
if {$::tcl_platform(platform) eq "windows"} {
package require twapi
if {![catch {set h [twapi::get_console_window]} errM]} {
twapi::show_window $h -activate -normal
} else {
#no console - assume launched from something like wish?
catch {console show}
}
} else {
#todo
puts stderr "punkapp::show_console unimplemented on this platform"
}
}
}

114
src/bootsupport/modules/punkcheck-0.1.0.tm
Unescape View File

@ -243,12 +243,14 @@ namespace eval punkcheck {
}
method get_targets_exist {} {
set punkcheck_folder [file dirname [$o_installer get_checkfile]]
set existing [list]
foreach t $o_targets {
if {[file exists [file join $punkcheck_folder $t]]} {
lappend existing $t
}
}
set existing [glob -nocomplain -dir $punkcheck_folder -tails {*}$o_targets]
#set existing [list]
#foreach t $o_targets {
# if {[file exists [file join $punkcheck_folder $t]]} {
# lappend existing $t
# }
#}
return $existing
}
method end {} {
@ -880,19 +882,46 @@ namespace eval punkcheck {
#allow nonexistant as a source
set fpath [file join $punkcheck_folder $source_relpath]
if {![file exists $fpath]} {
#windows: file exist + file type = 2ms vs 500ms for 2x glob
set floc [file dirname $fpath]
set fname [file tail $fpath]
set file_set [glob -nocomplain -dir $floc -type f -tails $fname]
set dir_set [glob -nocomplain -dir $floc -type d -tails $fname]
set link_set [glob -nocomplain -dir $floc -type l -tails $fname]
if {[llength $file_set] == 0 && [llength $dir_set] == 0 && [llength $link_set] == 0} {
#could also theoretically exist as less common types, b,c,p,s (block,char,pipe,socket)
#- we don't expect them here - REVIEW - ever possible?
#- installing/examining such things an unlikely usecase and would require special handling anyway.
set ftype "missing"
set fsize ""
} else {
set ftype [file type $fpath]
if {$ftype eq "directory"} {
if {[llength $dir_set]} {
set ftype "directory"
set fsize "NA"
} elseif {[llength $link_set]} {
set ftype "link"
set fsize 0
} else {
set ftype "file"
#todo - optionally use mtime instead of cksum (for files only)?
#mtime is not reliable across platforms and filesystems though.. see article linked at top.
set fsize [file size $fpath]
}
}
#if {![file exists $fpath]} {
# set ftype "missing"
# set fsize ""
#} else {
# set ftype [file type $fpath]
# if {$ftype eq "directory"} {
# set fsize "NA"
# } else {
# #todo - optionally use mtime instead of cksum (for files only)?
# #mtime is not reliable across platforms and filesystems though.. see article linked at top.
# set fsize [file size $fpath]
# }
#}
#get_relativecksum_from_base and fill_relativecksums_from_base_and_relativepathdict will set cksum to <PATHNOTFOUND> if fpath doesn't exist
if {$use_cache} {
set source_cksum_info [punk::mix::base::lib::fill_relativecksums_from_base_and_relativepathdict $punkcheck_folder [dict create $source_relpath $use_cache_record]]
@ -1648,6 +1677,10 @@ namespace eval punkcheck {
set is_skip 0
if {$overwrite_what eq "all-targets"} {
file mkdir $current_target_dir
#--------------------------------------------
#sometimes we get the error: 'error copying "file1" to "file2": invalid argument'
#--------------------------------------------
puts stderr "punkcheck: about to: file copy -force $current_source_dir/$m $current_target_dir"
file copy -force $current_source_dir/$m $current_target_dir
lappend files_copied $current_source_dir/$m
} else {
@ -1859,22 +1892,75 @@ namespace eval punkcheck {
return [list files_copied $files_copied files_skipped $files_skipped sources_unchanged $sources_unchanged antiglob_paths_matched $antiglob_paths_matched punkcheck_records $punkcheck_records punkcheck_folder $punkcheck_folder srcdir $srcdir tgtdir $tgtdir]
}
proc summarize_install_resultdict {resultdict} {
lappend PUNKARGS [list {
@id -id ::punkcheck::summarize_install_resultdict
@cmd -name punkcheck::summarize_install_resultdict -help\
"Emits a string summarizing a punkcheck resultdict, showing
how many items were copied, and the source, target locations"
@opts
-title -type string -default ""
-forcecolour -type boolean -default 0 -help\
"When true, passes the forcecolour tag to punk::ansi functions.
This enables ANSI sgr colours even when colour
is off. (ignoring env(NO_COLOR))
To disable colour - ensure the NO_COLOR env var is set,
or use:
namespace eval ::punk::console {variable colour_disabled 1}"
@values -min 1 -max 1
resultdict -type dict
}]
proc summarize_install_resultdict {args} {
set argd [punk::args::parse $args withid ::punkcheck::summarize_install_resultdict]
lassign [dict values $argd] leaders opts values received
set title [dict get $opts -title]
set forcecolour [dict get $opts -forcecolour]
set resultdict [dict get $values resultdict]
set has_ansi [expr {![catch {package require punk::ansi}]}]
if {$has_ansi} {
if {$forcecolour} {
set fc "forcecolour"
} else {
set fc ""
}
set R [punk::ansi::a] ;#reset
set LINE_COLOUR [punk::ansi::a+ {*}$forcecolour bold cyan]
set LOW_COLOUR [punk::ansi::a+ {*}$forcecolour bold green]
set HIGH_COLOUR [punk::ansi::a+ {*}$forcecolour bold yellow]
} else {
set R ""
set LINE_COLOUR ""
set LOW_COLOUR ""
set HIGH_COLOUR ""
}
set msg ""
if {[dict size $resultdict]} {
set copied [dict get $resultdict files_copied]
append msg "--------------------------" \n
append msg "[dict keys $resultdict]" \n
if {[llength $copied] == 0} {
set HIGHLIGHT $LOW_COLOUR
} else {
set HIGHLIGHT $HIGH_COLOUR
}
set ruler $LINE_COLOUR[string repeat - 78]$R
if {$title ne ""} {
append msg $ruler \n
append msg $title \n
}
append msg $ruler \n
#append msg "[dict keys $resultdict]" \n
set tgtdir [dict get $resultdict tgtdir]
set checkfolder [dict get $resultdict punkcheck_folder]
append msg "Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]" \n
append msg "${HIGHLIGHT}Copied [llength $copied] files from [dict get $resultdict srcdir] to [dict get $resultdict tgtdir]$R" \n
foreach f $copied {
append msg "COPIED [punkcheck::lib::path_relative $checkfolder $f]" \n
append msg " TO $tgtdir" \n
}
append msg "[llength [dict get $resultdict sources_unchanged]] unchanged source files" \n
append msg "[llength [dict get $resultdict files_skipped]] skipped files" \n
append msg "--------------------------" \n
append msg $ruler \n
}
return $msg
}

BIN
src/bootsupport/modules/test/tomlish-1.1.1.tm
View File

Binary file not shown.

BIN
src/bootsupport/modules/test/tomlish-1.1.3.tm
View File

Binary file not shown.

7408
src/bootsupport/modules/textblock-0.1.1.tm
View File

File diff suppressed because it is too large Load Diff

8520
src/bootsupport/modules/textblock-0.1.2.tm
View File

File diff suppressed because it is too large Load Diff

160
src/bootsupport/modules/tomlish-1.1.2.tm
Unescape View File

@ -185,6 +185,8 @@ namespace eval tomlish {
error "tomlish _get_keyval_value invalid to have type TABLE on rhs of ="
}
ITABLE {
#This one should not be returned as a type <tag> value <something> structure!
#
set result [::tomlish::to_dict [list $found_sub]]
}
ARRAY {
@ -249,6 +251,7 @@ namespace eval tomlish {
}
#to_dict is a *basic* programmatic datastructure for accessing the data.
# produce a dictionary of keys and values from a tomlish tagged list.
# to_dict is primarily for reading toml data.
@ -271,8 +274,12 @@ namespace eval tomlish {
# so we can raise an error to satisfy the toml rule: 'You cannot define any key or table more than once. Doing so is invalid'
#Note that [a] and then [a.b] is ok if there are no subkey conflicts - so we are only tracking complete tablenames here.
#we don't error out just because a previous tablename segment has already appeared.
variable tablenames_seen [list]
##variable tablenames_seen [list]
if {[uplevel 1 [list info exists tablenames_seen]]} {
upvar tablenames_seen tablenames_seen
} else {
set tablenames_seen [list]
}
log::info ">>> processing '$tomlish'<<<"
set items $tomlish
@ -311,9 +318,9 @@ namespace eval tomlish {
}
DOTTEDKEY {
log::debug "--> processing $tag: $item"
set dkey_info [_get_dottedkey_info $item]
set dotted_key_hierarchy [dict get $dkey_info keys]
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw]
set dkey_info [_get_dottedkey_info $item]
set dotted_key_hierarchy [dict get $dkey_info keys]
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw]
#a.b.c = 1
#table_key_hierarchy -> a b
@ -345,6 +352,9 @@ namespace eval tomlish {
set keyval_dict [_get_keyval_value $item]
dict set datastructure {*}$pathkeys $leafkey $keyval_dict
#JMN test 2025
}
TABLE {
set tablename [lindex $item 1]
@ -386,8 +396,40 @@ namespace eval tomlish {
lappend table_key_hierarchy_raw $rawseg
if {[dict exists $datastructure {*}$table_key_hierarchy]} {
#It's ok for this key to already exist *if* it was defined by a previous tablename,
# but not if it was defined as a key/qkey/skey ?
#It's ok for this key to already exist *if* it was defined by a previous tablename or equivalent
#and if this key is longer
#consider the following 2 which are legal:
#[table]
#x.y = 3
#[table.x.z]
#k= 22
#equivalent
#[table]
#[table.x]
#y = 3
#[table.x.z]
#k=22
#illegal
#[table]
#x.y = 3
#[table.x.y.z]
#k = 22
## - we should bfail on encoungerint table.x.y because only table and table.x are effectively tables
## - we should also fail if
#illegal
#[table]
#x.y = {p=3}
#[table.x.y.z]
#k = 22
## we should fail because y is an inline table which is closed to further entries
#TODO! fix - this code is wrong
set testkey [join $table_key_hierarchy_raw .]
@ -422,7 +464,7 @@ namespace eval tomlish {
if {$found_testkey == 0} {
#the raw table_key_hierarchy is better to display in the error message, although it's not the actual dict keyset
set msg "key [join $table_key_hierarchy_raw .] already exists in datastructure, but wasn't defined by a supertable."
append msg "tablenames_seen:"
append msg \n "tablenames_seen:" \n
foreach ts $tablenames_seen {
append msg " " $ts \n
}
@ -453,13 +495,18 @@ namespace eval tomlish {
#now add the contained elements
foreach element [lrange $item 2 end] {
set type [lindex $element 0]
log::debug "--> $type processing contained element $element"
switch -exact -- $type {
DOTTEDKEY {
set dkey_info [_get_dottedkey_info $element]
set dotted_key_hierarchy [dict get $dkey_info keys]
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw]
set leaf_key [lindex $dotted_key_hierarchy end]
set dkeys [lrange $dotted_key_hierarchy 0 end-1]
#e.g1 keys {x.y y} keys_raw {'x.y' y}
#e.g2 keys {x.y y} keys_raw {{"x.y"} y}
set dotted_key_hierarchy [dict get $dkey_info keys]
set dkeys [lrange $dotted_key_hierarchy 0 end-1]
set leaf_key [lindex $dotted_key_hierarchy end]
set dotted_key_hierarchy_raw [dict get $dkey_info keys_raw]
set dkeys_raw [lrange $dotted_key_hierarchy_raw 0 end-1]
set leaf_key_raw [lindex $dotted_key_hierarchy_raw end]
#ensure empty keys are still represented in the datastructure
set test_keys $table_keys
@ -476,7 +523,22 @@ namespace eval tomlish {
error "Duplicate key '$table_keys $dkeys $leaf_key'. The key already exists at this level in the toml data. The toml data is not valid."
}
set keyval_dict [_get_keyval_value $element]
#keyval_dict is either a {type <tomltag> value <whatever>}
#or the result from parsing an arbitrary dict from an inline table - which could theoretically look the same at the topmost level
#punk::dict::is_tomlish_typeval can distinguish
puts stdout ">>> $keyval_dict"
dict set datastructure {*}$table_keys {*}$dkeys $leaf_key $keyval_dict
#JMN 2025
#tomlish::utils::normalize_key ??
lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw] .] ;#????
#if the keyval_dict is not a simple type x value y - then it's an inline table ?
#if so - we should add the path to the leaf_key as a seen table too - as it's not allowed to have more entries added.
if {![tomlish::dict::is_tomlish_typeval $keyval_dict]} {
#the value is either empty or or a dict structure with arbitrary (from-user-data) toplevel keys
# inner structure will contain {type <tag> value <etc>} if all leaves are not empty ITABLES
lappend tablenames_seen [join [list {*}$table_key_hierarchy_raw {*}$dkeys_raw $leaf_key_raw] .]
}
}
KEY - QKEY - SQKEY {
#obsolete ?
@ -777,7 +839,7 @@ namespace eval tomlish {
set result [list]
set lastparent [lindex $parents end]
if {$lastparent in [list "" do_inline]} {
if {[tomlish::dict::is_tomltype $vinfo]} {
if {[tomlish::dict::is_tomlish_typeval $vinfo]} {
set type [dict get $vinfo type]
#treat ITABLE differently?
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo]
@ -811,7 +873,7 @@ namespace eval tomlish {
} else {
set VK_PART [list KEY $vk]
}
if {[tomlish::dict::is_tomltype $vv]} {
if {[tomlish::dict::is_tomlish_typeval $vv]} {
#type x value y
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv]
set record [list DOTTEDKEY [list $VK_PART {WS { }}] = {WS { }} $sublist]
@ -877,7 +939,7 @@ namespace eval tomlish {
}
} else {
#lastparent is not toplevel "" or "do_inline"
if {[tomlish::dict::is_tomltype $vinfo]} {
if {[tomlish::dict::is_tomlish_typeval $vinfo]} {
#type x value y
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vinfo]
lappend result {*}$sublist
@ -901,7 +963,7 @@ namespace eval tomlish {
} else {
set VK_PART [list KEY $vk]
}
if {[tomlish::dict::is_tomltype $vv]} {
if {[tomlish::dict::is_tomlish_typeval $vv]} {
#type x value y
set sublist [_from_dictval_tomltype $parents $tablestack $keys $vv]
set record [list DOTTEDKEY [list $VK_PART] = $sublist]
@ -2404,7 +2466,8 @@ namespace eval tomlish::utils {
} ;#RS
#check if str is valid for use as a toml bare key
proc is_barekey {str} {
#Early toml versions? only allowed letters + underscore + dash
proc is_barekey1 {str} {
if {[tcl::string::length $str] == 0} {
return 0
} else {
@ -2418,6 +2481,52 @@ namespace eval tomlish::utils {
}
}
#from toml.abnf in github.com/toml-lang/toml
#unquoted-key = 1*unquoted-key-char
#unquoted-key-char = ALPHA / DIGIT / %x2D / %x5F ; a-z A-Z 0-9 - _
#unquoted-key-char =/ %xB2 / %xB3 / %xB9 / %xBC-BE ; superscript digits, fractions
#unquoted-key-char =/ %xC0-D6 / %xD8-F6 / %xF8-37D ; non-symbol chars in Latin block
#unquoted-key-char =/ %x37F-1FFF ; exclude GREEK QUESTION MARK, which is basically a semi-colon
#unquoted-key-char =/ %x200C-200D / %x203F-2040 ; from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ
#unquoted-key-char =/ %x2070-218F / %x2460-24FF ; include super-/subscripts, letterlike/numberlike forms, enclosed alphanumerics
#unquoted-key-char =/ %x2C00-2FEF / %x3001-D7FF ; skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces
#unquoted-key-char =/ %x2070-21FF / %x2300-24FF ; skip math operators
#unquoted-key-char =/ %x25A0-268B / %x2690-2757 ; skip box drawing, block elements, and some yin-yang symbols
#unquoted-key-char =/ %x2762-2767 / %x2776-27E5 ; skip some Dingbat punctuation
#unquoted-key-char =/ %x2801-297F ; skip some math brackets and arrows, and braille blank
#unquoted-key-char =/ %x2B00-2FFF / %x3001-D7FF ; skip various math operators and symbols, and ideographic space
#unquoted-key-char =/ %xF900-FDCF / %xFDF0-FFFD ; skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode)
#unquoted-key-char =/ %x10000-EFFFF ; all chars outside BMP range, excluding Private Use planes (F0000-10FFFF)
variable re_barekey
set ranges [list]
lappend ranges {a-zA-Z0-9\_\-}
lappend ranges {\u00B2} {\u00B3} {\u00B9} {\u00BC-\u00BE} ;# superscript digits, fractions
lappend ranges {\u00C0-\u00D6} {\u00D8-\u00F6} {\u00F8-\u037D} ;# non-symbol chars in Latin block
lappend ranges {\u037f-\u1FFF} ;# exclude GREEK QUESTION MARK, which is basically a semi-colon
lappend ranges {\u200C-\u200D} {\u203F-\u2040} ;# from General Punctuation Block, include the two tie symbols and ZWNJ, ZWJ
lappend ranges {\u2070-\u218f} {\u2460-\u24FF} ;# include super-subscripts, letterlike/numberlike forms, enclosed alphanumerics
lappend ranges {\u2C00-\u2FEF} {\u3001-\uD7FF} ;# skip arrows, math, box drawing etc, skip 2FF0-3000 ideographic up/down markers and spaces
lappend ranges {\u2070-\u21FF} {\u2300-\u24FF} ;# skip math operators
lappend ranges {\u25A0-\u268B} {\u2690-\u2757} ;# skip box drawing, block elements, and some yin-yang symbols
lappend ranges {\u2762-\u2767} {\u2776-\u27E5} ;# skip some Dingbat punctuation
lappend ranges {\u2801-\u297F} ;# skip some math brackets and arrows, and braille blank
lappend ranges {\u2B00-\u2FFF} {\u3001-\uD7FF} ;# skip various math operators and symbols, and ideographic space
lappend ranges {\uF900-\uFDCF} {\uFDF0-\uFFFD} ;# skip D800-DFFF surrogate block, E000-F8FF Private Use area, FDD0-FDEF intended for process-internal use (unicode)
lappend ranges {\U10000-\UEFFFF} ;# all chars outside BMP range, excluding Private Use planes (F0000-10FFFF)
set re_barekey {^[}
foreach r $ranges {
append re_barekey $r
}
append re_barekey {]+$}
proc is_barekey {str} {
if {[tcl::string::length $str] == 0} {
return 0
}
variable re_barekey
return [regexp $re_barekey $str]
}
#test only that the characters in str are valid for the toml specified type 'integer'.
proc int_validchars1 {str} {
set numchars [tcl::string::length $str]
@ -3471,7 +3580,7 @@ namespace eval tomlish::parse {
return 1
}
barekey {
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z_-\] allowed. [tomlish::parse::report_line]"
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed (see tomlish::utils::is_barekey). [tomlish::parse::report_line]"
}
whitespace {
# hash marks end of whitespace token
@ -5222,7 +5331,7 @@ namespace eval tomlish::parse {
if {[tomlish::utils::is_barekey $c]} {
append tok $c
} else {
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] allowed. [tomlish::parse::report_line]"
error "tomlish Unexpected character '$c' during bare key. Only \[a-zA-Z0-9_-\] and a selection of letter-like chars allowed. (see tomlish::utils::is_barekey) [tomlish::parse::report_line]"
}
}
starttablename - starttablearrayname {
@ -5354,10 +5463,15 @@ namespace eval tomlish::dict {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
proc is_tomltype {d} {
expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value]}
proc is_tomlish_typeval {d} {
#designed to detect {type <tag> value <whatever>} e.g {type INT value 3}, {type STRING value "blah etc"}
#as a sanity check we need to avoid mistaking user data that happens to match same form
#consider x.y={type="spud",value="blah"}
#The value of type will itself have already been converted to {type STRING value spud} ie never a single element.
#check the length of the type as a quick way to see it's a tag - not something else masqerading.
expr {[dict size $d] == 2 && [dict exists $d type] && [dict exists $d value] && [llength [dict get $d type]] == 1}
}
proc is_tomltype2 {d} {
proc is_tomlish_typeval2 {d} {
upvar ::tomlish::tags tags
expr {[lindex $d 0] eq "type" && [lindex $d 1] in $tags}
}
@ -5366,7 +5480,7 @@ namespace eval tomlish::dict {
set dictposn [expr {[dict size $d] -1}]
foreach k [lreverse [dict keys $d]] {
set dval [dict get $d $k]
if {[is_tomltype $dval]} {
if {[is_tomlish_typeval $dval]} {
set last_simple $dictposn
break
}

2110
src/bootsupport/modules/tomlish-1.1.1.tm → src/bootsupport/modules/tomlish-1.1.3.tm
View File

File diff suppressed because it is too large Load Diff

BIN
src/bootsupport/modules/zipper-0.11.tm
View File

Binary file not shown.

418
src/make.tcl
Unescape View File

@ -2,12 +2,15 @@
#
# punkboot - make any tclkits and modules in <projectdir>/src folders and place them and associated data files/scripts in the parent folder of src.
#e.g in 'bin' and 'modules' folders at same level as 'src' folder.
if {[info exists ::env(NO_COLOR)]} {
namespace eval ::punk::console {variable colour_disabled 1}
}
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###"
puts $hashline
puts " Punk Boot"
puts " Punk Boot"
puts $hashline\n
package prefer latest
package prefer latest
lassign [split [info tclversion] .] tclmajorv tclminorv
global A ;#UI Ansi code array
@ -104,7 +107,7 @@ namespace eval ::punkboot::lib {
}
}
return [join $newparts .]
}
}
proc tm_version_required_canonical {versionspec} {
#also trim leading zero from any dottedpart?
#Tcl *allows* leading zeros in any of the dotted parts - but they are not significant.
@ -112,10 +115,10 @@ namespace eval ::punkboot::lib {
#also 1b3 == 1b0003
if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version
set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification"
set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification"
if {[string first - $versionspec] < 0} {
#no dash
#looks like a minbounded version (ie a single version with no dash) convert to min-max form
#no dash
#looks like a minbounded version (ie a single version with no dash) convert to min-max form
set from $versionspec
if {![::punkboot::lib::tm_version_isvalid $from]} {
error "$errmsg '$versionpec'"
@ -127,7 +130,7 @@ namespace eval ::punkboot::lib {
error "$errmsg '$versionspec'"
}
} else {
# min- or min-max
# min- or min-max
#validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b)
set parts [split $versionspec -] ;#we expect only 2 parts
lassign $parts from to
@ -162,18 +165,18 @@ if {"::try" ni [info commands ::try]} {
#------------------------------------------------------------------------------
#Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder
#------------------------------------------------------------------------------
#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files
#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables
set startdir [pwd]
#we are focussed on pure-tcl libs/modules in bootsupport for now.
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries
# - we need to support that without binary downloads from repos unless the user explicitly asks for that.
# - They may already be available in the vfs (or pointed to package paths) of the running executable.
# - todo: some user prompting regarding installs with platform-appropriate package managers
# - todo: some user prompting regarding building accelerators from source.
# - todo: some user prompting regarding building accelerators from source.
# -------------------------------------------------------------------------------------
set bootsupport_module_paths [list]
@ -209,7 +212,7 @@ if {[file tail $startdir] eq "src"} {
#todo - other src 'module' dirs..
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] {
if {[file exists $p]} {
lappend sourcesupport_module_paths $p
lappend sourcesupport_module_paths $p
}
}
# -- -- --
@ -219,7 +222,7 @@ if {[file tail $startdir] eq "src"} {
}
}
# -- -- --
foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] {
if {[file exists $p]} {
set sourcesupport_paths_exist 1
@ -228,7 +231,7 @@ if {[file tail $startdir] eq "src"} {
}
if {$sourcesupport_paths_exist} {
#launch from <projectdir/src is also likely to be common
#launch from <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
@ -238,7 +241,7 @@ if {[file tail $startdir] eq "src"} {
}
# -------------------------------------------------------------------------------------
set package_paths_modified 0
set package_paths_modified 0
if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list
@ -254,7 +257,7 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
}
}
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] ;#packages we
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk]
if {$support_contents_exist} {
#only forget all *unloaded* package names
foreach pkg [package names] {
@ -270,9 +273,9 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
package forget $pkg
}
}
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths]
}
puts "----> auto_path $::auto_path"
@ -281,18 +284,19 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
#package require Thread
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly.
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies
#These are strong dependencies
package forget punk::mix
package forget punk::repo
package forget punkcheck
package forget punk::repo
package forget punkcheck
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies
package require punk::mix
package require punkcheck
package require punk::lib
package require punk::args
package require punk::ansi
set package_paths_modified 1
@ -302,11 +306,12 @@ if {$bootsupport_paths_exist || $sourcesupport_paths_exist} {
set ::punkboot::pkg_requirements_found [list]
#we will treat 'package require <mver>.<etc>' (minbounded) as <mver>.<etc>-<mver+1> ie explicitly convert to corresponding bounded form
#put some with leading zeros to test normalisation
#put some with leading zeros to test normalisation
set ::punkboot::bootsupport_requirements [dict create\
punk::repo [list version "00.01.01-"]\
punk::mix [list version ""]\
punk::ansi [list]\
punk::args [list]\
overtype [list version "1.6.5-"]\
punkcheck [list]\
fauxlink [list version "0.1.1-"]\
@ -322,7 +327,7 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} {
if {$canonical ne $ver} {
dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo
}
} else {
puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'"
@ -331,9 +336,9 @@ dict for {pkg pkginfo} $::punkboot::bootsupport_requirements {
} else {
#make sure each has a blank version entry if nothing was there.
dict set pkginfo version ""
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo
}
}
}
#Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max
#dict for {k v} $::punkboot::bootsupport_requirements {
# puts "- $k $v"
@ -356,7 +361,7 @@ set ::punkboot::bootsupport_recommended [dict create\
# create an interp in which we hijack package command
# This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required)
# Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW
# Hopefully the only side-effect is that a subsequent load of the package will be faster...
# Hopefully the only side-effect is that a subsequent load of the package will be faster...
# (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found)
# (tcllibc is also highly desirable as the performance impact when not available can be dramatic.)
# ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues.
@ -378,7 +383,7 @@ proc ::punkboot::check_package_availability {args} {
#best effort at auto-determinining packages required (dependencies) based on top-level packages in the list.
#Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability),
# this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional.
# 'optionality' is a contextual concept anyway depending on how the package is intended to be used.
# 'optionality' is a contextual concept anyway depending on how the package is intended to be used.
# The package developer may consider a feature optional - but it may not be optional in a particular usecase.
set bootsupport_requirements [lindex $args end]
@ -484,7 +489,7 @@ proc ::punkboot::check_package_availability {args} {
#should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on
set pkgrequest [list $pkgname $requirements_list]
if {$pkgrequest ni $::test::pkg_requested} {
lappend ::test::pkg_requested $pkgrequest
lappend ::test::pkg_requested $pkgrequest
}
# -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
@ -507,13 +512,13 @@ proc ::punkboot::check_package_availability {args} {
}
if {[llength $::test::pkg_stack]} {
set caller [lindex $::test::pkg_stack end]
set required_by [dict get $pinfo required_by]
set required_by [dict get $pinfo required_by]
if {$caller ni $required_by} {
lappend required_by $caller
}
dict set pinfo required_by $required_by
}
lappend ::test::pkg_stack $pkgname
lappend ::test::pkg_stack $pkgname
#At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require
#review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths..
@ -527,23 +532,23 @@ proc ::punkboot::check_package_availability {args} {
#use our normalised requirements instead of original args
#if {[catch [list ::package_orig {*}$args] result]} {}
if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} {
dict set pinfo testerror $result
dict set pinfo testerror $result
#package missing - or exists - but failing to initialise
if {!$::opt_quiet} {
set parent_path [lrange $::test::pkg_stack 0 end-1]
puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m"
set parent_path [join $parent_path " -> "]
puts stderr "pkg requirements: $parent_path"
puts stderr "pkg requirements: $parent_path"
puts stderr "error during : '$args'"
puts stderr " \x1b\[93m$result\x1b\[m"
}
#the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW
#to determine the version that we attempted to load,
#to determine the version that we attempted to load,
#- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies)
if {![llength $versions]} {
#no versions *and* we had an error - missing is our best guess. review.
#'package versions Tcl' never shows any results
#'package versions Tcl' never shows any results
#so requests for old versions will show as missing not broken.
#This is probably better anyway.
if {$pkgrequest ni $::test::pkg_missing} {
@ -572,21 +577,21 @@ proc ::punkboot::check_package_availability {args} {
lappend selectable_versions $v
}
} else {
#we are operating under 'package prefer' = latest
#we are operating under 'package prefer' = latest
set selectable_versions $ordered_versions
}
if {[llength $requirements_list]} {
#add one or no entry for each requirement.
#pick highest at end
set satisfiers [list]
set satisfiers [list]
foreach requirement $requirements_list {
foreach ver [lreverse $selectable_versions] {
if {[package vsatisfies $ver $requirement]} {
lappend satisfiers $ver
break
}
}
}
}
}
if {[llength $satisfiers]} {
set satisfiers [lsort -command {::package_orig vcompare} $satisfiers]
@ -622,7 +627,7 @@ proc ::punkboot::check_package_availability {args} {
if {![catch {::package_orig files Tcl} ]} {
#tcl9 (also some 8.6/8.7) has 'package files' subcommand.
#unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages.
#We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour
#We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour
#see: https://core.tcl-lang.org/tcl/tktview/209fd9adce
set all_files [::package_orig files $pkgname]
#some arbitrary threshold? REVIEW
@ -637,7 +642,7 @@ proc ::punkboot::check_package_availability {args} {
dict set pinfo packagefiles {} ;#default
#there are all sorts of scripts, so this is not predictably structured
#e.g using things like apply
#we will attempt to get a trailing source .. <file>
#we will attempt to get a trailing source .. <file>
set parts [split [string trim $ifneeded_script] {;}]
set trimparts [list]
foreach p $parts {
@ -648,7 +653,7 @@ proc ::punkboot::check_package_availability {args} {
if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} {
#if it's a file or dir - close enough (?)
#e.g tcllibc uses apply and the last entry is actuall a folder used to find the file..
#we aren't brave enough to try to work out the actual file(s)
#we aren't brave enough to try to work out the actual file(s)
if {[file exists $lastword]} {
dict set pinfo packagefiles $lastword
}
@ -662,10 +667,10 @@ proc ::punkboot::check_package_availability {args} {
return [uplevel 1 [list ::package_orig {*}$args]]
}
}
set ::test::pkg_stack [list]
catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results
dict for {pkg pkgdict} $::test::bootsupport_requirements {
dict for {pkg pkgdict} $::test::bootsupport_requirements {
#set nsquals [namespace qualifiers $pkg]
#if {$nsquals ne ""} {
# catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered
@ -690,7 +695,7 @@ proc ::punkboot::check_package_availability {args} {
# set ver [package provide $pkg]
# if {$ver eq ""} {
# #puts stderr "missing pkg: $pkg"
# lappend ::test::pkg_missing $pkg
# lappend ::test::pkg_missing $pkg
# } else {
# if {[string tolower $pkg] eq "tcl"} {
# #ignore
@ -1180,17 +1185,17 @@ if {$::punkboot::command eq "check"} {
puts stdout "- tcl::tm::list"
foreach fld [tcl::tm::list] {
if {[file exists $fld]} {
puts stdout " $fld"
puts stdout " $fld"
} else {
puts stdout " $fld (not present)"
puts stdout " $fld (not present)"
}
}
puts stdout "- auto_path"
foreach fld $::auto_path {
if {[file exists $fld]} {
puts stdout " $fld"
puts stdout " $fld"
} else {
puts stdout " $fld (not present)"
puts stdout " $fld (not present)"
}
}
flush stdout
@ -1283,22 +1288,22 @@ if {$::punkboot::command eq "info"} {
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil"
@ -1389,10 +1394,9 @@ if {$::punkboot::command eq "vendorupdate"} {
#todo vendor/lib
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
lappend vendormodulefolders vendormodules
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*]
#lappend vendormodulefolders vendormodules
foreach vf $vendormodulefolders {
if {[file exists $sourcefolder/$vf]} {
lassign [split $vf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
@ -1481,7 +1485,6 @@ if {$::punkboot::command eq "vendorupdate"} {
} else {
puts stderr "No config at $vendor_config - nothing configured to update"
}
}
}
}
@ -1508,105 +1511,102 @@ if {$::punkboot::command eq "bootsupport"} {
set bootsupport_modules [list] ;#variable populated by include_modules.config file - review
set sourcefolder $projectroot/src
set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*]
lappend bootmodulefolders modules
set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*]
foreach bm $bootmodulefolders {
if {[file exists $sourcefolder/bootsupport/$bm]} {
lassign [split $bm _] _bm tclx
if {$tclx ne ""} {
set which _$tclx
lassign [split $bm _] _bm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;#
if {[file exists $bootsupport_config]} {
set targetroot $projectroot/src/bootsupport/modules$which
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list
if {![llength $bootsupport_modules]} {
puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating"
} else {
set which ""
}
set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;#
if {[file exists $bootsupport_config]} {
set targetroot $projectroot/src/bootsupport/modules$which
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list
if {![llength $bootsupport_modules]} {
puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating"
} else {
if {[catch {
#----------
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck]
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport
set boot_event [$boot_installer start_event {-make_step bootsupport}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for bootsupport error: $errM"
set boot_event ""
}
if {[catch {
#----------
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck]
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport
set boot_event [$boot_installer start_event {-make_step bootsupport}]
#----------
} errM]} {
puts stderr "Unable to use punkcheck for bootsupport error: $errM"
set boot_event ""
}
foreach {relpath modulematch} $bootsupport_modules {
set modulematch [string trim $modulematch :]
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
}
if {![llength $pkgmatches]} {
puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation"
continue
}
foreach {relpath modulematch} $bootsupport_modules {
set modulematch [string trim $modulematch :]
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]]
set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $modulematch $module_subpath $srclocation"
if {[string first - $modulematch]} {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm]
} else {
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm]
}
if {![llength $pkgmatches]} {
puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation"
continue
}
set modulematch_is_glob [regexp {[*?\[\]]} $modulematch]
if {!$modulematch_is_glob} {
#if modulematch was specified without globs - only copy latest
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func
set pkgmatches [lsort -command modfile_sort $pkgmatches]
set latestfile [lindex $pkgmatches end]
#set latestver [lindex [split [file rootname $latestfile] -] 1]
set copy_files $latestfile
} else {
#globs in modulematch - may be different packages matched by glob - copy all versions of matches
#review
set copy_files $pkgmatches
}
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
if {$boot_event ne ""} {
#----------
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\
} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$boot_event targetset_started
# -- --- --- --- --- ---
puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$boot_event targetset_end FAILED
} else {
$boot_event targetset_end OK
}
# -- --- --- --- --- ---
set modulematch_is_glob [regexp {[*?\[\]]} $modulematch]
if {!$modulematch_is_glob} {
#if modulematch was specified without globs - only copy latest
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func
set pkgmatches [lsort -command modfile_sort $pkgmatches]
set latestfile [lindex $pkgmatches end]
#set latestver [lindex [split [file rootname $latestfile] -] 1]
set copy_files $latestfile
} else {
#globs in modulematch - may be different packages matched by glob - copy all versions of matches
#review
set copy_files $pkgmatches
}
foreach cfile $copy_files {
set srcfile [file join $srclocation $cfile]
set tgtfile [file join $targetroot $module_subpath $cfile]
if {$boot_event ne ""} {
#----------
$boot_event targetset_init INSTALL $tgtfile
$boot_event targetset_addsource $srcfile
#----------
if {\
[llength [dict get [$boot_event targetset_source_changes] changed]]\
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\
} {
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists
$boot_event targetset_started
# -- --- --- --- --- ---
puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile"
if {[catch {
file copy -force $srcfile $tgtfile
} errM]} {
$boot_event targetset_end FAILED
} else {
puts -nonewline stderr "."
$boot_event targetset_end SKIPPED
$boot_event targetset_end OK
}
$boot_event end
# -- --- --- --- --- ---
} else {
file copy -force $srcfile $tgtfile
puts -nonewline stderr "."
$boot_event targetset_end SKIPPED
}
$boot_event end
} else {
file copy -force $srcfile $tgtfile
}
}
if {$boot_event ne ""} {
puts \n
$boot_event destroy
$boot_installer destroy
}
}
if {$boot_event ne ""} {
puts \n
$boot_event destroy
$boot_installer destroy
}
}
}
}
}
@ -1699,59 +1699,53 @@ if {$::punkboot::command ni {project modules vfs}} {
#install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list)
if {$::punkboot::command in {project modules}} {
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
lappend vendorlibfolders vendorlib
foreach lf $vendorlibfolders {
if {[file exists $sourcefolder/$lf]} {
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep.
# **/test.txt will match at any level below the root (but not in the root)
set antipaths [list\
README.md\
]
puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
}
if {![llength $vendorlibfolders]} {
puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found."
}
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
lappend vendormodulefolders vendormodules
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*]
foreach vf $vendormodulefolders {
if {[file exists $sourcefolder/$vf]} {
lassign [split $vf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_module_folder $projectroot/modules$which
file mkdir $target_module_folder
#install .tm *and other files*
puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
lassign [split $vf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_module_folder $projectroot/modules$which
file mkdir $target_module_folder
#install .tm *and other files*
puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
if {![llength $vendormodulefolders]} {
puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found."
}
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*]
foreach lf $vendorlibfolders {
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep.
# **/test.txt will match at any level below the root (but not in the root)
set antipaths [list\
README.md\
]
puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
if {![llength $vendorlibfolders]} {
puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found."
}
########################################################
#templates
#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
@ -1760,10 +1754,10 @@ if {$::punkboot::command in {project modules}} {
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 layoutbase $layout_bases {
if {![file exists $layoutbase]} {
@ -1823,27 +1817,25 @@ if {$::punkboot::command in {project modules}} {
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
foreach lf $projectlibfolders {
if {[file exists $sourcefolder/$lf]} {
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep.
# **/test.txt will match at any level below the root (but not in the root)
set antipaths [list\
README.md\
]
puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep.
# **/test.txt will match at any level below the root (but not in the root)
set antipaths [list\
README.md\
]
puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
if {![llength $projectlibfolders]} {
puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found."
@ -2355,7 +2347,7 @@ foreach vfstail $vfs_tails {
} else {
lappend runtimes $matchrt
}
}
}
}
#assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config

Write Preview
Loading…
Cancel
Save