Browse Source
Batched punkcheck-managed build outputs from make.tcl modules/bootsupport/ vfscommonupdate for the G-133 change-set: bootsupport and _vfscommon.vfs gain utils-0.5.0.tm (0.4.0 pruned), thin-layout make.tcl copies and the modpod templates payload re-synced. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
9 changed files with 2145 additions and 752 deletions
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 |
||||||
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