You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
352 lines
16 KiB
352 lines
16 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punkboot::utils 0.4.0 |
|
# Meta platform tcl |
|
# Meta license BSD |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
package require Tcl 8.6- |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punkboot::utils { |
|
variable version 0.1.0 |
|
namespace export parse_punkproject_version read_punkproject_version read_changelog_latest_version vcs_dirty_warnings vfs_boot_library_report |
|
|
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punkboot::utils::parse_punkproject_version |
|
@cmd -name "::punkboot::utils::parse_punkproject_version"\ |
|
-summary\ |
|
"Parse the [project] version from TOML content string"\ |
|
-help\ |
|
"Scans TOML content for the [project] section and returns |
|
the value of the version key as a string. Returns an empty |
|
string if the section or key is not found." |
|
@leaders |
|
content -type string -optional 0 -help\ |
|
"TOML content string to parse" |
|
}] |
|
} |
|
proc parse_punkproject_version {content} { |
|
set in_project 0 |
|
foreach line [split $content \n] { |
|
set trimmed [string trim $line] |
|
if {[string index $trimmed 0] eq {[} && [string index $trimmed end] eq {]}} { |
|
set in_project [expr {$trimmed eq "\[project\]"}] |
|
continue |
|
} |
|
if {$in_project && [regexp {^version\s*=\s*"([^"]+)"} $trimmed _ v]} { |
|
return $v |
|
} |
|
} |
|
return "" |
|
} |
|
|
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punkboot::utils::read_punkproject_version |
|
@cmd -name "::punkboot::utils::read_punkproject_version"\ |
|
-summary\ |
|
"Read the [project] version from a TOML file"\ |
|
-help\ |
|
"Reads the file at tomlfile and returns the [project] |
|
version value as a string. Returns an empty string if the |
|
file does not exist or the version is not found." |
|
@leaders |
|
tomlfile -type string -optional 0 -help\ |
|
"Path to the TOML file to read" |
|
}] |
|
} |
|
proc read_punkproject_version {tomlfile} { |
|
if {![file exists $tomlfile]} {return ""} |
|
set fh [open $tomlfile r] |
|
try { |
|
set content [read $fh] |
|
} finally { |
|
close $fh |
|
} |
|
return [::punkboot::utils::parse_punkproject_version $content] |
|
} |
|
|
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punkboot::utils::read_changelog_latest_version |
|
@cmd -name "::punkboot::utils::read_changelog_latest_version"\ |
|
-summary\ |
|
"Read the latest ## [X.Y.Z] version header from a changelog file"\ |
|
-help\ |
|
"Scans the changelog file from the top and returns the |
|
version string from the first '## [X.Y.Z]' header line. |
|
Returns an empty string if the file does not exist or no |
|
matching header is found." |
|
@leaders |
|
changelogfile -type string -optional 0 -help\ |
|
"Path to the changelog file to read" |
|
}] |
|
} |
|
proc read_changelog_latest_version {changelogfile} { |
|
if {![file exists $changelogfile]} {return ""} |
|
set fh [open $changelogfile r] |
|
try { |
|
set content [read $fh] |
|
} finally { |
|
close $fh |
|
} |
|
foreach line [split $content \n] { |
|
if {[regexp {^##\s*\[([0-9][^\]]*)\]} $line _ v]} { |
|
return $v |
|
} |
|
} |
|
return "" |
|
} |
|
|
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punkboot::utils::vcs_dirty_warnings |
|
@cmd -name "::punkboot::utils::vcs_dirty_warnings"\ |
|
-summary\ |
|
"Warning lines for uncommitted VCS changes above a path"\ |
|
-help\ |
|
"Walks up from path to the nearest fossil and/or git root and |
|
returns warning lines describing uncommitted changes. |
|
Artifacts built from a dirty source tree have no committed |
|
provenance - callers such as make.tcl vendorupdate use this |
|
to flag source projects that should be committed first. |
|
|
|
checkedrootsvar names a dict variable in the caller's scope |
|
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." |
|
@leaders |
|
path -type string -optional 0 -help\ |
|
"Path to check; the nearest enclosing fossil/git root is examined" |
|
checkedrootsvar -type string -optional 0 -help\ |
|
"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 ""} {scope ""}} { |
|
upvar 1 $checkedrootsvar checkedroots |
|
if {![info exists checkedroots]} {set checkedroots [dict create]} |
|
if {$label ne ""} {set label "$label "} |
|
set warnings [list] |
|
set dir [file normalize $path] |
|
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} { |
|
if {$fossilroot eq "" && ([file exists [file join $dir .fslckout]] || [file exists [file join $dir _FOSSIL_]])} { |
|
set fossilroot $dir |
|
} |
|
if {$gitroot eq "" && [file exists [file join $dir .git]]} { |
|
set gitroot $dir |
|
} |
|
if {$fossilroot ne "" || $gitroot ne ""} { |
|
break ;#report at the nearest VCS root(s); a dual git+fossil root is caught in one pass |
|
} |
|
set parent [file dirname $dir] |
|
if {$parent eq $dir} { break } |
|
set dir $parent |
|
} |
|
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 { |
|
cd $fossilroot |
|
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)" |
|
} else { |
|
set flines [list] |
|
foreach line [split $fchanges \n] { |
|
set line [string trim $line] |
|
if {$line eq ""} {continue} |
|
if {$scopeabs ne ""} { |
|
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>' |
|
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue} |
|
set normfile [file normalize [file join $fossilroot $relfile]] |
|
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue} |
|
} |
|
lappend flines $line |
|
} |
|
if {[llength $flines]} { |
|
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance" |
|
} |
|
} |
|
cd $original_cwd |
|
} |
|
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$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 {*}$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${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance" |
|
} |
|
} |
|
return $warnings |
|
} |
|
|
|
|
|
#Companion files of a real Tcl library directory. init.tcl sources these, so a |
|
#directory holding init.tcl with none of them beside it is a package's own init |
|
#script (lib/BWidget1.10.1/init.tcl and friends), not a tcl library. |
|
variable boot_library_companions {tm.tcl package.tcl auto.tcl clock.tcl history.tcl word.tcl} |
|
|
|
namespace eval argdoc { |
|
lappend PUNKARGS [list { |
|
@id -id ::punkboot::utils::vfs_boot_library_report |
|
@cmd -name "::punkboot::utils::vfs_boot_library_report"\ |
|
-summary\ |
|
"Report whether an assembled vfs tree can supply a bootable tcl library"\ |
|
-help\ |
|
"Structural check of a merged .vfs tree for the precondition a kit |
|
needs to initialise at all: a Tcl library the runtime can find. Reads |
|
the directory only - nothing is executed, decompressed or launched, so |
|
a caller such as make.tcl can run it for every kit on every bake and |
|
for a cross-target kit it could never run itself. |
|
|
|
Three conventions are recognised, all observed in real runtimes: |
|
tcl_library/ zipfs-attached kits (tclZipfs looks for |
|
<mount>/tcl_library/init.tcl) |
|
lib/tcl<M>.<m>/ starkit/tclkit-style kits (lib/tcl8.6, |
|
lib/tcl9.0) |
|
tcl<M>.<m>/ runtimes whose archive mounts at the |
|
executable's own path rather than at |
|
//zipfs:/app, so [info library] is |
|
<exe>/tcl8.6 - the androwish/undroidwish |
|
zipfs backport for Tcl 8.6 does this |
|
|
|
A candidate directory qualifies only when it holds init.tcl AND at |
|
least one companion file a real Tcl library carries beside it |
|
(tm.tcl, package.tcl, auto.tcl, clock.tcl, history.tcl, word.tcl) or |
|
an encoding/ subdirectory. Without that second test a package's own |
|
init script - lib/BWidget1.10.1/init.tcl, present in every punkshell |
|
kit - would answer for a tcl library it cannot provide. |
|
|
|
Returned dict keys: |
|
ok 1 when at least one qualifying library was found |
|
locations qualifying directories, relative to vfsfolder |
|
rejected candidate directories that held init.tcl but no |
|
companion, relative to vfsfolder - the near-misses |
|
worth naming when a gate fires unexpectedly |
|
checked the location patterns examined, relative to vfsfolder |
|
reason why ok is 0; empty string when ok is 1" |
|
@leaders |
|
vfsfolder -type string -optional 0 -help\ |
|
"Path of the assembled vfs tree to inspect" |
|
}] |
|
} |
|
proc vfs_boot_library_report {vfsfolder} { |
|
variable boot_library_companions |
|
set checked [list tcl_library lib/tcl<M>.<m> tcl<M>.<m>] |
|
set report [dict create ok 0 locations {} rejected {} checked $checked reason ""] |
|
if {![file isdirectory $vfsfolder]} { |
|
dict set report reason "no such directory: $vfsfolder" |
|
return $report |
|
} |
|
#candidates are the three conventions only - a full tree walk would find every |
|
#package's init.tcl and cost more than the check is worth. |
|
#The tcl[0-9]* globs deliberately also match module trees named tcl8/ or tcl9/ |
|
#(both exist in this project's kits); they carry no init.tcl, so the qualification |
|
#test below rejects them without needing a narrower pattern. |
|
set candidates [list [file join $vfsfolder tcl_library]] |
|
foreach dir [lsort [glob -nocomplain -type d -directory [file join $vfsfolder lib] -- {tcl[0-9]*}]] { |
|
lappend candidates $dir |
|
} |
|
foreach dir [lsort [glob -nocomplain -type d -directory $vfsfolder -- {tcl[0-9]*}]] { |
|
lappend candidates $dir |
|
} |
|
set locations [list] |
|
set rejected [list] |
|
foreach dir $candidates { |
|
if {![file isfile [file join $dir init.tcl]]} { |
|
continue |
|
} |
|
set qualifies 0 |
|
foreach companion $boot_library_companions { |
|
if {[file isfile [file join $dir $companion]]} { |
|
set qualifies 1 |
|
break |
|
} |
|
} |
|
if {!$qualifies && [file isdirectory [file join $dir encoding]]} { |
|
set qualifies 1 |
|
} |
|
set rel [string range $dir [expr {[string length $vfsfolder] + 1}] end] |
|
if {$qualifies} { |
|
lappend locations $rel |
|
} else { |
|
lappend rejected $rel |
|
} |
|
} |
|
if {[llength $locations]} { |
|
dict set report ok 1 |
|
dict set report locations $locations |
|
dict set report rejected $rejected |
|
return $report |
|
} |
|
dict set report rejected $rejected |
|
if {[llength $rejected]} { |
|
dict set report reason "no tcl library in [file tail $vfsfolder]: [join $rejected {, }] hold init.tcl but none of the companion files a tcl library carries beside it ([join $boot_library_companions {, }]) nor an encoding/ directory" |
|
} else { |
|
dict set report reason "no tcl library in [file tail $vfsfolder]: none of tcl_library/init.tcl, lib/tcl<major>.<minor>/init.tcl or tcl<major>.<minor>/init.tcl is present" |
|
} |
|
return $report |
|
} |
|
} |
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punkboot::utils ::punkboot::utils::argdoc |
|
} |
|
|
|
## Ready |
|
package provide punkboot::utils [tcl::namespace::eval punkboot::utils { |
|
variable version |
|
#- this version number, exactly 0.4.0, is a literal used in src module folders |
|
#- we refer to this sometimes as the magic version number |
|
set version 0.4.0 |
|
}] |
|
return
|
|
|