Another Tcl module maker

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