Browse Source

bootsupport + layout sync: punkboot::utils 0.2.0, pending 0.2.0 module snapshots

make.tcl modules + make.tcl bootsupport outputs (punkcheck-managed, batched
per src/AGENTS.md): punkboot::utils 0.1.1 -> 0.2.0 (scoped vcs_dirty_warnings)
plus the pending libunknown / mix::commandset::loadedlib / args::moduledoc
tclcore 0.2.0 snapshot updates from the lib.search work, superseded versions
pruned. Layout make.tcl copies picked up the dirty-src provenance gate via the
same bootsupport propagation.

Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
Julian Noble 4 days ago
parent
commit
803f3ca5ff
  1. 105
      src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm
  2. 210
      src/bootsupport/modules/punk/libunknown-0.2.0.tm
  3. 71
      src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm
  4. 54
      src/bootsupport/modules/punkboot/utils-0.2.0.tm
  5. 120
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  6. 105
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm
  7. 210
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm
  8. 71
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm
  9. 54
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm
  10. 120
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  11. 105
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm
  12. 210
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm
  13. 71
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm
  14. 54
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm
  15. 120
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

105
src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm → src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm

@ -8,7 +8,7 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::args::moduledoc::tclcore 0.1.0
# Application punk::args::moduledoc::tclcore 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.1.0]
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.2.0]
#[copyright "2025"]
#[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}]
#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}]
@ -9817,41 +9817,37 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# ==============================================================================================================
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {
alnum
alpha
ascii
boolean
control
dict
digit
double
entier
false
graph
integer
list
lower
print
punct
space
true
upper
wideinteger
wordchar
xdigit
}\
-choicelabels {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
alnum
" Any Unicode alphabet
or digit character"
@ -9877,7 +9873,9 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
will contain the index of
the \"element\" where the
dict parsing fails or -1 if
this cannot be determined."
this cannot be determined.
(class not present in
Tcl 8.6)"
digit
" Any Unicode digit char.
Note that this includes
@ -9937,6 +9935,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
" Any of the forms allowed
for Tcl_GetBoolean where the
value is true"
unicode
" Any Unicode character.
(class exists only in the
unreleased Tcl 8.7 series -
removed in Tcl 9)"
upper
" Any upper case alphabet
character in the Unicode
@ -9959,7 +9962,29 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
xdigit
" Any hexadecimal digit
character ([0-9A-Fa-f])."
}\
}]
set string_is_choicelabels ""
foreach _sis_c $string_is_classes {
if {[dict exists $string_is_class_descriptions $_sis_c]} {
append string_is_choicelabels [list $_sis_c] " " [list [dict get $string_is_class_descriptions $_sis_c]] \n
} else {
append string_is_choicelabels [list $_sis_c] " " [list " (class accepted by this Tcl\n runtime - not yet described\n in the punk tclcore docs)"] \n
}
}
unset -nocomplain _sis_msg _sis_csv _sis_c
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {${$string_is_classes}}\
-choicelabels {${$string_is_choicelabels}}\
-help\
"character class
In the case of boolean, true and false, if the function will return 0, then the
@ -12518,7 +12543,7 @@ namespace eval ::punk::args::register {
package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore {
variable pkg punk::args::moduledoc::tclcore
variable version
set version 0.1.0
set version 0.2.0
}]
return

210
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm → src/bootsupport/modules/punk/libunknown-0.2.0.tm

@ -7,17 +7,34 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::libunknown 0.1
# Application punk::libunknown 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
#
# Version history (manually versioned module - the real version lives in the
# filename and the 'package provide' block at the bottom; there is no
# <name>-buildversion.txt. Apply the standard Patch/Minor/Major bump rules
# from src/modules/AGENTS.md "Versioning And Releases" - bumping means
# renaming the file AND updating the Meta line above, the manpage_begin line
# below and the provide-block version, then appending a line here):
#0.2.0 - register_all_tm: deep discovery proc registering ifneeded scripts for
# .tm modules at every namespace depth (once per tm epoch, interp-local
# tm_fullscan guard); used by 'dev lib.search' by default
#0.2.0 - source_pkgindex: pkgIndex.tcl scripts execute in an isolated frame
# ($dir formal + auto_path/env global links) instead of at :: scope -
# user global 'dir' no longer clobbered, index helper vars no longer
# leak into the global namespace ('global dir' removed from
# zipfs_tclPkgUnknown)
#0.1 - initial: epoch-based zipfs_tm_UnknownHandler/zipfs_tclPkgUnknown
# package unknown chain, 'package epoch' command, controlled forget
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.2.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -81,6 +98,10 @@ tcl::namespace::eval ::punk::libunknown {
}]
variable epoch ;#don't set - can be pre-set cooperatively
variable tm_fullscan [dict create] ;#tm epochs fully scanned by register_all_tm.
#Deliberately interp-local (NOT part of the shareable epoch dict): 'package ifneeded'
#registrations are interp-local, so an interp receiving a shared epoch must still run
#its own registration pass (cheap - directory listings come from the shared index cache).
variable has_package_files
if {[catch {package files foobaz}]} {
@ -100,6 +121,21 @@ tcl::namespace::eval ::punk::libunknown {
}
}
#Execute a pkgIndex.tcl script in this proc's frame (tcl_Pkg_source uplevels
#the actual 'source' into its caller).
#The pkgIndex.tcl contract is that $dir holds the index file's directory, and
#stock tclPkgUnknown additionally exposes the auto_path and env globals (some
#indexes, e.g tcllib's, extend auto_path with an unqualified lappend).
#Providing exactly that environment here means anything ELSE the script sets
#stays local to this frame and is discarded - previously indexes were sourced
#via 'namespace eval ::', which clobbered any user global named 'dir' (via the
#handler's since-removed 'global dir') and leaked each index's helper
#variables (ver, pkg, script, ...) into the global namespace.
proc source_pkgindex {dir indexfile} {
global auto_path env
tcl_Pkg_source $indexfile
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@ -492,6 +528,12 @@ tcl::namespace::eval ::punk::libunknown {
Key differences from Tcl's standard tclPkgUnknown:
- Uses an epoch-based cache to avoid re-sourcing pkgIndex.tcl files that have
already been processed in the current epoch.
- pkgIndex.tcl scripts execute in an isolated frame (see source_pkgindex)
providing the documented \$dir variable plus auto_path/env global links.
Stray unqualified variables set by index scripts stay local to that frame
instead of leaking into the global namespace, and user globals (notably
'dir') are not clobbered. Stock tclPkgUnknown instead exposes all of its
own proc locals to the index scripts.
- Processes auto_path entries from end to front (same as tclPkgUnknown), but
tracks which packages and versions were added or changed by each pkgIndex.tcl
so that ifneeded scripts from earlier (higher-priority) paths can be reverted
@ -514,7 +556,10 @@ tcl::namespace::eval ::punk::libunknown {
proc zipfs_tclPkgUnknown {name args} {
#puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL"
global dir
#Note: no 'global dir' here (an earlier revision had one so that pkgIndex.tcl
#scripts sourced at :: scope could read $dir - at the cost of clobbering any
#user global named 'dir'). Index scripts now execute in a source_pkgindex
#frame which provides $dir locally - see source_pkgindex.
variable epoch
set pkg_epoch [dict get $epoch pkg current]
@ -679,9 +724,8 @@ tcl::namespace::eval ::punk::libunknown {
# puts stderr "----->0 sourcing zipfs file $file"
#}
incr sourced ;#count as sourced even if source fails; keep before actual source action
#::tcl::Pkg::source $file
#lappend sourced_files $file
namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)"
@ -711,8 +755,7 @@ tcl::namespace::eval ::punk::libunknown {
#puts "----->2 sourcing $file"
incr sourced
#lappend sourced_files $file
#::tcl::Pkg::source $file
namespace eval :: [list punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)"
@ -1195,6 +1238,157 @@ tcl::namespace::eval ::punk::libunknown {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::libunknown::register_all_tm
@cmd -name punk::libunknown::register_all_tm\
-summary\
"Deep discovery: register ifneeded scripts for all .tm modules at every namespace depth."\
-help\
"Walks every path in tcl::tm::list recursively and registers a 'package ifneeded'
script for each .tm module found - including modules in namespace subfolders
that have never been requested. (The tm package unknown handler registers
sibling .tm files only at the namespace depth of the package being required,
so such modules are otherwise absent from 'package names' until first
requested.)
Existing ifneeded scripts are never overridden - first registration wins,
matching the tm unknown handler, so head-of-tm-list precedence for
same-version modules is preserved.
Uses and populates the same per-epoch directory index cache as the unknown
handlers: for zipfs (static) paths the whole tree listing is gathered in one
call; for filesystem paths each directory's *.tm glob is cached per
'package epoch'. Directories named #modpod-*, #tarjar-* and _build are
skipped.
The scan runs at most once per tm epoch per interp (tracked in the
interp-local tm_fullscan variable - deliberately not part of the shareable
epoch dict, because ifneeded registrations are interp-local; an interp
receiving a shared epoch re-registers cheaply from the cached indexes).
Path-list changes and 'package epoch incr' start a new tm epoch,
re-enabling the scan - a call after 'package epoch incr' re-reads the
filesystem and picks up modules added or removed on disk.
Returns a stats dict: epoch, roots, dirs, tmfiles, registered - plus
'cached 1' when the call was a per-epoch no-op.
punk::libunknown::init must have been called first."
@opts
-force -type none -help\
"Run the registration pass even if already performed in the current tm epoch.
Directory listings still come from the epoch index cache where present -
use 'package epoch incr' first to force re-reading the filesystem."
}]
}
proc register_all_tm {args} {
variable epoch
if {![info exists epoch]} {
error "punk::libunknown::register_all_tm - punk::libunknown::init has not been called in this interp"
}
set opt_force [expr {"-force" in $args}]
variable tm_fullscan
set tm_epoch [dict get $epoch tm current]
if {!$opt_force && [dict exists $tm_fullscan $tm_epoch]} {
return [dict merge [dict get $tm_fullscan $tm_epoch] [dict create cached 1]]
}
upvar ::tcl::tm::paths paths
upvar ::tcl::tm::pkgpattern pkgpattern
if {[info commands ::tcl::zipfs::root] ne ""} {
set zipfsroot [tcl::zipfs::root]
set has_zipfs 1
} else {
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands
set has_zipfs 0
}
set stat_roots 0
set stat_dirs 0
set stat_files 0
set stat_registered 0
foreach path $paths {
if {![interp issafe] && ![file exists $path]} {
continue
}
incr stat_roots
set tmfiles [list]
if {$has_zipfs && [string match $zipfsroot* $path]} {
#static filesystem - the whole tm tree is available in one quick call
#(as the tm unknown handler's zipfs branch does)
set tmfiles [::tcl::zipfs::list $path/*.tm]
set seen_dirs [dict create]
foreach tm_path $tmfiles {
set d [file dirname $tm_path]
dict set seen_dirs $d 1
dict set epoch tm epochs $tm_epoch indexes $d $tm_path $tm_epoch
}
incr stat_dirs [dict size $seen_dirs]
} else {
#plain filesystem - breadth-first walk, reusing/populating the per-epoch
#directory index cache so the unknown handlers can short-circuit later
set pending [list $path]
while {[llength $pending]} {
set current [lindex $pending 0]
set pending [lrange $pending 1 end]
incr stat_dirs
if {[dict exists $epoch tm epochs $tm_epoch indexes $current]} {
set dirfiles [dict keys [dict get $epoch tm epochs $tm_epoch indexes $current]]
} else {
set dirfiles [glob -nocomplain -directory $current -types f *.tm]
dict set epoch tm epochs $tm_epoch indexes $current [dict create]
foreach f $dirfiles {
dict set epoch tm epochs $tm_epoch indexes $current $f $tm_epoch
}
}
lappend tmfiles {*}$dirfiles
foreach sub [glob -nocomplain -directory $current -types d *] {
set tail [file tail $sub]
if {[string match "#modpod-*" $tail] || [string match "#tarjar-*" $tail] || $tail eq "_build"} {
continue
}
lappend pending $sub
}
}
}
#registration - same rules as the tm unknown handler (don't override existing
#ifneeded scripts: for tm modules the first encountered 'wins')
set strip [llength [file split $path]]
foreach file $tmfiles {
if {[string match "*/_build/*" $file]} {
continue
}
incr stat_files
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
# Ignore everything not matching our pattern for package names.
continue
}
try {
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not acceptable to
# "package vcompare".
continue
}
if {([package ifneeded $pkgname $pkgversion] ne {}) && (![interp issafe])} {
#already registered - possibly by an earlier (higher precedence) path
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
continue
}
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source $file]"
incr stat_registered
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
}
}
set stats [dict create epoch $tm_epoch roots $stat_roots dirs $stat_dirs tmfiles $stat_files registered $stat_registered]
dict set tm_fullscan $tm_epoch $stats
return $stats
}
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about.
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem)
#in practice the info is only available for tm modules
@ -1925,7 +2119,7 @@ namespace eval ::punk::args::register {
package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown {
variable pkg punk::libunknown
variable version
set version 0.1
set version 0.2.0
}]
return

71
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm → src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::mix::commandset::loadedlib 0.1.0
# Application punk::mix::commandset::loadedlib 0.2.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -28,13 +28,37 @@ namespace eval punk::mix::commandset::loadedlib {
#search automatically wrapped in * * - can contain inner * ? globs
punk::args::define {
@id -id ::punk::mix::commandset::loadedlib::search
@cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
@cmd -name "punk::mix::commandset::loadedlib search" -help\
"search all Tcl libraries available to your local interpreter.
When punk::libunknown is active (the punkshell default) a deep module
discovery pass runs first, so .tm modules at every namespace depth are
included - cached per 'package epoch', repeat searches are cheap.
See -refresh for cache/re-scan details."
-return -type string -default table -choices {table tableobject list lines}
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
"(unimplemented) Display only those that are 0:absent 1:present 2:either"
-highlight -type boolean -default 1 -help\
"Highlight which version is present with ansi underline and colour"
-refresh -type none -help "Re-scan the tm and library folders"
-refresh -type none -help\
"Force a genuine filesystem re-scan of the module and library folders.
When punk::libunknown is active (the punkshell default), every search
already performs a deep module discovery pass - registering .tm modules
at every namespace depth across all tcl::tm::list paths (see
punk::libunknown::register_all_tm) - cached per 'package epoch' so
repeat searches are cheap. Because directories already indexed in the
current epoch are not re-globbed, that default pass does not notice .tm
files added to (or removed from) already-scanned folders.
-refresh increments the package epoch ('package epoch incr'),
invalidating the scan caches, then re-runs discovery - picking up
on-disk changes and re-sourcing the pkgIndex.tcl files on ::auto_path.
Changes to tcl::tm::list or ::auto_path increment the epoch
automatically (via variable traces) - this flag is not needed for
those cases.
When punk::libunknown is not active there is no epoch cache: the
default search reflects only packages already registered in the
package database, and -refresh performs the (comparatively expensive)
deep discovery walk directly using dummy package require calls at
each namespace depth."
searchstring -default * -multiple 1 -help\
"Names to search for, may contain glob chars (* ?) e.g *lib*
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs.
@ -51,8 +75,35 @@ namespace eval punk::mix::commandset::loadedlib {
set opt_highlight [dict get $opts -highlight]
set opt_refresh [dict exists $received -refresh]
#Deep discovery of available packages.
#The package unknown handlers register .tm siblings only at the namespace depth
#being requested - modules in never-requested subfolders are absent from
#'package names' until a deep pass registers them.
#Note: ::info must be fully qualified here - this namespace defines its own 'info' proc
if {[::info commands ::punk::libunknown::register_all_tm] ne "" && [::info exists ::punk::libunknown::epoch]} {
if {$opt_refresh} {
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans
#genuine filesystem re-scan: start a new package epoch so the scan
#caches are invalidated (pkgIndex.tcl files on ::auto_path will also be
#re-sourced by the dummy require below)
package epoch incr
}
#register .tm modules at every namespace depth (cached per tm epoch -
#repeat searches are cheap)
punk::libunknown::register_all_tm
#sweep the pkgIndex.tcl files of ::auto_path for library-style packages
catch {package require frobznodule666}
} else {
#punk::libunknown deep registration unavailable - without its epoch cache a
#recursive walk on every search would be expensive, so deep discovery runs
#only on explicit request.
if {$opt_refresh} {
if {[::info exists ::punk::libunknown::epoch]} {
#older punk::libunknown without register_all_tm: invalidate its scan
#caches so the dummy requires below re-read the filesystem
catch {package epoch incr}
}
catch {package require frobznodule666} ;#top-level tm scan + pkgIndex sweep of ::auto_path
package require punk::path
foreach tm_path [tcl::tm::list] {
set paths_below [punk::path::subfolders -recursive $tm_path]
foreach folder $paths_below {
@ -67,6 +118,7 @@ namespace eval punk::mix::commandset::loadedlib {
}
}
}
}
set packages [package names]
@ -85,8 +137,12 @@ namespace eval punk::mix::commandset::loadedlib {
}
set matches [lsort -unique $matches]
set matchinfo [list]
set highlight_ansi [a+ web-limegreen underline]
set RST [a]
if {$opt_highlight} {
#not a module-top require: punk::ansi is only needed for highlighting
package require punk::ansi
set highlight_ansi [punk::ansi::a+ web-limegreen underline]
set RST [punk::ansi::a]
}
foreach m $matches {
set versions [package versions $m]
if {![llength $versions]} {
@ -122,6 +178,7 @@ namespace eval punk::mix::commandset::loadedlib {
return [join $matchinfo \n]
}
table - tableobject {
package require textblock
set t [textblock::class::table new]
$t add_column -headers "Package"
$t add_column -headers "Version"
@ -601,6 +658,6 @@ namespace eval punk::mix::commandset::loadedlib {
## Ready
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib {
variable version
set version 0.1.0
set version 0.2.0
}]
return

54
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm → src/bootsupport/modules/punkboot/utils-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punkboot::utils 0.1.1
# Application punkboot::utils 0.2.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -134,6 +134,10 @@ namespace eval punkboot::utils {
used to report each VCS root at most once across calls.
label, if supplied, is prefixed into each warning to name
the calling operation (e.g. 'vendorupdate').
scope, if supplied, is a subpath relative to path; only
uncommitted changes under that subpath are counted (e.g.
scope 'src' warns about dirty src/ while ignoring dirt
elsewhere in the checkout).
Returns an empty list if the path is clean, unversioned,
missing, already reported, or state cannot be determined."
@ -144,9 +148,11 @@ namespace eval punkboot::utils {
"Name of a dict variable in the caller's scope for dedupe across calls"
label -type string -optional 1 -default "" -help\
"Operation name prefixed into warnings"
scope -type string -optional 1 -default "" -help\
"Subpath relative to path limiting which changes count; empty = whole checkout"
}]
}
proc vcs_dirty_warnings {path checkedrootsvar {label ""}} {
proc vcs_dirty_warnings {path checkedrootsvar {label ""} {scope ""}} {
upvar 1 $checkedrootsvar checkedroots
if {![info exists checkedroots]} {set checkedroots [dict create]}
if {$label ne ""} {set label "$label "}
@ -155,6 +161,12 @@ namespace eval punkboot::utils {
if {![file isdirectory $dir]} {
return $warnings ;#missing path - not this proc's business to report
}
set scopeabs ""
set scopedesc "" ;#included in warning text when scoped
if {$scope ne ""} {
set scopeabs [file normalize [file join $dir $scope]]
set scopedesc " under [string trimright $scope /]/"
}
set fossilroot ""
set gitroot ""
while {1} {
@ -171,8 +183,8 @@ namespace eval punkboot::utils {
if {$parent eq $dir} { break }
set dir $parent
}
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot 1
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot,$scope] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot,$scope 1
#fossil changes must run from within the checkout
set original_cwd [pwd]
if {[catch {
@ -180,19 +192,37 @@ namespace eval punkboot::utils {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
return $warnings
@ -207,8 +237,8 @@ namespace eval ::punk::args::register {
## Ready
package provide punkboot::utils [tcl::namespace::eval punkboot::utils {
variable version
#- this version number, exactly 0.1.1, is a literal used in src module folders
#- this version number, exactly 0.2.0, is a literal used in src module folders
#- we refer to this sometimes as the magic version number
set version 0.1.1
set version 0.2.0
}]
return

120
src/project_layouts/custom/_project/punk.basic/src/make.tcl

@ -20,7 +20,7 @@ namespace eval ::punkboot {
variable scriptfolder [file normalize [file dirname [info script]]]
variable foldername [file tail $scriptfolder]
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable non_help_flags [list -k -dirty-abort]
variable help_flags [list -help --help /? -h]
variable known_commands [list project modules libs packages vfs vfslibs bin info check shell vendorupdate bootsupport vfscommonupdate projectversion]
}
@ -1364,6 +1364,13 @@ proc ::punkboot::punkboot_gethelp {args} {
append h " - run the punk shell using bootsupport libraries." \n
append h " $scriptname projectversion" \n
append h " - advisory check: verify CHANGELOG.md matches punkproject.toml and warn if src/ has changes since the last project-version bump." \n \n
append h " Flags:" \n
append h " -dirty-abort" \n
append h " - abort build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) when src/ has" \n
append h " uncommitted VCS changes. Default is warn-only: artifacts built from dirty src have no committed provenance." \n
append h " Warnings carry a plain PROVENANCE-WARNING: prefix (greppable in redirected output) and are recapped at the end of the run." \n
append h " Use '$scriptname check' to see the current provenance status. To evaluate uncommitted source without building," \n
append h " use '<builtexe> src' or '<builtexe> src shell'." \n \n
append h "" \n
if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} {
set has_recommended 0
@ -1604,6 +1611,98 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
set sourcefolder $projectroot/src
set binfolder $projectroot/bin
# ----------------------------------------
# Provenance-warning presentation + dirty-src check for build/promotion commands (goal G-026 direction).
# Build/promotion commands stamp versions onto src content and propagate it into trees other
# things consume (root modules/, bootsupport snapshots, vfs payloads, kits/zipkits).
# Artifacts built from uncommitted src have no committed provenance - warn by default,
# abort if the -dirty-abort flag was given. To evaluate uncommitted source without
# building, use '<builtexe> src' / '<builtexe> src shell' instead.
# Guarded require: a stale or missing punkboot::utils bootsupport snapshot must never
# brick the make.tcl commands used to repair it - the check degrades to a skip notice
# (but -dirty-abort still aborts rather than silently skipping the requested strictness).
#Emit provenance warnings with a plain column-0 token for automated discovery (grep PROVENANCE-WARNING
#in redirected output) and ANSI colour for humans. Lines are also accumulated in
#::punkboot::provenance_warnings_pending unless -norecap is given, so the wrapped ::exit below can
#recap them at the tail of the output - build progress output is chatty and the original warning
#position may scroll out of sight or even out of scrollback.
set ::punkboot::provenance_warnings_pending [list]
proc ::punkboot::print_provenance_warnings {warninglines args} {
global A
if {![array size A]} {punkboot::define_global_ansi}
foreach w $warninglines {
regsub {^WARNING: } $w "" w
puts stderr "PROVENANCE-WARNING: $A(BAD)$w$A(RST)"
if {"-norecap" ni $args} {
lappend ::punkboot::provenance_warnings_pending $w
}
}
flush stderr
}
#Availability probe + scoped dirty-src check, shared by the build/promotion gate below and the
#'check' command report. Returns {available warninglist}.
proc ::punkboot::get_src_provenance_warnings {projectroot label} {
set available [expr {\
![catch {package require punkboot::utils}]\
&& [llength [info commands ::punkboot::utils::vcs_dirty_warnings]]\
&& "scope" in [info args ::punkboot::utils::vcs_dirty_warnings]\
}]
if {!$available} {
return [list 0 [list]]
}
set checked_vcs_roots [dict create]
return [list 1 [::punkboot::utils::vcs_dirty_warnings $projectroot checked_vcs_roots $label src]]
}
#Wrap ::exit so accumulated provenance warnings are recapped at the very end of output no matter
#which of make.tcl's many exit points a command takes.
if {![llength [info commands ::punkboot::exit_original]]} {
rename ::exit ::punkboot::exit_original
proc ::exit {{returnCode 0}} {
if {[info exists ::punkboot::provenance_warnings_pending] && [llength $::punkboot::provenance_warnings_pending]} {
puts stderr ""
puts stderr "PROVENANCE-WARNING: recap of warning(s) emitted earlier in this run:"
::punkboot::print_provenance_warnings $::punkboot::provenance_warnings_pending -norecap
}
::punkboot::exit_original $returnCode
}
}
if {$::punkboot::command in {project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate}} {
set dirty_abort [expr {[lsearch $::argv -dirty-abort] >= 0}]
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl $::punkboot::command"] have_scoped_dirty_check dirty_warnings
if {$have_scoped_dirty_check} {
if {[llength $dirty_warnings]} {
::punkboot::print_provenance_warnings $dirty_warnings
puts stderr " To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
if {$dirty_abort} {
set ::punkboot::provenance_warnings_pending [list] ;#no recap needed - aborting adjacent to the warning
puts stderr "-aborted- (-dirty-abort given and src has uncommitted changes - commit first, or rerun without -dirty-abort to build with a warning)"
exit 1
}
#Grace period for an attentive human to ctrl-c - only when stdin is a terminal
#(-inputmode is only supported on terminal channels, Tcl 8.7+/9; pipes/redirects/8.6 skip the delay
# so agent/CI runs pay nothing)
if {![catch {chan configure stdin -inputmode}]} {
puts -nonewline stderr " proceeding despite dirty src - ctrl-c now to abort "
flush stderr
foreach tick {3 2 1} {
puts -nonewline stderr "..$tick"
flush stderr
after 1000
}
puts stderr ""
}
}
} else {
if {$dirty_abort} {
puts stderr "-aborted- (-dirty-abort given but the dirty-src provenance check is unavailable: punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
exit 1
}
puts stderr "NOTE: dirty-src provenance check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport) - continuing without it"
}
}
if {$::punkboot::command eq "check"} {
set sep [string repeat - 75]
puts stdout $sep
@ -1738,6 +1837,21 @@ if {$::punkboot::command eq "check"} {
puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport"
puts stderr "=============================================================================="
}
# Dirty-src provenance status - what the build/promotion commands would do
puts stdout $sep
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl check"] _prov_available _prov_warnings
if {!$_prov_available} {
puts stdout "src provenance: check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
puts stdout " build/promotion commands will proceed with a NOTE; -dirty-abort would abort as unverifiable."
} elseif {![llength $_prov_warnings]} {
puts stdout "src provenance: OK (no uncommitted fossil/git changes under src/)"
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will proceed without provenance warnings."
} else {
::punkboot::print_provenance_warnings $_prov_warnings -norecap
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will WARN as above and proceed."
puts stdout " With -dirty-abort they would abort. To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
}
puts stdout $sep
exit 0
}
@ -2040,9 +2154,7 @@ if {$::punkboot::command eq "vendorupdate"} {
set normsrclocation [file normalize $srclocation]
if {![dict exists $checked_source_paths $normsrclocation]} {
dict set checked_source_paths $normsrclocation 1
foreach w [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate] {
puts stderr $w
}
::punkboot::print_provenance_warnings [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate]
}
}
#puts stdout "$relpath $module $module_subpath $srclocation"

105
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm

@ -8,7 +8,7 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::args::moduledoc::tclcore 0.1.0
# Application punk::args::moduledoc::tclcore 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.1.0]
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.2.0]
#[copyright "2025"]
#[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}]
#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}]
@ -9817,41 +9817,37 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# ==============================================================================================================
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {
alnum
alpha
ascii
boolean
control
dict
digit
double
entier
false
graph
integer
list
lower
print
punct
space
true
upper
wideinteger
wordchar
xdigit
}\
-choicelabels {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
alnum
" Any Unicode alphabet
or digit character"
@ -9877,7 +9873,9 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
will contain the index of
the \"element\" where the
dict parsing fails or -1 if
this cannot be determined."
this cannot be determined.
(class not present in
Tcl 8.6)"
digit
" Any Unicode digit char.
Note that this includes
@ -9937,6 +9935,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
" Any of the forms allowed
for Tcl_GetBoolean where the
value is true"
unicode
" Any Unicode character.
(class exists only in the
unreleased Tcl 8.7 series -
removed in Tcl 9)"
upper
" Any upper case alphabet
character in the Unicode
@ -9959,7 +9962,29 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
xdigit
" Any hexadecimal digit
character ([0-9A-Fa-f])."
}\
}]
set string_is_choicelabels ""
foreach _sis_c $string_is_classes {
if {[dict exists $string_is_class_descriptions $_sis_c]} {
append string_is_choicelabels [list $_sis_c] " " [list [dict get $string_is_class_descriptions $_sis_c]] \n
} else {
append string_is_choicelabels [list $_sis_c] " " [list " (class accepted by this Tcl\n runtime - not yet described\n in the punk tclcore docs)"] \n
}
}
unset -nocomplain _sis_msg _sis_csv _sis_c
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {${$string_is_classes}}\
-choicelabels {${$string_is_choicelabels}}\
-help\
"character class
In the case of boolean, true and false, if the function will return 0, then the
@ -12518,7 +12543,7 @@ namespace eval ::punk::args::register {
package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore {
variable pkg punk::args::moduledoc::tclcore
variable version
set version 0.1.0
set version 0.2.0
}]
return

210
src/bootsupport/modules/punk/libunknown-0.1.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm

@ -7,17 +7,34 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::libunknown 0.1
# Application punk::libunknown 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
#
# Version history (manually versioned module - the real version lives in the
# filename and the 'package provide' block at the bottom; there is no
# <name>-buildversion.txt. Apply the standard Patch/Minor/Major bump rules
# from src/modules/AGENTS.md "Versioning And Releases" - bumping means
# renaming the file AND updating the Meta line above, the manpage_begin line
# below and the provide-block version, then appending a line here):
#0.2.0 - register_all_tm: deep discovery proc registering ifneeded scripts for
# .tm modules at every namespace depth (once per tm epoch, interp-local
# tm_fullscan guard); used by 'dev lib.search' by default
#0.2.0 - source_pkgindex: pkgIndex.tcl scripts execute in an isolated frame
# ($dir formal + auto_path/env global links) instead of at :: scope -
# user global 'dir' no longer clobbered, index helper vars no longer
# leak into the global namespace ('global dir' removed from
# zipfs_tclPkgUnknown)
#0.1 - initial: epoch-based zipfs_tm_UnknownHandler/zipfs_tclPkgUnknown
# package unknown chain, 'package epoch' command, controlled forget
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.2.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -81,6 +98,10 @@ tcl::namespace::eval ::punk::libunknown {
}]
variable epoch ;#don't set - can be pre-set cooperatively
variable tm_fullscan [dict create] ;#tm epochs fully scanned by register_all_tm.
#Deliberately interp-local (NOT part of the shareable epoch dict): 'package ifneeded'
#registrations are interp-local, so an interp receiving a shared epoch must still run
#its own registration pass (cheap - directory listings come from the shared index cache).
variable has_package_files
if {[catch {package files foobaz}]} {
@ -100,6 +121,21 @@ tcl::namespace::eval ::punk::libunknown {
}
}
#Execute a pkgIndex.tcl script in this proc's frame (tcl_Pkg_source uplevels
#the actual 'source' into its caller).
#The pkgIndex.tcl contract is that $dir holds the index file's directory, and
#stock tclPkgUnknown additionally exposes the auto_path and env globals (some
#indexes, e.g tcllib's, extend auto_path with an unqualified lappend).
#Providing exactly that environment here means anything ELSE the script sets
#stays local to this frame and is discarded - previously indexes were sourced
#via 'namespace eval ::', which clobbered any user global named 'dir' (via the
#handler's since-removed 'global dir') and leaked each index's helper
#variables (ver, pkg, script, ...) into the global namespace.
proc source_pkgindex {dir indexfile} {
global auto_path env
tcl_Pkg_source $indexfile
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@ -492,6 +528,12 @@ tcl::namespace::eval ::punk::libunknown {
Key differences from Tcl's standard tclPkgUnknown:
- Uses an epoch-based cache to avoid re-sourcing pkgIndex.tcl files that have
already been processed in the current epoch.
- pkgIndex.tcl scripts execute in an isolated frame (see source_pkgindex)
providing the documented \$dir variable plus auto_path/env global links.
Stray unqualified variables set by index scripts stay local to that frame
instead of leaking into the global namespace, and user globals (notably
'dir') are not clobbered. Stock tclPkgUnknown instead exposes all of its
own proc locals to the index scripts.
- Processes auto_path entries from end to front (same as tclPkgUnknown), but
tracks which packages and versions were added or changed by each pkgIndex.tcl
so that ifneeded scripts from earlier (higher-priority) paths can be reverted
@ -514,7 +556,10 @@ tcl::namespace::eval ::punk::libunknown {
proc zipfs_tclPkgUnknown {name args} {
#puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL"
global dir
#Note: no 'global dir' here (an earlier revision had one so that pkgIndex.tcl
#scripts sourced at :: scope could read $dir - at the cost of clobbering any
#user global named 'dir'). Index scripts now execute in a source_pkgindex
#frame which provides $dir locally - see source_pkgindex.
variable epoch
set pkg_epoch [dict get $epoch pkg current]
@ -679,9 +724,8 @@ tcl::namespace::eval ::punk::libunknown {
# puts stderr "----->0 sourcing zipfs file $file"
#}
incr sourced ;#count as sourced even if source fails; keep before actual source action
#::tcl::Pkg::source $file
#lappend sourced_files $file
namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)"
@ -711,8 +755,7 @@ tcl::namespace::eval ::punk::libunknown {
#puts "----->2 sourcing $file"
incr sourced
#lappend sourced_files $file
#::tcl::Pkg::source $file
namespace eval :: [list punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)"
@ -1195,6 +1238,157 @@ tcl::namespace::eval ::punk::libunknown {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::libunknown::register_all_tm
@cmd -name punk::libunknown::register_all_tm\
-summary\
"Deep discovery: register ifneeded scripts for all .tm modules at every namespace depth."\
-help\
"Walks every path in tcl::tm::list recursively and registers a 'package ifneeded'
script for each .tm module found - including modules in namespace subfolders
that have never been requested. (The tm package unknown handler registers
sibling .tm files only at the namespace depth of the package being required,
so such modules are otherwise absent from 'package names' until first
requested.)
Existing ifneeded scripts are never overridden - first registration wins,
matching the tm unknown handler, so head-of-tm-list precedence for
same-version modules is preserved.
Uses and populates the same per-epoch directory index cache as the unknown
handlers: for zipfs (static) paths the whole tree listing is gathered in one
call; for filesystem paths each directory's *.tm glob is cached per
'package epoch'. Directories named #modpod-*, #tarjar-* and _build are
skipped.
The scan runs at most once per tm epoch per interp (tracked in the
interp-local tm_fullscan variable - deliberately not part of the shareable
epoch dict, because ifneeded registrations are interp-local; an interp
receiving a shared epoch re-registers cheaply from the cached indexes).
Path-list changes and 'package epoch incr' start a new tm epoch,
re-enabling the scan - a call after 'package epoch incr' re-reads the
filesystem and picks up modules added or removed on disk.
Returns a stats dict: epoch, roots, dirs, tmfiles, registered - plus
'cached 1' when the call was a per-epoch no-op.
punk::libunknown::init must have been called first."
@opts
-force -type none -help\
"Run the registration pass even if already performed in the current tm epoch.
Directory listings still come from the epoch index cache where present -
use 'package epoch incr' first to force re-reading the filesystem."
}]
}
proc register_all_tm {args} {
variable epoch
if {![info exists epoch]} {
error "punk::libunknown::register_all_tm - punk::libunknown::init has not been called in this interp"
}
set opt_force [expr {"-force" in $args}]
variable tm_fullscan
set tm_epoch [dict get $epoch tm current]
if {!$opt_force && [dict exists $tm_fullscan $tm_epoch]} {
return [dict merge [dict get $tm_fullscan $tm_epoch] [dict create cached 1]]
}
upvar ::tcl::tm::paths paths
upvar ::tcl::tm::pkgpattern pkgpattern
if {[info commands ::tcl::zipfs::root] ne ""} {
set zipfsroot [tcl::zipfs::root]
set has_zipfs 1
} else {
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands
set has_zipfs 0
}
set stat_roots 0
set stat_dirs 0
set stat_files 0
set stat_registered 0
foreach path $paths {
if {![interp issafe] && ![file exists $path]} {
continue
}
incr stat_roots
set tmfiles [list]
if {$has_zipfs && [string match $zipfsroot* $path]} {
#static filesystem - the whole tm tree is available in one quick call
#(as the tm unknown handler's zipfs branch does)
set tmfiles [::tcl::zipfs::list $path/*.tm]
set seen_dirs [dict create]
foreach tm_path $tmfiles {
set d [file dirname $tm_path]
dict set seen_dirs $d 1
dict set epoch tm epochs $tm_epoch indexes $d $tm_path $tm_epoch
}
incr stat_dirs [dict size $seen_dirs]
} else {
#plain filesystem - breadth-first walk, reusing/populating the per-epoch
#directory index cache so the unknown handlers can short-circuit later
set pending [list $path]
while {[llength $pending]} {
set current [lindex $pending 0]
set pending [lrange $pending 1 end]
incr stat_dirs
if {[dict exists $epoch tm epochs $tm_epoch indexes $current]} {
set dirfiles [dict keys [dict get $epoch tm epochs $tm_epoch indexes $current]]
} else {
set dirfiles [glob -nocomplain -directory $current -types f *.tm]
dict set epoch tm epochs $tm_epoch indexes $current [dict create]
foreach f $dirfiles {
dict set epoch tm epochs $tm_epoch indexes $current $f $tm_epoch
}
}
lappend tmfiles {*}$dirfiles
foreach sub [glob -nocomplain -directory $current -types d *] {
set tail [file tail $sub]
if {[string match "#modpod-*" $tail] || [string match "#tarjar-*" $tail] || $tail eq "_build"} {
continue
}
lappend pending $sub
}
}
}
#registration - same rules as the tm unknown handler (don't override existing
#ifneeded scripts: for tm modules the first encountered 'wins')
set strip [llength [file split $path]]
foreach file $tmfiles {
if {[string match "*/_build/*" $file]} {
continue
}
incr stat_files
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
# Ignore everything not matching our pattern for package names.
continue
}
try {
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not acceptable to
# "package vcompare".
continue
}
if {([package ifneeded $pkgname $pkgversion] ne {}) && (![interp issafe])} {
#already registered - possibly by an earlier (higher precedence) path
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
continue
}
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source $file]"
incr stat_registered
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
}
}
set stats [dict create epoch $tm_epoch roots $stat_roots dirs $stat_dirs tmfiles $stat_files registered $stat_registered]
dict set tm_fullscan $tm_epoch $stats
return $stats
}
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about.
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem)
#in practice the info is only available for tm modules
@ -1925,7 +2119,7 @@ namespace eval ::punk::args::register {
package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown {
variable pkg punk::libunknown
variable version
set version 0.1
set version 0.2.0
}]
return

71
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::mix::commandset::loadedlib 0.1.0
# Application punk::mix::commandset::loadedlib 0.2.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -28,13 +28,37 @@ namespace eval punk::mix::commandset::loadedlib {
#search automatically wrapped in * * - can contain inner * ? globs
punk::args::define {
@id -id ::punk::mix::commandset::loadedlib::search
@cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
@cmd -name "punk::mix::commandset::loadedlib search" -help\
"search all Tcl libraries available to your local interpreter.
When punk::libunknown is active (the punkshell default) a deep module
discovery pass runs first, so .tm modules at every namespace depth are
included - cached per 'package epoch', repeat searches are cheap.
See -refresh for cache/re-scan details."
-return -type string -default table -choices {table tableobject list lines}
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
"(unimplemented) Display only those that are 0:absent 1:present 2:either"
-highlight -type boolean -default 1 -help\
"Highlight which version is present with ansi underline and colour"
-refresh -type none -help "Re-scan the tm and library folders"
-refresh -type none -help\
"Force a genuine filesystem re-scan of the module and library folders.
When punk::libunknown is active (the punkshell default), every search
already performs a deep module discovery pass - registering .tm modules
at every namespace depth across all tcl::tm::list paths (see
punk::libunknown::register_all_tm) - cached per 'package epoch' so
repeat searches are cheap. Because directories already indexed in the
current epoch are not re-globbed, that default pass does not notice .tm
files added to (or removed from) already-scanned folders.
-refresh increments the package epoch ('package epoch incr'),
invalidating the scan caches, then re-runs discovery - picking up
on-disk changes and re-sourcing the pkgIndex.tcl files on ::auto_path.
Changes to tcl::tm::list or ::auto_path increment the epoch
automatically (via variable traces) - this flag is not needed for
those cases.
When punk::libunknown is not active there is no epoch cache: the
default search reflects only packages already registered in the
package database, and -refresh performs the (comparatively expensive)
deep discovery walk directly using dummy package require calls at
each namespace depth."
searchstring -default * -multiple 1 -help\
"Names to search for, may contain glob chars (* ?) e.g *lib*
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs.
@ -51,8 +75,35 @@ namespace eval punk::mix::commandset::loadedlib {
set opt_highlight [dict get $opts -highlight]
set opt_refresh [dict exists $received -refresh]
#Deep discovery of available packages.
#The package unknown handlers register .tm siblings only at the namespace depth
#being requested - modules in never-requested subfolders are absent from
#'package names' until a deep pass registers them.
#Note: ::info must be fully qualified here - this namespace defines its own 'info' proc
if {[::info commands ::punk::libunknown::register_all_tm] ne "" && [::info exists ::punk::libunknown::epoch]} {
if {$opt_refresh} {
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans
#genuine filesystem re-scan: start a new package epoch so the scan
#caches are invalidated (pkgIndex.tcl files on ::auto_path will also be
#re-sourced by the dummy require below)
package epoch incr
}
#register .tm modules at every namespace depth (cached per tm epoch -
#repeat searches are cheap)
punk::libunknown::register_all_tm
#sweep the pkgIndex.tcl files of ::auto_path for library-style packages
catch {package require frobznodule666}
} else {
#punk::libunknown deep registration unavailable - without its epoch cache a
#recursive walk on every search would be expensive, so deep discovery runs
#only on explicit request.
if {$opt_refresh} {
if {[::info exists ::punk::libunknown::epoch]} {
#older punk::libunknown without register_all_tm: invalidate its scan
#caches so the dummy requires below re-read the filesystem
catch {package epoch incr}
}
catch {package require frobznodule666} ;#top-level tm scan + pkgIndex sweep of ::auto_path
package require punk::path
foreach tm_path [tcl::tm::list] {
set paths_below [punk::path::subfolders -recursive $tm_path]
foreach folder $paths_below {
@ -67,6 +118,7 @@ namespace eval punk::mix::commandset::loadedlib {
}
}
}
}
set packages [package names]
@ -85,8 +137,12 @@ namespace eval punk::mix::commandset::loadedlib {
}
set matches [lsort -unique $matches]
set matchinfo [list]
set highlight_ansi [a+ web-limegreen underline]
set RST [a]
if {$opt_highlight} {
#not a module-top require: punk::ansi is only needed for highlighting
package require punk::ansi
set highlight_ansi [punk::ansi::a+ web-limegreen underline]
set RST [punk::ansi::a]
}
foreach m $matches {
set versions [package versions $m]
if {![llength $versions]} {
@ -122,6 +178,7 @@ namespace eval punk::mix::commandset::loadedlib {
return [join $matchinfo \n]
}
table - tableobject {
package require textblock
set t [textblock::class::table new]
$t add_column -headers "Package"
$t add_column -headers "Version"
@ -601,6 +658,6 @@ namespace eval punk::mix::commandset::loadedlib {
## Ready
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib {
variable version
set version 0.1.0
set version 0.2.0
}]
return

54
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm → src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punkboot::utils 0.1.1
# Application punkboot::utils 0.2.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -134,6 +134,10 @@ namespace eval punkboot::utils {
used to report each VCS root at most once across calls.
label, if supplied, is prefixed into each warning to name
the calling operation (e.g. 'vendorupdate').
scope, if supplied, is a subpath relative to path; only
uncommitted changes under that subpath are counted (e.g.
scope 'src' warns about dirty src/ while ignoring dirt
elsewhere in the checkout).
Returns an empty list if the path is clean, unversioned,
missing, already reported, or state cannot be determined."
@ -144,9 +148,11 @@ namespace eval punkboot::utils {
"Name of a dict variable in the caller's scope for dedupe across calls"
label -type string -optional 1 -default "" -help\
"Operation name prefixed into warnings"
scope -type string -optional 1 -default "" -help\
"Subpath relative to path limiting which changes count; empty = whole checkout"
}]
}
proc vcs_dirty_warnings {path checkedrootsvar {label ""}} {
proc vcs_dirty_warnings {path checkedrootsvar {label ""} {scope ""}} {
upvar 1 $checkedrootsvar checkedroots
if {![info exists checkedroots]} {set checkedroots [dict create]}
if {$label ne ""} {set label "$label "}
@ -155,6 +161,12 @@ namespace eval punkboot::utils {
if {![file isdirectory $dir]} {
return $warnings ;#missing path - not this proc's business to report
}
set scopeabs ""
set scopedesc "" ;#included in warning text when scoped
if {$scope ne ""} {
set scopeabs [file normalize [file join $dir $scope]]
set scopedesc " under [string trimright $scope /]/"
}
set fossilroot ""
set gitroot ""
while {1} {
@ -171,8 +183,8 @@ namespace eval punkboot::utils {
if {$parent eq $dir} { break }
set dir $parent
}
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot 1
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot,$scope] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot,$scope 1
#fossil changes must run from within the checkout
set original_cwd [pwd]
if {[catch {
@ -180,19 +192,37 @@ namespace eval punkboot::utils {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
return $warnings
@ -207,8 +237,8 @@ namespace eval ::punk::args::register {
## Ready
package provide punkboot::utils [tcl::namespace::eval punkboot::utils {
variable version
#- this version number, exactly 0.1.1, is a literal used in src module folders
#- this version number, exactly 0.2.0, is a literal used in src module folders
#- we refer to this sometimes as the magic version number
set version 0.1.1
set version 0.2.0
}]
return

120
src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl

@ -20,7 +20,7 @@ namespace eval ::punkboot {
variable scriptfolder [file normalize [file dirname [info script]]]
variable foldername [file tail $scriptfolder]
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable non_help_flags [list -k -dirty-abort]
variable help_flags [list -help --help /? -h]
variable known_commands [list project modules libs packages vfs vfslibs bin info check shell vendorupdate bootsupport vfscommonupdate projectversion]
}
@ -1364,6 +1364,13 @@ proc ::punkboot::punkboot_gethelp {args} {
append h " - run the punk shell using bootsupport libraries." \n
append h " $scriptname projectversion" \n
append h " - advisory check: verify CHANGELOG.md matches punkproject.toml and warn if src/ has changes since the last project-version bump." \n \n
append h " Flags:" \n
append h " -dirty-abort" \n
append h " - abort build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) when src/ has" \n
append h " uncommitted VCS changes. Default is warn-only: artifacts built from dirty src have no committed provenance." \n
append h " Warnings carry a plain PROVENANCE-WARNING: prefix (greppable in redirected output) and are recapped at the end of the run." \n
append h " Use '$scriptname check' to see the current provenance status. To evaluate uncommitted source without building," \n
append h " use '<builtexe> src' or '<builtexe> src shell'." \n \n
append h "" \n
if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} {
set has_recommended 0
@ -1604,6 +1611,98 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
set sourcefolder $projectroot/src
set binfolder $projectroot/bin
# ----------------------------------------
# Provenance-warning presentation + dirty-src check for build/promotion commands (goal G-026 direction).
# Build/promotion commands stamp versions onto src content and propagate it into trees other
# things consume (root modules/, bootsupport snapshots, vfs payloads, kits/zipkits).
# Artifacts built from uncommitted src have no committed provenance - warn by default,
# abort if the -dirty-abort flag was given. To evaluate uncommitted source without
# building, use '<builtexe> src' / '<builtexe> src shell' instead.
# Guarded require: a stale or missing punkboot::utils bootsupport snapshot must never
# brick the make.tcl commands used to repair it - the check degrades to a skip notice
# (but -dirty-abort still aborts rather than silently skipping the requested strictness).
#Emit provenance warnings with a plain column-0 token for automated discovery (grep PROVENANCE-WARNING
#in redirected output) and ANSI colour for humans. Lines are also accumulated in
#::punkboot::provenance_warnings_pending unless -norecap is given, so the wrapped ::exit below can
#recap them at the tail of the output - build progress output is chatty and the original warning
#position may scroll out of sight or even out of scrollback.
set ::punkboot::provenance_warnings_pending [list]
proc ::punkboot::print_provenance_warnings {warninglines args} {
global A
if {![array size A]} {punkboot::define_global_ansi}
foreach w $warninglines {
regsub {^WARNING: } $w "" w
puts stderr "PROVENANCE-WARNING: $A(BAD)$w$A(RST)"
if {"-norecap" ni $args} {
lappend ::punkboot::provenance_warnings_pending $w
}
}
flush stderr
}
#Availability probe + scoped dirty-src check, shared by the build/promotion gate below and the
#'check' command report. Returns {available warninglist}.
proc ::punkboot::get_src_provenance_warnings {projectroot label} {
set available [expr {\
![catch {package require punkboot::utils}]\
&& [llength [info commands ::punkboot::utils::vcs_dirty_warnings]]\
&& "scope" in [info args ::punkboot::utils::vcs_dirty_warnings]\
}]
if {!$available} {
return [list 0 [list]]
}
set checked_vcs_roots [dict create]
return [list 1 [::punkboot::utils::vcs_dirty_warnings $projectroot checked_vcs_roots $label src]]
}
#Wrap ::exit so accumulated provenance warnings are recapped at the very end of output no matter
#which of make.tcl's many exit points a command takes.
if {![llength [info commands ::punkboot::exit_original]]} {
rename ::exit ::punkboot::exit_original
proc ::exit {{returnCode 0}} {
if {[info exists ::punkboot::provenance_warnings_pending] && [llength $::punkboot::provenance_warnings_pending]} {
puts stderr ""
puts stderr "PROVENANCE-WARNING: recap of warning(s) emitted earlier in this run:"
::punkboot::print_provenance_warnings $::punkboot::provenance_warnings_pending -norecap
}
::punkboot::exit_original $returnCode
}
}
if {$::punkboot::command in {project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate}} {
set dirty_abort [expr {[lsearch $::argv -dirty-abort] >= 0}]
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl $::punkboot::command"] have_scoped_dirty_check dirty_warnings
if {$have_scoped_dirty_check} {
if {[llength $dirty_warnings]} {
::punkboot::print_provenance_warnings $dirty_warnings
puts stderr " To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
if {$dirty_abort} {
set ::punkboot::provenance_warnings_pending [list] ;#no recap needed - aborting adjacent to the warning
puts stderr "-aborted- (-dirty-abort given and src has uncommitted changes - commit first, or rerun without -dirty-abort to build with a warning)"
exit 1
}
#Grace period for an attentive human to ctrl-c - only when stdin is a terminal
#(-inputmode is only supported on terminal channels, Tcl 8.7+/9; pipes/redirects/8.6 skip the delay
# so agent/CI runs pay nothing)
if {![catch {chan configure stdin -inputmode}]} {
puts -nonewline stderr " proceeding despite dirty src - ctrl-c now to abort "
flush stderr
foreach tick {3 2 1} {
puts -nonewline stderr "..$tick"
flush stderr
after 1000
}
puts stderr ""
}
}
} else {
if {$dirty_abort} {
puts stderr "-aborted- (-dirty-abort given but the dirty-src provenance check is unavailable: punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
exit 1
}
puts stderr "NOTE: dirty-src provenance check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport) - continuing without it"
}
}
if {$::punkboot::command eq "check"} {
set sep [string repeat - 75]
puts stdout $sep
@ -1738,6 +1837,21 @@ if {$::punkboot::command eq "check"} {
puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport"
puts stderr "=============================================================================="
}
# Dirty-src provenance status - what the build/promotion commands would do
puts stdout $sep
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl check"] _prov_available _prov_warnings
if {!$_prov_available} {
puts stdout "src provenance: check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
puts stdout " build/promotion commands will proceed with a NOTE; -dirty-abort would abort as unverifiable."
} elseif {![llength $_prov_warnings]} {
puts stdout "src provenance: OK (no uncommitted fossil/git changes under src/)"
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will proceed without provenance warnings."
} else {
::punkboot::print_provenance_warnings $_prov_warnings -norecap
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will WARN as above and proceed."
puts stdout " With -dirty-abort they would abort. To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
}
puts stdout $sep
exit 0
}
@ -2040,9 +2154,7 @@ if {$::punkboot::command eq "vendorupdate"} {
set normsrclocation [file normalize $srclocation]
if {![dict exists $checked_source_paths $normsrclocation]} {
dict set checked_source_paths $normsrclocation 1
foreach w [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate] {
puts stderr $w
}
::punkboot::print_provenance_warnings [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate]
}
}
#puts stdout "$relpath $module $module_subpath $srclocation"

105
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm

@ -8,7 +8,7 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::args::moduledoc::tclcore 0.1.0
# Application punk::args::moduledoc::tclcore 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
@ -18,7 +18,7 @@
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.1.0]
#[manpage_begin punkshell_module_punk::args::moduledoc::tclcore 0 0.2.0]
#[copyright "2025"]
#[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}]
#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}]
@ -9817,41 +9817,37 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
# ==============================================================================================================
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {
alnum
alpha
ascii
boolean
control
dict
digit
double
entier
false
graph
integer
list
lower
print
punct
space
true
upper
wideinteger
wordchar
xdigit
}\
-choicelabels {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
alnum
" Any Unicode alphabet
or digit character"
@ -9877,7 +9873,9 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
will contain the index of
the \"element\" where the
dict parsing fails or -1 if
this cannot be determined."
this cannot be determined.
(class not present in
Tcl 8.6)"
digit
" Any Unicode digit char.
Note that this includes
@ -9937,6 +9935,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
" Any of the forms allowed
for Tcl_GetBoolean where the
value is true"
unicode
" Any Unicode character.
(class exists only in the
unreleased Tcl 8.7 series -
removed in Tcl 9)"
upper
" Any upper case alphabet
character in the Unicode
@ -9959,7 +9962,29 @@ tcl::namespace::eval punk::args::moduledoc::tclcore {
xdigit
" Any hexadecimal digit
character ([0-9A-Fa-f])."
}\
}]
set string_is_choicelabels ""
foreach _sis_c $string_is_classes {
if {[dict exists $string_is_class_descriptions $_sis_c]} {
append string_is_choicelabels [list $_sis_c] " " [list [dict get $string_is_class_descriptions $_sis_c]] \n
} else {
append string_is_choicelabels [list $_sis_c] " " [list " (class accepted by this Tcl\n runtime - not yet described\n in the punk tclcore docs)"] \n
}
}
unset -nocomplain _sis_msg _sis_csv _sis_c
punk::args::define [punk::args::lib::tstr -return string {
@id -id ::tcl::string::is
@cmd -name "Built-in: tcl::string::is"\
-summary\
"Test character class of string."\
-help\
"Returns 1 if string is a valid member of the specified character class, otherwise returns 0.
"
@leaders -min 1 -max 1
class -type string\
-choices {${$string_is_classes}}\
-choicelabels {${$string_is_choicelabels}}\
-help\
"character class
In the case of boolean, true and false, if the function will return 0, then the
@ -12518,7 +12543,7 @@ namespace eval ::punk::args::register {
package provide punk::args::moduledoc::tclcore [tcl::namespace::eval punk::args::moduledoc::tclcore {
variable pkg punk::args::moduledoc::tclcore
variable version
set version 0.1.0
set version 0.2.0
}]
return

210
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm

@ -7,17 +7,34 @@
# (C) 2025
#
# @@ Meta Begin
# Application punk::libunknown 0.1
# Application punk::libunknown 0.2.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
#
# Version history (manually versioned module - the real version lives in the
# filename and the 'package provide' block at the bottom; there is no
# <name>-buildversion.txt. Apply the standard Patch/Minor/Major bump rules
# from src/modules/AGENTS.md "Versioning And Releases" - bumping means
# renaming the file AND updating the Meta line above, the manpage_begin line
# below and the provide-block version, then appending a line here):
#0.2.0 - register_all_tm: deep discovery proc registering ifneeded scripts for
# .tm modules at every namespace depth (once per tm epoch, interp-local
# tm_fullscan guard); used by 'dev lib.search' by default
#0.2.0 - source_pkgindex: pkgIndex.tcl scripts execute in an isolated frame
# ($dir formal + auto_path/env global links) instead of at :: scope -
# user global 'dir' no longer clobbered, index helper vars no longer
# leak into the global namespace ('global dir' removed from
# zipfs_tclPkgUnknown)
#0.1 - initial: epoch-based zipfs_tm_UnknownHandler/zipfs_tclPkgUnknown
# package unknown chain, 'package epoch' command, controlled forget
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin punkshell_module_punk::libunknown 0 0.1]
#[manpage_begin punkshell_module_punk::libunknown 0 0.2.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
@ -81,6 +98,10 @@ tcl::namespace::eval ::punk::libunknown {
}]
variable epoch ;#don't set - can be pre-set cooperatively
variable tm_fullscan [dict create] ;#tm epochs fully scanned by register_all_tm.
#Deliberately interp-local (NOT part of the shareable epoch dict): 'package ifneeded'
#registrations are interp-local, so an interp receiving a shared epoch must still run
#its own registration pass (cheap - directory listings come from the shared index cache).
variable has_package_files
if {[catch {package files foobaz}]} {
@ -100,6 +121,21 @@ tcl::namespace::eval ::punk::libunknown {
}
}
#Execute a pkgIndex.tcl script in this proc's frame (tcl_Pkg_source uplevels
#the actual 'source' into its caller).
#The pkgIndex.tcl contract is that $dir holds the index file's directory, and
#stock tclPkgUnknown additionally exposes the auto_path and env globals (some
#indexes, e.g tcllib's, extend auto_path with an unqualified lappend).
#Providing exactly that environment here means anything ELSE the script sets
#stays local to this frame and is discarded - previously indexes were sourced
#via 'namespace eval ::', which clobbered any user global named 'dir' (via the
#handler's since-removed 'global dir') and leaked each index's helper
#variables (ver, pkg, script, ...) into the global namespace.
proc source_pkgindex {dir indexfile} {
global auto_path env
tcl_Pkg_source $indexfile
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@ -492,6 +528,12 @@ tcl::namespace::eval ::punk::libunknown {
Key differences from Tcl's standard tclPkgUnknown:
- Uses an epoch-based cache to avoid re-sourcing pkgIndex.tcl files that have
already been processed in the current epoch.
- pkgIndex.tcl scripts execute in an isolated frame (see source_pkgindex)
providing the documented \$dir variable plus auto_path/env global links.
Stray unqualified variables set by index scripts stay local to that frame
instead of leaking into the global namespace, and user globals (notably
'dir') are not clobbered. Stock tclPkgUnknown instead exposes all of its
own proc locals to the index scripts.
- Processes auto_path entries from end to front (same as tclPkgUnknown), but
tracks which packages and versions were added or changed by each pkgIndex.tcl
so that ifneeded scripts from earlier (higher-priority) paths can be reverted
@ -514,7 +556,10 @@ tcl::namespace::eval ::punk::libunknown {
proc zipfs_tclPkgUnknown {name args} {
#puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL"
global dir
#Note: no 'global dir' here (an earlier revision had one so that pkgIndex.tcl
#scripts sourced at :: scope could read $dir - at the cost of clobbering any
#user global named 'dir'). Index scripts now execute in a source_pkgindex
#frame which provides $dir locally - see source_pkgindex.
variable epoch
set pkg_epoch [dict get $epoch pkg current]
@ -679,9 +724,8 @@ tcl::namespace::eval ::punk::libunknown {
# puts stderr "----->0 sourcing zipfs file $file"
#}
incr sourced ;#count as sourced even if source fails; keep before actual source action
#::tcl::Pkg::source $file
#lappend sourced_files $file
namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)"
@ -711,8 +755,7 @@ tcl::namespace::eval ::punk::libunknown {
#puts "----->2 sourcing $file"
incr sourced
#lappend sourced_files $file
#::tcl::Pkg::source $file
namespace eval :: [list punk::libunknown::tcl_Pkg_source $file]
source_pkgindex $dir $file
} trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)"
@ -1195,6 +1238,157 @@ tcl::namespace::eval ::punk::libunknown {
}
}
namespace eval argdoc {
variable PUNKARGS
lappend PUNKARGS [list {
@id -id ::punk::libunknown::register_all_tm
@cmd -name punk::libunknown::register_all_tm\
-summary\
"Deep discovery: register ifneeded scripts for all .tm modules at every namespace depth."\
-help\
"Walks every path in tcl::tm::list recursively and registers a 'package ifneeded'
script for each .tm module found - including modules in namespace subfolders
that have never been requested. (The tm package unknown handler registers
sibling .tm files only at the namespace depth of the package being required,
so such modules are otherwise absent from 'package names' until first
requested.)
Existing ifneeded scripts are never overridden - first registration wins,
matching the tm unknown handler, so head-of-tm-list precedence for
same-version modules is preserved.
Uses and populates the same per-epoch directory index cache as the unknown
handlers: for zipfs (static) paths the whole tree listing is gathered in one
call; for filesystem paths each directory's *.tm glob is cached per
'package epoch'. Directories named #modpod-*, #tarjar-* and _build are
skipped.
The scan runs at most once per tm epoch per interp (tracked in the
interp-local tm_fullscan variable - deliberately not part of the shareable
epoch dict, because ifneeded registrations are interp-local; an interp
receiving a shared epoch re-registers cheaply from the cached indexes).
Path-list changes and 'package epoch incr' start a new tm epoch,
re-enabling the scan - a call after 'package epoch incr' re-reads the
filesystem and picks up modules added or removed on disk.
Returns a stats dict: epoch, roots, dirs, tmfiles, registered - plus
'cached 1' when the call was a per-epoch no-op.
punk::libunknown::init must have been called first."
@opts
-force -type none -help\
"Run the registration pass even if already performed in the current tm epoch.
Directory listings still come from the epoch index cache where present -
use 'package epoch incr' first to force re-reading the filesystem."
}]
}
proc register_all_tm {args} {
variable epoch
if {![info exists epoch]} {
error "punk::libunknown::register_all_tm - punk::libunknown::init has not been called in this interp"
}
set opt_force [expr {"-force" in $args}]
variable tm_fullscan
set tm_epoch [dict get $epoch tm current]
if {!$opt_force && [dict exists $tm_fullscan $tm_epoch]} {
return [dict merge [dict get $tm_fullscan $tm_epoch] [dict create cached 1]]
}
upvar ::tcl::tm::paths paths
upvar ::tcl::tm::pkgpattern pkgpattern
if {[info commands ::tcl::zipfs::root] ne ""} {
set zipfsroot [tcl::zipfs::root]
set has_zipfs 1
} else {
set zipfsroot "//zipfs:/" ;#doesn't matter much what we use here - don't expect in tm list if no zipfs commands
set has_zipfs 0
}
set stat_roots 0
set stat_dirs 0
set stat_files 0
set stat_registered 0
foreach path $paths {
if {![interp issafe] && ![file exists $path]} {
continue
}
incr stat_roots
set tmfiles [list]
if {$has_zipfs && [string match $zipfsroot* $path]} {
#static filesystem - the whole tm tree is available in one quick call
#(as the tm unknown handler's zipfs branch does)
set tmfiles [::tcl::zipfs::list $path/*.tm]
set seen_dirs [dict create]
foreach tm_path $tmfiles {
set d [file dirname $tm_path]
dict set seen_dirs $d 1
dict set epoch tm epochs $tm_epoch indexes $d $tm_path $tm_epoch
}
incr stat_dirs [dict size $seen_dirs]
} else {
#plain filesystem - breadth-first walk, reusing/populating the per-epoch
#directory index cache so the unknown handlers can short-circuit later
set pending [list $path]
while {[llength $pending]} {
set current [lindex $pending 0]
set pending [lrange $pending 1 end]
incr stat_dirs
if {[dict exists $epoch tm epochs $tm_epoch indexes $current]} {
set dirfiles [dict keys [dict get $epoch tm epochs $tm_epoch indexes $current]]
} else {
set dirfiles [glob -nocomplain -directory $current -types f *.tm]
dict set epoch tm epochs $tm_epoch indexes $current [dict create]
foreach f $dirfiles {
dict set epoch tm epochs $tm_epoch indexes $current $f $tm_epoch
}
}
lappend tmfiles {*}$dirfiles
foreach sub [glob -nocomplain -directory $current -types d *] {
set tail [file tail $sub]
if {[string match "#modpod-*" $tail] || [string match "#tarjar-*" $tail] || $tail eq "_build"} {
continue
}
lappend pending $sub
}
}
}
#registration - same rules as the tm unknown handler (don't override existing
#ifneeded scripts: for tm modules the first encountered 'wins')
set strip [llength [file split $path]]
foreach file $tmfiles {
if {[string match "*/_build/*" $file]} {
continue
}
incr stat_files
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
# Ignore everything not matching our pattern for package names.
continue
}
try {
package vcompare $pkgversion 0
} on error {} {
# Ignore everything where the version part is not acceptable to
# "package vcompare".
continue
}
if {([package ifneeded $pkgname $pkgversion] ne {}) && (![interp issafe])} {
#already registered - possibly by an earlier (higher precedence) path
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
continue
}
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source $file]"
incr stat_registered
dict set epoch tm epochs $tm_epoch added $path $pkgname $pkgversion e$tm_epoch
dict unset epoch tm untracked $pkgname
}
}
set stats [dict create epoch $tm_epoch roots $stat_roots dirs $stat_dirs tmfiles $stat_files registered $stat_registered]
dict set tm_fullscan $tm_epoch $stats
return $stats
}
#see what basic info we can gather *quickly* about the indexes for each version of a pkg that the package db knows about.
#we want no calls out to the actual filesystem - but we can use some 'file' calls such as 'file dirname', 'file split' (review -safe interp problem)
#in practice the info is only available for tm modules
@ -1925,7 +2119,7 @@ namespace eval ::punk::args::register {
package provide punk::libunknown [tcl::namespace::eval ::punk::libunknown {
variable pkg punk::libunknown
variable version
set version 0.1
set version 0.2.0
}]
return

71
src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punk::mix::commandset::loadedlib 0.1.0
# Application punk::mix::commandset::loadedlib 0.2.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
@ -28,13 +28,37 @@ namespace eval punk::mix::commandset::loadedlib {
#search automatically wrapped in * * - can contain inner * ? globs
punk::args::define {
@id -id ::punk::mix::commandset::loadedlib::search
@cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
@cmd -name "punk::mix::commandset::loadedlib search" -help\
"search all Tcl libraries available to your local interpreter.
When punk::libunknown is active (the punkshell default) a deep module
discovery pass runs first, so .tm modules at every namespace depth are
included - cached per 'package epoch', repeat searches are cheap.
See -refresh for cache/re-scan details."
-return -type string -default table -choices {table tableobject list lines}
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
"(unimplemented) Display only those that are 0:absent 1:present 2:either"
-highlight -type boolean -default 1 -help\
"Highlight which version is present with ansi underline and colour"
-refresh -type none -help "Re-scan the tm and library folders"
-refresh -type none -help\
"Force a genuine filesystem re-scan of the module and library folders.
When punk::libunknown is active (the punkshell default), every search
already performs a deep module discovery pass - registering .tm modules
at every namespace depth across all tcl::tm::list paths (see
punk::libunknown::register_all_tm) - cached per 'package epoch' so
repeat searches are cheap. Because directories already indexed in the
current epoch are not re-globbed, that default pass does not notice .tm
files added to (or removed from) already-scanned folders.
-refresh increments the package epoch ('package epoch incr'),
invalidating the scan caches, then re-runs discovery - picking up
on-disk changes and re-sourcing the pkgIndex.tcl files on ::auto_path.
Changes to tcl::tm::list or ::auto_path increment the epoch
automatically (via variable traces) - this flag is not needed for
those cases.
When punk::libunknown is not active there is no epoch cache: the
default search reflects only packages already registered in the
package database, and -refresh performs the (comparatively expensive)
deep discovery walk directly using dummy package require calls at
each namespace depth."
searchstring -default * -multiple 1 -help\
"Names to search for, may contain glob chars (* ?) e.g *lib*
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs.
@ -51,8 +75,35 @@ namespace eval punk::mix::commandset::loadedlib {
set opt_highlight [dict get $opts -highlight]
set opt_refresh [dict exists $received -refresh]
#Deep discovery of available packages.
#The package unknown handlers register .tm siblings only at the namespace depth
#being requested - modules in never-requested subfolders are absent from
#'package names' until a deep pass registers them.
#Note: ::info must be fully qualified here - this namespace defines its own 'info' proc
if {[::info commands ::punk::libunknown::register_all_tm] ne "" && [::info exists ::punk::libunknown::epoch]} {
if {$opt_refresh} {
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans
#genuine filesystem re-scan: start a new package epoch so the scan
#caches are invalidated (pkgIndex.tcl files on ::auto_path will also be
#re-sourced by the dummy require below)
package epoch incr
}
#register .tm modules at every namespace depth (cached per tm epoch -
#repeat searches are cheap)
punk::libunknown::register_all_tm
#sweep the pkgIndex.tcl files of ::auto_path for library-style packages
catch {package require frobznodule666}
} else {
#punk::libunknown deep registration unavailable - without its epoch cache a
#recursive walk on every search would be expensive, so deep discovery runs
#only on explicit request.
if {$opt_refresh} {
if {[::info exists ::punk::libunknown::epoch]} {
#older punk::libunknown without register_all_tm: invalidate its scan
#caches so the dummy requires below re-read the filesystem
catch {package epoch incr}
}
catch {package require frobznodule666} ;#top-level tm scan + pkgIndex sweep of ::auto_path
package require punk::path
foreach tm_path [tcl::tm::list] {
set paths_below [punk::path::subfolders -recursive $tm_path]
foreach folder $paths_below {
@ -67,6 +118,7 @@ namespace eval punk::mix::commandset::loadedlib {
}
}
}
}
set packages [package names]
@ -85,8 +137,12 @@ namespace eval punk::mix::commandset::loadedlib {
}
set matches [lsort -unique $matches]
set matchinfo [list]
set highlight_ansi [a+ web-limegreen underline]
set RST [a]
if {$opt_highlight} {
#not a module-top require: punk::ansi is only needed for highlighting
package require punk::ansi
set highlight_ansi [punk::ansi::a+ web-limegreen underline]
set RST [punk::ansi::a]
}
foreach m $matches {
set versions [package versions $m]
if {![llength $versions]} {
@ -122,6 +178,7 @@ namespace eval punk::mix::commandset::loadedlib {
return [join $matchinfo \n]
}
table - tableobject {
package require textblock
set t [textblock::class::table new]
$t add_column -headers "Package"
$t add_column -headers "Version"
@ -601,6 +658,6 @@ namespace eval punk::mix::commandset::loadedlib {
## Ready
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib {
variable version
set version 0.1.0
set version 0.2.0
}]
return

54
src/bootsupport/modules/punkboot/utils-0.1.1.tm → src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm

@ -7,7 +7,7 @@
# (C) 2023
#
# @@ Meta Begin
# Application punkboot::utils 0.1.1
# Application punkboot::utils 0.2.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
@ -134,6 +134,10 @@ namespace eval punkboot::utils {
used to report each VCS root at most once across calls.
label, if supplied, is prefixed into each warning to name
the calling operation (e.g. 'vendorupdate').
scope, if supplied, is a subpath relative to path; only
uncommitted changes under that subpath are counted (e.g.
scope 'src' warns about dirty src/ while ignoring dirt
elsewhere in the checkout).
Returns an empty list if the path is clean, unversioned,
missing, already reported, or state cannot be determined."
@ -144,9 +148,11 @@ namespace eval punkboot::utils {
"Name of a dict variable in the caller's scope for dedupe across calls"
label -type string -optional 1 -default "" -help\
"Operation name prefixed into warnings"
scope -type string -optional 1 -default "" -help\
"Subpath relative to path limiting which changes count; empty = whole checkout"
}]
}
proc vcs_dirty_warnings {path checkedrootsvar {label ""}} {
proc vcs_dirty_warnings {path checkedrootsvar {label ""} {scope ""}} {
upvar 1 $checkedrootsvar checkedroots
if {![info exists checkedroots]} {set checkedroots [dict create]}
if {$label ne ""} {set label "$label "}
@ -155,6 +161,12 @@ namespace eval punkboot::utils {
if {![file isdirectory $dir]} {
return $warnings ;#missing path - not this proc's business to report
}
set scopeabs ""
set scopedesc "" ;#included in warning text when scoped
if {$scope ne ""} {
set scopeabs [file normalize [file join $dir $scope]]
set scopedesc " under [string trimright $scope /]/"
}
set fossilroot ""
set gitroot ""
while {1} {
@ -171,8 +183,8 @@ namespace eval punkboot::utils {
if {$parent eq $dir} { break }
set dir $parent
}
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot 1
if {$fossilroot ne "" && ![dict exists $checkedroots fossil,$fossilroot,$scope] && [llength [auto_execok fossil]]} {
dict set checkedroots fossil,$fossilroot,$scope 1
#fossil changes must run from within the checkout
set original_cwd [pwd]
if {[catch {
@ -180,19 +192,37 @@ namespace eval punkboot::utils {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
return $warnings
@ -207,8 +237,8 @@ namespace eval ::punk::args::register {
## Ready
package provide punkboot::utils [tcl::namespace::eval punkboot::utils {
variable version
#- this version number, exactly 0.1.1, is a literal used in src module folders
#- this version number, exactly 0.2.0, is a literal used in src module folders
#- we refer to this sometimes as the magic version number
set version 0.1.1
set version 0.2.0
}]
return

120
src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

@ -20,7 +20,7 @@ namespace eval ::punkboot {
variable scriptfolder [file normalize [file dirname [info script]]]
variable foldername [file tail $scriptfolder]
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k]
variable non_help_flags [list -k -dirty-abort]
variable help_flags [list -help --help /? -h]
variable known_commands [list project modules libs packages vfs vfslibs bin info check shell vendorupdate bootsupport vfscommonupdate projectversion]
}
@ -1364,6 +1364,13 @@ proc ::punkboot::punkboot_gethelp {args} {
append h " - run the punk shell using bootsupport libraries." \n
append h " $scriptname projectversion" \n
append h " - advisory check: verify CHANGELOG.md matches punkproject.toml and warn if src/ has changes since the last project-version bump." \n \n
append h " Flags:" \n
append h " -dirty-abort" \n
append h " - abort build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) when src/ has" \n
append h " uncommitted VCS changes. Default is warn-only: artifacts built from dirty src have no committed provenance." \n
append h " Warnings carry a plain PROVENANCE-WARNING: prefix (greppable in redirected output) and are recapped at the end of the run." \n
append h " Use '$scriptname check' to see the current provenance status. To evaluate uncommitted source without building," \n
append h " use '<builtexe> src' or '<builtexe> src shell'." \n \n
append h "" \n
if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} {
set has_recommended 0
@ -1604,6 +1611,98 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
set sourcefolder $projectroot/src
set binfolder $projectroot/bin
# ----------------------------------------
# Provenance-warning presentation + dirty-src check for build/promotion commands (goal G-026 direction).
# Build/promotion commands stamp versions onto src content and propagate it into trees other
# things consume (root modules/, bootsupport snapshots, vfs payloads, kits/zipkits).
# Artifacts built from uncommitted src have no committed provenance - warn by default,
# abort if the -dirty-abort flag was given. To evaluate uncommitted source without
# building, use '<builtexe> src' / '<builtexe> src shell' instead.
# Guarded require: a stale or missing punkboot::utils bootsupport snapshot must never
# brick the make.tcl commands used to repair it - the check degrades to a skip notice
# (but -dirty-abort still aborts rather than silently skipping the requested strictness).
#Emit provenance warnings with a plain column-0 token for automated discovery (grep PROVENANCE-WARNING
#in redirected output) and ANSI colour for humans. Lines are also accumulated in
#::punkboot::provenance_warnings_pending unless -norecap is given, so the wrapped ::exit below can
#recap them at the tail of the output - build progress output is chatty and the original warning
#position may scroll out of sight or even out of scrollback.
set ::punkboot::provenance_warnings_pending [list]
proc ::punkboot::print_provenance_warnings {warninglines args} {
global A
if {![array size A]} {punkboot::define_global_ansi}
foreach w $warninglines {
regsub {^WARNING: } $w "" w
puts stderr "PROVENANCE-WARNING: $A(BAD)$w$A(RST)"
if {"-norecap" ni $args} {
lappend ::punkboot::provenance_warnings_pending $w
}
}
flush stderr
}
#Availability probe + scoped dirty-src check, shared by the build/promotion gate below and the
#'check' command report. Returns {available warninglist}.
proc ::punkboot::get_src_provenance_warnings {projectroot label} {
set available [expr {\
![catch {package require punkboot::utils}]\
&& [llength [info commands ::punkboot::utils::vcs_dirty_warnings]]\
&& "scope" in [info args ::punkboot::utils::vcs_dirty_warnings]\
}]
if {!$available} {
return [list 0 [list]]
}
set checked_vcs_roots [dict create]
return [list 1 [::punkboot::utils::vcs_dirty_warnings $projectroot checked_vcs_roots $label src]]
}
#Wrap ::exit so accumulated provenance warnings are recapped at the very end of output no matter
#which of make.tcl's many exit points a command takes.
if {![llength [info commands ::punkboot::exit_original]]} {
rename ::exit ::punkboot::exit_original
proc ::exit {{returnCode 0}} {
if {[info exists ::punkboot::provenance_warnings_pending] && [llength $::punkboot::provenance_warnings_pending]} {
puts stderr ""
puts stderr "PROVENANCE-WARNING: recap of warning(s) emitted earlier in this run:"
::punkboot::print_provenance_warnings $::punkboot::provenance_warnings_pending -norecap
}
::punkboot::exit_original $returnCode
}
}
if {$::punkboot::command in {project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate}} {
set dirty_abort [expr {[lsearch $::argv -dirty-abort] >= 0}]
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl $::punkboot::command"] have_scoped_dirty_check dirty_warnings
if {$have_scoped_dirty_check} {
if {[llength $dirty_warnings]} {
::punkboot::print_provenance_warnings $dirty_warnings
puts stderr " To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
if {$dirty_abort} {
set ::punkboot::provenance_warnings_pending [list] ;#no recap needed - aborting adjacent to the warning
puts stderr "-aborted- (-dirty-abort given and src has uncommitted changes - commit first, or rerun without -dirty-abort to build with a warning)"
exit 1
}
#Grace period for an attentive human to ctrl-c - only when stdin is a terminal
#(-inputmode is only supported on terminal channels, Tcl 8.7+/9; pipes/redirects/8.6 skip the delay
# so agent/CI runs pay nothing)
if {![catch {chan configure stdin -inputmode}]} {
puts -nonewline stderr " proceeding despite dirty src - ctrl-c now to abort "
flush stderr
foreach tick {3 2 1} {
puts -nonewline stderr "..$tick"
flush stderr
after 1000
}
puts stderr ""
}
}
} else {
if {$dirty_abort} {
puts stderr "-aborted- (-dirty-abort given but the dirty-src provenance check is unavailable: punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
exit 1
}
puts stderr "NOTE: dirty-src provenance check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport) - continuing without it"
}
}
if {$::punkboot::command eq "check"} {
set sep [string repeat - 75]
puts stdout $sep
@ -1738,6 +1837,21 @@ if {$::punkboot::command eq "check"} {
puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport"
puts stderr "=============================================================================="
}
# Dirty-src provenance status - what the build/promotion commands would do
puts stdout $sep
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl check"] _prov_available _prov_warnings
if {!$_prov_available} {
puts stdout "src provenance: check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)"
puts stdout " build/promotion commands will proceed with a NOTE; -dirty-abort would abort as unverifiable."
} elseif {![llength $_prov_warnings]} {
puts stdout "src provenance: OK (no uncommitted fossil/git changes under src/)"
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will proceed without provenance warnings."
} else {
::punkboot::print_provenance_warnings $_prov_warnings -norecap
puts stdout " build/promotion commands (project packages modules libs vfs vfslibs bin bootsupport vfscommonupdate) will WARN as above and proceed."
puts stdout " With -dirty-abort they would abort. To evaluate uncommitted source without building, use '<builtexe> src' or '<builtexe> src shell'."
}
puts stdout $sep
exit 0
}
@ -2040,9 +2154,7 @@ if {$::punkboot::command eq "vendorupdate"} {
set normsrclocation [file normalize $srclocation]
if {![dict exists $checked_source_paths $normsrclocation]} {
dict set checked_source_paths $normsrclocation 1
foreach w [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate] {
puts stderr $w
}
::punkboot::print_provenance_warnings [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate]
}
}
#puts stdout "$relpath $module $module_subpath $srclocation"

Loading…
Cancel
Save