tcl/tools/makeHeader.tcl

# makeHeader.tcl --
#
#	This script generates embeddable C source (in a .h file) from a .tcl
#	script.
#
# Copyright © 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 {[^\x20-\x7E]} [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 < 0 || $to < 0 || $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: