diff options
Diffstat (limited to 'tools/makeHeader.tcl')
| -rw-r--r-- | tools/makeHeader.tcl | 182 |
1 files changed, 182 insertions, 0 deletions
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl new file mode 100644 index 0000000..e9b7ed1 --- /dev/null +++ b/tools/makeHeader.tcl @@ -0,0 +1,182 @@ +# makeHeader.tcl -- +# +# This script generates embeddable C source (in a .h file) from a .tcl +# script. +# +# Copyright (c) 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6 + +namespace eval makeHeader { + + #################################################################### + # + # mapSpecial -- + # Transform a single line so that it is able to be put in a C string. + # + proc mapSpecial {str} { + # All Tcl metacharacters and key C backslash sequences + set MAP { + \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\? + \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v + } + set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]} + + subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM] + } + + #################################################################### + # + # compactLeadingSpaces -- + # Converts the leading whitespace on a line into a more compact form. + # + proc compactLeadingSpaces {line} { + set line [string map {\t { }} [string trimright $line]] + if {[regexp {^[ ]+} $line spaces]} { + regsub -all {[ ]{4}} $spaces \t replace + set len [expr {[string length $spaces] - 1}] + set line [string replace $line 0 $len $replace] + } + return $line + } + + #################################################################### + # + # processScript -- + # Transform a whole sequence of lines with [mapSpecial]. + # + proc processScript {scriptLines} { + lmap line $scriptLines { + # Skip blank and comment lines; they're there in the original + # sources so we don't need to copy them over. + if {[regexp {^\s*(?:#|$)} $line]} continue + format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n] + } + } + + #################################################################### + # + # updateTemplate -- + # Rewrite a template to contain the content from the input script. + # + proc updateTemplate {dataVar scriptLines} { + set BEGIN "*!BEGIN!: Do not edit below this line.*" + set END "*!END!: Do not edit above this line.*" + + upvar 1 $dataVar data + + set from [lsearch -glob $data $BEGIN] + set to [lsearch -glob $data $END] + if {$from == -1 || $to == -1 || $from >= $to} { + throw BAD "not a template" + } + + set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]] + } + + #################################################################### + # + # stripSurround -- + # Removes the header and footer comments from a (line-split list of + # lines of) Tcl script code. + # + proc stripSurround {lines} { + set RE {^\s*$|^#} + set state 0 + set lines [lmap line [lreverse $lines] { + if {!$state && [regexp $RE $line]} continue { + set state 1 + set line + } + }] + return [lmap line [lreverse $lines] { + if {$state && [regexp $RE $line]} continue { + set state 0 + set line + } + }] + } + + #################################################################### + # + # updateTemplateFile -- + # Rewrites a template file with the lines of the given script. + # + proc updateTemplateFile {headerFile scriptLines} { + set f [open $headerFile "r+"] + try { + set content [split [chan read -nonewline $f] "\n"] + updateTemplate content [stripSurround $scriptLines] + chan seek $f 0 + chan puts $f [join $content \n] + chan truncate $f + } trap BAD msg { + # Add the filename to the message + throw BAD "${headerFile}: $msg" + } finally { + chan close $f + } + } + + #################################################################### + # + # readScript -- + # Read a script from a file and return its lines. + # + proc readScript {script} { + set f [open $script] + try { + chan configure $f -encoding utf-8 + return [split [string trim [chan read $f]] "\n"] + } finally { + chan close $f + } + } + + #################################################################### + # + # run -- + # The main program of this script. + # + proc run {args} { + try { + if {[llength $args] != 2} { + throw ARGS "inputTclScript templateFile" + } + lassign $args inputTclScript templateFile + + puts "Inserting $inputTclScript into $templateFile" + set scriptLines [readScript $inputTclScript] + updateTemplateFile $templateFile $scriptLines + exit 0 + } trap ARGS msg { + puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\"" + exit 2 + } trap BAD msg { + puts stderr $msg + exit 1 + } trap POSIX msg { + puts stderr $msg + exit 1 + } on error {- opts} { + puts stderr [dict get $opts -errorinfo] + exit 3 + } + } +} + +######################################################################## +# +# Launch the main program +# +if {[info script] eq $::argv0} { + makeHeader::run {*}$::argv +} + +# Local-Variables: +# mode: tcl +# fill-column: 78 +# End: |