TCL-enriched templated plain-text docs

[sgbeal]

Many years ago, inspired by a capability of the Fossil SCM, i implemented a feature in my home-brew scripting engine which processed plain-text documents with minimal markup which embeds code from that language. That scripting engine currently generates many of the static pages on my web site and i thought it would be interesting to explore replacing that with jimtcl.

To that end, i reimplemented the templating engine in TCL, making sure it works in both canonical TCL and JimTCL (the end goal being to use the latter, with a copy embedded in my web site's tree, but i'm still a number of steps away from that), which looks a little something like...

# License: released into the public domain by its author,
# Stephan Beal <https://wanderinghorse.net/home/stephan/>
########################################################################
# Takes a "tmplish"-format template and compiles it to TCL code,
# returning that code. Processing the template requires passing it to
# [uplevel 0] or [eval].
#
# $outputCall must either be the name of a function or the string
# {apply aLambda} which takes a single argument and is responsible for
# rendering the processed template, piece by piece, by emitting that
# argument however is appropriate for the app (e.g. appending it to a
# list or sending it to puts -nonewline). The callback is called one
# time for each chunk of input and is responsible for rendering it
# faithfully (e.g. adding no extra whitespace). It need not render it,
# per se - it can append it to a buffer or some such.
#
# $body is a "plain text document" with optional markup:
#
# - <% ... %> gets replaced by a call to the callback, passing it
#   [expr {...}]. i.e. the result of the expression becomes part of
#   the output.
#
# - <? ... ?> gets replaced by a call to uplevel 0 {...}. If the block
#   wants to produce any output, it must generate it itself, calling
#   the same callback which is passed to this function.
#
# The text surrounding such markup is passed on _almost_ untouched:
# any characters which require backslash-escaping to survive
# string interpolation get escaped so that they will be
# handled properly when the template is eval'd.
#
# Any initial whitespace content in $body is ignored for the simple
# reason that practice with previous implementations of this routine
# (in other languages) suggests that it's useful to do so. If the
# first non-whitespace content is one or more <? ?> blocks, they are
# treated as whitespace for this purpose because historically such
# block have frequently been used to set up various state for the doc
# being processed, without producing any output.  Conversely, <% %>
# blocks, because they inherently produce output, are _not_ counted as
# whitespace.
#
# There is currently no way to escape or configure the above markup
# delimiters, so the content must not contain them except as markup
# for this function.
#
# For example:
#
#   set body {...the template...}
#   set output {{arg} {puts -nonewline $arg}}
#   set compiled [tmplish-compile $body {apply $output}}
##   or:
##   proc myout {arg} {puts -nonewline $arg}
##   set compiled [tmplish-compile $body myout]
#   uplevel 0 $compiled
#
# Sidebars:
#
# - This could be done _much_ more efficiently in C but this impl is
#   intended to run in both canonical TCL and JimTCL.
#
# - If TCL had heredocs, this would be simpler (no escaping of
#   arbitrarily large strings).
#
# Potential TODOs:
#
# - Add an optional -config {...} flag which sets the opening and
#   closing tags, e.g. {exprOpen => "<(" exprClose => ")>"}, and
#   optionally set the callback in the config object.
#
# - For <? ?> blocks, if we find no matching ?> then take the rest of
#   the document as part of that block. That matches what PHP does and
#   has actually proven useful when using such templates in CGI apps
#   and for web page generation.
proc tmplish-compile {body outputCall} {
  set chars [split $body ""]
  set nLen [llength $chars]
  set seenContent 0; # gets set to 1 when non-whitespace is seen.
  set obuf [list]
  proc _tmplish-find-closer {list chType nStart nLen} {
    set i [expr {$nStart + 1}]
    set chPrev [lindex $list $i]
    for {} {$i < $nLen} {incr i} {
      set ch [lindex $list $i]
      if {$ch eq ">" && $chType eq $chPrev} {
        break;
      }
      set chPrev $ch
    }
    if {$i >= $nLen} {
      #return -code error "Did not find matching ${chType}> starting at index $nStart."
      error "Did not find matching ${chType}> in tmpl starting at index $nStart."
    }
    return $i
  }
  set outBegin "$outputCall \""
  append obuf $outBegin
  set qIsOpen 1; # 1 when the output call quoted string is opened, waiting closing
  set gotOpen 0; # 1 when we have seen a markup opener
  for {set i 0} {$i < $nLen} {incr i} {
    set ch [lindex $chars $i]
    #puts stderr "ch=$ch"
    if {!$seenContent && $ch in {" " "\n" "\t"}} {
      continue
    }
    if {$gotOpen && $ch in {? %}} {
      set gotOpen 0
      set nEnd [_tmplish-find-closer $chars $ch $i $nLen]
      if {$qIsOpen} {
        append obuf "\"\n";
        set qIsOpen 0
      }
      incr i
      #puts stderr "i=$i nEnd=$nEnd str=[join [lrange $chars $i [expr {$nEnd - 2}]]]"
      if { "%" eq $ch } {
        set seenContent 1
        append obuf "$outputCall \[expr \{"
        set closer "\}\]\n"
      } else {
        append obuf "uplevel 0 \{"
        set closer "\}\n"
      }
      append obuf [join [lrange $chars $i [expr {$nEnd - 2}]] ""]
      append obuf "$closer"
      set i $nEnd
      #puts "CLOSER=[lindex $chars $i]"
      continue
    }
    if {!$qIsOpen} {
      append obuf $outBegin
      set qIsOpen 1
    }
    switch -exact -- $ch {
      "\"" - "\[" - "\$" - "\\" {
        if {$gotOpen} { append obuf "<" }
        append obuf "\\" $ch
      }
      "<" {
        if {$gotOpen} {
          append obuf "<<"
        } else {
          set gotOpen 1
          continue
        }
      }
      default {
        if {$gotOpen} { append obuf "<" }
        append obuf $ch
      }
    }
    set seenContent 1
    set gotOpen 0
  }
  if {$qIsOpen} {
    append obuf "\"\n"
  }
  #puts stderr "obuf=$obuf"
  rename _tmplish-find-closer ""
  #return [join $obuf ""]
  return $obuf
}

proc tmpl-test {} {
  set outf {{arg} {puts -nonewline $arg}}
  proc outf2 {arg} {puts -nonewline $arg}
  proc noop {args} {}
  set body {
    <? noop "ignored" ?>
    <? noop "also ignored" ?>
    <? noop "also also ignored" ?>
    x=<% $x %>!
    x+5=<%$x + 5%>!!
    This {is} [a] $tmpl. x+3=<%$x + 3%>!
    And this is a code block: <?
    outf2 "this is from a code block"?>
  }
  set t [tmpl-compile $body outf2]
  #set t [tmpl-compile $body {apply $outf}]
  set x 11
  puts "<COMPILED>$t</COMPILED>"
  puts "<EVALED>"; uplevel 0 $t; puts "</EVALED>"
}
tmpl-test

When run as-is it says:

<COMPILED>outf2 ""
uplevel 0 { noop "ignored" }
outf2 ""
uplevel 0 { noop "also ignored" }
outf2 ""
uplevel 0 { noop "also also ignored" }
outf2 "x="
outf2 [expr { $x }]
outf2 "!
    x+5="
outf2 [expr {$x + 5}]
outf2 "!!
    This {is} \[a] \$tmpl. x+3="
outf2 [expr {$x + 3}]
outf2 "!
    And this is a code block: "
uplevel 0 {
    outf2 "this is from a code block"}
outf2 "
  "
</COMPILED>
<EVALED>
x=11!
    x+5=16!!
    This {is} [a] $tmpl. x+3=14!
    And this is a code block: this is from a code block
  </EVALED>

The reason for the "compilation" step is because this was initially envisioned for producing web-based output, where it is sometimes useful to generate, e.g. table rows via a template. The template is compiled one time and then eval'd once per table row, updating the vars which the template references before eval'ing it for each row.

Forewarning: being only a few minutes old, it very likely has an outstanding bug or three.

Edit: the current canonical home of this script, updated significantly from the copy shown above:

https://fossil.wanderinghorse.net/r/www-wh/file/site-tools/tcl.d/tmplish.tcl

PS: TCL is not my native language!

Edit: the API has since been restructured to use a namespace and optionally take its content from a file, but i'll leave the initial implementation here because it's simpler to read. See the link above for the latest code.