Browse Source
scriptlib/developer/assetorigin_check.tcl, sibling to goals_lint and architecture_lint: plain Tcl, no external binaries, no rasterizer - embedded sha256 (NIST-vector validated) plus a tolerant self-contained flat-TOML subset reader (comments, basic and literal strings, bare scalars; unknown keys skipped; root table ends at the first table header; duplicate keys last-wins), resolving the open toml/hash dependency posture from the pre-activation review in favour of self-containment. States evaluated in table order, first match wins: unrecorded, artifact-absent, replaced, source-absent, stale, verified. Unrecognised schema or a missing/unusable artifact hash means the record is ignored (unrecorded), never an error; unrecognised hash-algorithm prefixes are treated as not recorded, so a source claim without a usable hash is a presence check only. check mode defaults to src/ (minus buildsuites/), scriptlib/ and goals/ - 2.2s wall vs 116s for a whole-tree walk dominated by _build trees, bin/tools zig installs and TEMP_REFERENCE (those walk only when named explicitly; .git and _build always skipped). goals_lint-style exit: 0 clean, 1 with a line per finding; advisory - nothing gates a build on it. status mode classifies named assets (a sidecar path names its paired asset); selftest builds 13 fixtures demonstrating all six states, the rule-3 precedence (replaced wins over missing source) and every tolerance rule - 16/16 pass under mingw tclsh 8.6.11, native Tcl 9.0.3 and the punk91 kit runtime. Live tree: 8 records, 8 verified. Root AGENTS.md scriptlib/developer enumeration gains the new tool. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
2 changed files with 461 additions and 1 deletions
@ -0,0 +1,460 @@ |
|||||||
|
# assetorigin_check.tcl - advisory provenance checker for *.assetorigin.toml |
||||||
|
# asset sidecars (G-135; format documented in src/assets/logo/AGENTS.md). |
||||||
|
# |
||||||
|
# Plain Tcl, no dependencies, no rasterizer, no external binaries - runs under |
||||||
|
# any tclsh 8.6+ and any punkshell runtime. Sibling to goals_lint.tcl and |
||||||
|
# architecture_lint.tcl. Advisory only: nothing consumes its exit code to gate |
||||||
|
# a build. |
||||||
|
# |
||||||
|
# Each examined asset classifies as exactly ONE of six states, evaluated in |
||||||
|
# table order with the first match winning: |
||||||
|
# 1 unrecorded no (usable) sidecar for the file - fully supported, silent |
||||||
|
# 2 artifact-absent a sidecar exists but its paired asset does not |
||||||
|
# 3 replaced asset present, hash differs from the record (regardless |
||||||
|
# of source state) - the asset changed since recording |
||||||
|
# 4 source-absent asset matches, a recorded source is not present |
||||||
|
# 5 stale asset matches, source present but its hash differs - the |
||||||
|
# source changed since the artifact was generated |
||||||
|
# 6 verified asset matches and every other hash the record carries |
||||||
|
# matches too |
||||||
|
# Hash comparisons apply only to hashes actually recorded: a source named |
||||||
|
# without a source_hash contributes only a presence check. A record whose |
||||||
|
# schema is unrecognised, or which carries no usable artifact hash, is ignored |
||||||
|
# (the asset classifies unrecorded) - tolerance over error, so a future writer |
||||||
|
# cannot break this reader. |
||||||
|
# |
||||||
|
# usage: |
||||||
|
# tclsh scriptlib/developer/assetorigin_check.tcl check ?-all? ?path ...? |
||||||
|
# Find *.assetorigin.toml sidecars under the given files/directories and |
||||||
|
# classify each paired asset. Default paths: src/ (minus buildsuites/), |
||||||
|
# scriptlib/ and goals/ under the repo root containing this script - the |
||||||
|
# versioned territory where records live; .git and _build subtrees are |
||||||
|
# always skipped. Build outputs (bin/, root modules/ and lib/) and |
||||||
|
# reference material are walked only when named explicitly. Findings |
||||||
|
# (artifact-absent, replaced, source-absent, stale) print one line each; |
||||||
|
# verified and ignored records are counted, and listed too with -all. |
||||||
|
# Exit 0 when every record checks out (only verified/unrecorded), else 1. |
||||||
|
# tclsh scriptlib/developer/assetorigin_check.tcl status <path> ?<path>...? |
||||||
|
# Classify the named assets, one line each, unrecorded included; a |
||||||
|
# .assetorigin.toml path names its paired asset. Always exit 0. |
||||||
|
# tclsh scriptlib/developer/assetorigin_check.tcl selftest ?-keep? |
||||||
|
# Build fixtures in a temp dir demonstrating all six states and the |
||||||
|
# precedence/tolerance rules, verify each classification (plus sha256 |
||||||
|
# test vectors); exit 0 on pass. -keep retains the fixture dir. |
||||||
|
|
||||||
|
set SIDECAR_SUFFIX .assetorigin.toml |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- sha256 (pure Tcl) |
||||||
|
# Same algorithm embedded in src/assets/logo/make-ico.tcl; duplicated so each |
||||||
|
# script stays runnable standalone under a stock tclsh. |
||||||
|
|
||||||
|
namespace eval sha256 { |
||||||
|
variable K { |
||||||
|
0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5 |
||||||
|
0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174 |
||||||
|
0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da |
||||||
|
0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967 |
||||||
|
0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85 |
||||||
|
0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 0xd192e819 0xd6990624 0xf40e3585 0x106aa070 |
||||||
|
0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3 |
||||||
|
0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2 |
||||||
|
} |
||||||
|
proc hex {data} { |
||||||
|
variable K |
||||||
|
set bitlen [expr {wide([string length $data]) * 8}] |
||||||
|
append data \x80 |
||||||
|
set pad [expr {(56 - [string length $data] % 64 + 64) % 64}] |
||||||
|
append data [string repeat \x00 $pad] [binary format W $bitlen] |
||||||
|
set h0 0x6a09e667; set h1 0xbb67ae85; set h2 0x3c6ef372; set h3 0xa54ff53a |
||||||
|
set h4 0x510e527f; set h5 0x9b05688c; set h6 0x1f83d9ab; set h7 0x5be0cd19 |
||||||
|
set n [string length $data] |
||||||
|
for {set off 0} {$off < $n} {incr off 64} { |
||||||
|
binary scan [string range $data $off [expr {$off + 63}]] Iu16 w |
||||||
|
for {set t 16} {$t < 64} {incr t} { |
||||||
|
set x [lindex $w [expr {$t - 15}]] |
||||||
|
set s0 [expr {((($x >> 7) | ($x << 25)) ^ (($x >> 18) | ($x << 14)) ^ ($x >> 3)) & 0xffffffff}] |
||||||
|
set x [lindex $w [expr {$t - 2}]] |
||||||
|
set s1 [expr {((($x >> 17) | ($x << 15)) ^ (($x >> 19) | ($x << 13)) ^ ($x >> 10)) & 0xffffffff}] |
||||||
|
lappend w [expr {([lindex $w [expr {$t - 16}]] + $s0 + [lindex $w [expr {$t - 7}]] + $s1) & 0xffffffff}] |
||||||
|
} |
||||||
|
set a $h0; set b $h1; set c $h2; set d $h3 |
||||||
|
set e $h4; set f $h5; set g $h6; set h $h7 |
||||||
|
for {set t 0} {$t < 64} {incr t} { |
||||||
|
set S1 [expr {((($e >> 6) | ($e << 26)) ^ (($e >> 11) | ($e << 21)) ^ (($e >> 25) | ($e << 7))) & 0xffffffff}] |
||||||
|
set ch [expr {(($e & $f) ^ (~$e & $g)) & 0xffffffff}] |
||||||
|
set T1 [expr {($h + $S1 + $ch + [lindex $K $t] + [lindex $w $t]) & 0xffffffff}] |
||||||
|
set S0 [expr {((($a >> 2) | ($a << 30)) ^ (($a >> 13) | ($a << 19)) ^ (($a >> 22) | ($a << 10))) & 0xffffffff}] |
||||||
|
set maj [expr {($a & $b) ^ ($a & $c) ^ ($b & $c)}] |
||||||
|
set T2 [expr {($S0 + $maj) & 0xffffffff}] |
||||||
|
set h $g; set g $f; set f $e; set e [expr {($d + $T1) & 0xffffffff}] |
||||||
|
set d $c; set c $b; set b $a; set a [expr {($T1 + $T2) & 0xffffffff}] |
||||||
|
} |
||||||
|
set h0 [expr {($h0 + $a) & 0xffffffff}]; set h1 [expr {($h1 + $b) & 0xffffffff}] |
||||||
|
set h2 [expr {($h2 + $c) & 0xffffffff}]; set h3 [expr {($h3 + $d) & 0xffffffff}] |
||||||
|
set h4 [expr {($h4 + $e) & 0xffffffff}]; set h5 [expr {($h5 + $f) & 0xffffffff}] |
||||||
|
set h6 [expr {($h6 + $g) & 0xffffffff}]; set h7 [expr {($h7 + $h) & 0xffffffff}] |
||||||
|
} |
||||||
|
return [format %08x%08x%08x%08x%08x%08x%08x%08x $h0 $h1 $h2 $h3 $h4 $h5 $h6 $h7] |
||||||
|
} |
||||||
|
proc file_hex {path} { |
||||||
|
set f [open $path rb] |
||||||
|
set data [read $f] |
||||||
|
close $f |
||||||
|
return [hex $data] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- record reader |
||||||
|
|
||||||
|
# Tolerant flat-TOML subset reader for schema-1 sidecars. Returns a key->value |
||||||
|
# dict of the root table. Comments, blank lines and unparseable lines are |
||||||
|
# skipped; parsing stops at the first [table]/[[array]] header (TOML guarantees |
||||||
|
# root-table keys precede any table, and schema 1 defines none); basic "..." |
||||||
|
# and literal '...' strings and bare scalars are understood; duplicate keys: |
||||||
|
# last one wins. |
||||||
|
proc sidecar_parse {path} { |
||||||
|
set f [open $path rb] |
||||||
|
set raw [read $f] |
||||||
|
close $f |
||||||
|
set text [encoding convertfrom utf-8 $raw] |
||||||
|
set kv [dict create] |
||||||
|
foreach line [split $text \n] { |
||||||
|
set line [string trim [string map [list \r {}] $line]] |
||||||
|
if {$line eq "" || [string index $line 0] eq "#"} continue |
||||||
|
if {[string index $line 0] eq "\["} break |
||||||
|
set eq [string first = $line] |
||||||
|
if {$eq < 1} continue |
||||||
|
set key [string trim [string range $line 0 [expr {$eq - 1}]]] |
||||||
|
set val [string trim [string range $line [expr {$eq + 1}] end]] |
||||||
|
if {$key eq ""} continue |
||||||
|
set c0 [string index $val 0] |
||||||
|
if {$c0 eq "\""} { |
||||||
|
set out "" |
||||||
|
set ok 0 |
||||||
|
set n [string length $val] |
||||||
|
for {set i 1} {$i < $n} {incr i} { |
||||||
|
set ch [string index $val $i] |
||||||
|
if {$ch eq "\\"} { |
||||||
|
incr i |
||||||
|
set esc [string index $val $i] |
||||||
|
switch -- $esc { |
||||||
|
\" {append out \"} |
||||||
|
\\ {append out \\} |
||||||
|
n {append out \n} |
||||||
|
t {append out \t} |
||||||
|
r {append out \r} |
||||||
|
default {append out \\$esc} |
||||||
|
} |
||||||
|
} elseif {$ch eq "\""} { |
||||||
|
set ok 1 |
||||||
|
break |
||||||
|
} else { |
||||||
|
append out $ch |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$ok} continue |
||||||
|
set val $out |
||||||
|
} elseif {$c0 eq "'"} { |
||||||
|
set end [string first ' $val 1] |
||||||
|
if {$end < 0} continue |
||||||
|
set val [string range $val 1 [expr {$end - 1}]] |
||||||
|
} else { |
||||||
|
set cmt [string first # $val] |
||||||
|
if {$cmt >= 0} { |
||||||
|
set val [string trim [string range $val 0 [expr {$cmt - 1}]]] |
||||||
|
} |
||||||
|
} |
||||||
|
dict set kv $key $val |
||||||
|
} |
||||||
|
return $kv |
||||||
|
} |
||||||
|
|
||||||
|
# A recorded hash usable by this reader: "sha256:<64 hex>". Anything else |
||||||
|
# (absent key, unrecognised algorithm prefix, malformed hex) returns "" and is |
||||||
|
# treated as not recorded. |
||||||
|
proc hash_recorded {kv key} { |
||||||
|
if {![dict exists $kv $key]} {return ""} |
||||||
|
set v [dict get $kv $key] |
||||||
|
if {[string match sha256:* $v]} { |
||||||
|
set hexpart [string tolower [string range $v 7 end]] |
||||||
|
if {[string length $hexpart] == 64 && [string is xdigit -strict $hexpart]} { |
||||||
|
return $hexpart |
||||||
|
} |
||||||
|
} |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- classification |
||||||
|
|
||||||
|
# Classify the asset paired with (or lacking) a sidecar. Returns {state detail}. |
||||||
|
proc classify {asset} { |
||||||
|
global SIDECAR_SUFFIX |
||||||
|
set sidecar $asset$SIDECAR_SUFFIX |
||||||
|
if {![file exists $sidecar]} { |
||||||
|
return [list unrecorded ""] |
||||||
|
} |
||||||
|
if {[catch {sidecar_parse $sidecar} kv]} { |
||||||
|
return [list unrecorded "sidecar unreadable, ignored: $kv"] |
||||||
|
} |
||||||
|
if {![dict exists $kv schema] || [dict get $kv schema] ne "1"} { |
||||||
|
set s [expr {[dict exists $kv schema] ? [dict get $kv schema] : "missing"}] |
||||||
|
return [list unrecorded "sidecar ignored: schema $s not recognised"] |
||||||
|
} |
||||||
|
set arthash [hash_recorded $kv hash] |
||||||
|
if {$arthash eq ""} { |
||||||
|
return [list unrecorded "sidecar ignored: no usable artifact hash"] |
||||||
|
} |
||||||
|
if {![file exists $asset]} { |
||||||
|
return [list artifact-absent "sidecar present, its paired asset is gone"] |
||||||
|
} |
||||||
|
if {[sha256::file_hex $asset] ne $arthash} { |
||||||
|
return [list replaced "asset hash differs from the record"] |
||||||
|
} |
||||||
|
if {[dict exists $kv source]} { |
||||||
|
set srcref [dict get $kv source] |
||||||
|
set src [file join [file dirname $asset] $srcref] |
||||||
|
if {![file exists $src]} { |
||||||
|
return [list source-absent "recorded source $srcref not present"] |
||||||
|
} |
||||||
|
set srchash [hash_recorded $kv source_hash] |
||||||
|
if {$srchash ne "" && [sha256::file_hex $src] ne $srchash} { |
||||||
|
return [list stale "source $srcref changed since the artifact was generated"] |
||||||
|
} |
||||||
|
} |
||||||
|
return [list verified ""] |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- scanning |
||||||
|
|
||||||
|
proc find_sidecars {paths {skipdirs {}}} { |
||||||
|
global SIDECAR_SUFFIX |
||||||
|
set skips {} |
||||||
|
foreach s $skipdirs { |
||||||
|
lappend skips [file normalize $s] |
||||||
|
} |
||||||
|
set found {} |
||||||
|
set queue {} |
||||||
|
foreach p $paths { |
||||||
|
lappend queue [file normalize $p] |
||||||
|
} |
||||||
|
while {[llength $queue]} { |
||||||
|
set p [lindex $queue 0] |
||||||
|
set queue [lrange $queue 1 end] |
||||||
|
if {[file isdirectory $p]} { |
||||||
|
if {[file tail $p] in {.git _build} || $p in $skips} continue |
||||||
|
foreach sub [lsort [glob -nocomplain -directory $p *]] { |
||||||
|
lappend queue $sub |
||||||
|
} |
||||||
|
} elseif {[string match *$SIDECAR_SUFFIX $p]} { |
||||||
|
lappend found $p |
||||||
|
} |
||||||
|
} |
||||||
|
return [lsort -unique $found] |
||||||
|
} |
||||||
|
|
||||||
|
proc display_path {path root} { |
||||||
|
set np [file normalize $path] |
||||||
|
set nr [file normalize $root] |
||||||
|
if {[string equal -nocase -length [expr {[string length $nr] + 1}] $np "$nr/"]} { |
||||||
|
return [string range $np [expr {[string length $nr] + 1}] end] |
||||||
|
} |
||||||
|
return $np |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- subcommands |
||||||
|
|
||||||
|
proc cmd_check {argl} { |
||||||
|
global SIDECAR_SUFFIX |
||||||
|
set all 0 |
||||||
|
set paths {} |
||||||
|
foreach a $argl { |
||||||
|
if {$a eq "-all"} {set all 1} else {lappend paths $a} |
||||||
|
} |
||||||
|
set root [file dirname [file dirname [file dirname [file normalize [info script]]]]] |
||||||
|
set skipdirs {} |
||||||
|
if {![llength $paths]} { |
||||||
|
set paths [list [file join $root src] [file join $root scriptlib] [file join $root goals]] |
||||||
|
set skipdirs [list [file join $root src buildsuites]] |
||||||
|
} |
||||||
|
set sidecars [find_sidecars $paths $skipdirs] |
||||||
|
set counts [dict create] |
||||||
|
set findings 0 |
||||||
|
foreach sc $sidecars { |
||||||
|
set asset [string range $sc 0 end-[string length $SIDECAR_SUFFIX]] |
||||||
|
lassign [classify $asset] state detail |
||||||
|
dict incr counts $state |
||||||
|
set line "$state: [display_path $asset $root]" |
||||||
|
if {$detail ne ""} {append line " ($detail)"} |
||||||
|
if {$state in {artifact-absent replaced source-absent stale}} { |
||||||
|
incr findings |
||||||
|
puts $line |
||||||
|
} elseif {$all} { |
||||||
|
puts $line |
||||||
|
} |
||||||
|
} |
||||||
|
set summary {} |
||||||
|
foreach state {verified unrecorded artifact-absent replaced source-absent stale} { |
||||||
|
if {[dict exists $counts $state]} { |
||||||
|
lappend summary "[dict get $counts $state] $state" |
||||||
|
} |
||||||
|
} |
||||||
|
if {![llength $sidecars]} { |
||||||
|
puts "assetorigin_check: no sidecars found" |
||||||
|
} else { |
||||||
|
puts "assetorigin_check: [llength $sidecars] record(s): [join $summary {, }]" |
||||||
|
} |
||||||
|
exit [expr {$findings ? 1 : 0}] |
||||||
|
} |
||||||
|
|
||||||
|
proc cmd_status {argl} { |
||||||
|
global SIDECAR_SUFFIX |
||||||
|
if {![llength $argl]} { |
||||||
|
puts stderr "status: at least one path required" |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
foreach p $argl { |
||||||
|
if {[string match *$SIDECAR_SUFFIX $p]} { |
||||||
|
set p [string range $p 0 end-[string length $SIDECAR_SUFFIX]] |
||||||
|
} |
||||||
|
lassign [classify $p] state detail |
||||||
|
set line "$state: $p" |
||||||
|
if {$detail ne ""} {append line " ($detail)"} |
||||||
|
puts $line |
||||||
|
} |
||||||
|
exit 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc cmd_selftest {argl} { |
||||||
|
set keep [expr {"-keep" in $argl}] |
||||||
|
set base "" |
||||||
|
foreach v {TEMP TMP TMPDIR} { |
||||||
|
if {[info exists ::env($v)] && $::env($v) ne ""} { |
||||||
|
set base $::env($v) |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$base eq ""} {set base /tmp} |
||||||
|
set dir [file join $base "assetorigin-selftest-[pid]"] |
||||||
|
file delete -force $dir |
||||||
|
file mkdir $dir |
||||||
|
|
||||||
|
set pass 0 |
||||||
|
set fail 0 |
||||||
|
# sha256 implementation vectors first - the classifications below lean on it |
||||||
|
foreach {input want} { |
||||||
|
{} e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855 |
||||||
|
abc ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad |
||||||
|
abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq 248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1 |
||||||
|
} { |
||||||
|
set got [sha256::hex $input] |
||||||
|
if {$got eq $want} { |
||||||
|
incr pass |
||||||
|
} else { |
||||||
|
incr fail |
||||||
|
puts "FAIL sha256 vector [string range $input 0 10]...: got $got want $want" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc putfile {path content} { |
||||||
|
set f [open $path wb] |
||||||
|
puts -nonewline $f $content |
||||||
|
close $f |
||||||
|
} |
||||||
|
proc sidecarfile {dir asset lines} { |
||||||
|
putfile [file join $dir "$asset.assetorigin.toml"] "[join $lines \n]\n" |
||||||
|
} |
||||||
|
set H(src) [sha256::hex "SOURCE-V1"] |
||||||
|
set H(old) [sha256::hex "SOURCE-V0"] |
||||||
|
putfile [file join $dir s.svg] "SOURCE-V1" |
||||||
|
|
||||||
|
# fixture name -> {asset-content sidecar-lines expected-state note} |
||||||
|
# asset-content of "-" means the asset file is not created. |
||||||
|
set fixtures {} |
||||||
|
lappend fixtures [list a.bin "AAA" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha256:%S%\""] \ |
||||||
|
verified "full record, all hashes match"] |
||||||
|
lappend fixtures [list b.bin "-" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%H_abc%\""] \ |
||||||
|
artifact-absent "record whose paired asset is gone"] |
||||||
|
lappend fixtures [list c.bin "CCC-NEW" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%H_abc%\"" "source = \"missing.svg\"" "source_hash = \"sha256:%S%\""] \ |
||||||
|
replaced "asset changed since recording; wins over its missing source (rule-3 precedence)"] |
||||||
|
lappend fixtures [list d.bin "DDD" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"nowhere.svg\"" "source_hash = \"sha256:%S%\""] \ |
||||||
|
source-absent "recorded source not present"] |
||||||
|
lappend fixtures [list e.bin "EEE" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha256:%OLD%\""] \ |
||||||
|
stale "source changed since the artifact was generated"] |
||||||
|
lappend fixtures [list f.bin "FFF" {} unrecorded "no sidecar at all"] |
||||||
|
lappend fixtures [list g.bin "GGG" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\""] \ |
||||||
|
verified "hash-only record verifies on the artifact hash alone"] |
||||||
|
lappend fixtures [list h.bin "HHH" \ |
||||||
|
[list "schema = 99" "hash = \"sha256:%A%\""] \ |
||||||
|
unrecorded "unrecognised schema is ignored, not an error"] |
||||||
|
lappend fixtures [list i.bin "III" \ |
||||||
|
[list "schema = 1" "future_key = \"whatever\"" "hash = \"sha256:%A%\"" "\[future_table\]" "hash = \"sha256:%H_abc%\""] \ |
||||||
|
verified "unknown keys skipped; root table ends at the first table header"] |
||||||
|
lappend fixtures [list j.bin "JJJ" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\""] \ |
||||||
|
verified "source named without source_hash is a presence check only"] |
||||||
|
lappend fixtures [list k.bin "KKK" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"gone.svg\""] \ |
||||||
|
source-absent "presence check still applies without a source_hash"] |
||||||
|
lappend fixtures [list l.bin "LLL" \ |
||||||
|
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha512:beef\""] \ |
||||||
|
verified "unrecognised source-hash algorithm treated as not recorded"] |
||||||
|
lappend fixtures [list m.bin "MMM" \ |
||||||
|
[list "schema = 1" "source = \"s.svg\""] \ |
||||||
|
unrecorded "record without a usable artifact hash is ignored"] |
||||||
|
|
||||||
|
set habc [sha256::hex abc] |
||||||
|
foreach fx $fixtures { |
||||||
|
lassign $fx name content lines expected note |
||||||
|
set asset [file join $dir $name] |
||||||
|
if {$content ne "-"} { |
||||||
|
putfile $asset $content |
||||||
|
} |
||||||
|
if {[llength $lines]} { |
||||||
|
set subst [list %A% [sha256::hex $content] %S% $H(src) %OLD% $H(old) %H_abc% $habc] |
||||||
|
set out {} |
||||||
|
foreach l $lines { |
||||||
|
lappend out [string map $subst $l] |
||||||
|
} |
||||||
|
sidecarfile $dir $name $out |
||||||
|
} |
||||||
|
lassign [classify $asset] state detail |
||||||
|
if {$state eq $expected} { |
||||||
|
incr pass |
||||||
|
puts "PASS $name $state ($note)" |
||||||
|
} else { |
||||||
|
incr fail |
||||||
|
puts "FAIL $name got $state want $expected ($note) $detail" |
||||||
|
} |
||||||
|
} |
||||||
|
set keptnote "" |
||||||
|
if {$keep} { |
||||||
|
set keptnote " (fixtures kept: $dir)" |
||||||
|
} |
||||||
|
puts "assetorigin_check selftest: $pass passed, $fail failed$keptnote" |
||||||
|
if {!$keep} { |
||||||
|
file delete -force $dir |
||||||
|
} |
||||||
|
exit [expr {$fail ? 1 : 0}] |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------- dispatch |
||||||
|
|
||||||
|
set cmd [lindex $argv 0] |
||||||
|
set rest [lrange $argv 1 end] |
||||||
|
switch -- $cmd { |
||||||
|
check {cmd_check $rest} |
||||||
|
status {cmd_status $rest} |
||||||
|
selftest {cmd_selftest $rest} |
||||||
|
default { |
||||||
|
puts stderr "usage: tclsh assetorigin_check.tcl check ?-all? ?path ...?" |
||||||
|
puts stderr " tclsh assetorigin_check.tcl status <path> ?<path>...?" |
||||||
|
puts stderr " tclsh assetorigin_check.tcl selftest ?-keep?" |
||||||
|
exit 2 |
||||||
|
} |
||||||
|
} |
||||||
Loading…
Reference in new issue