Browse Source
Notes-only on the goal; the new tracked material is the sdx patch capture. G-101 gains four sections and an extended Scope line naming the surveyed trees and bin/sdx.kit: a reference-material inventory giving the metakit boot chain in reading order with file:line anchors (kbskit kitInit.c pre-init -> boot.tcl raw mk::select bootstrap -> setupvfs.tcl -> mk4tcl.cpp Mk4tcl_Init, with KitCreator's storage-switch variant as the comparison reference for scoping cookfs/zipvfs); sdx provenance; the self-mount shadowing gotcha; and metakit-under-Tcl-9 feasibility. Two findings bear on the container choice: 8.6's core zlib cannot do mk4vfs streaming (kbskit boot.tcl states it - forces whole-blob decompression, relevant to a battery-carrying kit), and TEMP_REFERENCE/metakit is UNPATCHED upstream while KitCreator carries eight 8.x-era fixes. Self-mount shadowing verified live rather than inferred: inside a running tclkit [file type [info nameofexecutable]] is 'directory', so a kit cannot read or copy itself as a file and cannot be handed to sdx as -runtime (wrap.tcl LoadHeader is a plain file read). make.tcl:4995-5005 already works around this with _BUILDCOPY; recorded as a requirement to preserve. Container-agnostic - zipfs has the same shape via its /app anchor. src/buildsuites/suite_tcl86/patches/ captures the bin/sdx.kit delta into tracked form. bin/sdx.kit is tracked and is what make.tcl resolves for the 'kit' wrap path, but it is NOT stock sdx: unwrapping it and stock 2011-03-17 sdx gives 64 identical files except lib/app-sdx/wrap.tcl, whose entire difference is a two-line binary-mode read of tclkit.inf before stringfileinfo patches the PE version resource. That evidence previously existed only in gitignored scratch/ and TEMP_REFERENCE/ copies - one git clean from gone. Stock baseline, patched file and diff are all byte-exact (hashes in the README); the patch round-trips to the patched file byte for byte under 'patch --binary'. The stock baseline is kept in full because upstream (svn://svn.equi4.com/sdx/trunk) no longer exists. Both .tcl files are CRLF and must stay CRLF - vendored fidelity artifacts, exempt from the repo's LF-on-edit preference. Scope-limiting facts recorded rather than assumed: the patched path is DORMANT for present builds (fires only with -runtime + a .exe runtime + a tclkit.inf in the source .vfs, and no tclkit.inf exists in this repo), and the fix itself is UNVERIFIED - plausible as a CRLF-corruption fix but no reproducer was recorded with it. Confirming or retiring it is part of this goal's characterization work, alongside the bootstrap circularity noted in the goal (sdx.kit is itself a metakit starkit, so wrapping a suite-built 8.6 runtime currently needs a prebuilt third-party tclkit of exactly the kind G-101 exists to replace). Of the two proposed acceptance riders, this commit discharges the first (capture the patch before any sdx rebuild). The second stands: the end-to-end demonstration must wrap a SEPARATE COPY of the runtime so the shadowing path is exercised rather than accidentally avoided. A back-pointer to these findings was added to TEMP_REFERENCE/AGENTS.md so the survey is not repeated; that tree is VCS-ignored, so it is not part of this commit. Claude-Session: https://claude.ai/code/session_014UkdFjhuEdfCNDp4f8V6Xe Assisted-by: harness=claude; primary-model=claude-opus-5[1m]; api-location=anthropic.commaster
5 changed files with 1007 additions and 1 deletions
@ -0,0 +1,109 @@
|
||||
# suite_tcl86 patches |
||||
|
||||
## sdx wrap.tcl - tclkit.inf binary-read fix (G-101) |
||||
|
||||
Recovered into tracked form 2026-07-26. Same rationale as the suite_tcl90 patch |
||||
recovery: these files previously existed ONLY in VCS-ignored on-disk copies |
||||
(`scratch/` and `TEMP_REFERENCE/` are ignored by both git and fossil - root |
||||
`.gitignore:35,59` and `.fossil-settings/ignore-glob:35-36,58-59`), so a |
||||
`git clean -xdf` would have destroyed the only evidence of what the patch is. |
||||
|
||||
### What this documents |
||||
|
||||
`bin/sdx.kit` is TRACKED and is the tool `src/make.tcl` resolves for the 'kit' |
||||
wrap path (discovery ladder at src/make.tcl:5048-5097). It is NOT stock sdx: it |
||||
is a locally-patched build whose patch was recorded nowhere in version control. |
||||
|
||||
Two distinct sdx binaries were found on the author's machine, differing by 121 |
||||
bytes: |
||||
|
||||
| copy | sha256 | size | VCS | |
||||
| --- | --- | --- | --- | |
||||
| `bin/sdx.kit` (== `TEMP_REFERENCE/sdx/sdx.kit`) | `5d4aa629495bb68b737dfe7280363ceb0a6653938380e8c9ccc9063a3864f531` | 119191 | tracked | |
||||
| `scratch/sdx.kit` (== `scratch/sdx-20110317.kit`) | `04dc85d4503c037f26c2b8719e45e4e20385674fbc7404481f3c171fce0a26c3` | 119312 | ignored | |
||||
|
||||
Unwrapped, both are 64 files and are IDENTICAL except `lib/app-sdx/wrap.tcl`. |
||||
That one file is the entire provenance delta, and it is the two-line change |
||||
captured here. |
||||
|
||||
### The change |
||||
|
||||
In the Windows version-resource customization path (wrap.tcl:232-239 in the |
||||
patched copy), reading `tclkit.inf`: |
||||
|
||||
``` |
||||
- set fd [open [file join $idir tclkit.inf]] |
||||
+ set fd [open [file join $idir tclkit.inf] "r"] |
||||
+ fconfigure $fd -translation binary |
||||
``` |
||||
|
||||
The array read from that file is handed straight to |
||||
`::stringfileinfo::writeStringInfo`, which patches the PE version resource of the |
||||
output executable. Without binary translation the read is line-ending-translated, |
||||
so this reads as a fix for CRLF corruption of `tclkit.inf` content on Windows. |
||||
NOT VERIFIED against a failing case - the fix is plausible and small, but no |
||||
reproducer was recorded with it. Confirming (or retiring) it is part of the |
||||
G-101 sdx characterization work. |
||||
|
||||
Note the patch only fires when ALL of: `-runtime` was given, the runtime has a |
||||
`.exe` extension, and `tclkit.inf` exists in the source `.vfs`. No `tclkit.inf` |
||||
currently exists anywhere in this repo, so the patched path is DORMANT for |
||||
present builds - it matters only if/when version-stamping of wrapped executables |
||||
is turned on. |
||||
|
||||
### Files |
||||
|
||||
- `sdx-2011.03.17-wrap.tcl` - the STOCK baseline, byte-exact |
||||
(sha256 `41e669dce6da5b102f4924a4c177501b0ab8f3f62bf0657d88bdea73089c0a75`). |
||||
Kept in full because upstream is GONE: sdx's home was |
||||
`svn://svn.equi4.com/sdx/trunk` (per its ChangeLog, last entry 2011-03-17 by |
||||
Pat Thoyts) and it cannot be re-fetched. This is the irreplaceable artifact |
||||
here - the patched version is independently recoverable by unwrapping the |
||||
tracked `bin/sdx.kit`. |
||||
- `sdx-wrap_tclkitinf_binary.tcl` - the PATCHED file as it exists inside |
||||
`bin/sdx.kit`, byte-exact |
||||
(sha256 `7a77009be04e0da5fb750d86a6c1e7141bf712422434d0908456e40766b847be`). |
||||
Kept as a drop-in per the suite_tcl90 convention (full patched file alongside |
||||
the diff), so a rebuild does not depend on a working `patch` tool. |
||||
- `sdx-wrap.tcl.tclkitinf-binary.patch` - the diff between the two. Round-trip |
||||
verified 2026-07-26: applying it to the stock baseline reproduces the patched |
||||
file byte for byte. Apply with `patch --binary` on Windows - without it the |
||||
CRLF context lines will not match. |
||||
|
||||
LINE ENDINGS: the two `.tcl` files are CRLF and MUST STAY CRLF. They are vendored |
||||
fidelity artifacts whose bytes must match the kit contents; the repo's usual |
||||
LF-on-edit preference does not apply to them. Do not run a line-ending normalizer |
||||
over this directory. This README is LF. |
||||
|
||||
### Verifying the capture |
||||
|
||||
`sdx version` walks a mounted kit and prints `<mtime> <crc-hi>-<crc-lo>` |
||||
(`lib/app-sdx/version.tcl`). Observed under |
||||
`bin/runtime/win32-x86_64/tclkit86bi.exe`: |
||||
|
||||
``` |
||||
bin/sdx.kit -> 2025/06/04 22:56:36 69170-33997 |
||||
scratch/sdx.kit -> 2011/03/17 23:39:41 50768-16003 |
||||
``` |
||||
|
||||
The tracked kit's timestamp is exactly the patched `wrap.tcl` mtime, which is |
||||
what confirms the patch is inside the tracked kit rather than only on disk. |
||||
|
||||
TRAP for any rebuild-and-compare: `traverse` hashes file NAME + MTIME + SIZE, not |
||||
content, so this signature is NOT reproducible across a re-wrap unless mtimes are |
||||
normalised (`sdx version -fixtime`). Content-level characterization needs its own |
||||
comparison - unwrap and diff trees, plus behavioural wrap/unwrap/mksplit |
||||
round-trips - not this signature alone. |
||||
|
||||
### Why this lives here |
||||
|
||||
Placed under the suite that owns the question rather than beside the binary: |
||||
`bin/` is documented as build outputs and tooling (bin/AGENTS.md), not source |
||||
material. G-101 (kit container strategy for zig-built 8.6 runtimes) owns the sdx |
||||
provenance and rebuild decision, and sdx is the kit-wrapping tool that goal must |
||||
either keep, rebuild, or replace. If G-101 replaces sdx with a suite-owned kit |
||||
writer, this capture stays as the record of what the retired tool did. |
||||
|
||||
Full findings - including the bootstrap circularity (sdx.kit is itself a metakit |
||||
starkit and needs a tclkit to run), the 2011-era bundled library set, and the |
||||
stale `bin/sdx1.bat` wrapper - are in `goals/G-101-tcl86-kit-container-strategy.md`. |
||||
@ -0,0 +1,344 @@
|
||||
# wrap - convert file system tree to a starkit |
||||
# by Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com> |
||||
# |
||||
# 20020607 jcw added -writeable, switched to starkit package |
||||
# the default is now to creates a read-only starkit |
||||
|
||||
set header \ |
||||
{#!/bin/sh |
||||
# % |
||||
exec @PROG@ "$0" ${1+"$@"} |
||||
package require starkit |
||||
starkit::header @TYPE@ @OPTS@ |
||||
} |
||||
append header \32 |
||||
regsub % $header \\ header |
||||
|
||||
if {[llength $argv] < 1} { |
||||
puts stderr "Usage: $argv0 outfile ?-option ...?" |
||||
exit 1 |
||||
} |
||||
|
||||
set origtime [clock seconds] |
||||
|
||||
proc readfile {name} { |
||||
set fd [open $name] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
return $data |
||||
} |
||||
|
||||
proc writefile {name data} { |
||||
set fd [open $name w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $data |
||||
close $fd |
||||
} |
||||
|
||||
# decode Windows .ICO file contents into the individual bit maps |
||||
# Each icon header has: |
||||
# byte : width in pixels (0 for 256 px) |
||||
# byte : height in pixels (0 for 256px) |
||||
# byte : number of colors in palette (0 for truecolor) |
||||
# byte : reserved (0) |
||||
# short: number of color planes (0 or 1) |
||||
# short: number of bits per pixel |
||||
# long : size of the bitmap data in bytes |
||||
# long : offset to the start of bitmap data |
||||
proc decICO {dat} { |
||||
set result {} |
||||
binary scan $dat sss - type count |
||||
for {set pos 6} {[incr count -1] >= 0} {incr pos 16} { |
||||
binary scan $dat @${pos}ccccssii w h cc - p bc bir io |
||||
if {$cc == 0} { set cc 256 } |
||||
#puts "pos $pos w $w h $h cc $cc p $p bc $bc bir $bir io $io" |
||||
binary scan $dat @${io}a$bir image |
||||
lappend result ${w}x${h}/$bc $image |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc LoadHeader {filename} { |
||||
if {[file normalize $filename] == [info nameofexe]} { |
||||
puts stderr "file in use, cannot be prefix: [file normalize $filename]" |
||||
exit 1 |
||||
} |
||||
set size [file size $filename] |
||||
catch { |
||||
package require vfs::mk4 |
||||
vfs::mk4::Mount $filename hdr -readonly |
||||
# we only look for an icon if the runtime is called *.exe (!) |
||||
if {[string tolower [file extension $filename]] == ".exe"} { |
||||
catch { set ::origicon [readfile hdr/tclkit.ico] } |
||||
} |
||||
} |
||||
catch { vfs::unmount $filename } |
||||
return [readfile $filename] |
||||
} |
||||
|
||||
set out [lindex $argv 0] |
||||
set base [file root [file tail $out]] |
||||
set idir $base.vfs |
||||
if {![file isdirectory $idir]} { |
||||
if {[file isdirectory $base] && [file exists $base/main.tcl]} { |
||||
set idir $base |
||||
if {[lindex [split $out .] 0] eq $out} { |
||||
# append kit if user hasn't specified an extension |
||||
set out $base.kit |
||||
} |
||||
} |
||||
} |
||||
set compress 1 |
||||
set verbose 0 |
||||
set ropts -readonly |
||||
set prefix 0 |
||||
set reusefile 0 |
||||
set prog tclkit |
||||
set type mk4 |
||||
set explist {} |
||||
set syncopts {} |
||||
|
||||
set a [lindex $argv 1] |
||||
while {[string match -* $a]} { |
||||
switch -- $a { |
||||
-interp { |
||||
set prog [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
-runtime { |
||||
set pfile [lindex $argv 2] |
||||
if {$pfile == $out} { |
||||
set reusefile 1 |
||||
} else { |
||||
set header [LoadHeader $pfile] |
||||
} |
||||
set argv [lreplace $argv 1 2] |
||||
set prefix 1 |
||||
} |
||||
-writable - |
||||
-writeable { |
||||
#set ropts "-nocommit" |
||||
set ropts "" |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-nocomp - |
||||
-nocompress { |
||||
set compress 0 |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-verbose { |
||||
set verbose 1 |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-uncomp { |
||||
lappend explist [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
-vfs { |
||||
set idir [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
default { |
||||
lappend syncopts [lindex $argv 1] [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
} |
||||
set a [lindex $argv 1] |
||||
} |
||||
|
||||
if {![file isdir $idir]} { |
||||
puts stderr "Input directory not found: $idir" |
||||
exit 1 |
||||
} |
||||
|
||||
if {!$prefix} { |
||||
regsub @PROG@ $header $prog header |
||||
regsub @OPTS@ $header $ropts header |
||||
regsub @TYPE@ $header $type header |
||||
|
||||
set n [string length $header] |
||||
while {$n <= 240} { |
||||
append header ################ |
||||
incr n 16 |
||||
} |
||||
|
||||
set slop [expr { 15 - (($n + 15) % 16) }] |
||||
for {set i 0} {$i < $slop} {incr i} { |
||||
append header # |
||||
} |
||||
set n [string length $header] |
||||
if {$n % 16 != 0} { |
||||
error "Header size is $n, should be a multiple of 16" |
||||
} |
||||
} |
||||
|
||||
if {!$reusefile} { |
||||
writefile $out $header |
||||
} |
||||
|
||||
set origsize [file size $out] |
||||
|
||||
switch $tcl_platform(platform) { |
||||
unix { |
||||
catch {file attributes $out -permissions +x} |
||||
} |
||||
windows { |
||||
set batfile [file root $out].bat |
||||
# 2005-03-18 don't create a batfile if "-runtime" is specified |
||||
if {![file exists $batfile] && ![info exists pfile]} { |
||||
set fd [open $batfile w] |
||||
puts -nonewline $fd \ |
||||
"@$prog [file tail $out] %1 %2 %3 %4 %5 %6 %7 %8 %9" |
||||
close $fd |
||||
} |
||||
} |
||||
macintosh { |
||||
catch {file attributes $out -creator TKd4} |
||||
} |
||||
} |
||||
|
||||
# 2003-02-08: added code to patch icon in windows executable |
||||
# triggered by existence of tclkit.ico in vfs dir *and* tclkit.ico in orig |
||||
|
||||
# careful: this applies only to windows executables, but the |
||||
# icon replacement can in fact take place on any platform... |
||||
|
||||
if {[info exists origicon] && [file exists [file join $idir tclkit.ico]]} { |
||||
puts " customizing tclkit.ico in executable" |
||||
set custicon [readfile [file join $idir tclkit.ico]] |
||||
array set newimg [decICO $custicon] |
||||
foreach {k v} [decICO $origicon] { |
||||
if {[info exists newimg($k)]} { |
||||
set len [string length $v] |
||||
set pos [string first $v $header] |
||||
if {$pos < 0} { |
||||
puts " icon $k: NOT FOUND" |
||||
} elseif {[string length $newimg($k)] != $len} { |
||||
puts " icon $k: NOT SAME SIZE" |
||||
} else { |
||||
binary scan $header a${pos}a${len}a* prefix - suffix |
||||
set header "$prefix$newimg($k)$suffix" |
||||
puts " icon $k: replaced" |
||||
} |
||||
} |
||||
} |
||||
writefile $out $header |
||||
} |
||||
|
||||
# 2005-03-15 added AF's code to customize version/description strings in exe's |
||||
if {[info exists pfile] && |
||||
[string tolower [file extension $pfile]] == ".exe" && |
||||
[file exists [file join $idir tclkit.inf]]} { |
||||
puts " customizing strings in executable" |
||||
package require stringfileinfo |
||||
set fd [open [file join $idir tclkit.inf]] |
||||
array set strinfo [read $fd] |
||||
close $fd |
||||
::stringfileinfo::writeStringInfo $out strinfo |
||||
} |
||||
|
||||
proc tclLog {msg} { puts $msg } |
||||
|
||||
proc mkFileStart {filename} { |
||||
set end [file size $filename] |
||||
if {$end < 27} { |
||||
fail "file too small, cannot be a datafile" |
||||
} |
||||
|
||||
set fd [open $filename] |
||||
fconfigure $fd -translation binary |
||||
seek $fd -16 end |
||||
binary scan [read $fd 16] IIII a b c d |
||||
close $fd |
||||
|
||||
#puts [format %x-%d-%x-%d $a $b $c $d] |
||||
|
||||
if {($c >> 24) != -128} { |
||||
error "this is not a Metakit datafile" |
||||
} |
||||
|
||||
# avoid negative sign / overflow issues |
||||
if {[format %x [expr {$a & 0xffffffff}]] eq "80000000"} { |
||||
set start [expr {$end - 16 - $b}] |
||||
} else { |
||||
# if the file is in commit-progress state, we need to do more |
||||
error "this code needs to be finished..." |
||||
} |
||||
|
||||
return $start |
||||
} |
||||
|
||||
if {![catch { package require Mk4tcl }]} { |
||||
vfs::mk4::Mount $out $out |
||||
set argv $syncopts |
||||
lappend argv -compress $compress -verbose $verbose -noerror 0 $idir $out |
||||
|
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
# 2003-06-19: new "-uncomp name" option to store specific file(s) |
||||
# in uncompressed form, even if the rest is compressed |
||||
set o $vfs::mk4::compress |
||||
set vfs::mk4::compress 0 |
||||
foreach f $explist { |
||||
file delete -force [file join $out $f] |
||||
file copy [file join $idir $f] [file join $out $f] |
||||
} |
||||
set vfs::mk4::compress $o |
||||
|
||||
vfs::unmount $out |
||||
} elseif {![catch { package require vlerq }]} { |
||||
package require vfs::m2m 1.8 |
||||
|
||||
if {$verbose} { |
||||
puts "Mk4tcl not found, switching to the Vlerq driver." |
||||
} |
||||
|
||||
# 2006-12-06, must do a bit more work for starpacks when there is no Mk4tcl: |
||||
# - split the tail off |
||||
# - truncate the file so only the head remains |
||||
# - copy the original vfs contents to m2m, to be overwritten/extended later |
||||
|
||||
set outsize [file size $out] |
||||
|
||||
if {![catch { mkFileStart $out } mkpos]} { |
||||
set fd [open $out] |
||||
fconfigure $fd -translation binary |
||||
set outhead [read $fd $mkpos] |
||||
set origvfs [read $fd] |
||||
close $fd |
||||
|
||||
set fd [open $out w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $outhead |
||||
close $fd |
||||
} |
||||
|
||||
vfs::m2m::Mount $out $out |
||||
|
||||
if {[info exists origvfs]} { |
||||
set fd [open $out.tmp w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $origvfs |
||||
close $fd |
||||
|
||||
package require vfs::mkcl |
||||
vfs::mkcl::Mount $out.tmp $out.tmp |
||||
|
||||
set argv [list -verbose 0 $out.tmp $out] |
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
vfs::unmount $out.tmp |
||||
file delete $out.tmp |
||||
} |
||||
|
||||
set argv $syncopts |
||||
lappend argv -verbose $verbose -noerror 0 $idir $out |
||||
|
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
vfs::unmount $out |
||||
} else { |
||||
puts stderr "cannot find required packages (Mk4tcl or Vlerq)" |
||||
exit 1 |
||||
} |
||||
@ -0,0 +1,12 @@
|
||||
--- a/lib/app-sdx/wrap.tcl (sdx 2011-03-17 stock)
|
||||
+++ b/lib/app-sdx/wrap.tcl (bin/sdx.kit patched)
|
||||
@@ -232,7 +232,8 @@
|
||||
[file exists [file join $idir tclkit.inf]]} {
|
||||
puts " customizing strings in executable"
|
||||
package require stringfileinfo
|
||||
- set fd [open [file join $idir tclkit.inf]]
|
||||
+ set fd [open [file join $idir tclkit.inf] "r"]
|
||||
+ fconfigure $fd -translation binary
|
||||
array set strinfo [read $fd]
|
||||
close $fd
|
||||
::stringfileinfo::writeStringInfo $out strinfo
|
||||
@ -0,0 +1,345 @@
|
||||
# wrap - convert file system tree to a starkit |
||||
# by Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com> |
||||
# |
||||
# 20020607 jcw added -writeable, switched to starkit package |
||||
# the default is now to creates a read-only starkit |
||||
|
||||
set header \ |
||||
{#!/bin/sh |
||||
# % |
||||
exec @PROG@ "$0" ${1+"$@"} |
||||
package require starkit |
||||
starkit::header @TYPE@ @OPTS@ |
||||
} |
||||
append header \32 |
||||
regsub % $header \\ header |
||||
|
||||
if {[llength $argv] < 1} { |
||||
puts stderr "Usage: $argv0 outfile ?-option ...?" |
||||
exit 1 |
||||
} |
||||
|
||||
set origtime [clock seconds] |
||||
|
||||
proc readfile {name} { |
||||
set fd [open $name] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
return $data |
||||
} |
||||
|
||||
proc writefile {name data} { |
||||
set fd [open $name w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $data |
||||
close $fd |
||||
} |
||||
|
||||
# decode Windows .ICO file contents into the individual bit maps |
||||
# Each icon header has: |
||||
# byte : width in pixels (0 for 256 px) |
||||
# byte : height in pixels (0 for 256px) |
||||
# byte : number of colors in palette (0 for truecolor) |
||||
# byte : reserved (0) |
||||
# short: number of color planes (0 or 1) |
||||
# short: number of bits per pixel |
||||
# long : size of the bitmap data in bytes |
||||
# long : offset to the start of bitmap data |
||||
proc decICO {dat} { |
||||
set result {} |
||||
binary scan $dat sss - type count |
||||
for {set pos 6} {[incr count -1] >= 0} {incr pos 16} { |
||||
binary scan $dat @${pos}ccccssii w h cc - p bc bir io |
||||
if {$cc == 0} { set cc 256 } |
||||
#puts "pos $pos w $w h $h cc $cc p $p bc $bc bir $bir io $io" |
||||
binary scan $dat @${io}a$bir image |
||||
lappend result ${w}x${h}/$bc $image |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc LoadHeader {filename} { |
||||
if {[file normalize $filename] == [info nameofexe]} { |
||||
puts stderr "file in use, cannot be prefix: [file normalize $filename]" |
||||
exit 1 |
||||
} |
||||
set size [file size $filename] |
||||
catch { |
||||
package require vfs::mk4 |
||||
vfs::mk4::Mount $filename hdr -readonly |
||||
# we only look for an icon if the runtime is called *.exe (!) |
||||
if {[string tolower [file extension $filename]] == ".exe"} { |
||||
catch { set ::origicon [readfile hdr/tclkit.ico] } |
||||
} |
||||
} |
||||
catch { vfs::unmount $filename } |
||||
return [readfile $filename] |
||||
} |
||||
|
||||
set out [lindex $argv 0] |
||||
set base [file root [file tail $out]] |
||||
set idir $base.vfs |
||||
if {![file isdirectory $idir]} { |
||||
if {[file isdirectory $base] && [file exists $base/main.tcl]} { |
||||
set idir $base |
||||
if {[lindex [split $out .] 0] eq $out} { |
||||
# append kit if user hasn't specified an extension |
||||
set out $base.kit |
||||
} |
||||
} |
||||
} |
||||
set compress 1 |
||||
set verbose 0 |
||||
set ropts -readonly |
||||
set prefix 0 |
||||
set reusefile 0 |
||||
set prog tclkit |
||||
set type mk4 |
||||
set explist {} |
||||
set syncopts {} |
||||
|
||||
set a [lindex $argv 1] |
||||
while {[string match -* $a]} { |
||||
switch -- $a { |
||||
-interp { |
||||
set prog [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
-runtime { |
||||
set pfile [lindex $argv 2] |
||||
if {$pfile == $out} { |
||||
set reusefile 1 |
||||
} else { |
||||
set header [LoadHeader $pfile] |
||||
} |
||||
set argv [lreplace $argv 1 2] |
||||
set prefix 1 |
||||
} |
||||
-writable - |
||||
-writeable { |
||||
#set ropts "-nocommit" |
||||
set ropts "" |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-nocomp - |
||||
-nocompress { |
||||
set compress 0 |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-verbose { |
||||
set verbose 1 |
||||
set argv [lreplace $argv 1 1] |
||||
} |
||||
-uncomp { |
||||
lappend explist [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
-vfs { |
||||
set idir [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
default { |
||||
lappend syncopts [lindex $argv 1] [lindex $argv 2] |
||||
set argv [lreplace $argv 1 2] |
||||
} |
||||
} |
||||
set a [lindex $argv 1] |
||||
} |
||||
|
||||
if {![file isdir $idir]} { |
||||
puts stderr "Input directory not found: $idir" |
||||
exit 1 |
||||
} |
||||
|
||||
if {!$prefix} { |
||||
regsub @PROG@ $header $prog header |
||||
regsub @OPTS@ $header $ropts header |
||||
regsub @TYPE@ $header $type header |
||||
|
||||
set n [string length $header] |
||||
while {$n <= 240} { |
||||
append header ################ |
||||
incr n 16 |
||||
} |
||||
|
||||
set slop [expr { 15 - (($n + 15) % 16) }] |
||||
for {set i 0} {$i < $slop} {incr i} { |
||||
append header # |
||||
} |
||||
set n [string length $header] |
||||
if {$n % 16 != 0} { |
||||
error "Header size is $n, should be a multiple of 16" |
||||
} |
||||
} |
||||
|
||||
if {!$reusefile} { |
||||
writefile $out $header |
||||
} |
||||
|
||||
set origsize [file size $out] |
||||
|
||||
switch $tcl_platform(platform) { |
||||
unix { |
||||
catch {file attributes $out -permissions +x} |
||||
} |
||||
windows { |
||||
set batfile [file root $out].bat |
||||
# 2005-03-18 don't create a batfile if "-runtime" is specified |
||||
if {![file exists $batfile] && ![info exists pfile]} { |
||||
set fd [open $batfile w] |
||||
puts -nonewline $fd \ |
||||
"@$prog [file tail $out] %1 %2 %3 %4 %5 %6 %7 %8 %9" |
||||
close $fd |
||||
} |
||||
} |
||||
macintosh { |
||||
catch {file attributes $out -creator TKd4} |
||||
} |
||||
} |
||||
|
||||
# 2003-02-08: added code to patch icon in windows executable |
||||
# triggered by existence of tclkit.ico in vfs dir *and* tclkit.ico in orig |
||||
|
||||
# careful: this applies only to windows executables, but the |
||||
# icon replacement can in fact take place on any platform... |
||||
|
||||
if {[info exists origicon] && [file exists [file join $idir tclkit.ico]]} { |
||||
puts " customizing tclkit.ico in executable" |
||||
set custicon [readfile [file join $idir tclkit.ico]] |
||||
array set newimg [decICO $custicon] |
||||
foreach {k v} [decICO $origicon] { |
||||
if {[info exists newimg($k)]} { |
||||
set len [string length $v] |
||||
set pos [string first $v $header] |
||||
if {$pos < 0} { |
||||
puts " icon $k: NOT FOUND" |
||||
} elseif {[string length $newimg($k)] != $len} { |
||||
puts " icon $k: NOT SAME SIZE" |
||||
} else { |
||||
binary scan $header a${pos}a${len}a* prefix - suffix |
||||
set header "$prefix$newimg($k)$suffix" |
||||
puts " icon $k: replaced" |
||||
} |
||||
} |
||||
} |
||||
writefile $out $header |
||||
} |
||||
|
||||
# 2005-03-15 added AF's code to customize version/description strings in exe's |
||||
if {[info exists pfile] && |
||||
[string tolower [file extension $pfile]] == ".exe" && |
||||
[file exists [file join $idir tclkit.inf]]} { |
||||
puts " customizing strings in executable" |
||||
package require stringfileinfo |
||||
set fd [open [file join $idir tclkit.inf] "r"] |
||||
fconfigure $fd -translation binary |
||||
array set strinfo [read $fd] |
||||
close $fd |
||||
::stringfileinfo::writeStringInfo $out strinfo |
||||
} |
||||
|
||||
proc tclLog {msg} { puts $msg } |
||||
|
||||
proc mkFileStart {filename} { |
||||
set end [file size $filename] |
||||
if {$end < 27} { |
||||
fail "file too small, cannot be a datafile" |
||||
} |
||||
|
||||
set fd [open $filename] |
||||
fconfigure $fd -translation binary |
||||
seek $fd -16 end |
||||
binary scan [read $fd 16] IIII a b c d |
||||
close $fd |
||||
|
||||
#puts [format %x-%d-%x-%d $a $b $c $d] |
||||
|
||||
if {($c >> 24) != -128} { |
||||
error "this is not a Metakit datafile" |
||||
} |
||||
|
||||
# avoid negative sign / overflow issues |
||||
if {[format %x [expr {$a & 0xffffffff}]] eq "80000000"} { |
||||
set start [expr {$end - 16 - $b}] |
||||
} else { |
||||
# if the file is in commit-progress state, we need to do more |
||||
error "this code needs to be finished..." |
||||
} |
||||
|
||||
return $start |
||||
} |
||||
|
||||
if {![catch { package require Mk4tcl }]} { |
||||
vfs::mk4::Mount $out $out |
||||
set argv $syncopts |
||||
lappend argv -compress $compress -verbose $verbose -noerror 0 $idir $out |
||||
|
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
# 2003-06-19: new "-uncomp name" option to store specific file(s) |
||||
# in uncompressed form, even if the rest is compressed |
||||
set o $vfs::mk4::compress |
||||
set vfs::mk4::compress 0 |
||||
foreach f $explist { |
||||
file delete -force [file join $out $f] |
||||
file copy [file join $idir $f] [file join $out $f] |
||||
} |
||||
set vfs::mk4::compress $o |
||||
|
||||
vfs::unmount $out |
||||
} elseif {![catch { package require vlerq }]} { |
||||
package require vfs::m2m 1.8 |
||||
|
||||
if {$verbose} { |
||||
puts "Mk4tcl not found, switching to the Vlerq driver." |
||||
} |
||||
|
||||
# 2006-12-06, must do a bit more work for starpacks when there is no Mk4tcl: |
||||
# - split the tail off |
||||
# - truncate the file so only the head remains |
||||
# - copy the original vfs contents to m2m, to be overwritten/extended later |
||||
|
||||
set outsize [file size $out] |
||||
|
||||
if {![catch { mkFileStart $out } mkpos]} { |
||||
set fd [open $out] |
||||
fconfigure $fd -translation binary |
||||
set outhead [read $fd $mkpos] |
||||
set origvfs [read $fd] |
||||
close $fd |
||||
|
||||
set fd [open $out w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $outhead |
||||
close $fd |
||||
} |
||||
|
||||
vfs::m2m::Mount $out $out |
||||
|
||||
if {[info exists origvfs]} { |
||||
set fd [open $out.tmp w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $origvfs |
||||
close $fd |
||||
|
||||
package require vfs::mkcl |
||||
vfs::mkcl::Mount $out.tmp $out.tmp |
||||
|
||||
set argv [list -verbose 0 $out.tmp $out] |
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
vfs::unmount $out.tmp |
||||
file delete $out.tmp |
||||
} |
||||
|
||||
set argv $syncopts |
||||
lappend argv -verbose $verbose -noerror 0 $idir $out |
||||
|
||||
source [file join [file dirname [info script]] sync.tcl] |
||||
|
||||
vfs::unmount $out |
||||
} else { |
||||
puts stderr "cannot find required packages (Mk4tcl or Vlerq)" |
||||
exit 1 |
||||
} |
||||
Loading…
Reference in new issue