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