- first writes all specified Tcl scripts to the output file
- then, if a DLL is specified, generates loader code, puts a Ctrl-Z to terminate sourceing
- and finally appends the DLL in binary translation
#!/usr/bin/env tclsh
set usage {
usage: make_tm package version ?tclfile...? ?dllfile initfunc?
Creates a Tcl module file 'outfilename' from the specified tclfiles
and/or maximally one DLL.
}
if {[llength $argv] == 0} {puts stderr $usage; exit 1}
proc main argv {
set package [lindex $argv 0]
set version [lindex $argv 1]
set outf [open ${package}-${version}.tm w]
fconfigure $outf -translation lf
puts $outf "package provide [lindex $argv 0] [lindex $argv 1]"
foreach a [lrange $argv 2 end] {
switch -- [file extension $a] {
.tcl {
puts $outf "\#-- from $a"
set f [open $a]
fcopy $f $outf
close $f
}
.dll {
set f [open $a]
fconfigure $f -translation binary
puts $outf "\#-- from $a"
puts $outf "set tmp \[open \$env(TMP)\\[file tail $a] w\]"
puts $outf {
set f [open [info script]]
fconfigure $f -translation binary
set data [read $f][close $f]
set ctrlz [string first \u001A $data]
fconfigure $tmp -translation binary
puts -nonewline $tmp [string range $data [incr ctrlz] end]
close $tmp
}
puts $outf "load \$env(TMP)/[file tail $a] [lindex $argv end]"
puts -nonewline $outf \u001A
fconfigure $outf -translation binary
fcopy $f $outf
close $f
break
}
default {error "cannot handle file $a"}
}
}
close $outf
}
main $argvI tested this on Windows with Tcl 8.4.1 and
/Tcl $ make_tm.tcl regtry 1.1 vecmath.tcl lib/reg1.1/tclreg11.dll registryand it worked nicely, as far as I can tell - the registry command is usable after sourcing. One can even edit the resulting .tm file with emacs, without damage to the embedded DLL :^)MJ - Some remarks
- the / slash after the TEMP directory gives me an 'access denied' error when loading the dll. With \\ it works. (changed)
- if the line terminator of the Tcl scripts is CRLF I cannot edit it with emacs or vim on windows. With LF it's fine. (changed)
- changed the command line parameters and added a package provide
[sbasi] - 2016-05-30 19:14:15An even more elaborate version:I wanted to be able to create Tcl modules with binary extensions that can be used on different platforms - i.e. modules that contain binary data for each supported platform.Thus, my module maker can add any number of binary and script files, and lets you specify on which platform(s) each file should be loaded or sourced.
#!/usr/bin/env tclsh
#
# mk_tm.tcl --
#
# Create tm module from one or more files (binary and/or scripts).
#
package require Tcl 8.6
set usage "Create a tm module from one or more files, with multiplatform-support.
Usage:
$argv0 packagename version specstr: filename ?specstr: filename ...?
packagename name of the package
version version of the package
specstr platform-{script|binary} platform is one of the values that
\$tcl_platform(platform) chan have or \"any\".
filename path to the file to add to the module
"
if {$argc < 3} {
puts stderr "Wrong # args: must be $argv0 package version specstr: filename ?specstr: filename ...?"
puts stderr ""
puts stderr $usage
exit 1
}
set package [lindex $argv 0]
set version [lindex $argv 1]
#
# Collect info about infiles
#
puts "Scanning infiles..."
set dataDict dict create
for {set i 2} {$i < $argc} {incr i} {
set tmp [lindex $argv $i]
if {[incr i] >= $argc} {
puts stderr "Missing filename to go with specstr [lindex $argv $i-1]"
exit 1
}
if {[string index $tmp end] eq ":"} {
set tmp [string range $tmp 0 end-1]
}
set tmp [split $tmp "-"]
if {[llength $tmp] != 2} {
puts stderr "Malformed specstr [lindex $argv $i-1]: must be platform-{script|binary}:"
exit 1
}
if {[lindex $tmp 0] ni {windows unix any}} {
puts stderr "Unknown platform: [lindex $tmp 0]"
exit 1
}
set type [lindex $tmp 1]
if {$type ni {script binary}} {
puts stderr "Wrong file type spec $type: should be script or binary"
exit 1
}
if {$type eq {binary} && [lindex $tmp 0] eq {any}} {
puts stderr "Platform independent binary file? This can't be right..."
exit 1
}
set filename [lindex $argv $i]
if {[catch {open $filename r} fd]} {
puts stderr "$fd. Skipping."
continue
}
if {$type eq {binary}} {
fconfigure $fd -translation binary
}
dict set dataDict $filename data [read $fd]
dict set dataDict $filename tail [file tail $filename]
dict set dataDict $filename platform [lindex $tmp 0]
dict set dataDict $filename type $type
dict set dataDict $filename size [string length [dict get $dataDict $filename data]]
close $fd
}
if {[dict size $dataDict] == 0} {
puts stderr "No infiles, nothing to do!"
exit 1
}
#
# Create script to extract binary data
#
puts "Generating script..."
if {[catch {open ${package}-${version}.tm w} tmfd]} {
puts stderr "Cannot create tm file: $tmfd"
exit 1
}
fconfigure $tmfd -translation lf
puts $tmfd {#
# -- tcl module generated by mk_tm
#
if {[file exists "/tmp"]} {set tmpdir "/tmp"}
catch {set tmpdir $::env(TMP)}
catch {set tmpdir $::env(TEMP)}
set fd [open [info script] r]
fconfigure $fd -translation binary
set data [read $fd]
close $fd
set startIndex [string first \u001A $data]
incr startIndex
}
set binaryFiles {}
set scriptFiles {}
foreach key [dict keys $dataDict] {
if {[dict get $dataDict $key type] eq {script}} {
lappend scriptFiles $key
continue
} else {
lappend binaryFiles $key
}
puts $tmfd "#-- extract [dict get $dataDict $key tail]"
puts $tmfd "set tmpFileName \[file normalize \[file join \$tmpdir \{[dict get $dataDict $key tail]\} \]\]"
puts $tmfd {set fd [open $tmpFileName w]}
puts $tmfd {fconfigure $fd -translation binary}
puts $tmfd "puts -nonewline \$fd \[string range \$data \$startIndex \[incr startIndex [dict get $dataDict $key size]\]-1 \]"
puts $tmfd {close $fd }
puts $tmfd "if \{\$tcl_platform(platform) eq \{[dict get $dataDict $key platform]\}\} \{"
puts $tmfd " load \$tmpFileName"
puts $tmfd "\}"
puts $tmfd {file delete $tmpFileName}
puts $tmfd ""
}
#
# Add script files
#
puts "Adding scripts..."
foreach file $scriptFiles {
puts $tmfd "#-- From [dict get $dataDict $file tail]"
if {[dict get $dataDict $file platform] ne {any}} {
puts $tmfd "if \{\$tcl_platform(platform) eq \{[dict get $dataDict $file platform]\}\} \{"
puts $tmfd [dict get $dataDict $file data]
puts $tmfd "\}\n"
} else {
puts $tmfd [dict get $dataDict $file data]
puts ""
}
}
puts $tmfd "package provide ${package} ${version}"
puts $tmfd "#-- End of script section"
#
# Append binary data
#
puts "Writing binary data..."
fconfigure $tmfd -translation binary
puts -nonewline $tmfd "\u001A"
foreach file $binaryFiles {
puts -nonewline $tmfd [dict get $dataDict $file data]
}
close $tmfd
puts "Done!"
exit 0