21Jan2005 - [PS]

This code was created for a starpack based installer/updater project we have at Unitas Software. I may have updated versions available, drop me a line if you are curious/want to have it.

- Pascal Scheffers

----
    # kitsplit -*- tcl -*- 
    # 
    #   Splits a starpack into the original executable tclkit.exe
    #   and a *.kit file or .vfs/ directory.
    #
    # Copyright (C) 2005 Unitas Software B.V. <info@unitas.nl>
    #    Author: Pascal Scheffers <pascal@scheffers.net>
    #
    # This file includes code written by Jean-Claude Wippler, Richard Suchenwirth
    # and others which was previously released to the public domain. The code in
    # question has comments to indicate. 
    #
    # The authors hereby grant permission to use, copy, modify, distribute,
    # and license this software and its documentation for any purpose, provided
    # that existing copyright notices are retained in all copies and that this
    # notice is included verbatim in any distributions. No written agreement,
    # license, or royalty fee is required for any of the authorized uses.
    # Modifications to this software may be copyrighted by their authors
    # and need not follow the licensing terms described here, provided that
    # the new terms are clearly indicated on the first page of each file where
    # they apply.
    #
    # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
    # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
    # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
    # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
    # POSSIBILITY OF SUCH DAMAGE.
    #
    # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
    # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
    # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
    # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
    # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
    # MODIFICATIONS.
    #  
    #
    # Usage:
    # 
    # Include kitsplit.tcl and a suitable pkgIndex.tcl in your starpack 
    #
    # API Documentation:
    #  
    #   kitsplit /TclkitToWrite/ /ApplicationkitToWrite/ 
    #      Writes a tclkit.exe and application.kit file from the currently running
    #      starpack. Existing files will be overwritten. 
    #
    #      /TclkitToWrite/ full path for the tclkit.exe
    #
    #      /ApplicationkitToWrite/ full path for the application.kit
    #                              if the name ends with .vfs, an unwrapped version
    #                              will be written instead.
    #                              
    #  writeKitExe /TclkitToWrite/
    #      Writes a tclkit.exe running starpack. 
    #      If the tclkit.exe already exists an error is raised.
    #
    #      /TclkitToWrite/ full path for the tclkit.exe
    #  
    #  writeKitFile /ApplicationkitToWrite/ ?/wrapped/?
    #      Writes a application.kit from the running starpack. 
    #      If the application.kit already exists an error is raised.
    #
    #      /ApplicationkitToWrite/ full path for the application.kit
    #      /wrapped/ Boolean value, 0 = write .vfs directory, 1=(default) write .kit file
    #  
    #  unwrap /VFSDirToWrite/
    #      Writes a application.vfs/ from the running starpack. 
    #      If the application.vfs/ already exists an error is raised.
    #
    #      /VFSDirToWrite/ full path for the application.vfs/
    #  
    #  runningAsStarpack
    #      Returns 1 if the currently running application is a starpack, 0 otherwise.
    #      Query $::starkit::mode to figure out other states such as unwrapped,
    #      starkit, ...
    #
    # Example:
    #  package require kitsplit 
    #  namespace import kitsplit::*
    #
    #  if { [runningAsStarpack] } {
    #     kitsplit c:/path/to/desired/tclkit.exe c:/path/to/desired/application.kit   
    #  }
    #  
    # contents of pkgIndex.tcl:
    #      package ifneeded kitsplit 1.0 [list source [file join $dir kitsplit.tcl]]
    
    namespace eval kitsplit {    
        # Which files belong to tclkit.exe? (glob patterns)
        variable tclkitContent {
            boot.tcl
            config.tcl
            tclkit.ico
            lib/itcl*/*
            lib/vfs/*        
        }    
        lappend tclkitContent lib/tcl$::tcl_version/*
        lappend tclkitContent lib/tk$::tcl_version/*
    
        proc glob-r {{dir .}} {
            # By Richard Suchenwirth
            set res {}
            foreach i [lsort [glob -nocomplain -dir $dir *]] {
                if {[file type $i]=="directory"} {
                        eval lappend  res [glob-r $i]
                } else {
                        lappend res $i
                }
            }
            set res
        } 
            
        proc isKitFile { filename } {
            variable tclkitContent
            foreach pattern $tclkitContent {
                if { [string match $pattern $filename] } {
                    return 1
                }
            }
            return 0        
        }
        
        
            
        proc writeKitExe { path } {
            if { [file exists $path] } {
                error "writeKitExe will not over write an existing tclkit.exe file."
            }
            
            # Write the tclkit.exe from the current tclkit name-of-executable
            #vfs::unmount 
            set exefile $::starkit::topdir
            set exefile z:/pascaltesting/unitasupdate.exe
            set tmpfile $path.writeKitTmp
            
            switch $::tcl_platform(platform) {
                windows {                
                    exec $::env(COMSPEC) /c copy [file nativename $exefile] [file nativename $tmpfile]
                }
                default {
                    exec cp [file nativename $exefile] [file nativename $tmpfile]
                }
            }
            #file copy -force -- $::starkit::topdir $path
            set mnt ${exefile}_work
            vfs::mk4::Mount $tmpfile $mnt
            set cutlen [string length $mnt]
            incr cutlen 
            
            set files [glob-r $mnt]
            set dirs {}
            foreach file $files {
                if { ![isKitFile [string range $file $cutlen end]] } {
                    file delete $file
                    if { [llength [glob -nocomplain -dir [file dirname $file] *]]==0 } {
                        file delete [file dirname $file]
                    }
                }
            }
            vfs::unmount $mnt        
            mkpack $tmpfile $path        
            file delete -force $tmpfile        
        }
        
        proc unwrap { path } {
            # Copy out the entire application specific VFS to $path as a metakit.kit
            # file.
            writeKitFile $path 0        
        }
        
        proc writeKitFile { path {wrapped 1} } {        
            # Write the application.kit from the currenty running tclkit
            # will not over write an existing kit file.
            # returns the number of files written to the new kit file.
            if { [file exists $path] } {
                error "writeKitFile will not over write an existing (kit) file."
            }
            
            if { $wrapped } {
                set mnt $path.mntpoint
                vfs::mk4::Mount $path $mnt
            } else {
                set mnt $path
            }
            
            set files [glob-r $::starkit::topdir]
            set cutlen [string length $::starkit::topdir]
            incr cutlen
            set count 0
            foreach file $files {
                set filename [string range $file $cutlen end]
                if { ![isKitFile $filename] } {
                    if { ![file exists [file dirname [file join $mnt $filename]]] } {
                        file mkdir [file dirname [file join $mnt $filename]]
                    }
                    file copy $file [file join $mnt $filename]
                    incr count
                }
            }
            
            if { $wrapped } {
                vfs::unmount $mnt
            }
            return $count    
        }    
        
        proc mkpack {infile outfile} {
            # Adapted from sdx.kit
            
            # Take infile, copy the bit upto the actual mk file into outfile,
            # mk::file open the infile and write a new mk file appended to outfile.
    
            # returns the number of bytes shaved of the original. Negative value
            # indicates the new files is bigger.
            
            if {[file normalize $infile] eq [file normalize $outfile]} {
              error "input and output may not be the same file"
            }
            if {![file exists $infile]} {
              error "file does not exist"
            }
            if {![file isfile $infile]} {
              error "this is not a regular file (perhaps mounted as VFS?)"
            }
            set end [file size $infile]
            if {$end < 27} {
              error "file too small, cannot be a datafile"
            }
            
            set fd [open $infile]
            fconfigure $fd -translation binary -encoding binary
            seek $fd -16 end
            binary scan [read $fd 16] IIII a b c d
            
            #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 $a] 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..."
            }
            
            seek $fd $start
            switch -- [read $fd 2] {
              JL { set endian little }
              LJ { set endian big }
              default { error "failed to locate data header" }
            }
            seek $fd 0
            
            mk::file open db $infile -readonly
            
            set ofd [open $outfile w]
            fconfigure $ofd -translation binary -encoding binary
            fcopy $fd $ofd -size $start
            mk::file save db $ofd        
            mk::file close db        
            close $ofd           
            close $fd        
            return [expr {[file size $infile]-[file size $outfile]}]
        }
        
        proc kit_compare { kit1 kit2 } {
            # compares the two kitfiles file-by-file and lists the differences.
            # Mainly for debugging.
            
            if {[file normalize $kit1] eq [file normalize $kit2]} {
              error "input and output may not be the same file"
            }
            
            if { ![file isdirectory $kit1] } {
                vfs::mk4::Mount $kit1 $kit1
            }
            if { ![file isdirectory $kit2] } {
                vfs::mk4::Mount $kit2 $kit2
            }
            
            set _kit1files [glob-r $kit1]        
            set _kit2files [glob-r $kit2]
            set kit1files {}
            set kit2files {}
            # Trim off the base path names:
            foreach kitno {1 2} {
                set cutlen [string length [set kit$kitno]]
                incr cutlen
                foreach name [set _kit${kitno}files] {
                    lappend kit${kitno}files [string range $name $cutlen end]
                }
            }
                    
            # files in kit2 not in kit1
            set additions [list_extras $kit1files $kit2files]
            # files in kit1 not in kit2
            set missing [list_extras $kit2files $kit1files]
            
            if { ![file isdirectory $kit1] } {
                vfs::unmount $kit1
            }
            if { ![file isdirectory $kit2] } {
                vfs::unmount $kit2
            }
            
            return [list additions $additions missing $missing]
        }
        
        proc list_extras { list1 list2 } {
            # used by kit_compare
            # returns items in list2 not in list1
            set extras {}
            set list1 [lsort $list1]
            foreach item $list2 {
                if { [lsearch -sorted $list1 $item] == -1 } {
                    lappend extras $item
                }
            }
            return $extras
        }
        
        proc kitsplit { tclkitexe applicationkit } {
            # Write out the tclkit exe and the applicationkit.
            # If the applicationkit file name ends in .vfs write out as .vfs
            # directory, otherwise write out as metakitvfs.kit file.
            
            set wrapped [expr {[string tolower [file extension $applicationkit]] ne ".vfs"} ]
            
            if { [file exists $tclkitexe.splittmp] } {
                file delete -force $tclkitexe.splittmp
            }        
            writeKitExe $tclkitexe.splittmp
            file rename -force $tclkitexe.splittmp $tclkitexe
    
            if { [file exists $applicationkit.splittmp] } {
                file delete -force $applicationkit.splittmp
            }        
            writeKitFile $applicationkit.splittmp $wrapped
            file rename -force $applicationkit.splittmp $applicationkit        
        }
        
        proc runningAsStarpack {} {
            return [expr { $::starkit::mode eq "starpack" } ]
        }
        
        namespace export kitsplit writeKitFile writeKitExe unwrap runningAsStarpack
    }
    
    package provide kitsplit 1.0
----    
[[ [Category Package] | [Category Application] | [Category Tclkit] ]]