# 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 ]
