SDX Enhancements

AMG: Bug fixes and enhancements to SDX version 20110317:

diff -ur old/lib/app-sdx/mkpack.tcl new/lib/app-sdx/mkpack.tcl
--- old/lib/app-sdx/mkpack.tcl        2017-08-09 19:43:50.089879453 -0500
+++ new/lib/app-sdx/mkpack.tcl        2017-08-08 19:07:52.495423972 -0500
@@ -3,7 +3,7 @@
 # Re-pack a starkit/starpack or MK datafile (header is kept intact)
 # Jan 2004, [email protected]
 
-proc fail {msg} { puts stderr "${::inf}: $msg"; exit 1 }
+proc fail {msg} { variable inf; puts stderr "$inf: $msg"; exit 1 }
 
 if {[llength $argv] != 2} {
   set inf usage
diff -ur old/lib/app-sdx/mksplit.tcl new/lib/app-sdx/mksplit.tcl
--- old/lib/app-sdx/mksplit.tcl        2017-08-09 19:43:50.090879452 -0500
+++ new/lib/app-sdx/mksplit.tcl        2017-08-08 19:07:52.495423972 -0500
@@ -4,7 +4,7 @@
 # derived from mkinfo.tcl code
 # Jan 2004, [email protected]
 
-proc fail {msg} { puts stderr "${::filename}: $msg"; exit 1 }
+proc fail {msg} { variable filename; puts stderr "$filename: $msg"; exit 1 }
 
 if {[llength $argv] < 1} {
   set filename usage
diff -ur old/lib/app-sdx/ratarx.tcl new/lib/app-sdx/ratarx.tcl
--- old/lib/app-sdx/ratarx.tcl        2017-08-09 19:43:50.092879451 -0500
+++ new/lib/app-sdx/ratarx.tcl        2017-08-08 19:07:52.496423972 -0500
@@ -60,7 +60,8 @@
 close $fd
 
 proc cleandir {{d ""}} {
-  set f [expr {![info exists ::dirs($d/)]}]
+  variable dirs
+  set f [expr {![info exists dirs($d/)]}]
   foreach x [glob -nocomplain [file join $d *]] {
     incr f [expr {[file isdir $x] ? [cleandir $x] : 1}]
   }
diff -ur old/lib/app-sdx/wrap.tcl new/lib/app-sdx/wrap.tcl
--- old/lib/app-sdx/wrap.tcl        2017-08-09 19:43:50.095879453 -0500
+++ new/lib/app-sdx/wrap.tcl        2017-08-09 19:26:22.948879456 -0500
@@ -64,16 +64,6 @@
     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]
 }
 
@@ -110,11 +100,19 @@
       set pfile [lindex $argv 2]
       if {$pfile == $out} {
               set reusefile 1
-      } else {
-              set header [LoadHeader $pfile]
       }
+      set header [LoadHeader $pfile]
       set argv [lreplace $argv 1 2]
       set prefix 1
+      catch {
+        package require vfs::mk4
+        vfs::mk4::Mount $pfile $pfile -readonly
+        # we only look for an icon if the runtime is called *.exe (!)
+        if {[string tolower [file extension $pfile]] == ".exe"} {
+          catch { set origicon [readfile [file join $pfile tclkit.ico]] }
+        }
+      }
+      catch { vfs::unmount $pfile }
     }
     -writable -
     -writeable {
@@ -223,7 +221,15 @@
       }
     }
   }
-  writefile $out $header
+  if {$reusefile} {
+    set fd [open $out a+]
+    fconfigure $fd -translation binary
+    seek $fd 0
+    puts -nonewline $fd $header
+    close $fd
+  } else {
+    writefile $out $header
+  }
 }
 
 # 2005-03-15 added AF's code to customize version/description strings in exe's
@@ -278,13 +284,21 @@
 
     # 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
+  if {[info exists vfs::mk4::compress]} {
+    set o $vfs::mk4::compress
+  }
+  if {[namespace exists vfs::mk4]} {
+    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
+  if {[info exists o]} {
+    set vfs::mk4::compress $o
+  } elseif {[namespace exists vfs::mk4]} {
+    unset vfs::mk4::compress
+  }
 
   vfs::unmount $out
 } elseif {![catch { package require vlerq }]} {

Improved "sdx" package, better enabling SDX to be used as a utility library:

# sdx.tcl
#
# This package is an alternative to sdx.kit's lib/sdx/sdx.tcl.  Namespaces, not
# slave interpreters, are used to sandbox the SDX scripts because the Starkit
# infrastructure is not given the opportunity to initialize slave interpreters
# to the point where SDX can function reliably.

# Create namespace variables.
namespace eval ::sdx {
    # Directory in which the SDX scripts are located.
    variable SdxDir
}

# Create stdout/stderr interception mechanism.
namespace eval ::sdx::Intercept {
    proc initialize {chan mode} {info procs}
    proc finalize {chan} {}
    proc clear {chan} {}
    proc flush {chan} {}
    proc write {chan data} {append ::sdx::Intercept::Output $data; return}
    namespace export *
    namespace ensemble create
}

# Analyze the app-sdx package.
apply {{} {
    variable ::sdx::SdxDir

    # Force all package information to be loaded.
    catch {package require {}}

    # Find the load script for the latest version of app-sdx.
    set script [package ifneeded app-sdx [lindex [lsort\
            -command {package vcompare} [package versions app-sdx]] end]]

    # Extract the directory from the app-sdx load script.
    set SdxDir [file dirname [lindex $script end]]

    # Create aliases for each available SDX command.
    foreach file [glob -tails -directory $SdxDir *.tcl] {
        if {$file ni {pkgIndex.tcl sdx.tcl}} {
            set command [file rootname $file]
            interp alias {} ::sdx::$command {} ::sdx::sdx $command
        }
    }
}}

# ::sdx::sdx --
# Invokes the SDX application as a script command.
proc ::sdx::sdx {command args} {
    variable ::sdx::Intercept::Output {} SdxDir

    # Compute name of SDX script file.
    set script [file join $SdxDir $command.tcl]

    # Confirm the SDX script exists.
    if {![file exists $script]} {
        foreach file [lsort [glob -tails -directory $SdxDir *.tcl]] {
            if {$file ni {pkgIndex.tcl sdx.tcl}} {
                lappend commands [file rootname $file]
            }
        }
        return -code error "unknown subcommand \"$command\":\
                must be [join $commands ", "]"
    }

    # Get the list of mounted filesystems.  This allows automatically unmounting
    # filesystems left mounted by SDX.
    set filesystems [vfs::filesystem info]

    # Get the list of file channels.  This allows automatically closing channels
    # left open by SDX.
    set channels [chan names]

    # Prepare to restore the current working directory, should SDX change it.
    set pwd [pwd]

    # Collect everything written to stdout and stderr into the Output variable.
    chan push stdout ::sdx::Intercept
    chan push stderr ::sdx::Intercept

    # Intercept [exit] and convert it to an error with a custom "-exit" option.
    rename ::exit ::sdx::RealExit
    set token [interp alias {} ::exit {} apply {{{exit 0}} {
        return -code error -exit $exit [string trim $::sdx::Intercept::Output]
    }}]

    # Create temporary sandbox namespace in which to execute SDX command.  This
    # namespace will collect any variables and commands created by SDX.  It is
    # kept separate from the ::sdx namespace so that commands in ::sdx (such as
    # [eval]) do not interfere with the operation of the underlying SDX command.
    namespace eval ::sdx::Sandbox [list set argv0 [list ::sdx::sdx $command]]
    namespace eval ::sdx::Sandbox [list set argv $args]

    # Prepare to handle SDX errors.
    set options {-code return}
    try {
        # Run the requested SDX script.
        namespace eval ::sdx::Sandbox [list source $script]
    } on error {value options} {
        # Handle errors and intercepted [exit], which was converted to an error.
        if {![dict exists $options -exit]} {
            set Output $value\n$Output
        } elseif {[dict get $options -exit]} {
            set Output "SDX exit code [dict get $options -exit]\n$Output"
        } else {
            dict set options -code return
        }
    } finally {
        # Delete sandbox namespace.
        namespace delete ::sdx::Sandbox

        # Restore original [exit] command.
        interp alias {} $token {}
        rename ::sdx::RealExit ::exit

        # Stop intercepting stdout/stderr.
        chan pop stdout
        chan pop stderr

        # Return to the original working directory.
        cd $pwd

        # Close leftover channels.
        foreach chan [chan names] {
            if {$chan ni $channels} {
                chan close $chan
            }
        }

        # Unmount leftover filesystems.
        foreach filesystem [vfs::filesystem info] {
            if {$filesystem ni $filesystems} {
                vfs::unmount $filesystem
            }
        }
    }

    # The return value is the intercepted stdout/stderr text.
    dict set options -level 0
    return {*}$options [string trim $Output[set Output {}]]
}

# vim: set sts=4 sw=4 tw=80 et ft=tcl:

PYK 2017-08-09: How about publishing your changes as a fossil repository on chisel?

AMG: At this point I don't want to go so far as to take ownership of SDX.

PYK 2017-08-09: It's pretty fair these days to publish forks into a scm system without asserting a claim of ongoing maintenance. If it's not in a repository, there's a much lower change that change history will be captured as the source code changes hands, and that history can be valuable. FWIW, jcw responded quickly when made a pull request on github last year for metakit. Also, publishing a diff makes you the new owner every bit as much as publishing a fossil repository would ;)

aspect: There is already a repository on chiselapp, linked at the very top of SDX. I've created a ticket - if anyone feels like attaching a fossil bundle or want commit access I'd be much obliged :).

AMG: Thank you for checking in my code. I've done a lot of work with SDX lately. It's kind of odd. The more I use it, the less I use it. By that I mean: the more I've studied it, the more I've migrated away from blindly relying on it as a magical all-in-one black box in favor of mounting the Starkit/Starpack VFS and putting files in it myself. At this point, the only thing my application uses it for is [sdx::mksplit]. My "makefile" (actually a Tcl script) does call [sdx::wrap], but that could be replaced with a call to the application code that also does wrapping. However, I like having sdx.tcl (not the above sdx.tcl, instead see below) for command-line use to help me examine Starkits/Starpacks and so on, so ultimately I'm not going to remove it.

#!/bin/bash
# sdx.tcl - Starkit Developer eXtension command line interface.
#
# This comment hides the next two lines from the Tcl interpreter.\
[ "$(uname -m)" == ppc64 ] && SUFFIX=-ppc;\
exec "$(dirname "$0")/tclkit$SUFFIX" "$0" "$@"

# Load required packages.
lappend auto_path [file join [file dirname [info script]] .. lib]
package require Tcl 8.6
package require sdx

# Run SDX.
puts [sdx::sdx {*}$argv]

# vim: set sts=4 sw=4 tw=80 et ft=tcl:

Also, please note that I made a bug fix: using [vfs::unmount] instead of [vfs::filesystem unmount] because the latter doesn't give the Metakit database engine a chance to close the file.

aspect: Thanks! I think I know what you mean about sdx: when I started using it, starkit and sdx seemed like magic, but after a while it sunk in that it's just simple vfs operations, which can be done from tclsh if you recall the syntax. Peeking under the hood is very instructive. In the end, I still use sdx because my build scripts Just Work but I can imagine its role shrinking if I revisited those. Though with the way you've improved [package require sdx] it's convenient to just use it in tclsh or tcl scripts now, which is great!

I've committed the [vfs::unmount] change - thanks for the clear description. I also added package provide and bumped the version to 1.1, which seems appropriate after 6 years. How would you like your contributions credited?

AMG: Use my name "Andy Goth" if you wish to credit me.


drkoru - 2018-03-18 19:32:10

I experienced an issue with syncing the starkit copy served through a cgi script on my server with a local starkit. Examining the problem, I found a potential problem with the starsync.tcl file where the virtual file system is mounted. It may be worth to take a look so that others will not experience the same issue. It is described here:

https://chiselapp.com/user/aspect/repository/sdx/info/126a356681e046c4