Updated 2016-05-30 19:33:14 by sbasi

Richard Suchenwirth 2007-08-17 - Looking at Tcl modules, I wanted to know how to produce such a sourceable module file which contains both Tcl scripts and one DLL (and thus does more than the Tcl module creation script). Here is my take, which

  • 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 $argv

I tested this on Windows with Tcl 8.4.1 and
 /Tcl $ make_tm.tcl regtry 1.1 vecmath.tcl lib/reg1.1/tclreg11.dll registry

and 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:15

An 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