# 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. <[email protected]> # Author: Pascal Scheffers <[email protected]> # # 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 ]