From 803f3ca5ff1c36f15b7f6a55288755828596f066 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Sat, 11 Jul 2026 16:45:39 +1000 Subject: [PATCH] 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 --- .../{tclcore-0.1.0.tm => tclcore-0.2.0.tm} | 105 +++++---- .../modules/punk/libunknown-0.2.0.tm} | 210 +++++++++++++++++- .../punk/mix/commandset/loadedlib-0.2.0.tm} | 93 ++++++-- .../modules/punkboot/utils-0.2.0.tm} | 54 ++++- .../custom/_project/punk.basic/src/make.tcl | 120 +++++++++- .../{tclcore-0.1.0.tm => tclcore-0.2.0.tm} | 105 +++++---- .../modules/punk/libunknown-0.2.0.tm} | 210 +++++++++++++++++- .../punk/mix/commandset/loadedlib-0.2.0.tm} | 93 ++++++-- .../modules/punkboot/utils-0.2.0.tm} | 54 ++++- .../_project/punk.project-0.1/src/make.tcl | 120 +++++++++- .../{tclcore-0.1.0.tm => tclcore-0.2.0.tm} | 105 +++++---- ...{libunknown-0.1.tm => libunknown-0.2.0.tm} | 210 +++++++++++++++++- .../punk/mix/commandset/loadedlib-0.2.0.tm} | 93 ++++++-- .../modules/punkboot/utils-0.2.0.tm} | 54 ++++- .../_project/punk.shell-0.1/src/make.tcl | 120 +++++++++- 15 files changed, 1500 insertions(+), 246 deletions(-) rename src/bootsupport/modules/punk/args/moduledoc/{tclcore-0.1.0.tm => tclcore-0.2.0.tm} (99%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm => bootsupport/modules/punk/libunknown-0.2.0.tm} (89%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm => bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm} (84%) rename src/{project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm => bootsupport/modules/punkboot/utils-0.2.0.tm} (77%) rename src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/{tclcore-0.1.0.tm => tclcore-0.2.0.tm} (99%) rename src/{bootsupport/modules/punk/libunknown-0.1.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm} (89%) rename src/project_layouts/custom/_project/{punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm => punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm} (84%) rename src/project_layouts/custom/_project/{punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm => punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm} (77%) rename src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/{tclcore-0.1.0.tm => tclcore-0.2.0.tm} (99%) rename src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/{libunknown-0.1.tm => libunknown-0.2.0.tm} (89%) rename src/{bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm} (84%) rename src/{bootsupport/modules/punkboot/utils-0.1.1.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm} (77%) diff --git a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm similarity index 99% rename from src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm rename to src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm index 04a903c4..e9aa41b9 100644 --- a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/bootsupport/modules/punk/libunknown-0.2.0.tm similarity index 89% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm rename to src/bootsupport/modules/punk/libunknown-0.2.0.tm index eca0df03..6319daf0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/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 +# -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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm similarity index 84% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm rename to src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm index a07aca09..056f243e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/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 # @@ 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,19 +75,47 @@ namespace eval punk::mix::commandset::loadedlib { set opt_highlight [dict get $opts -highlight] set opt_refresh [dict exists $received -refresh] - if {$opt_refresh} { - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans - foreach tm_path [tcl::tm::list] { - set paths_below [punk::path::subfolders -recursive $tm_path] - foreach folder $paths_below { - set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { - continue + #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} { + #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 { + set tail [file tail $folder] + if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + continue + } + if {[string match */_build/* $folder]} {continue} + set relpath [string tolower [punk::path::relative $tm_path $folder]] + set modpath [string map {/ ::} $relpath] + catch {package require ${modpath}::flobrudder99} } - if {[string match */_build/* $folder]} {continue} - set relpath [string tolower [punk::path::relative $tm_path $folder]] - set modpath [string map {/ ::} $relpath] - catch {package require ${modpath}::flobrudder99} } } } @@ -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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm b/src/bootsupport/modules/punkboot/utils-0.2.0.tm similarity index 77% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm rename to src/bootsupport/modules/punkboot/utils-0.2.0.tm index be23f56e..736f28f8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm +++ b/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 ' ' + 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 diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index eead4196..1a7dc687 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/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 ' src' or ' 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 ' src' / ' 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 ' src' or ' 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 ' src' or ' 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" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm index 04a903c4..e9aa41b9 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/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 diff --git a/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm similarity index 89% rename from src/bootsupport/modules/punk/libunknown-0.1.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm index eca0df03..6319daf0 100644 --- a/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/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 +# -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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm similarity index 84% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm index a07aca09..056f243e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/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 # @@ 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,19 +75,47 @@ namespace eval punk::mix::commandset::loadedlib { set opt_highlight [dict get $opts -highlight] set opt_refresh [dict exists $received -refresh] - if {$opt_refresh} { - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans - foreach tm_path [tcl::tm::list] { - set paths_below [punk::path::subfolders -recursive $tm_path] - foreach folder $paths_below { - set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { - continue + #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} { + #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 { + set tail [file tail $folder] + if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + continue + } + if {[string match */_build/* $folder]} {continue} + set relpath [string tolower [punk::path::relative $tm_path $folder]] + set modpath [string map {/ ::} $relpath] + catch {package require ${modpath}::flobrudder99} } - if {[string match */_build/* $folder]} {continue} - set relpath [string tolower [punk::path::relative $tm_path $folder]] - set modpath [string map {/ ::} $relpath] - catch {package require ${modpath}::flobrudder99} } } } @@ -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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm similarity index 77% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm index be23f56e..736f28f8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.1.1.tm +++ b/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 ' ' + 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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index eead4196..1a7dc687 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/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 ' src' or ' 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 ' src' / ' 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 ' src' or ' 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 ' src' or ' 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" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm similarity index 99% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.2.0.tm index 04a903c4..e9aa41b9 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm similarity index 89% rename from src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.2.0.tm index eca0df03..6319daf0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/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 +# -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 diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm similarity index 84% rename from src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.2.0.tm index a07aca09..056f243e 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/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 # @@ 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,19 +75,47 @@ namespace eval punk::mix::commandset::loadedlib { set opt_highlight [dict get $opts -highlight] set opt_refresh [dict exists $received -refresh] - if {$opt_refresh} { - catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything REVIEW - this doesn't result in full scans - foreach tm_path [tcl::tm::list] { - set paths_below [punk::path::subfolders -recursive $tm_path] - foreach folder $paths_below { - set tail [file tail $folder] - if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { - continue + #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} { + #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 { + set tail [file tail $folder] + if {[string match #modpod-* $tail] || [string match #tarjar-* $tail]} { + continue + } + if {[string match */_build/* $folder]} {continue} + set relpath [string tolower [punk::path::relative $tm_path $folder]] + set modpath [string map {/ ::} $relpath] + catch {package require ${modpath}::flobrudder99} } - if {[string match */_build/* $folder]} {continue} - set relpath [string tolower [punk::path::relative $tm_path $folder]] - set modpath [string map {/ ::} $relpath] - catch {package require ${modpath}::flobrudder99} } } } @@ -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 diff --git a/src/bootsupport/modules/punkboot/utils-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm similarity index 77% rename from src/bootsupport/modules/punkboot/utils-0.1.1.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkboot/utils-0.2.0.tm index be23f56e..736f28f8 100644 --- a/src/bootsupport/modules/punkboot/utils-0.1.1.tm +++ b/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 ' ' + 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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index eead4196..1a7dc687 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/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 ' src' or ' 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 ' src' / ' 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 ' src' or ' 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 ' src' or ' 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"