Compare commits
6 Commits
7a37e36362
...
9b0fe35aa0
| Author | SHA1 | Date |
|---|---|---|
 Julian Noble
|
9b0fe35aa0 | 4 days ago |
|
Julian Noble
|
5a51cd87c4 | 4 days ago |
|
Julian Noble
|
81148b8fa7 | 4 days ago |
|
Julian Noble
|
f5a559038e | 4 days ago |
|
Julian Noble
|
d2f7dc6f0e | 4 days ago |
|
Julian Noble
|
583dd5e0b2 | 4 days ago |
32 changed files with 3536 additions and 783 deletions
@ -0,0 +1,71 @@
|
||||
# G-134 Baked kits pinned archive-relative: advisory offset-style probe on assembled kit images |
||||
|
||||
Status: proposed |
||||
Scope: src/make.tcl (post-assembly offset-style probe at the G-133 advisory-check seam, recapped reporting); src/modules/punkboot/utils-999999.0a1.0.tm (probe predicate beside the G-133 scan helpers, guarded require; bootsupport copies via established sync channels); src/tests/modules/punkboot/utils/ + src/tests/shell/testsuites/punkexe/ (characterization); src/AGENTS.md (what the pin does and does not guarantee) |
||||
Goal: every kit image make.tcl assembles is verified to carry an ARCHIVE-relative zip payload - probed with punk::zip::archive_info post-assembly - so the bake pipeline's archive-relative output property becomes a checked contract rather than a by-construction accident, and any future assembly path (new kit type, modpod or accelerator change) that emits file-relative offsets surfaces at bake time instead of when G-128's stamper refuses punkshell's own kits. |
||||
Acceptance: each assembled kit image is probed with punk::zip::archive_info and a recapped BUILD-WARNING naming the kit is emitted when offsetstyle is file (advisory per the G-133 posture - the kit still builds and deploys, unlike the G-125 hard gate); plain and none results (no zip attached - the metakit kit shape G-131 targets) are silence, not warnings: the pin covers zip offset convention, not the presence of a zip; today's bakes produce no warning (G-124's measured baseline: every built kit archive-relative); the probe predicate lives in punkboot::utils beside the G-133 scan helpers, called through the same guarded require so a stale bootsupport snapshot degrades it to a NOTE, and tclsh src/make.tcl check reports its ACTIVE/UNAVAILABLE state; characterization pins the warning on a file-relative kit fixture and silence on the archive-relative kit set; scope is make.tcl's own assembly paths only - punk::zip::mkzip -offsettype file and modpod's equivalent REMAIN available for deliberate manual creation of file-relative artifacts (user decision 2026-07-27: the format works and serves naive zip-tooling/SFX-repair interop, it is simply not what our pipeline emits), and external zip-repair tools' file-relative output remains tolerated on input by the G-124 reader and normalized away by any re-bake. |
||||
|
||||
## Context |
||||
|
||||
Archive-relative output has been by-construction, never contractual: it falls out of |
||||
mkzip's `-offsettype archive` default and modern zipfs mkimg, and G-124 measured it |
||||
across the store 2026-07-26 (15 archive-relative runtimes plus every built kit; the |
||||
single file-relative artifact is `tclsh90b4_piperepl.exe`, the historical mkimg |
||||
convention). Input artifacts may legitimately be file-relative - 3rd-party zipfs kits, |
||||
external zip-repair output - and the merge normalizes them because the payload is |
||||
always rebuilt from extracted members. But nothing fails loudly if a future assembly |
||||
path regresses the output convention; the first symptom would be G-128's stamper |
||||
refusing punkshell's own kits. This goal pins the property at the seam G-133 |
||||
established for advisory payload checks. |
||||
|
||||
Decided 2026-07-27 alongside G-128's consented file-relative preserve amendment: the |
||||
file-relative format is supported everywhere it can arrive (the reader tolerates it, |
||||
the stamper preserves it with consent, the writers can emit it on request) - this pin |
||||
asserts only what OUR pipeline emits by default. |
||||
|
||||
## Approach |
||||
|
||||
- One probe at the post-assembly seam beside G-133's binary-arch scan: |
||||
`punk::zip::archive_info` on the finished image; BUILD-WARNING unless offsetstyle is |
||||
`archive`, recapped at end of run. Per-kit cost is one EOCD scan + central-directory |
||||
walk, only when the kit rebuilds (G-124 measured ~735ms for an 841-member archive - |
||||
the same order as G-133's arch scan). |
||||
- Advisory, matching G-133: warnings never block build or deploy. |
||||
- No new instrument: G-124's archive_info is the whole probe; the punkboot::utils |
||||
predicate wraps it so it unit-tests without a bake. |
||||
|
||||
## Alternatives considered |
||||
|
||||
- Hard gate (G-125-style kit failure) - rejected (user decision 2026-07-27): the |
||||
property holds by construction today and make.tcl has no deliberate file-relative |
||||
path; a hard gate would fire only on a regression already loud in tests and would |
||||
block any future deliberate per-kit opt-out. G-125's gate exists for user-facing |
||||
undeployable kits; this is a developer-facing convention notice. |
||||
- Documentation-only pin in src/AGENTS.md - rejected as enforcement-free: prose does |
||||
not fire when the regression lands. |
||||
|
||||
## Notes |
||||
|
||||
- Related: G-124 (achieved 2026-07-26 - see goals/archive/G-124-punkzip-reader.md) - |
||||
supplies the probe (archive_info: offsetstyle archive|file|plain|none plus |
||||
dataoffset) and the store survey that is this pin's baseline. |
||||
- Related: G-133 (achieved 2026-07-27 - see |
||||
goals/archive/G-133-bake-payload-consistency-checks.md) - the advisory-check seam, |
||||
recapped BUILD-WARNING convention, guarded-require degradation and `make.tcl check` |
||||
reporting this probe follows. |
||||
- Related: G-125 - the hard-gate contrast recorded under Alternatives. |
||||
- Related: G-128 - the consumer that motivated the pin: its stamper refuses |
||||
file-relative payloads by default (consent-flag preserve per the 2026-07-27 |
||||
amendment); without this pin a pipeline regression surfaces there first, on our own |
||||
kits. |
||||
- Related: G-122 (achieved - see goals/archive/G-122-host-target-platform-split.md) / |
||||
G-127 - the zipfs-less and cross-target assembly paths under the probe; both assemble |
||||
via mkzip/mkimg archive-relative defaults today. |
||||
- Related: G-131 - metakit-shape kits carry no zip; the probe's `none` result is |
||||
silence, not a warning. |
||||
- Overlap survey 2026-07-27: `goals_xref paths src/make.tcl src/bootsupport src/tests` |
||||
- no live goals intersect src/make.tcl or src/tests; src/bootsupport produced weak |
||||
lexical hits only (G-004, G-024, G-026, G-132 - bootsupport path mentions, no |
||||
semantic overlap with an offset-style probe). `goals_xref report` reviewed: no |
||||
unlinked pair concerns an output offset-convention check. The G-124/G-133 anchors are |
||||
archived; the relations above are from reading. |
||||
@ -1,4 +1,4 @@
|
||||
[project] |
||||
name = "punkshell" |
||||
version = "0.28.1" |
||||
version = "0.28.2" |
||||
license = "BSD-2-Clause" |
||||
|
||||
Binary file not shown.
@ -1,352 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application 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 |
||||
@ -0,0 +1,753 @@
|
||||
# -*- 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.5.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 binary_arch_classify parse_punkproject_version read_punkproject_version read_changelog_latest_version vcs_dirty_warnings vfs_binary_arch_report 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 |
||||
} |
||||
|
||||
#G-133 binary-arch scan support. Recognition data is deliberately plain namespace |
||||
#variables so extending it (a new vendor spelling, a new cpu token) is a visible |
||||
#one-line edit rather than a code change. |
||||
# |
||||
#PE Machine field values (IMAGE_FILE_HEADER.Machine, 2 bytes LE at e_lfanew+4) |
||||
variable pe_machine_map { |
||||
014c i386 |
||||
8664 x86_64 |
||||
aa64 arm64 |
||||
01c0 arm |
||||
01c4 arm |
||||
0200 ia64 |
||||
0166 mips |
||||
01f0 ppc |
||||
5032 riscv32 |
||||
5064 riscv64 |
||||
} |
||||
#ELF e_machine values (2 bytes at offset 18, endianness per EI_DATA) |
||||
variable elf_machine_map { |
||||
3 i386 |
||||
62 x86_64 |
||||
183 arm64 |
||||
40 arm |
||||
8 mips |
||||
20 ppc |
||||
21 ppc64 |
||||
22 s390x |
||||
2 sparc |
||||
43 sparc64 |
||||
243 riscv |
||||
} |
||||
#Mach-O cputype base values (CPU_ARCH_ABI64 flag 0x01000000 selects the 64-bit variant) |
||||
variable macho_cputype_map { |
||||
7 {i386 x86_64} |
||||
12 {arm arm64} |
||||
18 {ppc ppc64} |
||||
} |
||||
#os / cpu tokens accepted in a CANONICAL platform-dir segment (<os>-<cpu>). The os and |
||||
#cpu lists follow the punk::platform canon plus common alias tokens, so a platform- |
||||
#discriminated subdir is recognised whichever spelling a package author normalised to. |
||||
variable platform_segment_os { |
||||
win32 windows linux macosx freebsd netbsd openbsd dragonfly solaris sunos |
||||
aix hpux irix qnx haiku android msys cygwin |
||||
} |
||||
variable platform_segment_cpu { |
||||
x86_64 amd64 x64 ix86 i386 i486 i586 i686 x86 |
||||
arm64 aarch64 arm armv6 armv7 armv6l armv7l |
||||
ppc ppc64 ppc64le powerpc mips mipsel mips64 |
||||
riscv32 riscv64 s390 s390x sparc sparc64 universal |
||||
} |
||||
#Recognised VENDOR spellings observed (or near-certain) as platform-discriminating |
||||
#directory names that do not parse as <canonical os>-<canonical cpu>. blend2d, |
||||
#extrafont and tclMuPDF ship win-x64 today. |
||||
variable platform_segment_vendor { |
||||
win-x64 win-x86 win-arm64 win-arm win32 win64 |
||||
linux-x64 linux-arm64 macos-x64 macos-arm64 osx-x64 osx-arm64 |
||||
} |
||||
#File tails treated as binary libraries by vfs_binary_arch_report |
||||
variable binary_library_globs {*.dll *.so *.so.[0-9]* *.dylib} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::binary_arch_classify |
||||
@cmd -name "::punkboot::utils::binary_arch_classify"\ |
||||
-summary\ |
||||
"Classify a binary library file's executable format and cpu architecture"\ |
||||
-help\ |
||||
"Reads only the file's header bytes (a couple of small reads - nothing |
||||
is executed or loaded) and classifies the executable format and cpu |
||||
architecture: |
||||
PE Machine field (2 bytes at e_lfanew+4): i386, x86_64, arm64... |
||||
ELF e_machine honouring EI_DATA endianness |
||||
Mach-O thin (cputype) and fat/universal (per-member cputypes) |
||||
Unrecognised content is reported honestly as format 'unknown' rather |
||||
than guessed. |
||||
|
||||
Returned dict keys: |
||||
format pe | elf | macho | unknown |
||||
arch i386 | x86_64 | arm64 | ... | universal | unknown | |
||||
unknown-0x<hex> (a real header whose machine value is not |
||||
in the recognition map - definite, just unmapped) |
||||
archs member architectures (macho universal only; absent otherwise) |
||||
detail short human-readable classification" |
||||
@leaders |
||||
libfile -type string -optional 0 -help\ |
||||
"Path of the binary library file to classify" |
||||
}] |
||||
} |
||||
proc binary_arch_classify {libfile} { |
||||
variable pe_machine_map |
||||
variable elf_machine_map |
||||
variable macho_cputype_map |
||||
if {[catch { |
||||
set fd [open $libfile r] |
||||
chan configure $fd -translation binary |
||||
set head [read $fd 64] |
||||
} errM]} { |
||||
catch {close $fd} |
||||
return [dict create format unknown arch unknown detail "unreadable: $errM"] |
||||
} |
||||
set result [dict create format unknown arch unknown detail "not a recognised binary library format"] |
||||
try { |
||||
if {[string length $head] < 8} { |
||||
dict set result detail "too short to carry an executable header ([string length $head] bytes)" |
||||
return $result |
||||
} |
||||
set magic4 [string range $head 0 3] |
||||
if {[string range $head 0 1] eq "MZ"} { |
||||
#PE: e_lfanew at 0x3c points at "PE\0\0" + IMAGE_FILE_HEADER |
||||
if {[binary scan $head @60iu e_lfanew] != 1} { |
||||
dict set result detail "MZ header too short for e_lfanew" |
||||
return $result |
||||
} |
||||
seek $fd $e_lfanew |
||||
set pehdr [read $fd 6] |
||||
if {[string length $pehdr] < 6 || [string range $pehdr 0 3] ne "PE\x00\x00"} { |
||||
dict set result detail "MZ header without PE signature (DOS executable?)" |
||||
return $result |
||||
} |
||||
binary scan $pehdr @4su machine |
||||
set hexmachine [format %04x $machine] |
||||
if {[dict exists $pe_machine_map $hexmachine]} { |
||||
set arch [dict get $pe_machine_map $hexmachine] |
||||
set result [dict create format pe arch $arch detail "PE $arch"] |
||||
} else { |
||||
set result [dict create format pe arch unknown-0x$hexmachine detail "PE machine 0x$hexmachine (not in recognition map)"] |
||||
} |
||||
} elseif {$magic4 eq "\x7fELF"} { |
||||
binary scan $head @4cu elfclass |
||||
binary scan $head @5cu elfdata |
||||
if {$elfdata == 2} { |
||||
binary scan $head @18Su e_machine ;#big-endian |
||||
} else { |
||||
binary scan $head @18su e_machine ;#little-endian (and honest-enough default) |
||||
} |
||||
if {[dict exists $elf_machine_map $e_machine]} { |
||||
set arch [dict get $elf_machine_map $e_machine] |
||||
if {$arch eq "riscv"} { |
||||
set arch [expr {$elfclass == 2 ? "riscv64" : "riscv32"}] |
||||
} |
||||
set result [dict create format elf arch $arch detail "ELF $arch"] |
||||
} else { |
||||
set result [dict create format elf arch unknown-$e_machine detail "ELF e_machine $e_machine (not in recognition map)"] |
||||
} |
||||
} else { |
||||
binary scan $head Iu be32 |
||||
switch -- [format %08x $be32] { |
||||
feedface - feedfacf - cefaedfe - cffaedfe { |
||||
#thin Mach-O; cputype follows the magic in the file's own byte order |
||||
if {[string index $head 0] eq "\xfe"} { |
||||
binary scan $head @4Iu cputype ;#big-endian file |
||||
} else { |
||||
binary scan $head @4iu cputype |
||||
} |
||||
set is64 [expr {($cputype & 0x01000000) != 0}] |
||||
set base [expr {$cputype & 0x00ffffff}] |
||||
if {[dict exists $macho_cputype_map $base]} { |
||||
set arch [lindex [dict get $macho_cputype_map $base] $is64] |
||||
set result [dict create format macho arch $arch detail "Mach-O $arch"] |
||||
} else { |
||||
set result [dict create format macho arch unknown-cputype-$base detail "Mach-O cputype $base (not in recognition map)"] |
||||
} |
||||
} |
||||
cafebabe - cafebabf { |
||||
#fat/universal (big-endian header). A Java class file shares the |
||||
#magic - its version field where nfat_arch sits is >= 45, far above |
||||
#any credible member count, so an implausible count stays unknown. |
||||
binary scan $head @4Iu nfat |
||||
if {$nfat == 0 || $nfat > 30} { |
||||
dict set result detail "cafebabe magic with implausible member count $nfat (java class file?)" |
||||
return $result |
||||
} |
||||
set entrysize [expr {$be32 == 0xcafebabf ? 32 : 20}] |
||||
seek $fd 8 |
||||
set fatdata [read $fd [expr {$nfat * $entrysize}]] |
||||
set archs [list] |
||||
for {set i 0} {$i < $nfat} {incr i} { |
||||
if {[binary scan $fatdata @[expr {$i * $entrysize}]Iu cputype] != 1} { |
||||
break |
||||
} |
||||
set is64 [expr {($cputype & 0x01000000) != 0}] |
||||
set base [expr {$cputype & 0x00ffffff}] |
||||
if {[dict exists $macho_cputype_map $base]} { |
||||
lappend archs [lindex [dict get $macho_cputype_map $base] $is64] |
||||
} else { |
||||
lappend archs unknown-cputype-$base |
||||
} |
||||
} |
||||
set result [dict create format macho arch universal archs $archs detail "Mach-O universal ([join $archs {, }])"] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} finally { |
||||
catch {close $fd} |
||||
} |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::platform_expected_binary |
||||
@cmd -name "::punkboot::utils::platform_expected_binary"\ |
||||
-summary\ |
||||
"Expected binary format/arch for a canonical target platform name"\ |
||||
-help\ |
||||
"Maps a canonical punkshell platform name (<os>-<cpu>, e.g |
||||
win32-ix86) to the executable format and classifier arch token a |
||||
native binary library for that platform carries. Returns a dict |
||||
{format F arch A}, or an empty dict when the os or cpu token has |
||||
no recognised mapping (callers treat that as scan-not-applicable |
||||
rather than guessing)." |
||||
@leaders |
||||
targetplatform -type string -optional 0 -help\ |
||||
"Canonical platform name, e.g win32-x86_64, linux-x86_64, macosx-arm64" |
||||
}] |
||||
} |
||||
proc platform_expected_binary {targetplatform} { |
||||
set idx [string first - $targetplatform] |
||||
if {$idx <= 0} { |
||||
return [dict create] |
||||
} |
||||
set os [string range $targetplatform 0 [expr {$idx - 1}]] |
||||
set cpu [string range $targetplatform [expr {$idx + 1}] end] |
||||
switch -- $os { |
||||
win32 - windows {set format pe} |
||||
linux - freebsd - netbsd - openbsd - dragonfly - solaris - sunos {set format elf} |
||||
macosx - darwin - macos {set format macho} |
||||
default {return [dict create]} |
||||
} |
||||
switch -- $cpu { |
||||
ix86 - i386 - i486 - i586 - i686 - x86 {set arch i386} |
||||
x86_64 - amd64 - x64 {set arch x86_64} |
||||
arm64 - aarch64 {set arch arm64} |
||||
arm - armv6 - armv7 {set arch arm} |
||||
ppc - ppc64 - riscv64 - mips - s390x - sparc - sparc64 {set arch $cpu} |
||||
default {return [dict create]} |
||||
} |
||||
return [dict create format $format arch $arch] |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::platform_discriminated_segment |
||||
@cmd -name "::punkboot::utils::platform_discriminated_segment"\ |
||||
-summary\ |
||||
"Whether a directory name is a recognised platform-discriminating segment"\ |
||||
-help\ |
||||
"True when the segment is a canonical <os>-<cpu> platform-dir name |
||||
(os and cpu each from the recognised token lists), the bare |
||||
universal 'macosx' folder, or one of the recognised vendor |
||||
spellings (blend2d-style win-x64 etc). Binary libraries under such |
||||
a directory are selected per-platform by their package's own index |
||||
logic, so a multi-arch payload is legitimate there." |
||||
@leaders |
||||
segment -type string -optional 0 -help\ |
||||
"One directory name (a single path segment, not a path)" |
||||
}] |
||||
} |
||||
proc platform_discriminated_segment {segment} { |
||||
variable platform_segment_os |
||||
variable platform_segment_cpu |
||||
variable platform_segment_vendor |
||||
set segment [string tolower $segment] |
||||
if {$segment eq "macosx"} { |
||||
return 1 ;#the universal store-dir convention |
||||
} |
||||
if {$segment in $platform_segment_vendor} { |
||||
return 1 |
||||
} |
||||
set idx [string first - $segment] |
||||
if {$idx > 0} { |
||||
set os [string range $segment 0 [expr {$idx - 1}]] |
||||
set cpu [string range $segment [expr {$idx + 1}] end] |
||||
if {$os in $platform_segment_os && $cpu in $platform_segment_cpu} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::vfs_binary_arch_report |
||||
@cmd -name "::punkboot::utils::vfs_binary_arch_report"\ |
||||
-summary\ |
||||
"Advisory scan of an assembled vfs tree for binary libraries that mismatch the kit's target"\ |
||||
-help\ |
||||
"Walks a merged .vfs tree, classifies each binary library file |
||||
(*.dll, *.so, *.so.<n>, *.dylib) by header (binary_arch_classify) |
||||
and compares it against the kit's declared target platform. A |
||||
library under a platform-discriminated subdirectory (canonical |
||||
<os>-<cpu> names, the universal macosx folder, or a recognised |
||||
vendor spelling such as win-x64) is EXEMPT - multi-arch payloads |
||||
are legitimate when a platform segment lets the package's own |
||||
index logic pick per platform. Purely structural: header bytes are |
||||
read, nothing is executed or loaded, so the scan also covers |
||||
cross-target kits the build host could never run. |
||||
|
||||
A mismatch is reported only when the classification is DEFINITE |
||||
(a real PE/ELF/Mach-O header whose format or architecture differs |
||||
from the target's); unclassifiable files are counted as unknown, |
||||
never warned about. What this cannot see: statically linked |
||||
packages, pure-tcl packages whose binary dependency is elsewhere, |
||||
and package resolution order (a wrong-arch copy shadowing a |
||||
working one by version) - only an in-artifact 'package require' |
||||
smoke probe observes those. |
||||
|
||||
Returned dict keys: |
||||
ok 1 when no mismatches were found (advisory) |
||||
target the target platform as supplied |
||||
expected {format F arch A} for the target ({} if unmapped) |
||||
scanned binary library files classified |
||||
matched files matching the expected format/arch |
||||
exempt files under platform-discriminated subdirs (not read) |
||||
unknown files whose classification was indefinite |
||||
mismatches list of {file <rel> format F arch A detail D} |
||||
reason why the scan did not apply; empty when it ran" |
||||
@leaders |
||||
vfsfolder -type string -optional 0 -help\ |
||||
"Path of the assembled vfs tree to scan" |
||||
targetplatform -type string -optional 0 -help\ |
||||
"Canonical target platform of the kit, e.g win32-ix86" |
||||
}] |
||||
} |
||||
proc vfs_binary_arch_report {vfsfolder targetplatform} { |
||||
variable binary_library_globs |
||||
set report [dict create ok 1 target $targetplatform expected {} scanned 0 matched 0 exempt 0 unknown 0 mismatches {} reason ""] |
||||
if {![file isdirectory $vfsfolder]} { |
||||
dict set report ok 0 |
||||
dict set report reason "no such directory: $vfsfolder" |
||||
return $report |
||||
} |
||||
set expected [platform_expected_binary $targetplatform] |
||||
dict set report expected $expected |
||||
if {![dict size $expected]} { |
||||
dict set report reason "target platform '$targetplatform' has no recognised binary format/arch mapping - scan not applicable" |
||||
return $report |
||||
} |
||||
set expected_format [dict get $expected format] |
||||
set expected_arch [dict get $expected arch] |
||||
set scanned 0 |
||||
set matched 0 |
||||
set exempt 0 |
||||
set unknown 0 |
||||
set mismatches [list] |
||||
set rootlen [string length $vfsfolder] |
||||
#iterative walk - plain Tcl 8.6, no deps. Exemption is decided per DIRECTORY |
||||
#(one platform_discriminated_segment test as each dir is queued), so files |
||||
#under an exempt subtree are counted without being read. |
||||
set pending [list [list $vfsfolder 0]] |
||||
while {[llength $pending]} { |
||||
set entry [lindex $pending end] |
||||
set pending [lrange $pending 0 end-1] |
||||
lassign $entry dir dir_exempt |
||||
foreach sub [glob -nocomplain -types d -directory $dir *] { |
||||
set sub_exempt $dir_exempt |
||||
if {!$sub_exempt && [platform_discriminated_segment [file tail $sub]]} { |
||||
set sub_exempt 1 |
||||
} |
||||
lappend pending [list $sub $sub_exempt] |
||||
} |
||||
foreach libfile [glob -nocomplain -types f -directory $dir -- {*}$binary_library_globs] { |
||||
if {$dir_exempt} { |
||||
incr exempt |
||||
continue |
||||
} |
||||
incr scanned |
||||
set class [binary_arch_classify $libfile] |
||||
set cformat [dict get $class format] |
||||
set carch [dict get $class arch] |
||||
if {$cformat eq "unknown"} { |
||||
incr unknown |
||||
continue |
||||
} |
||||
set rel [string map {\\ /} [string range $libfile [expr {$rootlen + 1}] end]] |
||||
if {$cformat ne $expected_format} { |
||||
lappend mismatches [dict create file $rel format $cformat arch $carch detail [dict get $class detail]] |
||||
continue |
||||
} |
||||
if {$carch eq $expected_arch} { |
||||
incr matched |
||||
continue |
||||
} |
||||
if {$carch eq "universal" && [dict exists $class archs] && $expected_arch in [dict get $class archs]} { |
||||
incr matched |
||||
continue |
||||
} |
||||
#definite finding either way: a differing mapped arch, or a real header |
||||
#whose unmapped machine value is provably not the expected architecture |
||||
lappend mismatches [dict create file $rel format $cformat arch $carch detail [dict get $class detail]] |
||||
} |
||||
} |
||||
dict set report scanned $scanned |
||||
dict set report matched $matched |
||||
dict set report exempt $exempt |
||||
dict set report unknown $unknown |
||||
dict set report mismatches $mismatches |
||||
dict set report ok [expr {[llength $mismatches] == 0}] |
||||
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.5.0, is a literal used in src module folders |
||||
#- we refer to this sometimes as the magic version number |
||||
set version 0.5.0 |
||||
}] |
||||
return |
||||
@ -0,0 +1,353 @@
|
||||
# -*- tcl -*- |
||||
# Tests for the punkboot::utils G-133 payload/target binary-arch machinery: |
||||
# - binary_arch_classify: PE Machine-field classification (i386/x86_64/arm64), ELF and |
||||
# Mach-O (thin + fat/universal) classification, and honest 'unknown' for everything |
||||
# else (text named .dll, MZ without PE, java-class cafebabe decoy, short files) |
||||
# - platform_expected_binary / platform_discriminated_segment mapping + recognition |
||||
# - vfs_binary_arch_report: the 2026-07-27 punkluck86 case reproduced as a fixture (an |
||||
# x64 thread dll under plain lib_tcl8/ in a win32-ix86 kit), the platform-subdir |
||||
# exemptions (iocp-2.0.2's win32-ix86 + win32-x86_64 pair, blend2d-style win-x64), |
||||
# and the real assembled trees in src/_build when a build has been run |
||||
# All binary fixtures are GENERATED here with 'binary format' - header bytes only, no |
||||
# committed binaries (root AGENTS.md binary policy), nothing executable. The scan reads |
||||
# headers only and never executes anything - what makes it usable for cross-target kits. |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punkboot/utils/*** binaryarch.test |
||||
|
||||
package require tcltest |
||||
package require punkboot::utils |
||||
|
||||
#added 2026-07-27 (agent, G-133) |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable BASE [makeDirectory g133_binaryarch] |
||||
|
||||
#<projectroot>/src/tests/modules/punkboot/utils/testsuites/utils -> 7 levels up |
||||
variable projectroot [file normalize [file join [file dirname [info script]] .. .. .. .. .. .. ..]] |
||||
variable buildfolder [file join $projectroot src _build] |
||||
testConstraint builtvfsavailable [expr {[llength [glob -nocomplain -type d -directory $buildfolder *.exe.vfs]] > 0}] |
||||
|
||||
proc writebytes {path bytes} { |
||||
file mkdir [file dirname $path] |
||||
set fd [open $path w] |
||||
chan configure $fd -translation binary |
||||
puts -nonewline $fd $bytes |
||||
close $fd |
||||
} |
||||
#minimal PE: MZ header, e_lfanew(0x3c)=128, PE\0\0 + Machine at 128 |
||||
proc pebytes {machine} { |
||||
return [binary format a2x58ix64a4sx20 MZ 128 PE\x00\x00 $machine] |
||||
} |
||||
#minimal ELF: magic, EI_CLASS, EI_DATA, e_machine at 18 (endianness per EI_DATA) |
||||
proc elfbytes {class data machine} { |
||||
if {$data == 2} { |
||||
return [binary format a4ccx10x2Sx12 \x7fELF $class $data $machine] |
||||
} |
||||
return [binary format a4ccx10x2sx12 \x7fELF $class $data $machine] |
||||
} |
||||
proc mktree {name} { |
||||
variable BASE |
||||
set root [file join $BASE $name] |
||||
file delete -force $root |
||||
file mkdir $root |
||||
return $root |
||||
} |
||||
proc classify {path} { |
||||
return [punkboot::utils::binary_arch_classify $path] |
||||
} |
||||
#distinct name - a proc named 'scan' would shadow the Tcl builtin in this namespace |
||||
proc archscan {root target} { |
||||
return [punkboot::utils::vfs_binary_arch_report $root $target] |
||||
} |
||||
proc fmtarch {class} { |
||||
return [list [dict get $class format] [dict get $class arch]] |
||||
} |
||||
|
||||
variable common { |
||||
set result [list] |
||||
} |
||||
|
||||
# -- --- --- classifier: PE --- --- -- |
||||
|
||||
test binaryarch_classify_pe_fixtures {PE i386, x86_64 and arm64 fixtures classify by Machine field}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
foreach {name machine} {i386 0x014c x86_64 0x8664 arm64 -0x559c} { |
||||
#-0x559c is 0xaa64 as a signed 16-bit value - 'binary format s' takes either |
||||
set f [file join $BASE pe_$name.dll] |
||||
writebytes $f [pebytes [expr {$machine}]] |
||||
lappend result [fmtarch [classify $f]] |
||||
} |
||||
set result |
||||
}\ |
||||
-result {{pe i386} {pe x86_64} {pe arm64}} |
||||
|
||||
test binaryarch_classify_pe_unknown_machine {a real PE with an unmapped Machine value is definite-but-unmapped, not silently unknown}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f [file join $BASE pe_odd.dll] |
||||
writebytes $f [pebytes 0x1234] |
||||
set c [classify $f] |
||||
lappend result [dict get $c format] [dict get $c arch] |
||||
}\ |
||||
-result {pe unknown-0x1234} |
||||
|
||||
test binaryarch_classify_mz_without_pe {an MZ header without a PE signature (DOS executable) is honestly unknown}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f [file join $BASE dos.dll] |
||||
writebytes $f [binary format a2x58ix64a4x20 MZ 128 XX\x00\x00] |
||||
lappend result [fmtarch [classify $f]] |
||||
}\ |
||||
-result {{unknown unknown}} |
||||
|
||||
# -- --- --- classifier: ELF and Mach-O --- --- -- |
||||
|
||||
test binaryarch_classify_elf_fixtures {ELF i386, x86_64 and arm64 fixtures classify via e_machine}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
foreach {name class data machine} {i386 1 1 3 x86_64 2 1 62 arm64 2 1 183} { |
||||
set f [file join $BASE elf_$name.so] |
||||
writebytes $f [elfbytes $class $data $machine] |
||||
lappend result [fmtarch [classify $f]] |
||||
} |
||||
set result |
||||
}\ |
||||
-result {{elf i386} {elf x86_64} {elf arm64}} |
||||
|
||||
test binaryarch_classify_elf_bigendian {a big-endian ELF (EI_DATA=2) reads e_machine big-endian}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f [file join $BASE elf_be.so] |
||||
writebytes $f [elfbytes 2 2 21] |
||||
lappend result [fmtarch [classify $f]] |
||||
}\ |
||||
-result {{elf ppc64}} |
||||
|
||||
test binaryarch_classify_macho_fixtures {thin Mach-O x86_64 and arm64 (little-endian on-disk form) classify via cputype}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
foreach {name cputype} {x86_64 0x01000007 arm64 0x0100000C} { |
||||
set f [file join $BASE macho_$name.dylib] |
||||
writebytes $f [binary format iix56 [expr {0xfeedfacf}] [expr {$cputype}]] |
||||
lappend result [fmtarch [classify $f]] |
||||
} |
||||
set result |
||||
}\ |
||||
-result {{macho x86_64} {macho arm64}} |
||||
|
||||
test binaryarch_classify_macho_universal {a fat/universal Mach-O reports its member architectures}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f [file join $BASE macho_fat.dylib] |
||||
#fat header (big-endian): magic, nfat=2, then 20-byte entries (cputype first) |
||||
writebytes $f [binary format IIIIIIIIIIIIx8 [expr {0xcafebabe}] 2\ |
||||
[expr {0x01000007}] 3 4096 100 12\ |
||||
[expr {0x0100000C}] 0 8192 100 12] |
||||
set c [classify $f] |
||||
lappend result [dict get $c format] [dict get $c arch] [dict get $c archs] |
||||
}\ |
||||
-result {macho universal {x86_64 arm64}} |
||||
|
||||
test binaryarch_classify_java_class_decoy {a java class file (cafebabe with implausible member count) stays unknown}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f [file join $BASE decoy.dll] |
||||
writebytes $f [binary format IIx56 [expr {0xcafebabe}] 52] |
||||
lappend result [fmtarch [classify $f]] |
||||
}\ |
||||
-result {{unknown unknown}} |
||||
|
||||
test binaryarch_classify_nonbinary_content {a text file named .dll and a too-short file are honestly unknown}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set f1 [file join $BASE textstub.dll] |
||||
writebytes $f1 "#this is a tcl stub pretending to be a dll\n" |
||||
set f2 [file join $BASE tiny.dll] |
||||
writebytes $f2 MZ |
||||
lappend result [fmtarch [classify $f1]] [fmtarch [classify $f2]] |
||||
}\ |
||||
-result {{unknown unknown} {unknown unknown}} |
||||
|
||||
# -- --- --- target mapping + segment recognition --- --- -- |
||||
|
||||
test binaryarch_expected_mapping {canonical target platforms map to expected format/arch; unknown os yields empty}\ |
||||
-setup $common -body { |
||||
foreach t {win32-x86_64 win32-ix86 win32-arm64 linux-x86_64 freebsd-x86_64 macosx-arm64 weirdos-x86 noarch} { |
||||
lappend result [punkboot::utils::platform_expected_binary $t] |
||||
} |
||||
set result |
||||
}\ |
||||
-result {{format pe arch x86_64} {format pe arch i386} {format pe arch arm64} {format elf arch x86_64} {format elf arch x86_64} {format macho arch arm64} {} {}} |
||||
|
||||
test binaryarch_segment_recognition {canonical platform-dir names, the universal macosx folder and recognised vendor spellings discriminate; package dirs do not}\ |
||||
-setup $common -body { |
||||
foreach seg {win32-x86_64 win32-ix86 linux-x86_64 macosx win-x64 win64 WIN32-X86_64 tcl8.6 BWidget1.10.1 thread2.8.5 x86_64-linux-gnu} { |
||||
lappend result [punkboot::utils::platform_discriminated_segment $seg] |
||||
} |
||||
set result |
||||
}\ |
||||
-result {1 1 1 1 1 1 1 0 0 0 0} |
||||
|
||||
# -- --- --- the scan: the motivating case and the exemptions --- --- -- |
||||
|
||||
test binaryarch_scan_punkluck86_case {the 2026-07-27 punkluck86 case: an x64 thread dll under plain lib_tcl8/ in a win32-ix86 kit is named as a mismatch}\ |
||||
-setup $common -body { |
||||
set root [mktree luckcase] |
||||
#the payload shape that broke the repl: wrong-arch Thread outside any platform |
||||
#subdir, beside the runtime's own working 32-bit copy |
||||
writebytes [file join $root thread2.8.5 thread285.dll] [pebytes 0x014c] |
||||
writebytes [file join $root lib_tcl8 thread2.8.12 thread28.dll] [pebytes [expr {0x8664}]] |
||||
set r [archscan $root win32-ix86] |
||||
lappend result ok [dict get $r ok] scanned [dict get $r scanned] matched [dict get $r matched] |
||||
set m [lindex [dict get $r mismatches] 0] |
||||
lappend result file [dict get $m file] arch [dict get $m arch] |
||||
}\ |
||||
-result {ok 0 scanned 2 matched 1 file lib_tcl8/thread2.8.12/thread28.dll arch x86_64} |
||||
|
||||
test binaryarch_scan_platform_subdir_exempt {the iocp-2.0.2 multi-arch pair layout produces no mismatch - platform subdirs are exempt without being read}\ |
||||
-setup $common -body { |
||||
set root [mktree iocppair] |
||||
writebytes [file join $root lib_tcl8 iocp-2.0.2 win32-ix86 iocp202.dll] [pebytes 0x014c] |
||||
writebytes [file join $root lib_tcl8 iocp-2.0.2 win32-x86_64 iocp202.dll] [pebytes [expr {0x8664}]] |
||||
set r [archscan $root win32-ix86] |
||||
lappend result ok [dict get $r ok] scanned [dict get $r scanned] exempt [dict get $r exempt] mismatches [llength [dict get $r mismatches]] |
||||
}\ |
||||
-result {ok 1 scanned 0 exempt 2 mismatches 0} |
||||
|
||||
test binaryarch_scan_vendor_spelling_exempt {a blend2d-style win-x64 vendor subdir is recognised - no warning for its wrong-arch dll in an ix86 kit}\ |
||||
-setup $common -body { |
||||
set root [mktree vendorspelling] |
||||
writebytes [file join $root lib_tcl9 blend2d1.5 win-x64 blend2d.dll] [pebytes [expr {0x8664}]] |
||||
set r [archscan $root win32-ix86] |
||||
lappend result ok [dict get $r ok] exempt [dict get $r exempt] mismatches [llength [dict get $r mismatches]] |
||||
}\ |
||||
-result {ok 1 exempt 1 mismatches 0} |
||||
|
||||
test binaryarch_scan_exemption_covers_subtree {everything below a platform-discriminated dir is exempt, not just its direct files}\ |
||||
-setup $common -body { |
||||
set root [mktree subtree] |
||||
writebytes [file join $root lib win32-x86_64 sub deeper thing.dll] [pebytes [expr {0x8664}]] |
||||
set r [archscan $root win32-ix86] |
||||
lappend result ok [dict get $r ok] exempt [dict get $r exempt] |
||||
}\ |
||||
-result {ok 1 exempt 1} |
||||
|
||||
test binaryarch_scan_format_mismatch {a wrong-FORMAT library (ELF .so in a windows-target kit) outside platform subdirs is a mismatch}\ |
||||
-setup $common -body { |
||||
set root [mktree formatmismatch] |
||||
writebytes [file join $root lib foreign libfoo.so] [elfbytes 2 1 62] |
||||
set r [archscan $root win32-x86_64] |
||||
lappend result ok [dict get $r ok] |
||||
set m [lindex [dict get $r mismatches] 0] |
||||
lappend result file [dict get $m file] format [dict get $m format] |
||||
}\ |
||||
-result {ok 0 file lib/foreign/libfoo.so format elf} |
||||
|
||||
test binaryarch_scan_unknown_not_warned {unclassifiable files are counted unknown and never reported as mismatches}\ |
||||
-setup $common -body { |
||||
set root [mktree unknowns] |
||||
writebytes [file join $root lib stub.dll] "#tcl stub\n" |
||||
set r [archscan $root win32-x86_64] |
||||
lappend result ok [dict get $r ok] scanned [dict get $r scanned] unknown [dict get $r unknown] mismatches [llength [dict get $r mismatches]] |
||||
}\ |
||||
-result {ok 1 scanned 1 unknown 1 mismatches 0} |
||||
|
||||
test binaryarch_scan_matching_tree {a tree whose libraries all match the target reports ok with counts}\ |
||||
-setup $common -body { |
||||
set root [mktree allmatch] |
||||
writebytes [file join $root bin tcl9tk90.dll] [pebytes [expr {0x8664}]] |
||||
writebytes [file join $root tcl_library dde tcl9dde14.dll] [pebytes [expr {0x8664}]] |
||||
set r [archscan $root win32-x86_64] |
||||
lappend result ok [dict get $r ok] scanned [dict get $r scanned] matched [dict get $r matched] |
||||
}\ |
||||
-result {ok 1 scanned 2 matched 2} |
||||
|
||||
test binaryarch_scan_macho_universal_matches {a universal Mach-O carrying the target's arch matches a macosx target}\ |
||||
-setup $common -body { |
||||
set root [mktree fattree] |
||||
writebytes [file join $root lib libuni.dylib] [binary format IIIIIIIIIIIIx8 [expr {0xcafebabe}] 2\ |
||||
[expr {0x01000007}] 3 4096 100 12\ |
||||
[expr {0x0100000C}] 0 8192 100 12] |
||||
set r1 [archscan $root macosx-arm64] |
||||
set r2 [archscan $root macosx-x86_64] |
||||
lappend result [dict get $r1 ok] [dict get $r1 matched] [dict get $r2 ok] [dict get $r2 matched] |
||||
}\ |
||||
-result {1 1 1 1} |
||||
|
||||
test binaryarch_scan_unmapped_target {a target with no recognised binary mapping reports not-applicable rather than guessing}\ |
||||
-setup $common -body { |
||||
set root [mktree unmappedtarget] |
||||
writebytes [file join $root lib foo.dll] [pebytes 0x014c] |
||||
set r [archscan $root weirdos-x86] |
||||
lappend result ok [dict get $r ok] scanned [dict get $r scanned] |
||||
lappend result reason_says [string match "*no recognised binary format/arch mapping*" [dict get $r reason]] |
||||
}\ |
||||
-result {ok 1 scanned 0 reason_says 1} |
||||
|
||||
test binaryarch_scan_missing_directory {a nonexistent folder is refused by name rather than erroring}\ |
||||
-setup $common -body { |
||||
variable BASE |
||||
set r [archscan [file join $BASE no_such_vfs] win32-x86_64] |
||||
lappend result [dict get $r ok] [string match "no such directory:*" [dict get $r reason]] |
||||
}\ |
||||
-result {0 1} |
||||
|
||||
test binaryarch_scan_does_not_write {the scan writes nothing into the tree it inspects}\ |
||||
-setup $common -body { |
||||
set root [mktree readonlycheck] |
||||
writebytes [file join $root lib thing.dll] [pebytes [expr {0x8664}]] |
||||
set before [lsort [glob -nocomplain -directory $root -tails *]] |
||||
archscan $root win32-x86_64 |
||||
set after [lsort [glob -nocomplain -directory $root -tails *]] |
||||
lappend result [expr {$before eq $after}] $before |
||||
}\ |
||||
-result {1 lib} |
||||
|
||||
# -- --- --- the trees a bake actually scans --- --- -- |
||||
|
||||
test binaryarch_scan_real_built_vfs_trees {assembled kit vfs trees in src/_build produce no findings beyond the KNOWN real ones - the advisory must not cry wolf on payloads that work today}\ |
||||
-constraints {builtvfsavailable} -setup $common -body { |
||||
variable buildfolder |
||||
#KNOWN REAL FINDINGS the scan is EXPECTED to report (true positives, not noise): |
||||
# zint.dll 2.13.0 in src/vfs/punk8win.vfs/lib_tcl8/ is a 32-bit (i386) PE |
||||
# ('file' confirms: PE32 Intel 80386) carried by the x64 tcl8 kits, where its |
||||
# unconditional pkgIndex load can never succeed - found by this scan's first |
||||
# real sweep 2026-07-27. Filtered here (not required to exist, so fixing the |
||||
# payload keeps this test green); anything OUTSIDE this list is a false |
||||
# positive or a new payload defect and fails the test. |
||||
set known_findings { |
||||
{*.exe.vfs:lib_tcl8/zint-2.13.0/zint.dll=i386} |
||||
} |
||||
set failures [list] |
||||
set checked 0 |
||||
foreach d [lsort [glob -nocomplain -type d -directory $buildfolder *.exe.vfs]] { |
||||
switch -glob -- [file tail $d] { |
||||
punkluck86.* - punk91ix86.* {set target win32-ix86} |
||||
default {set target win32-x86_64} |
||||
} |
||||
incr checked |
||||
set r [archscan $d $target] |
||||
if {![dict get $r ok]} { |
||||
foreach m [dict get $r mismatches] { |
||||
set finding "[file tail $d]:[dict get $m file]=[dict get $m arch]" |
||||
set is_known 0 |
||||
foreach pat $known_findings { |
||||
if {[string match $pat $finding]} { |
||||
set is_known 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_known} { |
||||
lappend failures $finding |
||||
} |
||||
} |
||||
} |
||||
} |
||||
lappend result [expr {$checked > 0}] $failures |
||||
}\ |
||||
-result {1 {}} |
||||
|
||||
cleanupTests |
||||
} |
||||
@ -0,0 +1,146 @@
|
||||
package require tcltest |
||||
|
||||
#Piped characterization of the make.tcl side of the G-133 payload/target consistency |
||||
#checks: the advisory binary-arch scan at the G-125 gate seam and the post-build |
||||
#smoke-require probe. Runs the WORKING TREE's src/make.tcl under the built punk |
||||
#executable's 'script' subcommand with output captured through a pipe, and pins: |
||||
# - 'check' reports the arch scan with one of the two documented statuses (ACTIVE with |
||||
# a current bootsupport punkboot::utils carrying vfs_binary_arch_report; UNAVAILABLE |
||||
# is the documented guarded-require degradation), states its advisory nature, the |
||||
# platform-discriminated-subdir exemption and the recapped BUILD-WARNING reporting |
||||
# - 'check' describes the smoke-require probe contract (host-runnable kits only, |
||||
# cross-target kits skip with a stated reason, undeclared kits run nothing new) and |
||||
# lists the kits declaring smoke-require packages. The declared list is |
||||
# characterization of the current src/runtime/mapvfs.config - a deliberate config |
||||
# change legitimately updates it (same stance as maketclbakelist.test row pins) |
||||
# - the report stays ESC-free under the G-113 piped colour policy |
||||
#The scan's VERDICT - what classifies and what mismatches - is characterized against |
||||
#generated header fixtures in modules/punkboot/utils/testsuites/utils/binaryarch.test; |
||||
#the classifier lives in punkboot::utils precisely so it is testable without a bake. |
||||
# |
||||
#Target executable resolved from env(PUNK_SHELL_TEST_EXE), else <projectroot>/bin/punk902z.exe |
||||
#then <projectroot>/bin/punkshell902. Skipped (constraint punkexeavailable) if none found. |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable testdir [file dirname [file normalize [info script]]] |
||||
#<projectroot>/src/tests/shell/testsuites/punkexe -> 5 levels up to <projectroot> |
||||
variable projectroot [file normalize [file join $testdir .. .. .. .. ..]] |
||||
variable maketcl [file join $projectroot src make.tcl] |
||||
|
||||
variable punkexe "" |
||||
if {[info exists ::env(PUNK_SHELL_TEST_EXE)] && $::env(PUNK_SHELL_TEST_EXE) ne ""} { |
||||
set punkexe [file normalize $::env(PUNK_SHELL_TEST_EXE)] |
||||
} else { |
||||
foreach candidate [list [file join $projectroot bin punk902z.exe] [file join $projectroot bin punkshell902]] { |
||||
if {[file exists $candidate]} { |
||||
set punkexe $candidate |
||||
break |
||||
} |
||||
} |
||||
} |
||||
testConstraint punkexeavailable [expr {$punkexe ne "" && [file exists $punkexe]}] |
||||
|
||||
variable maketcl_run_timeout_ms 60000 |
||||
|
||||
variable runstate |
||||
array set runstate {} |
||||
|
||||
proc maketcl_run_read {chan} { |
||||
variable runstate |
||||
append runstate(output) [read $chan] |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set runstate(done) eof |
||||
} |
||||
} |
||||
|
||||
#Run <punkexe> script src/make.tcl <subcommand...> with output captured through a |
||||
#pipe (stdin half-closed for immediate EOF - make.tcl must never wait on stdin for |
||||
#these subcommands). Returns dict: timedout 0|1, exitcode <int|"">, output |
||||
#<combined stdout+stderr>. |
||||
proc maketcl_run {cmdargs} { |
||||
variable runstate |
||||
variable maketcl_run_timeout_ms |
||||
variable punkexe |
||||
variable maketcl |
||||
array unset runstate |
||||
set runstate(output) "" |
||||
set runstate(done) "" |
||||
|
||||
set chan [open |[list $punkexe script $maketcl {*}$cmdargs 2>@1] r+] |
||||
chan configure $chan -blocking 0 -translation binary |
||||
catch {chan close $chan write} ;#no stdin for the child - immediate EOF |
||||
set timerid [after $maketcl_run_timeout_ms [list set [namespace current]::runstate(done) timeout]] |
||||
chan event $chan readable [list [namespace current]::maketcl_run_read $chan] |
||||
while {$runstate(done) eq ""} { |
||||
vwait [namespace current]::runstate(done) |
||||
} |
||||
after cancel $timerid |
||||
set timedout [expr {$runstate(done) eq "timeout"}] |
||||
set exitcode "" |
||||
if {$timedout} { |
||||
catch {exec {*}[auto_execok taskkill] /F /T /PID [lindex [pid $chan] 0]} |
||||
catch {chan close $chan} |
||||
} else { |
||||
chan configure $chan -blocking 1 |
||||
if {[catch {chan close $chan} errdata errdict]} { |
||||
set exitcode [lindex [dict get $errdict -errorcode] end] |
||||
} else { |
||||
set exitcode 0 |
||||
} |
||||
} |
||||
return [dict create timedout $timedout exitcode $exitcode output $runstate(output)] |
||||
} |
||||
|
||||
#added 2026-07-27 (agent, G-133) |
||||
test maketcl_check_payloadchecks_status {make.tcl check reports the payload/target arch scan with one of the two documented statuses, ESC-free}\ |
||||
-constraints {punkexeavailable} -body { |
||||
set r [maketcl_run {check}] |
||||
set out [dict get $r output] |
||||
set result [list] |
||||
lappend result timedout [dict get $r timedout] exitcode [dict get $r exitcode] |
||||
lappend result esc [regexp -all {\x1b} $out] |
||||
lappend result scanline [regexp -line {^payload/target arch scan \(G-133\): (ACTIVE \(advisory\)|UNAVAILABLE)} $out] |
||||
lappend result smokeline [regexp -line {^smoke-require probe \(G-133, advisory\):} $out] |
||||
set result |
||||
}\ |
||||
-result {timedout 0 exitcode 0 esc 0 scanline 1 smokeline 1} |
||||
|
||||
#added 2026-07-27 (agent, G-133) |
||||
test maketcl_check_payloadchecks_active_contract {with a current bootsupport snapshot the arch scan is ACTIVE and check states the advisory contract: subdir exemption, recapped warnings, cross-target coverage and skip, undeclared-kits-unchanged}\ |
||||
-constraints {punkexeavailable} -body { |
||||
set r [maketcl_run {check}] |
||||
set out [dict get $r output] |
||||
set result [list] |
||||
lappend result active [regexp -line {^payload/target arch scan \(G-133\): ACTIVE \(advisory\)\s*$} $out] |
||||
#structural coverage claim: nothing executed, cross-target kits included |
||||
lappend result crosstarget [regexp {nothing executed, cross-target kits included} $out] |
||||
#advisory reporting channel (appears for both the scan and the smoke probe) |
||||
lappend result recapped [expr {[regexp -all {recapped\s+BUILD-WARNINGs} $out] >= 1}] |
||||
#the exemption that keeps multi-arch payloads legitimate |
||||
lappend result exemption [regexp {platform-discriminated subdirs} $out] |
||||
#smoke probe contract lines |
||||
lappend result seesresolution [regexp {resolution-order defects} $out] |
||||
lappend result skipstated [regexp {cross-target kits skip with a stated reason} $out] |
||||
lappend result undeclared [regexp {undeclared kits run nothing new} $out] |
||||
set result |
||||
}\ |
||||
-result {active 1 crosstarget 1 recapped 1 exemption 1 seesresolution 1 skipstated 1 undeclared 1} |
||||
|
||||
#added 2026-07-27 (agent, G-133) - the declared list characterizes the current |
||||
#src/runtime/mapvfs.config smoke-require matrix (deliberate config changes update it) |
||||
test maketcl_check_payloadchecks_declared_kits {check lists the kits currently declaring smoke-require packages}\ |
||||
-constraints {punkexeavailable} -body { |
||||
set r [maketcl_run {check}] |
||||
set out [dict get $r output] |
||||
set result [list] |
||||
lappend result declared [regexp -line {^\s+declared: punkluck86 \(Thread\); punkshell902 \(Thread\); punk91ix86 \(Thread, iocp\)\s*$} $out] |
||||
set result |
||||
}\ |
||||
-result {declared 1} |
||||
|
||||
cleanupTests |
||||
} |
||||
namespace delete ::testspace |
||||
Binary file not shown.
@ -1,352 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application 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 |
||||
@ -0,0 +1,753 @@
|
||||
# -*- 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.5.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 binary_arch_classify parse_punkproject_version read_punkproject_version read_changelog_latest_version vcs_dirty_warnings vfs_binary_arch_report 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 |
||||
} |
||||
|
||||
#G-133 binary-arch scan support. Recognition data is deliberately plain namespace |
||||
#variables so extending it (a new vendor spelling, a new cpu token) is a visible |
||||
#one-line edit rather than a code change. |
||||
# |
||||
#PE Machine field values (IMAGE_FILE_HEADER.Machine, 2 bytes LE at e_lfanew+4) |
||||
variable pe_machine_map { |
||||
014c i386 |
||||
8664 x86_64 |
||||
aa64 arm64 |
||||
01c0 arm |
||||
01c4 arm |
||||
0200 ia64 |
||||
0166 mips |
||||
01f0 ppc |
||||
5032 riscv32 |
||||
5064 riscv64 |
||||
} |
||||
#ELF e_machine values (2 bytes at offset 18, endianness per EI_DATA) |
||||
variable elf_machine_map { |
||||
3 i386 |
||||
62 x86_64 |
||||
183 arm64 |
||||
40 arm |
||||
8 mips |
||||
20 ppc |
||||
21 ppc64 |
||||
22 s390x |
||||
2 sparc |
||||
43 sparc64 |
||||
243 riscv |
||||
} |
||||
#Mach-O cputype base values (CPU_ARCH_ABI64 flag 0x01000000 selects the 64-bit variant) |
||||
variable macho_cputype_map { |
||||
7 {i386 x86_64} |
||||
12 {arm arm64} |
||||
18 {ppc ppc64} |
||||
} |
||||
#os / cpu tokens accepted in a CANONICAL platform-dir segment (<os>-<cpu>). The os and |
||||
#cpu lists follow the punk::platform canon plus common alias tokens, so a platform- |
||||
#discriminated subdir is recognised whichever spelling a package author normalised to. |
||||
variable platform_segment_os { |
||||
win32 windows linux macosx freebsd netbsd openbsd dragonfly solaris sunos |
||||
aix hpux irix qnx haiku android msys cygwin |
||||
} |
||||
variable platform_segment_cpu { |
||||
x86_64 amd64 x64 ix86 i386 i486 i586 i686 x86 |
||||
arm64 aarch64 arm armv6 armv7 armv6l armv7l |
||||
ppc ppc64 ppc64le powerpc mips mipsel mips64 |
||||
riscv32 riscv64 s390 s390x sparc sparc64 universal |
||||
} |
||||
#Recognised VENDOR spellings observed (or near-certain) as platform-discriminating |
||||
#directory names that do not parse as <canonical os>-<canonical cpu>. blend2d, |
||||
#extrafont and tclMuPDF ship win-x64 today. |
||||
variable platform_segment_vendor { |
||||
win-x64 win-x86 win-arm64 win-arm win32 win64 |
||||
linux-x64 linux-arm64 macos-x64 macos-arm64 osx-x64 osx-arm64 |
||||
} |
||||
#File tails treated as binary libraries by vfs_binary_arch_report |
||||
variable binary_library_globs {*.dll *.so *.so.[0-9]* *.dylib} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::binary_arch_classify |
||||
@cmd -name "::punkboot::utils::binary_arch_classify"\ |
||||
-summary\ |
||||
"Classify a binary library file's executable format and cpu architecture"\ |
||||
-help\ |
||||
"Reads only the file's header bytes (a couple of small reads - nothing |
||||
is executed or loaded) and classifies the executable format and cpu |
||||
architecture: |
||||
PE Machine field (2 bytes at e_lfanew+4): i386, x86_64, arm64... |
||||
ELF e_machine honouring EI_DATA endianness |
||||
Mach-O thin (cputype) and fat/universal (per-member cputypes) |
||||
Unrecognised content is reported honestly as format 'unknown' rather |
||||
than guessed. |
||||
|
||||
Returned dict keys: |
||||
format pe | elf | macho | unknown |
||||
arch i386 | x86_64 | arm64 | ... | universal | unknown | |
||||
unknown-0x<hex> (a real header whose machine value is not |
||||
in the recognition map - definite, just unmapped) |
||||
archs member architectures (macho universal only; absent otherwise) |
||||
detail short human-readable classification" |
||||
@leaders |
||||
libfile -type string -optional 0 -help\ |
||||
"Path of the binary library file to classify" |
||||
}] |
||||
} |
||||
proc binary_arch_classify {libfile} { |
||||
variable pe_machine_map |
||||
variable elf_machine_map |
||||
variable macho_cputype_map |
||||
if {[catch { |
||||
set fd [open $libfile r] |
||||
chan configure $fd -translation binary |
||||
set head [read $fd 64] |
||||
} errM]} { |
||||
catch {close $fd} |
||||
return [dict create format unknown arch unknown detail "unreadable: $errM"] |
||||
} |
||||
set result [dict create format unknown arch unknown detail "not a recognised binary library format"] |
||||
try { |
||||
if {[string length $head] < 8} { |
||||
dict set result detail "too short to carry an executable header ([string length $head] bytes)" |
||||
return $result |
||||
} |
||||
set magic4 [string range $head 0 3] |
||||
if {[string range $head 0 1] eq "MZ"} { |
||||
#PE: e_lfanew at 0x3c points at "PE\0\0" + IMAGE_FILE_HEADER |
||||
if {[binary scan $head @60iu e_lfanew] != 1} { |
||||
dict set result detail "MZ header too short for e_lfanew" |
||||
return $result |
||||
} |
||||
seek $fd $e_lfanew |
||||
set pehdr [read $fd 6] |
||||
if {[string length $pehdr] < 6 || [string range $pehdr 0 3] ne "PE\x00\x00"} { |
||||
dict set result detail "MZ header without PE signature (DOS executable?)" |
||||
return $result |
||||
} |
||||
binary scan $pehdr @4su machine |
||||
set hexmachine [format %04x $machine] |
||||
if {[dict exists $pe_machine_map $hexmachine]} { |
||||
set arch [dict get $pe_machine_map $hexmachine] |
||||
set result [dict create format pe arch $arch detail "PE $arch"] |
||||
} else { |
||||
set result [dict create format pe arch unknown-0x$hexmachine detail "PE machine 0x$hexmachine (not in recognition map)"] |
||||
} |
||||
} elseif {$magic4 eq "\x7fELF"} { |
||||
binary scan $head @4cu elfclass |
||||
binary scan $head @5cu elfdata |
||||
if {$elfdata == 2} { |
||||
binary scan $head @18Su e_machine ;#big-endian |
||||
} else { |
||||
binary scan $head @18su e_machine ;#little-endian (and honest-enough default) |
||||
} |
||||
if {[dict exists $elf_machine_map $e_machine]} { |
||||
set arch [dict get $elf_machine_map $e_machine] |
||||
if {$arch eq "riscv"} { |
||||
set arch [expr {$elfclass == 2 ? "riscv64" : "riscv32"}] |
||||
} |
||||
set result [dict create format elf arch $arch detail "ELF $arch"] |
||||
} else { |
||||
set result [dict create format elf arch unknown-$e_machine detail "ELF e_machine $e_machine (not in recognition map)"] |
||||
} |
||||
} else { |
||||
binary scan $head Iu be32 |
||||
switch -- [format %08x $be32] { |
||||
feedface - feedfacf - cefaedfe - cffaedfe { |
||||
#thin Mach-O; cputype follows the magic in the file's own byte order |
||||
if {[string index $head 0] eq "\xfe"} { |
||||
binary scan $head @4Iu cputype ;#big-endian file |
||||
} else { |
||||
binary scan $head @4iu cputype |
||||
} |
||||
set is64 [expr {($cputype & 0x01000000) != 0}] |
||||
set base [expr {$cputype & 0x00ffffff}] |
||||
if {[dict exists $macho_cputype_map $base]} { |
||||
set arch [lindex [dict get $macho_cputype_map $base] $is64] |
||||
set result [dict create format macho arch $arch detail "Mach-O $arch"] |
||||
} else { |
||||
set result [dict create format macho arch unknown-cputype-$base detail "Mach-O cputype $base (not in recognition map)"] |
||||
} |
||||
} |
||||
cafebabe - cafebabf { |
||||
#fat/universal (big-endian header). A Java class file shares the |
||||
#magic - its version field where nfat_arch sits is >= 45, far above |
||||
#any credible member count, so an implausible count stays unknown. |
||||
binary scan $head @4Iu nfat |
||||
if {$nfat == 0 || $nfat > 30} { |
||||
dict set result detail "cafebabe magic with implausible member count $nfat (java class file?)" |
||||
return $result |
||||
} |
||||
set entrysize [expr {$be32 == 0xcafebabf ? 32 : 20}] |
||||
seek $fd 8 |
||||
set fatdata [read $fd [expr {$nfat * $entrysize}]] |
||||
set archs [list] |
||||
for {set i 0} {$i < $nfat} {incr i} { |
||||
if {[binary scan $fatdata @[expr {$i * $entrysize}]Iu cputype] != 1} { |
||||
break |
||||
} |
||||
set is64 [expr {($cputype & 0x01000000) != 0}] |
||||
set base [expr {$cputype & 0x00ffffff}] |
||||
if {[dict exists $macho_cputype_map $base]} { |
||||
lappend archs [lindex [dict get $macho_cputype_map $base] $is64] |
||||
} else { |
||||
lappend archs unknown-cputype-$base |
||||
} |
||||
} |
||||
set result [dict create format macho arch universal archs $archs detail "Mach-O universal ([join $archs {, }])"] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} finally { |
||||
catch {close $fd} |
||||
} |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::platform_expected_binary |
||||
@cmd -name "::punkboot::utils::platform_expected_binary"\ |
||||
-summary\ |
||||
"Expected binary format/arch for a canonical target platform name"\ |
||||
-help\ |
||||
"Maps a canonical punkshell platform name (<os>-<cpu>, e.g |
||||
win32-ix86) to the executable format and classifier arch token a |
||||
native binary library for that platform carries. Returns a dict |
||||
{format F arch A}, or an empty dict when the os or cpu token has |
||||
no recognised mapping (callers treat that as scan-not-applicable |
||||
rather than guessing)." |
||||
@leaders |
||||
targetplatform -type string -optional 0 -help\ |
||||
"Canonical platform name, e.g win32-x86_64, linux-x86_64, macosx-arm64" |
||||
}] |
||||
} |
||||
proc platform_expected_binary {targetplatform} { |
||||
set idx [string first - $targetplatform] |
||||
if {$idx <= 0} { |
||||
return [dict create] |
||||
} |
||||
set os [string range $targetplatform 0 [expr {$idx - 1}]] |
||||
set cpu [string range $targetplatform [expr {$idx + 1}] end] |
||||
switch -- $os { |
||||
win32 - windows {set format pe} |
||||
linux - freebsd - netbsd - openbsd - dragonfly - solaris - sunos {set format elf} |
||||
macosx - darwin - macos {set format macho} |
||||
default {return [dict create]} |
||||
} |
||||
switch -- $cpu { |
||||
ix86 - i386 - i486 - i586 - i686 - x86 {set arch i386} |
||||
x86_64 - amd64 - x64 {set arch x86_64} |
||||
arm64 - aarch64 {set arch arm64} |
||||
arm - armv6 - armv7 {set arch arm} |
||||
ppc - ppc64 - riscv64 - mips - s390x - sparc - sparc64 {set arch $cpu} |
||||
default {return [dict create]} |
||||
} |
||||
return [dict create format $format arch $arch] |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::platform_discriminated_segment |
||||
@cmd -name "::punkboot::utils::platform_discriminated_segment"\ |
||||
-summary\ |
||||
"Whether a directory name is a recognised platform-discriminating segment"\ |
||||
-help\ |
||||
"True when the segment is a canonical <os>-<cpu> platform-dir name |
||||
(os and cpu each from the recognised token lists), the bare |
||||
universal 'macosx' folder, or one of the recognised vendor |
||||
spellings (blend2d-style win-x64 etc). Binary libraries under such |
||||
a directory are selected per-platform by their package's own index |
||||
logic, so a multi-arch payload is legitimate there." |
||||
@leaders |
||||
segment -type string -optional 0 -help\ |
||||
"One directory name (a single path segment, not a path)" |
||||
}] |
||||
} |
||||
proc platform_discriminated_segment {segment} { |
||||
variable platform_segment_os |
||||
variable platform_segment_cpu |
||||
variable platform_segment_vendor |
||||
set segment [string tolower $segment] |
||||
if {$segment eq "macosx"} { |
||||
return 1 ;#the universal store-dir convention |
||||
} |
||||
if {$segment in $platform_segment_vendor} { |
||||
return 1 |
||||
} |
||||
set idx [string first - $segment] |
||||
if {$idx > 0} { |
||||
set os [string range $segment 0 [expr {$idx - 1}]] |
||||
set cpu [string range $segment [expr {$idx + 1}] end] |
||||
if {$os in $platform_segment_os && $cpu in $platform_segment_cpu} { |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punkboot::utils::vfs_binary_arch_report |
||||
@cmd -name "::punkboot::utils::vfs_binary_arch_report"\ |
||||
-summary\ |
||||
"Advisory scan of an assembled vfs tree for binary libraries that mismatch the kit's target"\ |
||||
-help\ |
||||
"Walks a merged .vfs tree, classifies each binary library file |
||||
(*.dll, *.so, *.so.<n>, *.dylib) by header (binary_arch_classify) |
||||
and compares it against the kit's declared target platform. A |
||||
library under a platform-discriminated subdirectory (canonical |
||||
<os>-<cpu> names, the universal macosx folder, or a recognised |
||||
vendor spelling such as win-x64) is EXEMPT - multi-arch payloads |
||||
are legitimate when a platform segment lets the package's own |
||||
index logic pick per platform. Purely structural: header bytes are |
||||
read, nothing is executed or loaded, so the scan also covers |
||||
cross-target kits the build host could never run. |
||||
|
||||
A mismatch is reported only when the classification is DEFINITE |
||||
(a real PE/ELF/Mach-O header whose format or architecture differs |
||||
from the target's); unclassifiable files are counted as unknown, |
||||
never warned about. What this cannot see: statically linked |
||||
packages, pure-tcl packages whose binary dependency is elsewhere, |
||||
and package resolution order (a wrong-arch copy shadowing a |
||||
working one by version) - only an in-artifact 'package require' |
||||
smoke probe observes those. |
||||
|
||||
Returned dict keys: |
||||
ok 1 when no mismatches were found (advisory) |
||||
target the target platform as supplied |
||||
expected {format F arch A} for the target ({} if unmapped) |
||||
scanned binary library files classified |
||||
matched files matching the expected format/arch |
||||
exempt files under platform-discriminated subdirs (not read) |
||||
unknown files whose classification was indefinite |
||||
mismatches list of {file <rel> format F arch A detail D} |
||||
reason why the scan did not apply; empty when it ran" |
||||
@leaders |
||||
vfsfolder -type string -optional 0 -help\ |
||||
"Path of the assembled vfs tree to scan" |
||||
targetplatform -type string -optional 0 -help\ |
||||
"Canonical target platform of the kit, e.g win32-ix86" |
||||
}] |
||||
} |
||||
proc vfs_binary_arch_report {vfsfolder targetplatform} { |
||||
variable binary_library_globs |
||||
set report [dict create ok 1 target $targetplatform expected {} scanned 0 matched 0 exempt 0 unknown 0 mismatches {} reason ""] |
||||
if {![file isdirectory $vfsfolder]} { |
||||
dict set report ok 0 |
||||
dict set report reason "no such directory: $vfsfolder" |
||||
return $report |
||||
} |
||||
set expected [platform_expected_binary $targetplatform] |
||||
dict set report expected $expected |
||||
if {![dict size $expected]} { |
||||
dict set report reason "target platform '$targetplatform' has no recognised binary format/arch mapping - scan not applicable" |
||||
return $report |
||||
} |
||||
set expected_format [dict get $expected format] |
||||
set expected_arch [dict get $expected arch] |
||||
set scanned 0 |
||||
set matched 0 |
||||
set exempt 0 |
||||
set unknown 0 |
||||
set mismatches [list] |
||||
set rootlen [string length $vfsfolder] |
||||
#iterative walk - plain Tcl 8.6, no deps. Exemption is decided per DIRECTORY |
||||
#(one platform_discriminated_segment test as each dir is queued), so files |
||||
#under an exempt subtree are counted without being read. |
||||
set pending [list [list $vfsfolder 0]] |
||||
while {[llength $pending]} { |
||||
set entry [lindex $pending end] |
||||
set pending [lrange $pending 0 end-1] |
||||
lassign $entry dir dir_exempt |
||||
foreach sub [glob -nocomplain -types d -directory $dir *] { |
||||
set sub_exempt $dir_exempt |
||||
if {!$sub_exempt && [platform_discriminated_segment [file tail $sub]]} { |
||||
set sub_exempt 1 |
||||
} |
||||
lappend pending [list $sub $sub_exempt] |
||||
} |
||||
foreach libfile [glob -nocomplain -types f -directory $dir -- {*}$binary_library_globs] { |
||||
if {$dir_exempt} { |
||||
incr exempt |
||||
continue |
||||
} |
||||
incr scanned |
||||
set class [binary_arch_classify $libfile] |
||||
set cformat [dict get $class format] |
||||
set carch [dict get $class arch] |
||||
if {$cformat eq "unknown"} { |
||||
incr unknown |
||||
continue |
||||
} |
||||
set rel [string map {\\ /} [string range $libfile [expr {$rootlen + 1}] end]] |
||||
if {$cformat ne $expected_format} { |
||||
lappend mismatches [dict create file $rel format $cformat arch $carch detail [dict get $class detail]] |
||||
continue |
||||
} |
||||
if {$carch eq $expected_arch} { |
||||
incr matched |
||||
continue |
||||
} |
||||
if {$carch eq "universal" && [dict exists $class archs] && $expected_arch in [dict get $class archs]} { |
||||
incr matched |
||||
continue |
||||
} |
||||
#definite finding either way: a differing mapped arch, or a real header |
||||
#whose unmapped machine value is provably not the expected architecture |
||||
lappend mismatches [dict create file $rel format $cformat arch $carch detail [dict get $class detail]] |
||||
} |
||||
} |
||||
dict set report scanned $scanned |
||||
dict set report matched $matched |
||||
dict set report exempt $exempt |
||||
dict set report unknown $unknown |
||||
dict set report mismatches $mismatches |
||||
dict set report ok [expr {[llength $mismatches] == 0}] |
||||
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.5.0, is a literal used in src module folders |
||||
#- we refer to this sometimes as the magic version number |
||||
set version 0.5.0 |
||||
}] |
||||
return |
||||
Loading…
Reference in new issue