#tarpack-tarpack-1.1.2/ 777 0 0 0 10647217642 7612 5#tarpack-tarpack-1.1.2/#tarpack-loadscript-tarpack-1.1.2.tcl 777 0 0 132173 10647213601 16351 0 #tarpack #Julian Marcel Noble 2005. BSD License. [JMN] on the Tcler's wiki - http://wiki.tcl.tk # #------------------------------------------------------------------------------------ # # Purpose: Read (load) & write tarpacked module files using pure-tcl. # This might be useful as a bootstrap for other (faster,smaller,funkier?) module-archivers that use binaries. # e.g trofs or starkit ?? # # A tarpack is a valid tarball with the contents under a specially named folder. # This foldername is a Tcl commented string: #tarpack-- # The first file in the archive starts with a linefeed, ends with a comment character (#) and contains the load-script. # There is also a file named #z that ends with a ctrl-z character to terminate sourcing. # # A tarpack .tm file is sourceable by Tcl and thus directly loadable as Tcl modules. # The tarpack format offers the advantage that the contents are accessible using # standard tar archive tools as well as other commandline tools such as grep. # # # This package only does a 'package require tar' (tcllib) if creating a tarpack. # Packages tar, vfs & any package requiring binaries, must not be required for reading. # Preferably this package will not require any other packages. # - It'd be nice to keep things ultra simple for relatively easy deployment by people unfamiliar with Tcl packages & modules. # # # !todo - investigate: Is there an *efficient* way to test for and utilize a binary tar package that may be present? # (i.e a method that doesn't trigger scans of the auto_path, or other extensive filesystem searches.) # Will this offer any worthwhile performance benefits, or should other module-archivers be used instead if that is an issue? #------------------------------------------------------------------------------------ # # zipped-tarpack # With thanks to Pascal Scheffers # see Using zip files like a .kit file: http://wiki.tcl.tk/13876 # #------------------------------------------------------------------------------------ #!todo - don't maintain connection to .tm file after diversion to unwrapped version. # (so how can we deliberately connect to the .tm file in this case?) #fix tarpack::create - works as needed by tarpack::wrap - but doesn't properly pack all supplied files when called directly. #------------------------------------------------------------------------------------ #don't do a 'package provide' until we've given a chance to redirect.. namespace eval tarpack { variable connected if {![info exists connected(to)]} { set connected(to) [list] } #extensions of loadable files variable loadable [list .so .dll] variable version } namespace eval tarpack::_ { #internal } #As tarpack is likely to be loaded very early in a script's life - # we must be careful about writing to stdout/stderr. # use ::tarpack::Puts in this package instead of puts to emit warnings. # stderr/stdout may have been redirected or not yet be open for writing. # (e.g script might require other packages before standard channels are in a usable state) # # We could just wrap all warnings in a catch... but then warnings are lost. # #tarpack cooperates with the channelguard package since we can't load it from within this package. namespace eval ::channelguard { variable buffer array set buffer [list] ;#make sure it exists so we can append to $chan,data elements. } proc ::tarpack::Puts {args} { set nl \n if {[llength $args] > 1 && ([lindex $args 0] eq "-nonewline")} { set nl "" set args [lrange $args 1 end] } if {[llength $args] == 1} { #default to stdout set args [list stdout [join $args]] } lassign $args channel s set cmd ::puts if {$nl==""} {lappend cmd -nonewline} if {![info exists ::channelguard::README-tarpack]} { set ::channelguard::README-tarpack { The ::channelguard namespace belongs to the 'channelguard' package. The 'tarpack' package has written directly to the channelguard::buffer variable. } } if {[catch {puts -nonewline $channel ""}]} { #channel not writeable #so where do we send our data?? #for now - just accumulate in a variable because loading other packages such as Memchan may also invoke puts. # (depending on package distribution method etc) #!todo - review # append ::tarpack::$channel $s append ::channelguard::buffer($channel,data) $s$nl } else { #{*}$cmd $channel $s if {![catch {package present channelguard}]} { if {$channel ni [::channelguard::guarded]} { #channelguard loaded but this channel not guarded.. #presumably therefore it's now ok to write to it. {*}$cmd $channel $s } else { append ::channelguard::buffer($channel,data) $s$nl } } else { append ::channelguard::buffer($channel,data) $s$nl } } } #------------------------------------------------------------ #see returneval: http://mini.net/tcl/4346 proc ::tarpack::_::returneval {script} {return -code -1 $script} proc ::tarpack::_::eproc {name arglist body} { set alt ::tarpack::_::[namespace tail $name] uplevel 1 [list proc $alt $arglist $body] interp alias {} $name {} [namespace which -command ::tarpack::_::eproc_call] $alt } proc ::tarpack::_::eproc_call {args} { set code [catch [list uplevel 1 $args] res] if {$code == -1} then { set code [catch [list uplevel 1 $res] res] return -code $code $res } elseif {$code == 1} then { return -code error -errorinfo $::errorInfo -errorcode $::errorCode $res } else { return -code $code $res } } #------------------------------------------------------------ #from tcllib tar proc ::tarpack::_::pad {size} { set pad [expr {512 - ($size % 512)}] if {$pad == 512} {return 0} return $pad } #straight snaffle from from tar::readHeader in tcllib! #tcllib tar API appears only designed to deal with entire tarball files, not streams, otherwise # we would have simply used that tar package. # proc ::tarpack::_::readHeader {data} { binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \ name mode uid gid size mtime cksum type \ linkname magic version uname gname devmajor devminor prefix foreach x {name mode type linkname magic uname gname prefix mode uid gid size mtime cksum version devmajor devminor} { set $x [string trim [set $x] "\x00"] } set mode [string trim $mode " \x00"] foreach x {uid gid size mtime cksum version devmajor devminor} { set $x [format %d 0[string trim [set $x] " \x00"]] } return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \ cksum $cksum type $type linkname $linkname magic $magic \ version $version uname $uname gname $gname devmajor $devmajor \ devminor $devminor prefix $prefix] } #return a stream open for reading at the beginning of the tar archive. tarpack::_::eproc ::tarpack::connect {tarpack {type ""}} { upvar #0 ::tarpack::connected con set sourced [expr {[file normalize $tarpack] eq [file normalize [info script]]}] if {![string length $tarpack]} { error "ERROR: tarpack path required for connection" } if {[lsearch $con(to) $tarpack] >= 0 } { #todo - count number of connections to particular tarpack and decrement on each disconnect til final? #error "ERROR: already connected to $tarpack" ::tarpack::Puts stderr "WARNING: already connected to $tarpack" return [list ok ALREADY_CONNECTED] } lappend con(to) $tarpack #puts "---------->connect $tarpack ---> [info level] [info script]" set con(location,$tarpack) [file dirname $tarpack] set con(startdata,$tarpack) -1 set con(type,$tarpack) $type set con(fh,$tarpack) "" if {[string range [file tail $tarpack] 0 7] eq "#tarpack" } { #connecting to unwrapped loadscript file. set con(type,$tarpack) "unwrapped" #use the containing folder's name to determine package & version #foreach [list _tarpackID con(package,$tarpack) con(version,$tarpack)] [::split [file tail [file dirname $tarpack]] -] {break} lassign [::split [file tail [file dirname $tarpack]] -] _tarpackID con(package,$tarpack) con(version,$tarpack) } else { #connecting to .tm or .tar archive - but may be still be unwrapped version available #use the tarpack file's name to determine package & version #foreach [list con(package,$tarpack) con(version,$tarpack)] [::split [file rootname [file tail $tarpack]] -] {break} lassign [::split [file rootname [file tail $tarpack]] -] con(package,$tarpack) con(version,$tarpack) } if {$con(type,$tarpack) ne "unwrapped"} { #Not directly connecting to unwrapped version - # but may still be redirected there set unwrappedFolder [file join $con(location,$tarpack) #tarpack-$con(package,$tarpack)-$con(version,$tarpack)] if {[file exists $unwrappedFolder]} { #folder with exact version-match must exist for redirect to 'unwrapped'. set con(type,$tarpack) tarpack-redirecting } } switch -- $con(type,$tarpack) { "tarpack-redirecting" { #We're about to redirect to the unwrapped version #Don't want to keep sourcing self # ...but we should keep a connection to ourself open. #'returneval' used to abort 'sourcing' of the wrapped version #connect to the tarball - start at 1st header. set con(startdata,$tarpack) 0 set fh [open $tarpack r] set con(fh,$tarpack) $fh fconfigure $fh -encoding binary -translation binary -eofchar {} if {![catch {::tarpack::_::readHeader [read $fh 512]}]} { seek $fh $con(startdata,$tarpack) start #!todo - efficiency: cache this so first read can use it? } set loadscript_name [file join $unwrappedFolder #tarpack-loadscript-$con(package,$tarpack)-$con(version,$tarpack).tcl] if {![file exists $loadscript_name]} { #no match for exact version - take largest version available. set versioned_loadscripts [::glob -nocomplain -dir $unwrappedFolder -tail #tarpack-loadscript-$con(package,$tarpack)-*.tcl] #version numbers cannot contain '-' char! if {[llength $versioned_loadscripts]} { set max 0 foreach fname $versioned_loadscripts { set v [lindex [split [file rootname $fname] -] end] if {[package vcompare $v $max] == 1} { #$v larger set max $v } } set loadscript_name [file join $unwrappedFolder #tarpack-loadscript-$con(package,$tarpack)-$max.tcl] } else { #last resort - versionless set loadscript_name [file join $unwrappedFolder #tarpack-loadscript-$con(package,$tarpack).tcl] } } if {$sourced} { #disconnect from the .tm pack prior to sourcing unwrapped version. tarpack::disconnect $tarpack #::tarpack::Puts stderr "---> about to source unwrapped version $loadscript_name" set script "uplevel #0 ::source $loadscript_name" set prev_info_script [info script] #puts stderr "===> about to source $loadscript_name" if {[catch "info script [list $loadscript_name];$script" errm]} { #info script {} info script $prev_info_script ::tarpack::_::returneval "error [list [set ::errorInfo]\n]" } else { #::tarpack::Puts stderr "===> stopping .tm sourcing action" #info script {} info script $prev_info_script ::tarpack::_::returneval "return [list ok -redirection $loadscript_name]" } } else { tarpack::disconnect $tarpack return [tarpack::connect $loadscript_name] } } "unwrapped" { if {[string length [info commands ::thread::id]]} { set from [pid],[thread::id] } else { set from [pid] } ::tarpack::Puts stderr "$from-> Package $con(package,$tarpack)-$con(version,$tarpack) is using unwrapped version: $tarpack" return [list ok ""] } default { # "tarpack" #connect to the tarball - start at 1st header. set con(startdata,$tarpack) 0 set fh [open $tarpack r] set con(fh,$tarpack) $fh fconfigure $fh -encoding binary -translation binary -eofchar {} } } if {$con(startdata,$tarpack) >= 0} { #verify we have a valid tar header if {![catch {::tarpack::_::readHeader [read $fh 512]}]} { seek $fh $con(startdata,$tarpack) start #!todo - efficiency: cache this so first read can use it? return [list ok $fh] } } set con(to) [lrange $con(to) 0 end-1] set con(startdata,$tarpack) -1 unset con(fh,$tarpack) close $fh return [list err {Does not appear to be a valid tarpack}] } proc ::tarpack::disconnect {{tarpack ""}} { variable connected #puts "===> disconnecting $tarpack " if {![llength $connected(to)]} { return 0 } if {$tarpack eq ""} { ::tarpack::Puts stderr "WARNING: tarpack not explicitly specified for tarpack::disconnect. Disconnecting last connected: [lindex $connected(to) end]\n - It is better to explicitly specify the tarpack. e.g 'tarpack::disconnect \[info script\]'" set tarpack [lindex $connected(to) end] } if {[set posn [lsearch $connected(to) $tarpack]] == -1} { ::tarpack::Puts stderr "WARNING: disconnect called when not connected: $tarpack" return 0 } if {[string length $connected(fh,$tarpack)]} { close $connected(fh,$tarpack) } array unset connected fh,$tarpack array unset connected type,$tarpack array unset connected startdata,$tarpack array unset connected location,$tarpack array unset connected package,$tarpack array unset connected version,$tarpack set connected(to) [lreplace $connected(to) $posn $posn] return 1 } tarpack::connect [info script] ;#give tarpack a chance to connect to the unwrapped version instead package provide tarpack [namespace eval tarpack { set version [lindex [split [file rootname [info script]] -] end] }] #load #changed args to be more consistent with standard Tcl 'load' command. #old api ::tarpack::load {filename {frompack ""}} proc ::tarpack::load {filename args} { #puts "%%%%%%%%%%%%% load $filename" set arglist [list] set options [list] for {set i 0} {$i < [llength $args]} {incr i} { set a [lindex $args $i] if {[string first - $a] == 0} { incr i ;#skip to value lappend options $a lappend options [lindex $args $i] } else { #not an option lappend arglist $a } } set packagename [lindex $arglist 0] set interp [lindex $arglist 1] if {([llength $arglist] % 2) == 0} { array set opts $arglist } if {![info exists opts(-from)]} { set opts(-from) [info script] #hack to see if old tarpacks are passing in 'frompack' instead of packagename if {$packagename eq $opts(-from)} { ::tarpack::Puts stderr "warning: tarpack:'$opts(-from)' usage 'tarpack::load file <-from tarpack>'" set packagename "" } } #puts "--->>>1 [info script]" #puts "--->>>2 [uplevel 1 {info script}]" #puts "---XXX3 $frompack" variable connected #!todo - copy it out to filesystem (and other binary files?) and load it. set frompack [tarpack::_::connect_if_not $opts(-from)] ;#ensure we're connected so we can get $frompack #foreach {stat info} [tarpack::getFileInfo $filename $frompack] {break} lassign [tarpack::getFileInfo $filename $frompack] stat info if {$stat ne "ok"} { error "unable to find file:'$filename' in tarpack:'$frompack'" } array set fileinfo $info if {$connected(type,$frompack) eq "unwrapped"} { set cache $connected(location,$frompack) set sofile [file join $cache $filename] } else { set cache [file join ~ .TclSoCache [file dirname $filename]] set sofile [file join $cache [file tail $filename]] if {![file exists $sofile]} { set filedata [lindex [tarpack::get $filename $frompack] 1] file mkdir $cache set fh [open $sofile w] fconfigure $fh -translation binary puts -nonewline $fh $filedata close $fh #'touch' the file to give it the same mtime as the packaged file. file mtime $sofile $fileinfo(mtime) } else { #!todo - check fstat and copy out IFF mismatching size &/or date? #set c [file size $sofile] file stat $sofile cachefile set c $cachefile(size) #array set fileinfo [lindex [tarpack::getFileInfo $file $frompack] 1] set p $fileinfo(size) #puts stderr "!!!size cached:$c pack:$p" if {($p != $c) || ($fileinfo(mtime) != $cachefile(mtime))} { ::tarpack::Puts stderr "warning - file: $filename. Filesize and/or mtime mismatch, cachedsize:$c packsize:$p; cachedmtime:$cachefile(mtime) packmtime:$fileinfo(mtime). To use this tarpack's version, remove $sofile and retry." } else { #puts stderr "OK - file: $file - size $p" } } } #temporarily cd to sofile location for loading. set place [pwd] cd $cache if {[string length $packagename]} { if {[string length $interp]} { uplevel #0 ::load $sofile $packagename $interp } else { uplevel #0 ::load $sofile $packagename } } else { uplevel #0 ::load $sofile } cd $place } #!todo - use #tarpack-xxx folder as base only if 'relative' path specified #old api proc ::tarpack::source {filename {frompack ""}} proc ::tarpack::source {filename args} { variable connected if {([llength $args] % 2) == 0} { array set opts $args } if {![info exists opts(-from)]} { set opts(-from) [info script] #hack to see if old tarpacks are passing in 'frompack' if {$args eq $opts(-from)} { ::tarpack::Puts stderr "warning: tarpack:'$opts(-from)' usage 'tarpack::source filename <-from tarpack>'" } } #!todo - what about -rsrc & -rsrcid options to 'source' for Mac platform? set frompack [tarpack::_::connect_if_not $opts(-from)] ;#ensure we're connected so we can get $frompack #foreach {stat dat} [tarpack::get $filename $frompack] {break} lassign [tarpack::get $filename $frompack] stat dat set prev_info_script [info script] if {$stat eq "ok"} { uplevel #0 [list if 1 "info script [list $filename];$dat"] #info script {} info script $prev_info_script } else { error "couldn't source file $file from tarpack $frompack. reason:$dat" } } proc ::tarpack::_::connect_if_not {frompack} { upvar #0 ::tarpack::connected connected #puts *---*---* #puts "connect_if_not $frompack" #parray connected #puts *---*---* set docon 0 if {![llength $connected(to)]} { if {![string length $frompack]} { error "Not connected to a tarpack file, and no tarpack specified" } else { set docon 1 } } else { if {![string length $frompack]} { set frompack [lindex $connected(to) end] ::tarpack::Puts stderr "WARNING: using last connected tarpack: $frompack for operation\n - tarpack not explicitly specified during operation: [info level -1]" } else { if {([lsearch $connected(to) $frompack] == -1) } { set docon 1 } } } if $docon { if {[lindex [tarpack::connect $frompack] 0] ne "ok"} { error "file $frompack does not seem to be a valid tarpack or tarbaby archive" } else { #we're now connected. return $frompack } } #We were already connected return $frompack } proc ::tarpack::getFileInfo {filename {frompack ""}} { #puts "%%%%%%%%%%%%% getFileInfo $filename" variable connected set frompack [::tarpack::_::connect_if_not $frompack] set fh $connected(fh,$frompack) if {$connected(type,$frompack) eq "unwrapped"} { #for unwrapped connection - $connected(location) already points to the #tarpack-pkg-ver folder if {[string range $filename 0 0] eq "/"} { #absolute path set path [file join $connected(location,$frompack) .. [string trim $filename /]] } else { #relative path - use #tarpack-xxx as base set path [file join $connected(location,$frompack) $filename] } file stat $path info return [list ok [array get info]] } else { set pkg $connected(package,$frompack) set ver $connected(version,$frompack) while {![eof $fh]} { array set header [::tarpack::_::readHeader [read $fh 512]] if {$header(name) eq ""} break set name [string trimleft $header(prefix)$header(name) /] if {($filename eq $name) || ("#tarpack-${pkg}-${ver}/$filename" eq $name)} { #!todo - set access position to header of first unread file instead? #!todo - maintain index of headers read so-far? #(what about added complexity when we also write to tarpack?) seek $fh $connected(startdata,$frompack) start return [list ok [array get header]] } seek $fh [expr {$header(size) + [::tarpack::_::pad $header(size)]}] current } seek $fh $connected(startdata,$frompack) start } return [list err "file $filename not found in archive"] } proc ::tarpack::get {filename {frompack ""}} { variable connected set frompack [::tarpack::_::connect_if_not $frompack] set fh $connected(fh,$frompack) if {$connected(type,$frompack) eq "unwrapped"} { #for unwrapped connection - $connected(location) already points to the #tarpack-pkg-ver folder if {[string range $filename 0 0] eq "/"} { #absolute path set path [file join $connected(location,$frompack) .. [string trim $filename /]] } else { #relative path - use #tarpack-xxx as base set path [file join $connected(location,$frompack) $filename] } set fd [open $path r] return [list ok [lindex [list [read $fd [file size $path]] [close $fd] ] 0]] #set fd [open $path r] #set filedata [read $fd [file size $path]] #close $fd #return [list ok $filedata] } else { set pkg $connected(package,$frompack) set ver $connected(version,$frompack) while {![eof $fh]} { array set header [::tarpack::_::readHeader [read $fh 512]] if {$header(name) eq ""} break set name [string trimleft $header(prefix)$header(name) /] if {($filename eq $name) || ("#tarpack-${pkg}-${ver}/$filename" eq $name)} { set filedata [read $fh $header(size)] seek $fh $connected(startdata,$frompack) start #!todo - set access position to header of first unread file instead? return [list ok $filedata] } seek $fh [expr {$header(size) + [::tarpack::_::pad $header(size)]}] current } seek $fh $connected(startdata,$frompack) start } return [list err "file $filename not found in archive"] } proc ::tarpack::glob {folder {glob *} {frompack ""}} { variable connected #parray connected #puts "*************" set frompack [::tarpack::_::connect_if_not $frompack] set fh $connected(fh,$frompack) #puts ">>>>>glob $folder $glob - whilst connected to $frompack . fh: $fh" if {$connected(type,$frompack) eq "unwrapped"} { #for unwrapped connection - $connected(location) already points to the #tarpack-pkg-ver folder if {[string range $folder 0 0] eq "/"} { #absolute path set path [file join $connected(location,$frompack) .. [string trim $folder /]] } else { #relative path - use #tarpack-xxx as base set path [file join $connected(location,$frompack) $folder] } #puts "--->globbing -nocomplain -directory $path -tail $glob" return [list ok [::glob -nocomplain -directory $path -tail $glob]] } elseif {$connected(type,$frompack) eq "tarpack-redirectingXXX???"} { if {[string range $folder 0 0] eq "/"} { #absolute path set path [file join $connected(location,$frompack) [string trim $folder /]] } else { #relative path - use #tarpack-xxx as base set path [file join $connected(location,$frompack) #tarpack-$connected(package,$frompack)-$connected(version,$frompack) $folder] } return [list ok [::glob -nocomplain -directory $path -tail $glob]] } else { if {[string range $folder 0 0] eq "/"} { #absolute path - assume full path was given set path [string trim $folder /] } else { #relative path - use #tarpack-xxx as base set path [file join #tarpack-$connected(package,$frompack)-$connected(version,$frompack) $folder] } #puts "--->doglob $folder $glob - path:$path" set matchlist [list] while {![eof $fh]} { array set header [::tarpack::_::readHeader [read $fh 512]] if {$header(name) eq ""} break set name [string trimleft $header(prefix)$header(name) /] set segs [::split $name /] set psegs [::split $path /] set dirsegs [lrange $segs 0 [expr {[llength $psegs]-1 }] ] set testpath [::join $dirsegs /] if {$testpath eq "."} {set testpath ""} #puts "***$path vs $testpath ***" if {$path eq $testpath} { #same folder set sub [lindex $segs [llength $dirsegs]] ;#next level folder or filename if {[string match $glob $sub]} { if {[lsearch $matchlist $sub] == -1} { lappend matchlist $sub } } } seek $fh [expr {$header(size) + [::tarpack::_::pad $header(size)]}] current } seek $fh $connected(startdata,$frompack) start #puts "---GLOB--- returning $matchlist" return [list ok $matchlist] } return [list err "file $filename not found in archive"] } proc ::tarpack::wrap {scriptfile args} { set opts(-version) "" set opts(-zip) 0 set opts(-force) 0 ;#-force 1 to insist we try to create the tarpack no matter what the inputfile format. array set opts $args if {[string is digit [string range [file extension $scriptfile] 1 end]]} { #file extension numeric.. seems unlikely, so treat filename as extensionless. set rootname $scriptfile } else { set rootname [file rootname $scriptfile] } set filename_parts [split [file tail $rootname] -] set modulename [join [lrange $filename_parts 0 end-1] -] set versionpart [lindex $filename_parts end] set $opts(-version) [string trim $opts(-version) .] ;#silently discard leadint/trailing dots! if {[string length $opts(-version)]} { if {![string is digit -strict [string map {. ""} $opts(-version)]]} { error "Version number '$opts(-version)' is invalid - must be comprised of digits separated by dots only." } #assume user supplied version replaces file version if {[string is digit -strict [string map {. ""} $versionpart]]} { #file has a version number - replace it. #puts "-->1) [join [lrange $filename_parts 0 end-1] -]" #puts "-->2) $opts(-version)" set tarpack [join [lrange $filename_parts 0 end-1] -]-$opts(-version).tm } else { #unversioned filename - add it. set tarpack $rootname-$opts(-version).tm } } else { if {[string is digit -strict [string map {. ""} $versionpart]]} { set tarpack $rootname.tm } else { #! Default 1st version 0.1 ! set tarpack $rootname-0.1.tm } } set tarpack [file join [file dirname $scriptfile] $tarpack] set fd [open $scriptfile r] set checkdata [read $fd 20] set isZP 0; set isTM 0 if {[string range $checkdata 0 1] eq "PK"} { #!todo - proper check for non-SFX zip format #Assume we want to add SFX header but forgot the -zip flag set opts(-zip) 1 } if {$opts(-zip)} { if {[string range $checkdata 0 1] eq "PK"} { #!todo - proper check for non-SFX zip format #assume we just want to add the SFX header ::tarpack::make_zip_tm $scriptfile $tarpack return } if {[string range $checkdata 0 14] eq "#zipped-tarpack"} { if {!$opts(-force)} { error "Input file is already a self-extracting zip file" } set isZP 1 } elseif {[string range $checkdata 0 7] eq "#tarpack"} { #only set isTM 1 if we're going to zip it! set isTM 1 } } else { if {[string range $checkdata 0 14] eq "#zipped-tarpack"} { error "This file is already marked as a zipped-tarpack." } if {([string range $checkdata 0 7] eq "#tarpack") && ([string range [file tail $scriptfile] 0 18] ne "#tarpack-loadscript")} { #seems we're trying to create a standard (unzipped) tarpack out of an existing tarpack - require '-force' to do that. if {!$opts(-force)} { error "Input file is already a tarpack." } } } if {!$isZP && !$isTM} { seek $fd 0 start set scriptdata [read $fd [file size $scriptfile]] close $fd if {[string range [file tail $scriptfile] 0 18] ne "#tarpack-loadscript"} { set hdr "[::tarpack::_::scriptComment]\n[::tarpack::_::scriptConnect]\n" if {![regexp [string map [list %m% $modulename] {.*package\s*provide\s*%m%.*}] $scriptdata]} { append hdr "[::tarpack::_::scriptPackageProvide $modulename]\n" } else { #already contains a package provide statement for the module. #append the example script append hdr "[::tarpack::_::scriptPackageProvideExample $modulename]\n" } append hdr "[::tarpack::_::scriptCommentEnd]\n\n\n[::tarpack::_::scriptTidy]" append hdr "#This tarpack initially generated using tarpack::wrap [file tail $scriptfile]\n" append hdr "#-------------------------script + tarpack footer follow-------------------------\n\n" } else { set tarpack [string range $tarpack 20 end] #assume loadscript already contains 'package require tarpack' & 'connect' call etc. set hdr \n } ::tarpack::create $tarpack [list] -script "${hdr}$scriptdata" {*}$args set uncompressed $tarpack } else { close $fd set uncompressed $scriptfile } if {$opts(-zip)} { if {![catch {exec zip -v}]} { #::tarpack::Puts stderr "-exec: zip -9 [file rootname $tarpack].zip $uncompressed" exec zip -9 [file rootname $tarpack].zip $uncompressed ::tarpack::make_zip_tm [file rootname $tarpack].zip $tarpack file delete [file rootname $tarpack].zip } } } #tarpack::update proc ::tarpack::update {tarpack files args} { package require tar set ok [list] set alreadyin [tar::contents $tarpack] if {[string range [lindex $alreadyin 0] 0 18] eq "#tarpack-loadscript"} { set alreadyin [lrange $alreadyin 1 end] } if {[string range [lindex $files 0] 0 18] eq "#tarpack-loadscript"} { set alreadyin [linsert $alreadyin 0 [lindex $files 0]] set files [lrange $files 1 end] } foreach f $files { if {[lsearch $alreadyin $f] < 0} { lappend ok $f } } lappend args -update 1 ::tarpack::create $tarpack [concat $alreadyin $ok] {*}$args } proc ::tarpack::_::scriptComment {} { return { #START-tarpack-loadscript-header---------------------------------------------------------------------------- #START-header-comments #If there is anything other than whitespace above this header, then this is a tarpack. # * Do not edit the code whilst in 'packed' form * # #If there is no data above the header, it is an unpacked fragment of a tarpack and may be edited. #Make sure however that your editor preserves the trailing comment (#) as the final character. # i.e - no trailing newline or carriage-return. # # A tarpack is a valid tar archive in which the first archived file consists of tcl script # containing a leading newline and a trailing comment (#) character. # The comment character hides the tar-header for the next file from Tcl. # This first file in the tarball must be named with the prefix #tarpack-loadscript # # The next file is named #z and contains a final ctrl-z to tell Tcl it has reached the end of scripts # (and thus to stop interpreting). # The #z file is separate from the initial script file because some editors may not be able to handle the # ctrl-z character. # The tarball should have all its contents within a single directory named #tarpack-- # - This allows you to safely untar any package 'in place' # - If a package on your 'tcl module path' is unwrapped (i.e untarred) - then the unwrapped files # are the ones that will be loaded by the interpreter. # # This header (excluding this comment block) and the call to tarpack::disconnect are needed to: # a) allow 'package require' to redirect to the unwrapped version of the tarpack # b) enable sourcing & loading of other files contained in the tarpack #END-header-comments } } proc ::tarpack::_::scriptConnect {} { return { set TEMP_auto_path $::auto_path; set ::auto_path [list] if {![catch {package require tarpack}]} { #Do not wrap 'tarpack::connect' in its own 'catch'! #for unwrapped execution, tarpack::connect may need to abort the 'source' operation using returneval. set ::auto_path $TEMP_auto_path; unset TEMP_auto_path ::tarpack::connect [info script] } else { set ::auto_path $TEMP_auto_path; unset TEMP_auto_path } } } proc ::tarpack::_::scriptPackageProvideExample {modulename} { return [string map [list %m% $modulename] { ##example 'package provide' statement. #package provide %m% [namespace eval %m% { # variable version # set version [lindex [split [file rootname [info script]] -] end] #}] }] } proc ::tarpack::_::scriptPackageProvide {modulename} { if {![string length $modulename]} { error "missing modulename" } return [string map [list %m% $modulename] { package provide %m% [namespace eval %m% { variable version set version [lindex [split [file rootname [info script]] -] end] }] }] } proc ::tarpack::_::scriptCommentEnd {} { return { # #END-tarpack-loadscript-header------------------------------------------------------------------------------ } } proc ::tarpack::_::scriptTidy {} { return { #START-tarpack-loadscript-tidy------------------------------------------------------------------------------ # if {![catch {package require tarpack}]} { ::tarpack::disconnect [info script] } # #END-tarpack-loadscript-tidy-------------------------------------------------------------------------------- } } #tarpack::create # tarpack : output file name (the 'standard' extension is .tm but this is not enforced) # files : list of files & directories to be archived. # ## optional arguments #-script : code for load-script. Ignored for tarpack if #tarpack-loadscript specified as 1st file in archive. #-tarball : if 1 create valid tarball (tarpack) else create a hybrid script & tarball (tarbaby) proc ::tarpack::create {tarpack files args} { package require tar variable loadable array set opts {-script "" -update 0} ;#defaults array set opts $args set script $opts(-script) set update $opts(-update) set name_dash_version [file rootname [file tail $tarpack]] set parts [split $name_dash_version -] set modulename [join [lrange $parts 0 end-1] -] set moduleversion [lindex $parts end] set magicprefix "#tarpack-loadscript" set magicfile "#tarpack-loadscript-$name_dash_version.tcl" set mainfolder "#tarpack-$name_dash_version" file mkdir $mainfolder if {[string range [lindex $files 0] 0 18] eq "#tarpack-loadscript" } { set magicfile [lindex $files 0] #We'll assume no -script argument supplied as it doesn't make sense to specify both. set script [read [set fd [open $magicfile r]] [file size $magicfile]] close $fd set files [lrange $files 1 end] } else { if {[string length $script]} { if {[file exists $magicfile]} { #script specified.. but magicfile (in tarpack destination folder) exists - move it aside. file rename -force $magicfile $magicfile.old Puts stderr "$magicfile moved to $magicfile.old" } } else { set fn [file join $mainfolder $magicfile] if {[file exists $fn]} { set script [read [set fd [open $fn r]] [file size $fn]] close $fd } else { #fallback to plain #tarpack-loadscript if it exists #but still insert it as #tarpack-loadscript- set fn [file join $mainfolder "#tarpack-loadscript"] if {[file exists $fn]} { set script [read [set fd [open $fn r]] [file size $fn]] close $fd } } } } if {![string length $script]} { #basic script. #assume we need to source all .tcl files and load anything else in loadable extension list. set script [::tarpack::_::scriptComment] append script [::tarpack::_::scriptConnect] #unless we grep all source files for 'package provide $modulename' - # then we can only really put in a commented-out sample 'package provide' statement. # Also - loaded binaries may make their own package provide call. append script [::tarpack::_::scriptPackageProvideExample $modulename] append script [::tarpack::_::scriptCommentEnd] append script { #Basic auto-generated tarpack-script. # - sources all .tcl files # - loads all files with known loadable extensions } append script \n foreach fn $files { set ext [file extension $fn] if {$ext eq ".tcl"} { append script "::tarpack::source $fn \n" } else { if {[lsearch $loadable $ext] >= 0} { append script "::tarpack::load $fn \n" } } } foreach fn [::glob -nocomplain -dir $mainfolder -type f *] { set ext [file extension $fn] if {$ext eq ".tcl"} { append script "::tarpack::source $fn\n" } else { if {[lsearch $loadable $ext] >= 0} { append script "::tarpack::load $fn \n" } } #!todo - also source & load files under platform-specific folders } append script [::tarpack::_::scriptTidy] } set ftemp $files set files [list] foreach f $ftemp { if {![file exists $f]} { Puts stderr "warning: file/folder not found - unable to add/update: $f" } else { lappend files $f } } if {[string range $script 0 0] ne "\n"} { set script \n$script } if {[string range $script end end] ne "#"} { if {[string first "#Do not remove the trailing comment" $script] == -1} { append script { #Do not remove the trailing comment character from this file. } } append script "#" } set fd [open [file join $mainfolder $magicfile] w] fconfigure $fd -encoding binary -translation binary puts -nonewline $fd $script close $fd #separate ctrl-z file if {![file exists [file join $mainfolder #z]]} { set fd [open [file join $mainfolder #z] w] fconfigure $fd -encoding binary -translation binary puts -nonewline $fd "#Do not remove the trailing ctrl-z character from this file.\n" puts -nonewline $fd "\u001A" close $fd } if {$update} { set missing [list] foreach f [lrange [tar::contents $tarpack] 1 end] { if {![file exists [file join [pwd] $f]]} { lappend missing $f } } if {[llength $missing]} { #missing at least 1 file #we don't have an update feature in the plain tar library.. only create & add # so to 'update' we'd have to untar and retar if not all the tarred files are present where we are. #for now.. we'll remove missing files from the archive #!todo - review behaviour - this possibly violates the 'least surprise' principle. puts stdout "Missing [llength $missing] items. They will be *removed* from the archive if you continue. Do you wish to continue? \[Y/N\]" set answer [gets stdin] if {[string tolower $answer] eq "y"} { set remaining [list] foreach f $files { if {[lsearch $missing $f] < 0} { lappend remaining $f } } tar::create $tarpack [linsert $remaining 0 $mainfolder] } } else { #everything present.. so we can just recreate the tarpack in place tar::create $tarpack [linsert $files 0 $mainfolder] } } else { tar::create $tarpack [linsert $files 0 $mainfolder] } } proc ::tarpack::getTempDir {} { if {[info exists ::env(TEMP)]} { return $::env(TEMP) } elseif {[info exists ::env(TMP)]} { return $::env(TMP) } elseif {[info exists ::env(TMPDIR)]} { return $::env(TMPDIR) } elseif {[info exists ::env(TRASH_FOLDER)]} { #for macintosh return $::env(TRASH_FOLDER) } else { if {[file exists /tmp]} { return /tmp } else { return [pwd] } } } proc ::tarpack::platform {} { set plat [lindex $::tcl_platform(os) 0] set mach $::tcl_platform(machine) switch -glob -- $mach { intel - i*86* { set mach x86 } sun4* { set mach sparc } Power* { set mach ppc } 9000* { set mach 9000} default { set mach [string map {" " - / -} $mach]} } return "$plat-$mach" } #------------------------------------------------------------------------------------ # zipped-tarpack # Original zipped-module creation code by Pascal Scheffers at 'Using a zip file as a Tcl Module' http://wiki.tcl.tk/13869 #------------------------------------------------------------------------------------ # [make_zip_tm /zipfile/ /outfile/] # Prefixes the specified zipfile with the tclmodule mounter stub and writes out 'outfile' # [make_sfx_zip /zipfile/ /outfile/ /sfxstub/] # Adds an arbitrary 'sfx' to a zip file, and adjusts the central directory # and file items to compensate for this extra data. proc ::tarpack::make_zip_tm { zipfile outfile } { set sfx_stub {#zipped-tarpack #Do not edit this script directly whilst it is part of a zipped .tm file! # (zip headers need to be adjusted if this script modified) #foreach {pkg ver} [split [file rootname [file tail [info script]]] -] {break} lassign [split [file rootname [file tail [info script]]] -] pkg ver if {[catch {package require vfs::zip}]} { error "You need the vfs::zip package to use the $pkg package as is. Alternatively, unzip the module file [info script] and try again." } vfs::zip::Mount [info script] [info script] set tarpack [file join [info script] $pkg-$ver.tm] if {[file exists $tarpack]} { source $tarpack } else { set tarpack_loadscript [file join [info script] #tarpack-$pkg-$ver #tarpack-loadscript-$pkg-$ver] ::tarpack::Puts stderr "2===> $tarpack not found. Will try to source $tarpack_loadscript" if {[file exists $tarpack_loadscript]} { source $tarpack_loadscript } } } append sfx_stub \x1A tarpack::_::make_sfx_zip $zipfile $outfile $sfx_stub } proc tarpack::_::make_sfx_zip { zipfile outfile sfx_stub } { set in [open $zipfile r] fconfigure $in -translation binary -encoding binary #set in_data [read $in [file size $zipfile]] set out [open $outfile w+] fconfigure $out -translation binary -encoding binary puts -nonewline $out $sfx_stub set offset [tell $out] lappend report "sfx stub size: $offset" fcopy $in $out close $in set size [tell $out] # Now seek in $out to find the end of directory signature: # The structure itself is 24 bytes long, followed by a maximum of 64Kbytes text if { $size < 65559 } { set seek 0 } else { set seek [expr { $size - 65559 } ] } #flush $out seek $out $seek #puts "$seek [tell $out]" set data [read $out] set start_of_end [string last "\x50\x4b\x05\x06" $data] set start_of_end [expr {$start_of_end + $seek}] lappend report "SEO: $start_of_end ([expr {$start_of_end-$size}]) [string length $data]" seek $out $start_of_end set end_of_ctrl_dir [read $out] binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) lappend report "End of central directory: [array get eocd]" seek $out [expr {$start_of_end+16}] #adjust offset of start of central directory by the length of our sfx stub puts -nonewline $out [binary format i [expr {$eocd(diroffset)+$offset}]] flush $out seek $out $start_of_end set end_of_ctrl_dir [read $out] binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) lappend report "New dir offset: $eocd(diroffset)" lappend report "Adjusting $eocd(totalnum) zip file items." seek $out $eocd(diroffset) for {set i 0} {$i <$eocd(totalnum)} {incr i} { set current_file [tell $out] set fileheader [read $out 46] binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) if { $x(sig) != 33639248 } { error "Bad file header signature at item $i: $x(sig)" } foreach size $x(lengths) var {filename extrafield comment} { if { $size > 0 } { set x($var) [read $out $size] } else { set x($var) "" } } set next_file [tell $out] lappend report "file $i: $x(offset) $x(sizes) $x(filename)" seek $out [expr {$current_file+42}] puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] #verify: flush $out seek $out $current_file set fileheader [read $out 46] lappend report "old $x(offset) + $offset" binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) lappend report "new $x(offset)" seek $out $next_file } close $out #puts [join $report \n] } #------------------------------------------------------------------------------------ tarpack::disconnect [info script] #do not remove trailing comment. There must be no linefeed/carriagereturn etc following it either. ##tarpack-tarpack-1.1.2/#z 777 0 0 73 10320643554 10065 0#do not remove trailing ctrl-z character from this file. #tarpack-tarpack-1.1.2/CHANGES 777 0 0 534 10466030112 10632 02006-08-08 - bump version to 1.1.2 - fix tarpack::wrap so that the 'scriptTidy' string doesn't force the wrapped package to be dependent on tarpack. i.e call to 'tarpack::disconnect' now wrapped in test for 'tarpack'. This allows a tcl-only script to be wrapped with tarpack, but not require tarpack on deployment. #tarpack-tarpack-1.1.2/README.tarpack.txt 777 0 0 1123 10334032671 13002 0A tarpack is a standard tar archive which is also directly loadable as a Tcl module without requiring the tarball to be unarchived. When the tarpack is placed on the Tcl module-path it can be loaded with: package require Where the is the segment of the tarpack filename before the dash and version number. !NOTE! The tarpack can be unpacked in the same folder as the .tm file, in which case, the unpacked files will take precedence over the wrapped version. The wrapped version however needs to remain in place to 'redirect' to the unwrapped version.