#!/bin/sh
# -*-tcl-*-
# the next line restarts using tclsh\
exec tclsh "$0" "$@"
#-------------------------------------------------------------------------
# TITLE:
# expand.tcl
#
# VERSION:
# 2.0
#
# AUTHOR:
# Will Duquette
#
# DESCRIPTION:
# Usage: tclsh expand.tcl [options] files....
#
# Reads files, writing input to output. Most text
# is output unchanged. Certain text is evaluated as Tcl code;
# the result of the Tcl code, if any, is output. If the Tcl
# code results in an error, the error result is output.
#
# Before reading any input, expand.tcl reads any exprules.tcl
# file in the current directory, or alternatively a tcl file
# specified by the "-rules" command line option. This allows the
# caller to define special formatting macros for general use
# and override them as needed. The rules file can also read
# arguments from the command line, after options are removed but
# before the files are processed.
#
# On an error in a macro, expand can "ignore" the macro,
# "output" the macro unchanged, "fail" (the default), halting
# processing, depending on the value of the "-error" option.
#
# Output is written to stdout, by default; the "-out" option
# sends it to a file, instead. If the specified file is "nul",
# then no output is written at all. The rules can also control
# the output via the setoutput command.
#
# Any text in brackets, e.g., "[" and "]" is treated as a Tcl
# command, and evaluated. The bracket characters can be changed
# using ::expand::setbrackets.
#
# Normally Expand reads the output files only once; a rules file
# can choose multiple passes using the ::expand::setpasses command. The
# ::expand::exppass command returns the number of the current pass,
# starting at 1.
#
# LICENSE:
# Copyright (C) 2000 by William H. Duquette. See license.txt,
# distributed with this file, for license information.
#
# CHANGE LOG:
#
# 06/27/98: Released V1.0 on web.
# 06/27/98: Changed exp_extract to handle multi-character bracket
# tokens. Added exp_stripBrackets to remove multi-character
# bracket tokens.
# 06/27/98: Added function setbrackets to allow the user to choose the
# bracket tokens.
# 06/27/98: Added brand new command line option parser. The new parser
# can be used by the rules file's begin_hook.
#
# 06/28/98: Version 1.1 released.
#
# 06/29/98: Added init_hook.
# 06/29/98: Added setoutput command.
# 06/29/98: Added setpasses/exppass and multi-pass processing.
# 06/29/98: Fixed potential bug in exp_getCmd: using "info complete"
# with changed left and right brackets.
# 06/30/98: Added -testmode flag: causes error output to go to
# stdout instead of stderr to aid testing.
# 07/01/98: Added a tclsh80 starter at the top of the file.
# 07/01/98: exp_error calls "exit 1" instead of "exit 0" again.
# 07/02/98: Added expandText and include commands.
# 07/03/98: Renamed exp_write to expwrite, and made it public,
# for use with setoutput.
# 07/07/98: Released Expand V1.2
#
# 10/10/99: Added raw_text_hook.
# 01/15/00: Rewrote popArg, in an attempt to prevent an odd bug
# that manifests only on certain platforms.
# 01/15/00: Released Expand V1.3
#
# 02/03/00: Found a bug in expandText; it isn't safe to extract
# the command name from an arbitrary Tcl script using
# lindex, as many valid scripts aren't valid lists. I
# now use scan instead of lindex.
#
# 04/17/00: Version 2 rewrite begins. The code is cleaned up and
# placed in the ::expand:: namespace.
#
# 05/07/00: Version 2 rewrite ends (for now).
#-------------------------------------------------------------------------
# Namespace: all of the expand code exists in the ::expand:: namespace,
# leaving the global namespace for the user's rules.
namespace eval ::expand:: {
# Exported Commands
namespace export {[a-z]*}
# Expand Variables
# Macro bracketing sequences.
variable leftBracket "\["
variable rightBracket "\]"
# What to output when an error is detected:
# "nothing", "macro", "error", "fail"
variable errorOutputMode fail
# Number of passes to make over the input
variable numberOfPasses 1
# The current output channel
variable outputChannel ""
# A command can push its context onto a stack, causing any text
# that follows it to be saved separately. Later on, a paired command
# can pop the stack, acquiring the saved text and including it in its own
# output.
variable level 0
variable context
variable contextName
variable contextData
set context($level) ""
set contextName($level) ":0"
# Status variables
variable currentFileName ""
variable currentPass 0
}
#-------------------------------------------------------------------------
# User settings: These commands allow the users to set, and in some
# cases retrieve, various expansion parameters.
# lb
#
# Return the left bracket sequence.
proc ::expand::lb {} {
variable leftBracket
return $leftBracket
}
# rb
#
# Return the right bracket sequence.
proc ::expand::rb {} {
variable rightBracket
return $rightBracket
}
# setbrackets lb rb
#
# Set the bracket sequences
proc ::expand::setbrackets {lb rb} {
variable leftBracket
variable rightBracket
if {$lb == "" || $rb == ""} {
error "Empty string specified as left or right bracket."
}
set leftBracket $lb
set rightBracket $rb
return
}
# setErrorOutputMode mode
#
# Set the error output mode
proc ::expand::setErrorOutputMode {mode} {
variable errorOutputMode
if {![oneOf {fail nothing macro error} $mode]} {
error "Invalid error output mode '$mode'"
}
set errorOutputMode $mode
}
# Return the current file name
proc ::expand::expfile {} {
variable currentFileName
return $currentFileName
}
# Return the number of the current pass.
proc ::expand::exppass {} {
variable currentPass
return $currentPass
}
# Set the number of passes
proc ::expand::setpasses {passes} {
variable numberOfPasses
set numberOfPasses $passes
if {$numberOfPasses < 1} {
error "setpasses: must be >= 1"
}
}
#-------------------------------------------------------------------------
# User hooks: a rule set can redefine these hooks to do anything desired.
# The init_hook doesn't contribute to the output, but the other hooks do.
# Since the hooks do nothing by default, and are to be redefined by the
# user, they are defined in the global name space.
# Initialization Hook: called when the rule set is loaded.
proc init_hook {} {}
# Begin Hook: Called at the beginning of each pass.
proc begin_hook {} {}
# End Hook: Called at the end of each pass.
proc end_hook {} {}
# Begin File Hook: Called before each file is processed.
proc begin_file_hook {fileName} {}
# End File Hook: Called after each file is processed.
proc end_file_hook {fileName} {}
# Raw Text Hook: All plain (non-macro) text is passed through this
# function.
proc raw_text_hook {text} {return $text}
#-------------------------------------------------------------------------
# Context: Every expansion takes place in its own context; however,
# a macro can push a new context, causing the text it returns and all
# subsequent text to be saved separately. Later, a matching macro can
# pop the context, acquiring all text saved since the first command,
# and use that in its own output.
# cpush name
#
# pushes an empty context onto the stack. All output text will be added
# to this context until it is popped.
proc ::expand::cpush {name} {
variable level
variable context
variable contextName
incr level
set context($level) {}
set contextName($level) $name
}
# cis name
#
# Returns true if the current context has the given name.
proc ::expand::cis {name} {
variable level
variable contextName
return [expr [string compare $name $contextName($level)] == 0]
}
# cname
#
# Returns the current context name.
proc ::expand::cname {} {
variable level
variable contextName
return $contextName($level)
}
# csave name value
#
# Save or retrieve value in the current context
proc ::expand::csave {name value} {
variable contextData
variable level
set contextData($level-$name) $value
}
# cget name
#
# Get the value of a context variable
proc ::expand::cget {name} {
variable contextData
variable level
if {![info exists contextData($level-$name)]} {
error "*** Error, context var $name doesn't exist in this context"
}
return $contextData($level-$name)
}
# cvar name
#
# Get a context variable's real name, e.g., for appending or lappending
proc ::expand::cvar {name} {
variable contextData
variable level
if {![info exists contextData($level-$name)]} {
error "*** Error, context var $name doesn't exist in this context"
}
return ::expand::contextData($level-$name)
}
# cpop
#
# Pops a context level off of the stack, returning the accumulated text.
proc ::expand::cpop {name} {
variable level
variable context
variable contextName
variable contextData
if {$level == 0} {
error "*** Error, context mismatch: got unexpected '$name'"
}
if {"$contextName($level)" != "$name"} {
error \
"*** Error, context mismatch: expected $contextName($level), got $name"
}
set result $context($level)
set context($level) ""
set contextName($level) ""
foreach name [array names contextData $level-*] {
unset contextData($name)
}
incr level -1
return $result
}
# ContextAppend text
#
# This private command appends text to the current context. It is for
# use only by the Expand code; macros should return their text.
proc ::expand::ContextAppend {text} {
variable context
variable level
append context($level) $text
}
#-------------------------------------------------------------------------
# Macro-expansion: The following code is the heart of the program.
# Given a text string, and the current variable settings, this code
# returns an expanded string, with all macros replaced.
#
# If a fatal error is detected during expansion, expandText throws
# an error for its caller to handle. An error detected while
# expanding a particular macro is only fatal if the errorOutputMode
# is "fail"; otherwise, the result of the expansion attempt is
# output according to the mode.
#
# All non-macro text is passed through the raw_text_hook.
# Expands a string using the current macro definitions and Expand
# variable settings.
proc ::expand::expandText {inputString} {
variable errorOutputMode
global errorInfo
cpush expandText
while {[string length $inputString] > 0} {
set plainText [ExtractToToken inputString [lb] exclude]
# FIRST, If there was plain text, append it to the output, and
# continue.
if {$plainText != ""} {
ContextAppend [raw_text_hook $plainText]
if {[string length $inputString] == 0} {
break
}
}
# NEXT, A macro is the next thing; process it.
if {[catch "GetMacro inputString" macro]} {
error "*** Error reading macro from input: $macro"
}
# Expand the macro, and output the result, or
# handle an error.
if {![catch "uplevel #0 [list $macro]" result]} {
ContextAppend $result
continue
}
switch $errorOutputMode {
nothing { }
macro {
ContextAppend "[lb]$macro[rb]"
}
error {
ContextAppend "[lb]$macro[rb]\n"
ContextAppend "*** Error in preceding macro: $result\n$errorInfo"
}
fail {
error "*** Error in macro:\n[lb]$macro[rb]\n$result"
}
}
}
return [cpop expandText]
}
# ExtractToToken string token mode
#
# Extract text from a string, up to or including a particular
# token. Remove the extracted text from the string.
# mode determines whether the found token is removed;
# it should be "include" or "exclude". The string is
# modified in place, and the extracted text is returned.
proc ::expand::ExtractToToken {string token mode} {
upvar $string theString
# First, determine the offset
switch $mode {
include { set offset [expr [string length $token] - 1] }
exclude { set offset -1 }
default { error "::expand::ExtractToToken: unknown mode $mode" }
}
# Next, find the first occurrence of the token.
set tokenPos [string first $token $theString]
# Next, return the entire string if it wasn't found, or just
# the part upto or including the character.
if {$tokenPos == -1} {
set theText $theString
set theString ""
} else {
set newEnd [expr $tokenPos + $offset]
set newBegin [expr $newEnd + 1]
set theText [string range $theString 0 $newEnd]
set theString [string range $theString $newBegin end]
}
return $theText
}
# Get the next complete command, removing it from the string.
proc ::expand::GetMacro {string} {
upvar $string theString
# FIRST, it's an error if the string doesn't begin with a
# character.
if {[string first [lb] $theString] != 0} {
error "::expand::GetMacro: assertion failure, next text isn't a command! '$theString'"
}
# NEXT, extract a full macro
set macro [ExtractToToken theString [lb] include]
while {[string length $theString] > 0} {
append macro [ExtractToToken theString [rb] include]
# Verify that the command really ends with the [rb] characters,
# whatever they are. If not, break because of unexpected
# end of file.
if {![IsBracketed $macro]} {
break;
}
set strippedMacro [StripBrackets $macro]
if {[info complete "puts \[$strippedMacro\]"]} {
return $strippedMacro
}
}
if {[string length $macro] > 40} {
set macro "[string range $macro 0 39]...\n"
}
error "*** Error, unexpected EOF in macro:\n$macro"
}
# Strip left and right bracket tokens from the ends of a macro,
# provided that it's properly bracketed.
proc ::expand::StripBrackets {macro} {
set llen [string length [lb]]
set rlen [string length [rb]]
set tlen [string length $macro]
return [string range $macro $llen [expr $tlen - $rlen - 1]]
}
# Return 1 if the macro is properly bracketed, and 0 otherwise.
proc ::expand::IsBracketed {macro} {
set llen [string length [lb]]
set rlen [string length [rb]]
set tlen [string length $macro]
set leftEnd [string range $macro 0 [expr $llen - 1]]
set rightEnd [string range $macro [expr $tlen - $rlen] end]
if {$leftEnd != [lb]} {
return 0
} elseif {$rightEnd != [rb]} {
return 0
} else {
return 1
}
}
#-------------------------------------------------------------------------
# File handling: these routines, some public and some private, handle
# processing of files.
# expand fileList outputFile
#
# This is the basic algorithm of the Expand tool. Given a list of files
# to expand, it executes the following sequence. Return values of all
# handlers, except for the initHandlers, is written to the current output
# file.
#
# - For each pass,
# - Set ::expand::currentPass.
# - Call the begin_hook.
# - For each file in the file list,
# - Set ::expand::currentFileName
# - Call the begin_file_hook.
# - read file and expand its contents
# - Call the end_file_hook.
# - Call the end_hook.
# - Close the current output file.
proc ::expand::expand {fileList outputFile} {
variable currentPass
variable numberOfPasses
variable currentFileName
for {set currentPass 1} {$currentPass <= $numberOfPasses} \
{incr currentPass} {
# First, if this is any pass but the last, set output to nul;
# otherwise, set output to the requested output file.
if {$currentPass < $numberOfPasses} {
setoutput nul
} else {
setoutput $outputFile
}
# Next, execute the beginning hook
set currentFileName ""
expwrite [begin_hook]
# Next, expand each of the files on the command line.
foreach file $fileList {
if {[catch "ExpandFile [list $file]" result]} {
puts stderr $result
exit 1
}
expwrite $result
}
# Next, execute the end hook
expwrite [end_hook]
}
# Next, close the output file.
setoutput nul
}
# ExpandFile
#
# Helper routine for ::expand::expand. It expands a single file,
# calling the begin and end file handlers and returning the expanded
# result.
proc ::expand::ExpandFile {fileName} {
variable currentFileName
# Set the current file
set currentFileName $fileName
# Call the begin_file_hook
set output [begin_file_hook $fileName]
# Expand the file
set contents [readFile $fileName]
if {[catch [list expandText $contents] result]} {
error "*** Error expanding $fileName:\n$result"
}
append output $result
# Call the endFileHandlers
append output [end_file_hook $fileName]
return $output
}
# include file
#
# Reads a file into memory, and expands its contents.
proc ::expand::include {fileName} {
# Get the file's contents, and prepare to output it.
set contents [readFile $fileName]
if {[catch [list expandText $contents] result]} {
error "*** Error including $fileName:\n$result"
}
return $result
}
# readFile file
#
# Reads a file into memory, returning its contents.
proc ::expand::readFile {fileName} {
# Open the file.
if {[catch "open $fileName" fin]} {
error "Could not read file '$fileName': $fin"
}
# Read the contents and close the file.
set contents [read $fin]
close $fin
return $contents
}
#-------------------------------------------------------------------------
# Output Management
# Set the output file
proc ::expand::setoutput {fileName} {
variable outputChannel
# Close any existing file
if {$outputChannel != "" && $outputChannel != "stdout"} {
close $outputChannel
}
# Pick stdout, no output at all, or a real file
if {$fileName == ""} {
set outputChannel stdout
} elseif {$fileName == "nul"} {
set outputChannel ""
} else {
if {[catch "open $fileName w" outputChannel]} {
error "Could not open output file $fileName"
}
}
return
}
# Output a bunch of text to the output file.
proc ::expand::expwrite {text} {
variable outputChannel
if {$outputChannel != ""} {
puts -nonewline $outputChannel $text
}
}
#-------------------------------------------------------------------------
# getoptions: command line option parsing
#
# The getoptions function parses a list as a command line, removing
# options and their values. Any remaining tokens and options remain
# in the list and can be parsed by another call to getoptions or in
# any other way the caller prefers.
#
# getoptions is called as follows:
#
# getoptions arglist [-strict] [{optionDef... }]
#
# "arglist" is the name of a list variable, typically argv. It is
# passed by name, and modified in place. If the "-strict" option
# is specified, unrecognized options are flagged as errors.
# The call may include any number of option definitions, including
# none. The call "getoptions argv -strict", for example, will ensure
# that no options remain in the list contained in "argv".
#
# Option definitions may take the following forms. In each, NAME is
# the option name, which must begin with a "-" character, and VAR is
# the name of a variable in the caller's scope to receive the option's value.
#
# {NAME VAR flag}
# If the option appears on the command line, the variable
# is set to 1, otherwise to 0.
#
# {NAME VAR enum VAL1 VAL2....}
# If the option appears on the command line, the next argument
# must be one of the enumerated values, VAL1, VAL2, etc. The
# variable is set to the value, or VAL1 if the option does not
# appear on the command line. If the option's value is not one of
# the valid choices, an error message will be displayed and the
# program will halt. None of the enumerated values may begin with
# a "-" character.
#
# {NAME VAR string DEFVALUE}
# The named variable is set to the value following the option on
# the command line. If the option doesn't appear, the variable is
# set to the DEFVALUE. The option's value may not begin with
# "-" character, as if it does, the most likely explanation is
# that the option's real value is missing and the next argument is
# another option name.
# Utility routine: pops an arg off of the front of an arglist.
proc ::expand::popArg {arglist} {
upvar $arglist args
if {[llength $args] == 0} {
set arg ""
} elseif {[llength $args] == 1} {
set arg $args
set args ""
} else {
set arg [lindex $args 0]
set args [lrange $args 1 end]
}
return $arg
}
proc ::expand::getoptions {arglist strictOrDefs {defsOrNil ""}} {
# First, the arglist is called by name.
upvar $arglist args
# Next, strictOrDefs is either the "-strict" option or the
# definition list.
if {$strictOrDefs == "-strict"} {
set strictFlag 1
set defList $defsOrNil
} else {
set strictFlag 0
set defList $strictOrDefs
}
# Next, get names of the options
set optNames {}
set optTypes {flag enum string}
set optLens {3 5 4}
foreach def $defList {
if {[llength $def] < 3} {
error "Error in option definition: $def"
}
lappend optNames [lindex $def 0]
set varName [lindex $def 1]
set optType [lindex $def 2]
set i [lsearch -exact $optTypes $optType]
if {$i == -1} {
error "Unknown option type: $optType"
}
if {[llength $def] < [lindex $optLens $i]} {
error "Error in option definition: $def"
}
upvar $varName theVar
switch $optType {
flag {set theVar 0}
enum -
string {set theVar [lindex $def 3]}
}
}
# Next, process the options on the command line.
set errorCount 0
set newList {}
for {set arg [popArg args]} {$arg != ""} {set arg [popArg args]} {
# First, does it look like an option? If not, add it to the
# output list.
if {[string index $arg 0] != "-"} {
lappend newList $arg
continue
}
# Next, Is the argument unknown? Flag an error or just skip it.
set i [lsearch -exact $optNames $arg]
if {$i == -1} {
if {$strictFlag} {
puts stderr "*** Unknown option: $arg"
incr errorCount
} else {
lappend newList $arg
}
continue
}
# Next, process the argument
set def [lindex $defList $i]
set varName [lindex $def 1]
set optType [lindex $def 2]
upvar $varName theVar
switch $optType {
flag {
set theVar 1
}
enum {
set vals [lreplace $def 0 2]
set theVar [popArg args]
if {$theVar == "" || [string index $theVar 0] == "-"} {
puts stderr "*** Missing option value: $arg"
incr errorCount
continue
}
if {[lsearch -exact $vals $theVar] == -1} {
puts stderr "*** Invalid option value: $arg $theVar"
incr errorCount
}
}
string {
set theVar [popArg args]
if {$theVar == "" || [string index $theVar 0] == "-"} {
puts stderr "*** Missing option value: $arg"
incr errorCount
}
}
}
}
# Next, if there are any errors, halt.
if {$errorCount > 0} {
exit 1
}
# Next, return the new argument list.
set args $newList
return
}
#-------------------------------------------------------------------------
# Importing macros into the global namespace
# GlobalizeMacros args
#
# args is a list of glob patterns matching the macros to be imported.
# The prefix ::expand:: is added automatically.
proc ::expand::GlobalizeMacros {args} {
set globList {}
foreach arg $args {
lappend globList ::expand::$arg
}
namespace eval :: "namespace import -force $globList"
}
#-------------------------------------------------------------------------
# Standard Rule Set:
#
# These are the rules that are always available.
proc ::expand::standardRuleSet {} {
GlobalizeMacros cget cis cname cpop cpush csave cvar expandText expfile
GlobalizeMacros exppass expwrite getoptions include lb popArg rb
GlobalizeMacros readFile setErrorOutputMode setbrackets setoutput
GlobalizeMacros setpasses textToID
}
#-------------------------------------------------------------------------
# Rule Set: Web Rules
#
# These macros are for creating HTML pages. They are only defined when
# webRuleSet is called.
proc ::expand::webRuleSet {} {
GlobalizeMacros dot tag link mailto today
}
# Output a big black dot.
proc ::expand::dot {} {
return "•"
}
# Format an html tag. name is the tag name, args is a list of
# of attribute names and values
proc ::expand::tag {name args} {
set result "<$name"
foreach {attr val} $args {
append result " $attr=\"$val\""
}
append result ">"
}
# Format a link. If text is given, use it as the displayed text;
# otherwise use the url.
proc ::expand::link {url {text ""}} {
if {$text == ""} {
set text $url
}
return "[tag a href $url]$text[tag /a]"
}
# Format an email URL
proc ::expand::mailto {address {name ""}} {
if {$name == ""} {
set name $address
}
return "[tag a href mailto:$address]$name[tag /a]"
}
# Return today's date. Use dd MONTH yyyy unless some other format is
# proposed.
proc ::expand::today {{format ""}} {
set secs [clock seconds]
if {$format == ""} {
set format "%d %B %Y"
}
return [string trimleft [clock format $secs -format $format] "0"]
}
#-------------------------------------------------------------------------
# Miscellaneous utility commands
# oneOf list value
#
# Checks to see if a value is in a list.
proc ::expand::oneOf {list value} {
return [expr {[lsearch -exact $list $value] != -1}]
}
# Converts a generic string to an ID string. Leading and trailing
# whitespace and internal punctuation is removed, internal whitespace
# is converted to "_", and the text is converted to lower case.
proc ::expand::textToID {text} {
# First, trim any white space and convert to lower case
set text [string trim [string tolower $text]]
# Next, substitute "_" for internal whitespace, and delete any
# non-alphanumeric characters (other than "_", of course)
regsub -all {[ ]+} $text "_" text
regsub -all {[^a-z0-9_]} $text "" text
return $text
}
#-------------------------------------------------------------------------
# Main-line code: This is the implementation of the Expand tool
# itself. It is executed only if this is the top-level script.
proc ::expand::ShowHelp { } {
puts {tclsh expand.tcl [options] files...
-help Displays this text.
-rules file Specify the name of the rules file
(exprules.tcl is the default)
-out file Specify the name of the output file, or "nul" for
no output. Output is to stdout, by default.
-errout mode nothing, macro, error, or fail (fail is the default)
-web Enable the optional web rule set.
files... Names of files to process.}
}
if {"[info script]" == "$argv0"} {
# First, parse the command line
::expand::getoptions argv {
{-help ::expand::helpFlag flag}
{-errout ::expand::errorOutputMode enum fail nothing macro error}
{-rules ::expand::rulesFile string "exprules.tcl"}
{-web ::expand::webFlag flag}
{-out ::expand::outputFile string ""}
}
# Next, if they asked for help or if there are no arguments left,
# show help and stop.
if {$::expand::helpFlag || [llength $argv] == 0} {
::expand::ShowHelp
exit 0
}
# Next, load the standard macros
::expand::standardRuleSet
# Next, load optional rule sets.
if {$::expand::webFlag} {
::expand::webRuleSet
}
# Next, load the rules file. (Should only do it if file exists;
# should die if there are any errors)
if {[file exists $::expand::rulesFile]} {
if {[catch "source $::expand::rulesFile" result]} {
puts "*** Error in rules file $::expand::rulesFile: $result"
exit 1
}
} elseif {$::expand::rulesFile != "exprules.tcl"} {
puts "*** Rules file $rulesFile not found."
exit 1
}
# Next, call the init_hook.
if {[catch init_hook result]} {
puts "*** Error executing init_hook: $result"
exit 1
}
# Next, make sure the command line contains no additional options
::expand::getoptions argv -strict
# Next, process the files
::expand::expand $argv $::expand::outputFile
}
syntax highlighted by Code2HTML, v. 0.9.1