EF The library below can be handy when loading dynamic libraries packed into virtual filesystems, e.g.
starkits. It serves two purposes:
- It arranges to copy dynamic libraries to a temporary location on the hard. This location is crafted so that it will be the same across runs by the same user, thus arranging for quicker startup phase of the program. The location has some intelligence as to change whenever the main program is changed, for example when a new version is installed and might have different dependencies.
- It arranges to copy any sibling of the dynamic library in the same directory to the same location so that the main program has a chance to also pick up that library when loading it. This is particularly useful for libraries with dependencies, i.e. dynamic libraries that depend on other dynamic libraries.
The library has
no other dependency so that it can be required early on in the initialisation phase of a script. The most simple and common use case is to simply require it and then initialise it using
dynloader init. This assumes that upon version changes, the main script at
argv0 will have changed and lead to a different checksum, you might want to use another script for that very purpose. It might be a good idea to arrange for removing the directories that would be returned by
dynloader residues from time to time in your program, this would arrange to cleanup directories that would have been used in prior versions of the program.
namespace eval ::dynloader {
namespace eval vars {
variable CRC32TABLE {
0x00000000 0x77073096 0xEE0E612C 0x990951BA
0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3
0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988
0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91
0x1DB71064 0x6AB020F2 0xF3B97148 0x84BE41DE
0x1ADAD47D 0x6DDDE4EB 0xF4D4B551 0x83D385C7
0x136C9856 0x646BA8C0 0xFD62F97A 0x8A65C9EC
0x14015C4F 0x63066CD9 0xFA0F3D63 0x8D080DF5
0x3B6E20C8 0x4C69105E 0xD56041E4 0xA2677172
0x3C03E4D1 0x4B04D447 0xD20D85FD 0xA50AB56B
0x35B5A8FA 0x42B2986C 0xDBBBC9D6 0xACBCF940
0x32D86CE3 0x45DF5C75 0xDCD60DCF 0xABD13D59
0x26D930AC 0x51DE003A 0xC8D75180 0xBFD06116
0x21B4F4B5 0x56B3C423 0xCFBA9599 0xB8BDA50F
0x2802B89E 0x5F058808 0xC60CD9B2 0xB10BE924
0x2F6F7C87 0x58684C11 0xC1611DAB 0xB6662D3D
0x76DC4190 0x01DB7106 0x98D220BC 0xEFD5102A
0x71B18589 0x06B6B51F 0x9FBFE4A5 0xE8B8D433
0x7807C9A2 0x0F00F934 0x9609A88E 0xE10E9818
0x7F6A0DBB 0x086D3D2D 0x91646C97 0xE6635C01
0x6B6B51F4 0x1C6C6162 0x856530D8 0xF262004E
0x6C0695ED 0x1B01A57B 0x8208F4C1 0xF50FC457
0x65B0D9C6 0x12B7E950 0x8BBEB8EA 0xFCB9887C
0x62DD1DDF 0x15DA2D49 0x8CD37CF3 0xFBD44C65
0x4DB26158 0x3AB551CE 0xA3BC0074 0xD4BB30E2
0x4ADFA541 0x3DD895D7 0xA4D1C46D 0xD3D6F4FB
0x4369E96A 0x346ED9FC 0xAD678846 0xDA60B8D0
0x44042D73 0x33031DE5 0xAA0A4C5F 0xDD0D7CC9
0x5005713C 0x270241AA 0xBE0B1010 0xC90C2086
0x5768B525 0x206F85B3 0xB966D409 0xCE61E49F
0x5EDEF90E 0x29D9C998 0xB0D09822 0xC7D7A8B4
0x59B33D17 0x2EB40D81 0xB7BD5C3B 0xC0BA6CAD
0xEDB88320 0x9ABFB3B6 0x03B6E20C 0x74B1D29A
0xEAD54739 0x9DD277AF 0x04DB2615 0x73DC1683
0xE3630B12 0x94643B84 0x0D6D6A3E 0x7A6A5AA8
0xE40ECF0B 0x9309FF9D 0x0A00AE27 0x7D079EB1
0xF00F9344 0x8708A3D2 0x1E01F268 0x6906C2FE
0xF762575D 0x806567CB 0x196C3671 0x6E6B06E7
0xFED41B76 0x89D32BE0 0x10DA7A5A 0x67DD4ACC
0xF9B9DF6F 0x8EBEEFF9 0x17B7BE43 0x60B08ED5
0xD6D6A3E8 0xA1D1937E 0x38D8C2C4 0x4FDFF252
0xD1BB67F1 0xA6BC5767 0x3FB506DD 0x48B2364B
0xD80D2BDA 0xAF0A1B4C 0x36034AF6 0x41047A60
0xDF60EFC3 0xA867DF55 0x316E8EEF 0x4669BE79
0xCB61B38C 0xBC66831A 0x256FD2A0 0x5268E236
0xCC0C7795 0xBB0B4703 0x220216B9 0x5505262F
0xC5BA3BBE 0xB2BD0B28 0x2BB45A92 0x5CB36A04
0xC2D7FFA7 0xB5D0CF31 0x2CD99E8B 0x5BDEAE1D
0x9B64C2B0 0xEC63F226 0x756AA39C 0x026D930A
0x9C0906A9 0xEB0E363F 0x72076785 0x05005713
0x95BF4A82 0xE2B87A14 0x7BB12BAE 0x0CB61B38
0x92D28E9B 0xE5D5BE0D 0x7CDCEFB7 0x0BDBDF21
0x86D3D2D4 0xF1D4E242 0x68DDB3F8 0x1FDA836E
0x81BE16CD 0xF6B9265B 0x6FB077E1 0x18B74777
0x88085AE6 0xFF0F6A70 0x66063BCA 0x11010B5C
0x8F659EFF 0xF862AE69 0x616BFFD3 0x166CCF45
0xA00AE278 0xD70DD2EE 0x4E048354 0x3903B3C2
0xA7672661 0xD06016F7 0x4969474D 0x3E6E77DB
0xAED16A4A 0xD9D65ADC 0x40DF0B66 0x37D83BF0
0xA9BCAE53 0xDEBB9EC5 0x47B2CF7F 0x30B5FFE9
0xBDBDF21C 0xCABAC28A 0x53B39330 0x24B4A3A6
0xBAD03605 0xCDD70693 0x54DE5729 0x23D967BF
0xB3667A2E 0xC4614AB8 0x5D681B02 0x2A6F2B94
0xB40BBE37 0xC30C8EA1 0x5A05DF1B 0x2D02EF8D
}
variable selfsum ""
variable tmpdir ""
variable loaded {}
variable levels {debug info notice warn error critical alert emergency}
variable log warn
variable -argv0 ""; # Main program, used for temp dir identification
variable -header "Wiki49292"; # Default leading token for temp dir creation
variable -separator "_"; # String for separating keywords in temp dir name
variable -logger ""; # External loggger object to delegate all logging to
}
namespace export {[a-z]*}
namespace ensemble create
}
# ::dynloader::init -- Module initialisation
#
# Module initialisation, the procedure takes a number of dash led keys and
# their values, keys that matches the dash led variables that are stored in
# the underlying vars namespace.
#
# Arguments:
# args descr
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::dynloader::init { args } {
# Capture incoming arguments as list of dash-led options and their values,
# refuse setting something that isn't a known variable with the same name
# under the namespace vars.
foreach {k v} $args {
if { [info exists vars::$k] } {
set vars::$k $v
}
}
# Capture main argv0 (global) if none provided and none set yet.
if { ${vars::-argv0} eq "" && [info exists ::argv0] } {
set vars::-argv0 $::argv0
}
# Calculate CRC sum of main program so we can use it to identify this
# version and arrange to create new directories as the set of dynamic
# libraries will likely change with version changes.
if { $vars::selfsum eq "" } {
set fd [open ${vars::-argv0}]
fconfigure $fd -encoding binary -translation binary
set vars::selfsum [format %.8X [CheckSum [read $fd]]]
Log debug "Computed versioning sum to $vars::selfsum"
close $fd
# Capture load command.
rename ::load [namespace current]::__original_load
interp alias {} ::load {} [namespace current]::dynload
}
}
# ::dynloader::CheckSum -- Generate a CRC32 sum
#
# This is adapted from https://wiki.tcl.tk/2259 and computes the CheckSum sum
# of the data passed as an argument. While there is an implementation
# available in the tcllib, we need an implementation early on in the
# initialisation phase in order to be able to identify ourselves (across
# historical differences).
#
# Arguments:
# instr Data to compute checksum from
# crc_value Initial checksum (usefull for calling this several times incrementally)
#
# Results:
# Return a checksum of data
#
# Side Effects:
# Uses a global table at __CRC32TABLE for speeding up calculations.
proc ::dynloader::CheckSum {instr {crc_value 0xFFFFFFFF}} {
foreach c [split $instr {}] {
set crc_value [expr {[lindex $vars::CRC32TABLE [expr {($crc_value ^ [scan $c %c])&0xff}]]^(($crc_value>>8)&0xffffff)}]
}
return [expr {$crc_value ^ 0xFFFFFFFF}]
}
# ::dynloader::location -- Compute temporary location
#
# Compute a temporary location for storage of dynamic libraries (over
# longer period of times). The defaults of this procedure consist in
# returning a glob-style pattern that can be used for cleanup operations.
#
# Arguments:
# sum Check sum of critical part of program
# id Identifier of program (e.g. its name) (will be guessed when empty)
# username Name of user (will be guessed when empty)
#
# Results:
# A platform-dependent absolute location where it should be possible to
# store file across future runs of the program; or a glob-style pattern
# matching this (by default).
#
# Side Effects:
# None.
proc ::dynloader::location { {sum "*" } {id ""} {username ""} } {
# Find out current username when none was specified in the arguments.
if { $username eq "" } {
foreach k [list USER USERNAME] {
if { [info exists ::env($k)] } {
set username [set ::env($k)]
break
}
}
}
# Find out identifier of program, whenever empty
if { $id eq "" } {
set id [file tail [file rootname ${vars::-argv0}]]
}
# Prepare some main temporary directory name in a multi-platform manner
if { $::tcl_platform(platform) eq "windows" } {
set tmpdir [file join $::env(SystemRoot) Temp]
} else {
set tmpdir /usr/tmp
}
foreach k [list TEMP TMP ALLUSERSPROFILE] {
if { [info exists ::env($k)] && [file isdirectory $::env($k)] } {
set tmpdir $::env($k)
break
}
}
# Append identifier for program and cleaned up name of user to directory name.
set dir "${vars::-header}${vars::-separator}"
append dir $id ${vars::-separator}
foreach c [split $username ""] {
if { [string first $c "abcdefghjklmnpqrstuvwxyzABCDEFGHJKLMNPQRSTUVWXYZ0123456789*+?!%-,="] >= 0 } {
append dir $c
} else {
append dir ${vars::-separator}
}
}
# Append main sum to properly migrate over version changes.
if { $sum ne "" } {
append dir ${vars::-separator} $sum
}
return [file join $tmpdir $dir]
}
# ::dynloader::residues -- Residues from prev. versions
#
# Returns the list of old directory caches that might have been left by
# older version of the program. This uses a glob-matching with a * instead
# of the checksum, but with the same program identifier and username.
#
# Arguments:
# None.
#
# Results:
# List of old directories, i.e. not including the directory that is
# currently in use for cache storage of dynamic libraries.
#
# Side Effects:
# None.
proc ::dynloader::residues {} {
set caches [glob -nocomplain -- [location]]
set i [lsearch $caches [location $vars::selfsum]]
if { $i >= 0 } {
set caches [lreplace $caches $i $i]
}
return $caches
}
# ::TmpDir -- Create a surviving temporary directory.
#
# Create (and store for further usage) a temporary directory that depends
# on the currrent implementation of this script and the user. This
# directory can be used to store files across sessions to minimise disk
# accesses whenever possible. An identifier for the user is automatically
# added to the name of the directory (only relevan ASCII characters), as
# well as a checksum of this script.
#
# Results:
# Return a global directory, exit program on failures.
#
# Side Effects:
# Uses the NP global table to store the path to the temporary directory
proc ::dynloader::TmpDir { } {
if { $vars::tmpdir eq "" } {
set vars::tmpdir [location $vars::selfsum]
# Now create and remember this directory, bail out on errors.
Log notice "DLL cache will be at $vars::tmpdir"
if { [catch {file mkdir $vars::tmpdir} err] } {
Log critical "Cannot create DLL cache ${vars::tmpdir}: $err"
set vars::tmpdir ""
}
}
return $vars::tmpdir
}
# ::dynloader::dynload -- Load outside of VFS
#
# This procedure will arrange to load libraries that are contained within a
# VFS (starkit) from outside the VFS. Dynamic libraries are dynamically
# discovered and copied out of the VFS into a unique, but future-resistent
# temporary directory to be loaded from there. All dynamic libraries that
# are siblings (same directory) to each library being loaded are copied to
# the same location, which gives a chance for the main binary to capture
# dependencies.
#
# Arguments:
# args Same as Tcl ::load command
#
# Results:
# Same as ::load command
#
# Side Effects:
# Will copy libraries to temporary directory out of the VFS.
proc ::dynloader::dynload { args } {
if { [info exists ::starkit::topdir] || [catch {uplevel 1 [linsert $args 0 [namespace current]::__original_load]} err] } {
# Advance through arguments to load until the filename, i.e. the path to
# the dynamic library to load.
for {set i 0} {$i<[llength $args]} {incr i} {
set arg [lindex $args $i]
if { $arg eq "--" } {
incr i
break
} elseif { [string index $arg 0] ne "-" } {
break
}
}
set fname [lindex $args $i]; # i contains the index of the dll path
# Create a temporary directory for now and "ever"
set dir [TmpDir]
if { $fname eq "" || $dir eq "" } {
# Empty filename is a complete valid case, we have nothing to do in
# particular and can pass this further to the original load
# implementation, as-is.
uplevel 1 [linsert $args 0 [namespace current]::__original_load]
} elseif { [lsearch $vars::loaded $fname] < 0 } {
# Copy all siblings of the library into the temporary directory.
# Siblings are all files with the same extension as the library,
# which should cover all platforms, .dll, .so, etc.
foreach libpath [glob -nocomplain -directory [file dirname $fname] -- *[file extension $fname]] {
set dst [file join $dir [file tail $libpath]]
if { ![file exists $dst] } {
Log debug "Copying $libpath to $dst"
file copy -force -- $libpath $dst
}
}
# Change arguments to the load call as we will be using a locally
# cached copy.
set cached [file join $dir [file tail $fname]]
set args [lreplace $args $i $i $cached]
# Call the original load command, but on the locally cached copy of
# the library. Change directory to give a chance to the binary to
# pick-up possible siblings, i.e. dependencies of the (binary)
# library.
set cwd [pwd]; cd $dir; # Change to cache dir to capture other libraries.
if { [catch {uplevel 1 [linsert $args 0 [namespace current]::__original_load]} err] } {
file delete -force -- $cached
cd $cwd
return -code error "Cannot load copy of library file at $cached: $err"
} else {
Log debug "Loaded dynamic library through external copy at $cached"
lappend vars::loaded $fname
cd $cwd
}
}
}
}
# ::dynloader::Log -- Program logging
#
# In most cases, this will log the message passed as a parameter if the
# current module logging level is greater than the log of the message.
# Whenever a global log has been set, all logging messages will be passed
# further. This logger should comply to the logger interface of tcllib.
#
# Arguments:
# lvl Log level of the message to output
# msg Message to log
#
# Results:
# None.
#
# Side Effects:
# Log on stderr, when appropriate.
proc ::dynloader::Log { lvl msg } {
if { ${vars::-logger} ne "" } {
${vars::-logger}::$lvl "\[[string trim [namespace current] :]\] $msg"
} else {
set i [lsearch $vars::levels $lvl]
if { $i >= 0 } {
if { $i >= [lsearch $vars::levels $vars::log] } {
puts stderr "\[[string trim [namespace current] :]\] \[$lvl\] $msg"
}
}
}
}
# ::dynloader::loglevel -- Set or query log level
#
# Set or query the log level of this library. Note that this level is
# useless when logging is delegated to an external logger using the -logger
# option (and variable). Level will not change if it is not one of the
# recognised ones.
#
# Arguments:
# lvl Current level to set, empty for query (the default)
#
# Results:
# Current level
#
# Side Effects:
# None.
proc ::dynloader::loglevel { { lvl "" } } {
if { $lvl ne "" } {
if { [lsearch $vars::levels $lvl] >= 0 } {
set vars::log $lvl
} else {
Log warn "$lvl is an unknown loglevel, should be one of [join $vars::levels ,\ ]"
}
}
return $vars::log
}
package provide dynloader 1.0
