Rewrite Squirrel::Template into parsing and processing steps
authorTony Cook <tony@develop-help.com>
Wed, 22 Feb 2012 13:06:17 +0000 (00:06 +1100)
committerTony Cook <tony@develop-help.com>
Wed, 7 Mar 2012 02:29:51 +0000 (13:29 +1100)
Works in two ways:

- avoid multiple passes over the whole very large text

  Previously the templater grabbed the base text, substituted any
  wrappers and includes to produce a large string in memory, and then
  performs multiple passes of substitution over the whole text until
  either there are no tags to replace or we hit a limit.

- avoid processing of iterators in false conditionals

  Previousl iterators were processed before conditionals so that
  conditionals within the iterator will be processed in the context of
  the iterator.

  With the changes if the conditional can be resolved only the true
  conditional will be processed.

The changes here lead directly to some other improvements:

- line numbers and source files are being tracked, and in the future
  may be used to report errors with a bit more precision.

- this provides the base for a more regular templating language that
  can work with an object system to avoid having to create tags to
  expose functionality that the objects already provide.

21 files changed:
MANIFEST
MANIFEST.SKIP
Makefile
site/cgi-bin/modules/BSE/Template.pm
site/cgi-bin/modules/Squirrel/Template.pm
site/cgi-bin/modules/Squirrel/Template/Constants.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Deparser.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Parser.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Processor.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Tokenizer.pm [new file with mode: 0644]
site/docs/Squirrel::Template.html [new file with mode: 0644]
site/docs/config.pod
site/docs/makedocs
site/util/bse_template_check.pl [new file with mode: 0644]
t/t010template.t
t/templater/00load.t [new file with mode: 0644]
t/templater/10token.t [new file with mode: 0644]
t/templater/20parse.t [new file with mode: 0644]
t/templates/included.recursive [new file with mode: 0644]
t/templates/wrapinner.tmpl [new file with mode: 0644]
t/templates/wrapself.tmpl [new file with mode: 0644]

index 69b144a..ddb2939 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -328,6 +328,11 @@ site/cgi-bin/modules/Squirrel/PGP6.pm
 site/cgi-bin/modules/Squirrel/Row.pm
 site/cgi-bin/modules/Squirrel/Table.pm
 site/cgi-bin/modules/Squirrel/Template.pm
+site/cgi-bin/modules/Squirrel/Template/Constants.pm
+site/cgi-bin/modules/Squirrel/Template/Deparser.pm
+site/cgi-bin/modules/Squirrel/Template/Parser.pm
+site/cgi-bin/modules/Squirrel/Template/Processor.pm
+site/cgi-bin/modules/Squirrel/Template/Tokenizer.pm
 site/cgi-bin/nuser.fcgi
 site/cgi-bin/nuser.pl
 site/cgi-bin/page.fcgi
@@ -388,6 +393,7 @@ site/docs/shop.html
 site/docs/shopadmin.html
 site/docs/siteusers.html
 site/docs/siteusers.pod
+site/docs/Squirrel::Template.html
 site/docs/standard.html
 site/docs/standard.pod
 site/docs/storages.html
@@ -782,6 +788,7 @@ site/util/bse_notify_files.pl
 site/util/bse_s3.pl
 site/util/bse_session_clean.pl
 site/util/bse_storage.pl
+site/util/bse_template_check.pl
 site/util/bse_thumb.pl
 site/util/bse_versiondeps.pl
 site/util/bseaddimages.pl
@@ -846,7 +853,12 @@ t/t80catalog.t
 t/t85message.t
 t/t90dyncat.t
 t/tags/bse.cfg
+t/templater/00load.t
+t/templater/10token.t
+t/templater/20parse.t
 t/templates/included.include   Used by t010template.t
+t/templates/included.recursive
+t/templates/wrapinner.tmpl
 t/templates/wraptest.tmpl      Used by t010template.t
 test.cfg-dist
 test.cfg.base
index 2f718be..838a1a6 100644 (file)
@@ -22,3 +22,4 @@
 ^site/cgi-bin/modules/Squirrel/ImageEditor\.pm$
 ^\.?\#
 /\.?\#
+^cover_db/
index 96d60f6..28b0e24 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -109,7 +109,7 @@ testup: checkver distdir
 checkver:
        if [ -d .git ] ; then perl site/util/check_versions.pl ; fi
 
-TEST_FILES=t/*.t
+TEST_FILES=t/*.t t/*/*.t
 TEST_VERBOSE=0
 
 test: testup
index 313671b..a637c0a 100644 (file)
@@ -4,7 +4,7 @@ use Squirrel::Template;
 use Carp qw(confess cluck);
 use Config ();
 
-our $VERSION = "1.004";
+our $VERSION = "1.005";
 
 sub templater {
   my ($class, $cfg, $rsets) = @_;
@@ -27,6 +27,11 @@ sub templater {
      utf8 => $cfg->utf8,
      charset => $cfg->charset,
     );
+  if ($cfg->entry("basic", "cache_templates")) {
+    require BSE::Cache;
+    $opts{cache} = BSE::Cache->load($cfg);
+  }
+
   return Squirrel::Template->new(%opts);
 }
 
index 00dc3b5..4f7112f 100644 (file)
@@ -1,6 +1,10 @@
 package Squirrel::Template;
 use vars qw($VERSION);
 use strict;
+use Squirrel::Template::Tokenizer;
+use Squirrel::Template::Parser;
+use Squirrel::Template::Deparser;
+use Squirrel::Template::Processor;
 use Carp qw/cluck confess/;
 BEGIN {
   unless ( defined &DEBUG ) {
@@ -11,7 +15,7 @@ BEGIN {
 
 use constant DEBUG_GET_PARMS => 0;
 
-our $VERSION = "1.003";
+our $VERSION = "1.010";
 
 my $tag_head = qr/(?:\s+<:-|<:-?)/;
 my $tag_tail = qr/(?:-:>\s*|:>)/;
@@ -20,6 +24,8 @@ sub new {
   my ($class, %opts) = @_;
 
   $opts{errout} = \*STDOUT;
+  $opts{param} = [];
+  $opts{wraps} = [];
 
   return bless \%opts, $class;
 }
@@ -106,6 +112,9 @@ sub low_perform {
     }
     # otherwise fall through
   }
+  elsif ($func eq "param") {
+    return $self->tag_param($args);
+  }
 
   return $self->{verbose} ? "** unknown function $func **" : $orig;
 }
@@ -141,143 +150,6 @@ sub perform {
   return $value;
 }
 
-sub iterator {
-  my ($self, $name, $args, $input, $sep, $acts, $orig) = @_;
-
-  $args = '' unless defined $args;
-  $sep = '' unless defined $sep;
-
-  print STDERR "iterator $name $args\n" if DEBUG;
-
-  if (my $entry = $acts->{"iterate_$name"}) {
-    $args =~ s/^\s+|\s+$//g;
-
-    my $reset = $acts->{"iterate_${name}_reset"};
-    my ($resetf, @rargs);
-    if ($reset) {
-      if (ref $reset eq 'ARRAY') {
-       ($resetf, @rargs) = @$reset;
-      }
-      else {
-       $resetf = $reset;
-      }
-    }
-
-    my ($entryf, @eargs);
-    if (ref $entry eq 'ARRAY') {
-      ($entryf, @eargs) = @$entry;
-    }
-    else {
-      $entryf = $entry;
-    }
-
-    if ($resetf) {
-      if (ref $resetf) {
-       print STDERR "  resetting (func)\n" if DEBUG > 1;
-       $resetf->(@rargs, $args, $acts, $name, $self);
-      }
-      else {
-       my $obj = shift @rargs;
-       print STDERR "  resetting (method) $obj->$resetf\n" if DEBUG > 1;
-       $obj->$resetf(@rargs, $args, $acts, $name, $self);
-      }
-      print STDERR "  reset done\n" if DEBUG > 1;
-    }
-    my $eobj;
-    ref $entryf or $eobj = shift @eargs;
-    my $result = '';
-    while ($eobj ? $eobj->$entryf(@eargs, $name, $args) 
-          : $entryf->(@eargs, $name, $args)) {
-      $result .= $self->replace_template($sep, $acts) if length $result;
-      $result .= $self->replace_template($input, $acts);
-    }
-    return $result;
-  }
-  else {
-    return $self->{verbose} ? "** No iterator $name **" : $orig;
-  }
-}
-
-sub with {
-  my ($self, $name, $args, $input, $sep, $acts, $orig) = @_;
-
-  $args = '' unless defined $args;
-  if (my $entry = $acts->{"with_$name"}) {
-    my $code;
-    my @args;
-    my $replace = 1;
-    if (ref $entry eq 'CODE') {
-      $code = $entry;
-    }
-    elsif (ref $entry eq 'ARRAY') {
-      ($code, @args) = @$entry;
-    }
-    elsif (ref $entry eq 'HASH') {
-      $code = $entry->{code};
-      @args = @{$entry->{args}} if $entry->{args};
-      $replace = $entry->{replace} if exists $entry->{replace};
-    }
-    else {
-      print STDERR "Cannot use '$entry' as a with_$name handler\n";
-      return $orig;
-    }
-
-    my $result = $input;
-    if ($replace) {
-      $result = $self->replace_template($result, $acts);
-    }
-
-    return $code->(@args, $args, $result, $sep, $acts, $name, $self);
-  }
-  else {
-    return $orig;
-  }
-}
-
-sub cond {
-  my ($self, $name, $args, $acts, $start, $true, $else, $false, $endif) = @_;
-
-  defined $args or $args = '';
-  print STDERR "cond $name $args\n" if DEBUG;
-
-  local $SIG{__DIE__};
-  my $result =
-    eval {
-      if (exists $acts->{"if$name"}) {
-       print STDERR " found cond if$name\n" if DEBUG > 1;
-       my $cond = $self->low_perform($acts, "if$name", $args, '');
-       return $cond ? $true : $false;
-      }
-      elsif (exists $acts->{lcfirst $name}) {
-       print STDERR " found cond $name\n" if DEBUG > 1;
-       my $cond = $self->low_perform($acts, lcfirst $name, $args, '');
-       return $cond ? $true : $false;
-      }
-      else {
-       print STDERR " not found\n" if DEBUG > 1;
-       $true = $self->replace_template($true, $acts) if length $true;
-       $false = $self->replace_template($false, $acts) if length $false;
-       length $args and $args = " " . $args;
-       return "$start$args:>$true$else$false$endif";
-      }
-    };
-  if ($@) {
-    my $msg = $@;
-    if ($msg =~ /\bENOIMPL\b/) {
-      print STDERR "Cond ENOIMPL\n" if DEBUG;
-      $true = $self->replace_template($true, $acts) if length $true;
-      $false = $self->replace_template($false, $acts) if length $false;
-      length $args and $args = " " . $args;
-      return "$start$args:>$true$else$false$endif";
-    }
-    print STDERR "Eval error in cond: $msg\n";
-    $msg =~ s/([<>&])/"&#".ord($1).";"/ge;
-    return "<!-- ** $msg ** -->";
-  }
-
-  return $result;
-}
-
 sub find_template {
   my ($self, $name) = @_;
 
@@ -302,86 +174,37 @@ sub include {
 
   my $filename = $self->find_template($name);
   unless ($filename) {
-    return '' if $options eq 'optional';
+    return wantarray ? ('', '' ) : '' if $options eq 'optional';
 
     print STDERR "** Could not find include code $name\n";
-    return "** cannot find include $name in path **";
+    my $error = "cannot find include $name in path";
+    return wantarray ? ( $error, undef, 1 ) : "* $error *";
   }
 
   print STDERR "Found $filename\n" if DEBUG;
 
   my $error;
   my $data = $self->_slurp($filename, \$error)
-    or return "* $error *";
+    or return wantarray ? ( $error, $filename, 1 ) : "* $error *";
   print STDERR "Included $filename >>$data<<\n"
       if DEBUG;
 
   $data = "<!-- included $filename -->$data<!-- endinclude $filename -->"
       if DEBUG;
 
-  return $data;
+  return wantarray ? ($data, $filename) : $data;
 }
 
-sub switch {
-  my ($self, $content, $acts) = @_;
-
-  print STDERR "** switch\n" if DEBUG;
-
-  my @cases = grep /\S/, split /(?=$tag_head\s*case\s)/s, $content;
-  shift @cases if @cases && $cases[0] !~ /$tag_head\s*case\s/;
-  my $case;
-  while ($case = shift @cases) {
-    my ($cond, $data) = $case =~ /$tag_head\s*case\s+(.*?)$tag_tail(.*)/s;
-
-    if ($cond eq 'default') {
-      print STDERR "  returning default\n" if DEBUG;
-      return $data;
-    }
-
-    my ($func, $args) = split ' ', $cond, 2;
-
-    print STDERR "  testing $func $args\n" if DEBUG;
-
-    local $SIG{__DIE__};
-    my $result = 
-      eval {
-       if (exists $acts->{"if$func"}) {
-         print STDERR "   found cond if$func\n" if DEBUG > 1;
-         return $self->low_perform($acts, "if$func", $args, '');
-       }
-       elsif (exists $acts->{lcfirst $func}) {
-         print STDERR "   found cond $func\n" if DEBUG > 1;
-         return $self->low_perform($acts, lcfirst $func, $args, '');
-       }
-       else {
-         print STDERR "   not found\n" if DEBUG > 1;
-         die "ENOIMPL\n";
-       }
-      };
-    if ($@) {
-      my $msg = $@;
-      if ($msg =~ /^ENOIMPL\b/) {
-       s/^($tag_head)case\s/${1}XcaseX / for $case, @cases;
-       return "<:XswitchX:>$case".join("", @cases)."<:XendswitchX:>";
-      }
+sub tag_param {
+  my ($self, $arg) = @_;
 
-      print STDERR "Eval error in cond: $msg\n";
-      $msg =~ s/([<>&])/"&#".ord($1).";"/ge;
-      return "<!-- switch cond $cond ** $msg ** -->";
+  for my $param (@{$self->{param}}) {
+    if (exists $param->{$arg}) {
+      return $param->{$arg};
     }
-    print STDERR "    result ",!!$result,"\n" if DEBUG > 1;
-    return $data if $result;
   }
 
-  return '';
-}
-
-sub tag_param {
-  my ($params, $arg) = @_;
-
-  exists $params->{$arg} or return "";
-
-  $params->{$arg};
+  return "";
 }
 
 my $parms_re = qr/\s*\[\s*(\w+)
@@ -400,6 +223,14 @@ my $parms_re = qr/\s*\[\s*(\w+)
                         )
                    \s*\]\s*/x;
 
+sub parms_re {
+  return $parms_re;
+}
+
+# dummy
+sub tag_summary {
+}
+
 sub get_parms {
   my ($templater, $args, $acts, $keep_unknown) = @_;
 
@@ -454,147 +285,125 @@ sub get_parms {
   @out;
 }
 
-sub replace_template {
-  my ($self, $template, $acts, $iter) = @_;
-
-  print STDERR "** >> replace_template\n" if DEBUG;
-
-  defined $template
-    or confess "Template must be defined";
-
-  # add any wrappers
-  my %params;
-  if ($self->{template_dir}) {
-    my $wrap_count = 0;
-    while ($template =~ /^(\s*<:\s*wrap\s+(\S+?)(?:\s+(\S.*?))?:>)/i) {
-      my $name = $2;
-      my $wrapper = $self->find_template($name);
-      unless ($wrapper) {
-       print STDERR "WARNING: Unknown wrap name: $name\n";
-       last;
-      }
-      unless (++$wrap_count < 10) {
-       print STDERR "WARNING: Exceeded wrap count trying to load $wrapper\n";
-       last;
-      }
-      my $params = $3;
-      my $error;
-      if (my $wraptext = $self->_slurp($wrapper, \$error)) {
-        $template = substr($template, length $1);
-        $wraptext =~ s/<:\s*wrap\s+here\s*:>/$template/i
-          and $template = $wraptext
-            or last;
-
-       if (defined $params) {
-         while ($params =~ s/^\s*(\w+)\s*=>\s*\"([^\"]+)\"//
-                || $params =~ s/^\s*(\w+)\s*=>\s*($parms_re)//
-                || $params =~ s/^\s*(\w+)\s*=>\s*([^\s,]+)//) {
-           my ($name, $value) = ($1, $2);
-           $value =~ s/^($parms_re)/ $self->perform($acts, $2, $3, $1) /egs;
-
-           $params{$name} = $value;
-           $params =~ s/\s*,\s*//;
-         }
-         $params =~ /^\s*$/
-           or print STDERR "WARNING: Extra data after parameters '$params'\n";
-       }
+sub errors {
+  my ($self) = @_;
+
+  return @{$self->{errors}};
+}
+
+sub start_wrap {
+  my ($self, $args) = @_;
+
+  if (@{$self->{param}} >= 10) {
+    return;
+  }
+
+  unshift @{$self->{param}}, $args;
+
+  return 1;
+}
+
+sub end_wrap {
+  my ($self) = @_;
+
+  shift @{$self->{param}};
+
+  return 11;
+}
+
+sub parse {
+  my ($self, $template, $name) = @_;
+
+  my $t = Squirrel::Template::Tokenizer->new($template, $name || "<string>",
+                                            $self);
+  my $p = Squirrel::Template::Parser->new($t, $self);
+
+  my $node = $p->parse;
+
+  push @{$self->{errors}}, $p->errors;
+
+  return $node;
+}
+
+sub parse_filename {
+  my ($self, $filename) = @_;
+
+  my $key = "Squirrel::Template::file:$filename";
+  my ($date, $size);
+
+  if ($self->{cache}) {
+    ($date, $size) = (stat $filename)[9, 7];
+
+    my $cached = $self->{cache}->get($key);
+    if ($cached) {
+      if ($cached->[0] == $date && $cached->[1] == $size) {
+       #print STDERR "Found cached $key / $date / $size\n";
+       return $cached->[2];
       }
       else {
-       print "ERROR: Unable to load wrapper $wrapper: $error\n";
+       #print STDERR "Cached but old $key / $date / $size\n";
+       $self->{cache}->delete($key);
       }
     }
   }
 
-  my $oldparam_tag = $acts->{param};
-  local $acts->{param} = $oldparam_tag || [ \&tag_param, \%params ];
-
-  if ($self->{template_dir} && !$acts->{include}) {
-    my $loops = 0;
-    1 while $template =~
-            s!$tag_head
-                \s*
-                include
-                \s+
-                ((?:\w+/)*\w+(?:\.\w+)?)
-                (?:
-                  \s+
-                  ([\w,]+)
-                )?
-                \s*
-               $tag_tail
-             ! 
-               $self->include($1,$2) 
-             !gex
-              && ++$loops < 10;
-  }
+  my $message;
+  my $text;
+
+  if (($text, $message) = $self->_slurp($filename)) {
+    unless ($message) {
+      my $parsed;
+
+      ($parsed, $message) = $self->parse($text, $filename);
+
+      if ($parsed && $self->{cache}) {
+       #print STDERR "Set $key / $date / $size\n";
+       $self->{cache}->set($key => [ $date, $size, $parsed ]);
+      }
 
-  print STDERR "Template text post include:\n---$template---\n"
-    if DEBUG;
-
-  # the basic iterator
-  if ($iter && 
-      (my ($before, $row, $after) =
-      $template =~ m/^(.*)
-           $tag_head\s+iterator\s+begin\s+$tag_tail
-            (.*)
-           $tag_head\s+iterator\s+end\s+$tag_tail
-            (.*)/sx)) {
-    until ($iter->EOF) {
-      my $temp = $row;
-      $temp =~ s/($tag_head\s*(\w+)(?:\s+([^:]*?))$tag_tail)/ $self->perform($acts, $2, $3, $1) /egx;
-      $before .= $temp;
+      return ($parsed, $message);
     }
-    $template = $before . $after;
   }
 
-  # more general iterators
-  $template =~ s/($tag_head\s*(iterator|with)\s+begin\s+(\w+)(?:\s+(.*?))?\s*$tag_tail
-                  (.*?)
-                   (?: 
-                    $tag_head\s*\2\s+separator\s+\3\s*$tag_tail
-                      (.*?)
-                    ) ?
-                 $tag_head\s*\2\s+end\s+\3\s*$tag_tail)/
-                   $self->$2($3, $4, $5, $6, $acts, $1) /segx;
-
-  # conditionals
-  my $nesting = 0; # prevents loops if result is an if statement
-  1 while $template =~ s/($tag_head\s*if\s+(\w+))(?:\s+(.*?))?$tag_tail
-                          (.*?)
-                         ($tag_head\s*or\s+\2\s*$tag_tail)
-                          (.*?)
-                         ($tag_head\s*eif\s+\2\s*$tag_tail)/
-                        $self->cond($2, $3, $acts, $1, $4, $5, $6, $7) /sgex
-                         && ++$nesting < 5;
-  $template =~ s/($tag_head\s*if([A-Z]\w*))(?:\s+(.*?))?$tag_tail
-                  (.*?)
-                 ($tag_head\s*or\s*$tag_tail)
-                  (.*?)
-                 ($tag_head\s*eif\s*$tag_tail)/
-                $self->cond($2, $3, $acts, $1, $4, $5, $6, $7) /sgex;
-
-  $nesting = 0;
-  1 while $template =~ s/$tag_head\s*switch\s*$tag_tail
-                         ((?:(?!<:-?\s*switch).)*?)
-                         $tag_head\s*endswitch\s*$tag_tail/
-                          $self->switch($1, $acts)/segx
-                            && ++$nesting < 5;
-  $template =~ s/($tag_head)XswitchX($tag_tail)/${1}switch$2/g;
-  $template =~ s/($tag_head)XendswitchX($tag_tail)/${1}endswitch$2/g;
-  $template =~ s/($tag_head)XcaseX /${1}case /g;
-
-  $template =~ s/($tag_head\s*(\w+)(?:\s+(.*?\s*(?:\|\S+?)?))?$tag_tail)/ 
-    $self->perform($acts, $2, $3, $1) /segx;
-
-  # replace any wrap parameters
-  # now done elsewhere
-  #$template =~ s/(<:\s*param\s+(\w+)\s*:>)/
-  #  exists $params{$2} ? $params{$2} : $1 /eg;
-
-
-  print STDERR "** << replace_template\n" if DEBUG;
-
-  return $template;
+  return (undef, $message);
+}
+
+sub parse_file {
+  my ($self, $name) = @_;
+
+  my $message;
+  my $filename = $self->find_template($name);
+  if ($filename) {
+    return $self->parse_filename($filename);
+  }
+  else {
+    $message = "File $name not found";
+  }
+
+  return (undef, $message);
+}
+
+sub replace {
+  my ($self, $parsed, $acts) = @_;
+
+  $self->{errors} = [];
+
+  my $oldparam_tag = $acts->{param};
+  local $acts->{param} = $oldparam_tag || [ tag_param => $self ];
+
+  my $processor = Squirrel::Template::Processor->new($acts, $self);
+
+  return wantarray
+    ? $processor->process($parsed)
+      : join("", $processor->process($parsed));
+}
+
+sub replace_template {
+  my ($self, $template, $acts, $iter, $name) = @_;
+
+  my $parsed = $self->parse($template, $name);
+
+  return scalar $self->replace($parsed, $acts, $name);
 }
 
 sub show_page {
@@ -618,17 +427,19 @@ sub show_page {
     $file
       or die "Cannot find template $page";
   }
-  my $error;
-  my $template = $self->_slurp($file, $error)
-    or die "Cannot open template $file: $!";
 
-  my $result = $self->replace_template($template, $acts, $iter);
+  my ($parsed, $error) = $self->parse_filename($file);
+
+  $error
+    and die $error;
+
+  my $result = scalar $self->replace($parsed, $acts, $file);
+
   print STDERR "<< show_page\n" if DEBUG;
 
   return $result;
 }
 
-1;
 
 __END__
 
@@ -638,13 +449,24 @@ __END__
 
 =head1 SYNOPSIS
 
+  use Squirrel::Template;
+  my $templater = Squirrel::Template->new(template_dir => $some_dir);
+  my $result = $templater->show_page($base, $filename, \%acts, undef, $alt);
+  my $result = $templater->replace_template($text, \%acts, undef, $display_name);
+  my @errors = $templater->errors;
+  my @args = $templater->get_parms($args, \%acts, $keep_unknown)
+
 =head1 DESCRIPTION
 
+BSE's template engine.
+
 =head1 METHODS
 
 =over 4
 
-=item $templ = Squirrel::Template->new(%opts);
+=item new()
+
+  $templater = Squirrel::Template->new(%opts);
 
 Create a new templating object.
 
@@ -659,99 +481,337 @@ message rather than being left in place.
 
 =item template_dir
 
-Used by the wrapper mechanism to find wrapper templates.  See
-L<WRAPPING> below.  This can be either a scalar, or a reference to an
-array of locations to search for the wrapper.  This is also used for
-the <:include filename:> mechanism.
+Used to find wrapper and include templates.  This can be either a
+scalar, or a reference to an array of locations to search for the
+wrapper.
+
+=item utf8
+
+If this is true then the template engine works in unicode internally.
+Template files are read into memory using the charecter set specified
+by C<charset>.
+
+=item charset
+
+Ignored unless C<utf8> is true.  Specifies the character encoding used
+by template files.  Defaults to C<"utf-8">.
+
+=item cache
+
+A BSE::Cache object to use for caching compiled templates.  Note that
+templates are currently only cached by filename.
 
 =back
 
-=item $text = $templ->show_page($base, $template, $acts, $iter)
+=item show_page()
+
+  $text = $templ->show_page($base, $template, \%acts, $iter)
 
 Performs template replacement on the text from the file $template in
 directory $base.
 
-=item $text = $templ->replace_template($intext, $acts, $iter)
+=item replace_template()
+
+  $text = $templ->replace_template($intext, \%acts, $iter, $name)
+
+Performs template replacement on C<$intext> using the tags in
+C<%acts>.  C<$iter> is accepted only for backward compatibility and it
+no longer used.  Errors are reported as if C<$intext> had been read
+from a file called C<$name>.
+
+=item errors()
+
+Return errors from the last show_page() or replace_template().
+
+This can include:
+
+=over
+
+=item *
+
+tokenization errors - an unknown token was found in the template
+
+=item *
+
+parsing errors - mismatched if/eif, etc
+
+=item *
+
+processing errors - die from tag handlers, etc
 
-Performs template replacement on $intext.
+=item *
+
+file errors - missing include or wrap files, and recursion from those.
 
 =back
 
-=head1 TEMPLATES
+Returns a list of error tokens, each of which is an array reference
+with:
 
-=over 4
+=over
+
+=item *
+
+The text "error".
+
+=item *
 
-=item <: name args :>
+An template text that caused the error.  This may be blank some cases.
 
-Replaced with $acts->{name}->(args)
+=item *
 
-=item <: iterator begin name args :> text <: iterator separator name :> separator <: iterator end name :>
+The line number.
 
-Replaced with repeated templating of text separated by separator while
-$acts->{iterator_name}->($args, $name) is true.
+=item *
 
+The filename.  If you called replace_template() this will be the
+C<$name> supplied to replace_template().
 
-=item <: iterator begin name args :> text <: iterator end name :>
+=item *
 
-Replaced with repeated templating of text while
-$acts->{iterate_name}->($args, $name) is true.
+An error message.
 
-This may be nested or repeated.
+=back
 
-=item <: iterator begin :> text <: iterator end :>
+=item get_parms()
 
-Replaced with repeated templating of text while $iter->EOF is true.
+  my @args = get_parms($args, $acts, $keep_unknown)
 
-=item <: ifname args :> true <: or :> false <: eif :>
+Does simple and stupid processing of C<$args> parsing it for a list of
+arguments.
 
-Emits true if $acts->{ifname}->($args) is true, otherwise the false text.
+Possible arguments that are parsed are:
 
-=item <: if name args :> true <: or name :> false <: eif name :>
+=over
 
-Emits true if $acts->{ifname}->($args) is true, otherwise the false text.
+=item *
+
+C<[> I<tagname> I<arguments> C<]> - return the results of calling the
+specified tag.  Only a limited amount of nesting is parsed.
+
+=item *
 
-Has the advantage that it can be nested (the other form doesn't
-support nesting - this isn't a proper parser.
+C<">I<text>C<"> - quoted text.  No escaping is done on the text.
+
+=item *
+
+I<text> - plain text not containing any C<[> or C<]>.
 
 =back
 
-=head1 WRAPPING
+Returns a list of parsed arguments.
 
-If you define the template_dir option when you create your templating
-object, then a mechnism to wrap the current template with another is
-enabled.
+If I<tagname> in C<$args> isn't defined, dies with an C<ENOIMPL\n>
+message.
 
-For the wrapping to occur:
+=back
 
-=over 4
+=head1 TEMPLATE SYNTAX
+
+In general, if the tag has no definition the original tag directive is
+left in place.  If the tag has sub-components (like C<if> or
+C<iterate>) tag replacement is done on the sub-components.
+
+Template directives start with C<< <: >>, if a C<-> is found
+immediately after the C<:> any whitespace before the tag is also
+replaced.
+
+Template directives end with C<< :> >>, if a C<-> if found immediately
+before the C<:> any whitespace after the tag is also replaced.
+
+eg.
+
+  <: tag foo -:>  sample  <:-  tag bar :>
+
+is treated the same as:
+
+  <: tag foo :>sample<: tag bar :>
+
+Directives available in templates:
+
+=over
+
+=item  *
+
+C<< <: I<name> I<args> :> >>
+
+Replaced with the value of the tag.  See L</Simple tag evaluation>.
 
 =item *
 
-The template specified in the call to replace_template() or
-show_page() needs to start with:
+C<< <: iterator begin I<name> I<args> :> I<text> <: iterator separator I<name> :> I<separator> <: iterator end I<name> :> >>
+
+C<< <: iterator begin I<name> I<args> :> I<text> <: iterator end I<name> :> >>
 
-<: wrap I<templatename> :>
+Replaced with repeated templating of I<text> separated by I<separator>.
+
+See L</Iterator tag evaluation>.
 
 =item *
 
-The template specified in the <: wrap ... :> tag must exist in the
-directory specified by the I<template_dir> option.
+C<< <: ifI<Name> I<args> :> I<true> <: or :> I<false> <: eif :> >>
+
+C<< <: if I<Name> I<args> :> I<true> <: or I<Name> :> I<false> <: eif I<Name> :> >>
+
+Emits I<true> if the tag evaluates to a true value, otherwise the
+I<false> text.  See L</Conditional tag evaluation>.
+
+Note that only the C<if> now requires the C<Name>.  The C<or> and
+C<eif> may include the name, but it is not required.  If the C<Name>
+is supplied it must match the C<if> C<Name> or an error will be
+returned.
+
+=item *
+
+C<< <: with begin I<name> I<args> :> I<replaced> <: with end I<name> :> >>
+
+Calls C<< $acts->{"with_I<name>"}->($args, $replaced, "", \%acts,
+I<$name>, $templaer) >> where C<$replaced> is the processed text and
+inserts that.
+
+=item *
+
+C<< <: # I<your comment> :> >>
+
+A comment, not included in the output.
+
+=item *
+
+C<< <:switch:><:case I<Name> I<optional-args> :>I<content> ... <:endswitch:> >>
+
+Replaced with the first matching conditional where C<< <:case I<Name>
+I<optional-args> :> >> is treated like an C<if>.
+
+A C<< <:case default:> >> is always true.
 
 =item *
 
-The template specified in the <: wrap ... :> tag must contain a:
+C<< <: include I<filename> I<options> :> >>
 
-   <: wrap here :>
+Replaced with the content of the supplied filename.
 
-tag.
+If the file I<filename> is not found, this results in an error being
+inserted (and reported via L</errors()>) unless I<options> contains
+C<optional>.
+
+No more than 10 levels of include can be nested.
+
+=item *
+
+C<< <: wrap I<templatename> :> I<wrapped> <:endwrap:> >>
+
+C<< <: wrap I<templatename> I<name> => I<value>, ... :> I<wrapped> <:endwrap> >>
+
+The C<< <:endwrap:> >> is optional.  A wrapper will be terminated by
+end of file if not otherwise terminated.
+
+Processes I<templatename> as a template.  Within that template C<< <:
+wrap here :> >> will be replaced with I<wrapped>.
+
+The values specified by the C<< I<name> => I<value> >> are used to
+populate the value of the built-in param tag.
+
+Wrapping can be nested up to 10 levels.
+
+=item *
+
+C<< <: wrap here :> >>
+
+Returns the wrapped content within a wrapper template.  Returns an
+error if not within a wrapper template.
+
+=back
+
+=head1 TAG EVALUATION
+
+=head2 Simple tag evaluation
+
+Tag definitions in C<%acts> can be in any of five forms:
+
+=over
+
+=item *
+
+A simple scalar - the value of the scalar is returned.
+
+=item *
+
+A scalar reference - the referred to scalar is returned.
+
+=item *
+
+A code reference - the code reference is called as:
+
+  $code->($args, \%acts, $tagname, $templater)
+
+=item *
+
+An array reference starting with a code reference, followed by
+arguments, eg C<< [ \&tag_sometag, $foo, $bar ] >>.  This is called
+as:
+
+  $code->($foo, $bar, \%acts, $tagname, $templater)
+
+=item *
+
+An array reference starting with a scalar, followed by an object or
+class name, followed by arguments, eg C<< [ method => $obj, $foo, $bar
+] >>.  This is called as:
+
+  $obj->$method($foo, $bar, \%acts, $tagname, $templater)
+
+=back
+
+A warning is produced if the tag returns an undef value.
+
+=head2 Conditional tag evaluation
+
+Given a C<< ifI<SomeName> >>, does L</Simple tag evaluation> on the
+first tag of C<< ifI<SomeName> >> or C<< I<someName> >> found.
+
+Unlike simple tag evaluation this does not warn if the result is undef.
+
+=head2 Iterator tag evaluation
+
+This uses two members of C<%acts>:
+
+=over
+
+=item *
+
+C<< iterate_I<name>_reset >> - called to start iteration.  Optional
+but recommended.
+
+=item *
+
+C<< iterate_I<name> >> - called until it returns false for each
+iteration.
 
 =back
 
-The current template text is then replaced with the contents of the
-template specified by I<templatename>, with the <: wrap here :>
-replaced by the original template text.
+Either can be any of:
 
-This is then repeated for the new template text.
+=over
+
+=item *
+
+a code reference - called as:
+
+  $code->($args, \%acts, $name, $templater)
+
+=item *
+
+an array reference starting with a code reference:
+
+  $arrayref->[0]->(@{$arrayref}[1 .. $#$arrayref], \%acts, $name, $templater);
+
+=item *
+
+an array reference starting with a scalar:
+
+  $arrayref->[1]->$method(@{$arrayref}[2 .. $#$arrayref], \%acts, $name, $templater);
+
+=back
 
 =head1 SPECIAL ACTIONS
 
@@ -770,6 +830,16 @@ function.
 
 =head1 SEE ALSO
 
-  Squirrel::Row(3p), Squirel::Table(3p)
+Squirrel::Row(3p), Squirel::Table(3p)
+
+=head1 HISTORY
+
+Started as a quick hack from seeing the hacky template replacement
+done by an employer.
+
+It grew.
+
+Largely rewritten in 2012 to avoid processing the same string a few
+hundred times.
 
 =cut
diff --git a/site/cgi-bin/modules/Squirrel/Template/Constants.pm b/site/cgi-bin/modules/Squirrel/Template/Constants.pm
new file mode 100644 (file)
index 0000000..f7b7a47
--- /dev/null
@@ -0,0 +1,54 @@
+package Squirrel::Template::Constants;
+use strict;
+use Exporter qw(import);
+
+our $VERSION = "1.001";
+
+sub _define_sequence {
+  my ($keys, $start) = @_;
+
+  $start ||= 0;
+
+  require constant;
+  for my $key (@$keys) {
+    constant->import($key => $start++);
+  }
+}
+
+my @token_base = qw(TOKEN_TYPE TOKEN_ORIG TOKEN_LINE TOKEN_FILENAME);
+_define_sequence(\@token_base, 0);
+my @token_generic = qw(TOKEN_TAG_NAME TOKEN_TAG_ARGS);
+_define_sequence(\@token_generic, 4);
+my @token_error = qw(TOKEN_ERROR_MESSAGE);
+_define_sequence(\@token_error, 4);
+
+my @node_base = qw(NODE_TYPE NODE_ORIG NODE_LINE NODE_FILENAME NODE_TAG_NAME NODE_TAG_ARGS);
+_define_sequence(\@node_base, 0);
+my @node_iter = qw(NODE_ITERATOR_LOOP NODE_ITERATOR_SEPARATOR NODE_ITERATOR_SEPTOK NODE_ITERATOR_ENDTOK);
+_define_sequence(\@node_iter, 6);
+my @node_cond = qw(NODE_COND_TRUE NODE_COND_FALSE NODE_COND_OR NODE_COND_EIF);
+_define_sequence(\@node_cond, 6);
+my @node_comp = qw(NODE_COMP_FIRST);
+_define_sequence(\@node_comp, 4);
+my @node_with = qw(NODE_WITH_CONTENT NODE_WITH_END);
+_define_sequence(\@node_with, 6);
+my @node_wrap = qw(NODE_WRAP_FILENAME NODE_WRAP_ARGS NODE_WRAP_CONTENT);
+_define_sequence(\@node_wrap, 4);
+my @node_switch = qw(NODE_SWITCH_CASES NODE_SWITCH_END);
+_define_sequence(\@node_switch, 5);
+my @node_error = qw(NODE_ERROR_MESSAGE);
+_define_sequence(\@node_error, 4);
+
+our %EXPORT_TAGS =
+  (
+   token => [ @token_base, @token_generic, @token_error ],
+   node =>
+   [
+    @node_base, @node_iter, @node_cond, @node_comp, @node_with,
+    @node_wrap, @node_switch, @node_error
+   ],
+  );
+
+our @EXPORT_OK = ( map @$_, values %EXPORT_TAGS );
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Deparser.pm b/site/cgi-bin/modules/Squirrel/Template/Deparser.pm
new file mode 100644 (file)
index 0000000..d65a35d
--- /dev/null
@@ -0,0 +1,94 @@
+package Squirrel::Template::Deparser;
+use strict;
+use Squirrel::Template::Constants qw(:node);
+
+our $VERSION = "1.000";
+
+sub deparse {
+  my ($class, $item) = @_;
+
+  my $method = "deparse_$item->[NODE_TYPE]";
+
+  return $class->$method($item);
+}
+
+sub deparse_comp {
+  my ($class, $item) = @_;
+
+  return join("", map $class->deparse($_), @{$item}[NODE_COMP_FIRST .. $#$item]);
+}
+
+sub deparse_cond {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG]
+    . $class->deparse($item->[NODE_COND_TRUE])
+      . "<:or:>"
+       . $class->deparse($item->[NODE_COND_FALSE])
+         . "<:eif:>";
+}
+
+sub deparse_iterator {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG] . $class->deparse($item->[NODE_ITERATOR_LOOP])
+    . "<:iterator separator $item->[NODE_TAG_NAME]:>"
+      . $class->deparse($item->[NODE_ITERATOR_SEPARATOR])
+    . "<:iterator end $item->[NODE_TAG_NAME]:>";
+}
+
+sub deparse_with {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG] . $class->deparse($item->[NODE_WITH_CONTENT])
+    . "<:with end $item->[NODE_TAG_NAME]:>";
+}
+
+sub deparse_wrap {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG] . $class->deparse($item->[NODE_WRAP_CONTENT])
+    . "<:endwrap:>";
+}
+
+sub deparse_switch {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG]
+    . join("", map {;
+      $_->[0][NODE_ORIG] . $class->deparse($_->[1])
+    } @{$item->[NODE_SWITCH_CASES]})
+      . "<:endswitch:>";
+}
+
+sub deparse_content {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG];
+}
+
+sub deparse_tag {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG];
+}
+
+sub deparse_wraphere {
+  my ($class, $item) = @_;
+
+  return $item->[NODE_ORIG];
+}
+
+sub deparse_error {
+  my ($class, $item) = @_;
+
+  return "";
+}
+
+sub deparse_empty {
+  my ($class, $item) = @_;
+
+  return "";
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Parser.pm b/site/cgi-bin/modules/Squirrel/Template/Parser.pm
new file mode 100644 (file)
index 0000000..c2377c8
--- /dev/null
@@ -0,0 +1,384 @@
+package Squirrel::Template::Parser;
+use strict;
+use Squirrel::Template::Constants qw(:token :node);
+
+our $VERSION = "1.004";
+
+use constant TOK => 0;
+use constant TMPLT => 1;
+use constant ERRORS => 2;
+
+use constant TRACE => 0;
+
+sub new {
+  my ($class, $tokenizer, $templater) = @_;
+
+  return bless [ $tokenizer, $templater, [] ], $class;
+}
+
+sub parse {
+  my ($self) = @_;
+
+  my @results;
+
+  while (1) {
+    push @results, $self->_parse_content;
+
+    my $tok = $self->[TOK]->get;
+
+    if (!$tok) {
+      die "Internal error: Unexpected end of tokens\n";
+    }
+
+    last if $tok->[TOKEN_TYPE] eq 'eof';
+
+    push @results, $self->_error_mod($tok, "Expected eof but found $tok->[TOKEN_TYPE]");
+  }
+
+  return @results > 1 ? $self->_comp(@results) : $results[0];
+}
+
+sub _parse_content {
+  my ($self) = @_;
+
+  my @result;
+  my $token;
+  TOKEN:
+  while (my $token = $self->[TOK]->get) {
+    my $type = $token->[TOKEN_TYPE];
+    print STDERR "NEXT: $type\n" if TRACE;
+    if ($type eq 'content' || $type eq 'tag' || $type eq 'wraphere') {
+      push @result, $token;
+    }
+    elsif ($type eq 'if') {
+      push @result, $self->_parse_if($token);
+    }
+    elsif ($type eq 'itbegin') {
+      push @result, $self->_parse_iterator($token);
+    }
+    elsif ($type eq 'withbegin') {
+      push @result, $self->_parse_with($token);
+    }
+    elsif ($type eq 'switch') {
+      push @result, $self->_parse_switch($token);
+    }
+    elsif ($type eq 'wrap') {
+      push @result, $self->_parse_wrap($token);
+    }
+    elsif ($type eq 'error') {
+      push @result, $self->_parse_error($token);
+    }
+    elsif ($type eq 'comment') {
+      # discard comments
+    }
+    else {
+      $self->[TOK]->unget($token);
+      last TOKEN;
+    }
+  }
+
+  if (@result > 1) {
+    return $self->_comp(@result);
+  }
+  elsif (@result) {
+    return $result[0];
+  }
+  else {
+    return $self->_empty($self->[TOK]->peek);
+  }
+}
+
+sub _empty {
+  my ($self, $tok) = @_;
+
+  return [ empty => "", $tok->[TOKEN_LINE], $tok->[TOKEN_FILENAME] ];
+}
+
+sub _error {
+  my ($self, $tok, $message) = @_;
+
+  print STDERR "ERROR: $message\n" if TRACE;
+
+  my $error = [ error => "", $tok->[TOKEN_LINE], $tok->[TOKEN_FILENAME], $message ];
+  push @{$self->[ERRORS]}, $error;
+
+  return $error;
+}
+
+# returns the token transformed into an error message, ie the token is being replaced
+
+sub _error_mod {
+  my ($self, $tok, $message) = @_;
+
+  my $error = [ error => $tok->[TOKEN_ORIG], $tok->[TOKEN_LINE], $tok->[TOKEN_FILENAME], $message ];
+  push @{$self->[ERRORS]}, $error;
+
+  return $error;
+}
+
+sub _dummy {
+  my ($self, $base, $type, $orig) = @_;
+
+  return [ $type => $orig, $base->[TOKEN_LINE], $base->[TOKEN_FILENAME] ];
+}
+
+sub _comp {
+  my ($self, @parts) = @_;
+
+  my @result = ( comp => "", $parts[0][TOKEN_LINE], $parts[0][TOKEN_FILENAME] );
+
+  for my $part (@parts) {
+    if ($part->[0] eq "comp") {
+      push @result, @{$part}[4 .. $#$part];
+    }
+    else {
+      push @result, $part;
+    }
+  }
+
+  return \@result;
+}
+
+sub _parse_if {
+  my ($self, $if) = @_;
+
+  my $true = $self->_parse_content;
+  my $or = $self->[TOK]->get;
+  my $eif;
+  my $false;
+  my @errors;
+  if ($or->[TOKEN_TYPE] eq 'or') {
+    if ($or->[TOKEN_TAG_NAME] ne "" && $or->[TOKEN_TAG_NAME] ne $if->[TOKEN_TAG_NAME]) {
+      push @errors, $self->_error($or, "'or' or 'eif' for 'if $if->[TOKEN_TAG_NAME]' starting $if->[TOKEN_FILENAME]:$if->[TOKEN_LINE] expected but found 'or $or->[TOKEN_TAG_NAME]'");
+    }
+    $false = $self->_parse_content;
+
+    $eif = $self->[TOK]->get;
+    if ($eif->[TOKEN_TYPE] eq 'eif') {
+      if ($eif->[TOKEN_TAG_NAME] ne "" && $eif->[TOKEN_TAG_NAME] ne $if->[TOKEN_TAG_NAME]) {
+       push @errors, $self->_error($or, "'eif' for 'if $if->[TOKEN_TAG_NAME]' starting $if->[TOKEN_FILENAME]:$if->[TOKEN_LINE] expected but found 'eif $eif->[TOKEN_TAG_NAME]'");
+      }
+      # fall through
+    }
+    else {
+      push @errors, $self->_error($eif, "Expected 'eif' tag for if starting $if->[TOKEN_FILENAME]:$if->[TOKEN_LINE] but found $eif->[TOKEN_TYPE]");
+      $self->[TOK]->unget($eif);
+      $eif = $self->_dummy($eif, eif => "<:eif:>");
+    }
+  }
+  elsif ($or->[TOKEN_TYPE] eq 'eif') {
+    if ($or->[TOKEN_TAG_NAME] ne "" && $or->[TOKEN_TAG_NAME] ne $if->[TOKEN_TAG_NAME]) {
+      push @errors, $self->_error($or, "'or' or 'eif' for 'if $if->[TOKEN_TAG_NAME]' starting $if->[TOKEN_FILENAME]:$if->[TOKEN_LINE] expected but found 'eif $or->[TOKEN_TAG_NAME]'");
+    }
+
+    $eif = $or;
+    $or = $false = $self->_empty($or);
+  }
+  else {
+    push @errors, $self->_error($or, "Expected 'or' or 'eif' tag for if starting $if->[TOKEN_FILENAME]:$if->[TOKEN_LINE] but found $or->[TOKEN_TYPE]");
+    $self->[TOK]->unget($or);
+    $or = $false = $self->_empty($or);
+    $eif = $self->_dummy($or, eif => "");
+  }
+  @{$if}[NODE_TYPE, NODE_COND_TRUE, NODE_COND_FALSE, NODE_COND_OR, NODE_COND_EIF] = ( "cond", $true, $false, $or, $eif );
+  if (@errors) {
+    return $self->_comp($if, @errors);
+  }
+  else {
+    return $if;
+  }
+}
+
+sub _parse_iterator {
+  my ($self, $start) = @_;
+
+  my $name = $start->[TOKEN_TAG_NAME];
+  my $loop = $self->_parse_content;
+  my $septok = $self->[TOK]->get;
+  my $endtok;
+  my $sep;
+  my @errors;
+  if ($septok->[TOKEN_TYPE] eq 'itsep') {
+    if ($septok->[TOKEN_TAG_NAME] ne $name) {
+      push @errors, $self->_error($septok, "Expected 'iterator separator $name' for 'iterator begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found 'iterator separator $septok->[TOKEN_TAG_NAME]'");
+    }
+    $sep = $self->_parse_content;
+    $endtok = $self->[TOK]->get;
+    if ($endtok->[TOKEN_TYPE] eq 'itend') {
+      if ($endtok->[TOKEN_TAG_NAME] ne $name) {
+       push @errors, $self->_error($endtok, "Expected 'iterator end $name' for 'iterator begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found 'iterator end $endtok->[TOKEN_TAG_NAME]'");
+      }
+    }
+    else {
+      push @errors, $self->_error($endtok, "Expected 'iterator end $name' for 'iterator begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found $endtok->[TOKEN_TYPE]");
+      $self->[TOK]->unget($endtok);
+      $endtok = $self->_dummy($endtok, "itend", "<:iterator end $name:>");
+    }
+  }
+  elsif ($septok->[TOKEN_TYPE] eq 'itend') {
+    $sep = $self->_empty($septok);
+    if ($septok->[TOKEN_TAG_NAME] ne $name) {
+      push @errors, $self->_error($septok, "Expected 'iterator end $name' for 'iterator begin $start->[TOKEN_TAG_NAME]' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found 'iterator end $septok->[TOKEN_TAG_NAME]'");
+    }
+    $endtok = $septok;
+    $septok = $self->_empty($endtok);
+  }
+  else {
+    push @errors, $self->_error($septok, "Expected 'iterator separator $name' or 'iterator end $name' for 'iterator begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found $septok->[TOKEN_TYPE]");
+    $self->[TOK]->unget($septok);
+    $sep = $self->_empty($septok);
+    $septok = $self->_empty($septok);
+    $endtok = $self->_dummy($septok, itend => "<:iterator end $name:>");
+  }
+  @{$start}[NODE_TYPE, NODE_ITERATOR_LOOP, NODE_ITERATOR_SEPARATOR, NODE_ITERATOR_SEPTOK, NODE_ITERATOR_ENDTOK] =
+    ( iterator => $loop, $sep, $septok, $endtok );
+  if (@errors) {
+    return $self->_comp($start, @errors);
+  }
+  else {
+    return $start;
+  }
+}
+
+sub _parse_with {
+  my ($self, $start) = @_;
+
+  my $name = $start->[TOKEN_TAG_NAME];
+  my $loop = $self->_parse_content;
+  my $end = $self->[TOK]->get;
+  my @errors;
+  if ($end->[TOKEN_TYPE] eq 'withend') {
+    if ($end->[TOKEN_TAG_NAME] ne $name) {
+      push @errors, $self->_error($end, "Expected 'with end $name' for 'with begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found 'with end $end->[TOKEN_TAG_NAME]'");
+    }
+  }
+  else {
+    push @errors, $self->_error($end, "Expected 'with end $name' for 'with begin $name' at $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found $end->[TOKEN_TYPE]");
+    $self->[TOK]->unget($end);
+    $end = $self->_dummy($end, withend => "<:with end $start->[TOKEN_TAG_NAME]:>");
+  }
+  @{$start}[NODE_TYPE, NODE_WITH_CONTENT, NODE_WITH_END] = ( "with", $loop, $end );
+  if (@errors) {
+    return $self->_comp($start, @errors);
+  }
+  else {
+    return $start;
+  }
+}
+
+sub _parse_switch {
+  my ($self, $start) = @_;
+
+  my $ignored = $self->_parse_content;
+  my $error;
+  my @cases;
+  my $tok;
+  CASE:
+  while ($tok = $self->[TOK]->get) {
+    if ($tok->[TOKEN_TYPE] eq 'case') {
+      my $case = $self->_parse_content;
+      push @cases, [ $tok, $case ];
+    }
+    elsif ($tok->[TOKEN_TYPE] eq 'endswitch') {
+      last CASE;
+    }
+    else {
+      $self->[TOK]->unget($tok);
+      $error = $self->_error($tok, "Expected case or endswitch for switch starting $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found $tok->[TOKEN_TYPE]");
+      $tok = $self->_dummy($tok, endswitch => "<:endswitch:>");
+      last CASE;
+    }
+  }
+
+  @{$start}[NODE_SWITCH_CASES, NODE_SWITCH_END] = ( \@cases, $tok );
+
+  if ($error) {
+    return $self->_comp($start, $error);
+  }
+  else {
+    return $start;
+  }
+}
+
+sub _parse_wrap {
+  my ($self, $start) = @_;
+
+  my $content = $self->_parse_content;
+  my $end = $self->[TOK]->get;
+  $end or $DB::single = 1;
+  my $error;
+  if ($end->[TOKEN_TYPE] eq 'endwrap') {
+    # nothing to do
+  }
+  elsif ($end->[TOKEN_TYPE] eq 'eof') {
+    $self->[TOK]->unget($end);
+  }
+  else {
+    $self->[TOK]->unget($end);
+    $error = $self->_error($end, "Expected 'endwrap' or eof for wrap started $start->[TOKEN_FILENAME]:$start->[TOKEN_LINE] but found $end->[TOKEN_TYPE]");
+  }
+  $start->[NODE_WRAP_CONTENT] = $content;
+
+  if ($error) {
+    return $self->_comp($start, $error);
+  }
+  else {
+    return $start;
+  }
+}
+
+sub _parse_error {
+  my ($self, $error) = @_;
+
+  push @{$self->[ERRORS]}, $error;
+
+  return $error;
+}
+
+sub errors {
+  my ($self) = @_;
+
+  return @{$self->[ERRORS]};
+}
+
+1;
+
+=head1 NAME
+
+Squirrel::Template::Parser - parse a stream of tokens from a template
+
+=head1 SYNOPSIS
+
+  use Squirrel::Template;
+  my $t = Squirrel::Template::Tokenizer->new($text, $filename, $templater);
+  my $p = Squirrel::Template::Parser->new($t, $templater);
+
+  my $parse_tree = $p->parse;
+
+  my @errors = $p->errors;
+
+=head1 DESCRIPTION
+
+Process the stream of tokens from a L<Squirrel::Template::Tokenizer>
+object into a parse tree.
+
+=head1 METHODS
+
+=over
+
+=item new($tokenizer, $templater)
+
+Create a new parser.
+
+=item parse()
+
+Parse the stream of tokens and return a parse tree.
+
+=item errors()
+
+Returns any errors encountered parsing the tree as error tokens.
+
+=back
+
+=cut
+
diff --git a/site/cgi-bin/modules/Squirrel/Template/Processor.pm b/site/cgi-bin/modules/Squirrel/Template/Processor.pm
new file mode 100644 (file)
index 0000000..ff637f6
--- /dev/null
@@ -0,0 +1,355 @@
+package Squirrel::Template::Processor;
+use strict;
+use Squirrel::Template::Constants qw(:node);
+
+our $VERSION = "1.006";
+
+use constant ACTS => 0;
+use constant TMPLT => 1;
+use constant PARMS => 2;
+use constant WRAPPED => 3;
+
+sub new {
+  my ($class, $acts, $tmplt, $wrapped) = @_;
+
+  return bless [ $acts, $tmplt, {}, $wrapped ];
+}
+
+# return an error node matching the supplied node
+sub _error {
+  my ($self, $node, $message) = @_;
+
+  my $error = [ error => "", $node->[NODE_LINE], $node->[NODE_FILENAME], $message ];
+
+  return $self->_process_error($error);
+}
+
+sub process {
+  my ($self, $node) = @_;
+
+  my $method = "_process_$node->[NODE_TYPE]";
+  return $self->$method($node);
+}
+
+sub _process_content {
+  my ($self, $node) = @_;
+
+  return $node->[NODE_ORIG];
+}
+
+sub _process_empty {
+  my ($self, $node) = @_;
+
+  return;
+}
+
+sub _process_error {
+  my ($self, $node) = @_;
+
+  return "* " . $node->[NODE_ERROR_MESSAGE] . " *";
+}
+
+sub _process_cond {
+  my ($self, $node) = @_;
+
+  local $SIG{__DIE__};
+  my $acts = $self->[ACTS];
+  my $cond;
+  my $name = $node->[NODE_TAG_NAME];
+  my @errors;
+  my $result =
+    eval {
+      if (exists $acts->{"if$name"}) {
+       #print STDERR " found cond if$name\n" if DEBUG > 1;
+       $cond = !!$self->[TMPLT]->low_perform($acts, "if$name", $node->[NODE_TAG_ARGS], undef);
+      }
+      elsif (exists $acts->{lcfirst $name}) {
+       #print STDERR " found cond $name\n" if DEBUG > 1;
+       $cond = !!$self->[TMPLT]->low_perform($acts, lcfirst $name, $node->[NODE_TAG_ARGS], undef);
+      }
+    };
+  if ($@) {
+    my $msg = $@;
+    if ($msg !~ /\bENOIMPL\b/) {
+      @errors = $self->_error($node, $msg);
+    }
+  }
+  if (defined $cond) {
+    return (@errors, $self->process($cond ? $node->[NODE_COND_TRUE]
+                                   : $node->[NODE_COND_FALSE]));
+  }
+  else {
+    return (@errors, $node->[NODE_ORIG], $self->process($node->[NODE_COND_TRUE]), $node->[NODE_COND_OR][NODE_ORIG], $self->process($node->[NODE_COND_FALSE]), $node->[NODE_COND_EIF][NODE_ORIG]);
+  }
+}
+
+sub _process_iterator {
+  my ($self, $node) = @_;
+
+  my $name = $node->[NODE_TAG_NAME];
+  my $args = $node->[NODE_TAG_ARGS];
+
+  my $entry = $self->[ACTS]{"iterate_$name"};
+  if ($entry) {
+    my $reset = $self->[ACTS]{"iterate_${name}_reset"};
+    my ($resetf, @rargs);
+    if ($reset) {
+      if (ref $reset eq 'ARRAY') {
+       ($resetf, @rargs) = @$reset;
+      }
+      else {
+       $resetf = $reset;
+      }
+    }
+
+    my ($entryf, @eargs);
+    if (ref $entry eq 'ARRAY') {
+      ($entryf, @eargs) = @$entry;
+    }
+    else {
+      $entryf = $entry;
+    }
+
+    if ($resetf) {
+      if (ref $resetf) {
+       #print STDERR "  resetting (func)\n" if DEBUG > 1;
+       $resetf->(@rargs, $args, $self->[ACTS], $name, $self->[TMPLT]);
+      }
+      else {
+       my $obj = shift @rargs;
+       #print STDERR "  resetting (method) $obj->$resetf\n" if DEBUG > 1;
+       $obj->$resetf(@rargs, $args, $self->[ACTS], $name, $self->[TMPLT]);
+      }
+      #print STDERR "  reset done\n" if DEBUG > 1;
+    }
+    my $eobj;
+    ref $entryf or $eobj = shift @eargs;
+    my @result;
+    my $index = 0;
+    while ($eobj ? $eobj->$entryf(@eargs, $name, $args)
+          : $entryf->(@eargs, $name, $args)) {
+      push @result, $self->process($node->[NODE_ITERATOR_SEPARATOR])
+       if $index;
+      push @result, $self->process($node->[NODE_ITERATOR_LOOP]);
+      ++$index;
+    }
+    return @result;
+  }
+  else {
+    return
+      (
+       $node->[NODE_ORIG],
+       $self->process($node->[NODE_ITERATOR_LOOP]),
+       $node->[NODE_ITERATOR_SEPTOK][NODE_ORIG],
+       $self->process($node->[NODE_ITERATOR_SEPARATOR]),
+       $node->[NODE_ITERATOR_ENDTOK][NODE_ORIG]
+      );
+  }
+}
+
+sub _process_with {
+  my ($self, $node) = @_;
+
+  my $name = $node->[NODE_TAG_NAME];
+  my $args = $node->[NODE_TAG_ARGS];
+
+  my $entry = $self->[ACTS]{"with_$name"};
+  if ($entry) {
+    my ($code, @args);
+    if (ref $entry eq 'ARRAY') {
+      ($code, @args) = @$entry;
+    }
+    else {
+      $code = $entry;
+    }
+
+    my $obj;
+    ref $code or $obj = shift @args;
+    my $work = join('', $self->process($node->[NODE_WITH_CONTENT]));
+    return $obj
+      ? $obj->$code(@args, $args, $work, "", $self->[ACTS], $name, $self->[TMPLT])
+       : $code->(@args, $args, $work, "", $self->[ACTS], $name, $self->[TMPLT]);
+  }
+  else {
+    return
+      (
+       $node->[NODE_ORIG],
+       $self->process($node->[NODE_WITH_CONTENT]),
+       $node->[NODE_WITH_END][NODE_ORIG]
+      );
+  }
+}
+
+sub _process_wrap {
+  my ($self, $node) = @_;
+
+  my ($filename, $args, $content) =
+    @{$node}[NODE_WRAP_FILENAME, NODE_WRAP_ARGS, NODE_WRAP_CONTENT];
+
+  my %params;
+  my $parms_re = $self->[TMPLT]->parms_re;
+
+  my @errors;
+  while ($args =~ s/^\s*(\w+)\s*=>\s*\"([^\"]+)\"//
+        || $args =~ s/^\s*(\w+)\s*=>\s*($parms_re)//
+        || $args =~ s/^\s*(\w+)\s*=>\s*([^\s,]+)//) {
+    my ($name, $value) = ($1, $2);
+    $value =~ s/\A($parms_re)\z/ $self->[TMPLT]->perform($self->[ACTS], $2, $3, $1) /egs;
+
+    $params{$name} = $value;
+    $args =~ s/\s*,\s*//;
+  }
+  $args =~ /^\s*$/
+    or push @errors, $self->_error($node, "WARNING: Extra data after parameters '$args'");
+
+  my @result;
+  if ($self->[TMPLT]->start_wrap(\%params)) {
+    my ($wrap_node, $error) = $self->[TMPLT]->parse_file($node->[NODE_WRAP_FILENAME]);
+
+    if ($wrap_node) {
+      my $proc = __PACKAGE__->new($self->[ACTS], $self->[TMPLT],
+                                 sub { $self->process($content) });
+
+      push @result, $proc->process($wrap_node);
+    }
+    else {
+      push @result, $self->_error($node, "Loading wrap: $error");
+    }
+    $self->[TMPLT]->end_wrap;
+  }
+  else {
+    push @errors, $self->_error($node, "Error starting wrap: Too many levels of wrap for '$node->[NODE_WRAP_FILENAME]'");
+    @result = $self->process($content);
+  }
+
+  return ( @errors, @result );
+}
+
+sub _process_wraphere {
+  my ($self, $node) = @_;
+
+  $self->[WRAPPED]
+    or return $self->_error($node, "wrap here without being wrapped");
+
+  return $self->[WRAPPED]->();
+}
+
+sub _process_switch {
+  my ($self, $node) = @_;
+
+  my $cases = $node->[NODE_SWITCH_CASES];
+  my @errors;
+  for my $i (0 .. $#$cases) {
+    my ($case, $content) = @{$cases->[$i]};
+
+    my ($func, $args) = @{$case}[NODE_TAG_NAME, NODE_TAG_ARGS];
+
+    if ($func eq "default") {
+      return $self->process($content);
+    }
+
+    my $result;
+    my $good = 
+      eval {
+       local $SIG{__DIE__};
+
+       if (exists $self->[ACTS]{"if$func"}) {
+         $result = $self->[TMPLT]->low_perform($self->[ACTS], "if$func", $args, "");
+       }
+       elsif (exists $self->[ACTS]{lcfirst $func}) {
+         $result = $self->[TMPLT]->low_perform($self->[ACTS], lcfirst $func, $args, '');
+       }
+       else {
+         die "ENOIMPL\n";
+       }
+       1;
+      };
+    unless ($good) {
+      my $msg = $@;
+      if ($msg =~ /^ENOIMPL\b/) {
+       return
+         (
+          @errors,
+          $node->[NODE_ORIG],
+          (
+           map {
+             $_->[0][NODE_ORIG], $self->process($_->[1])
+           } @{$cases}[$i .. $#$cases ]
+          ),
+          $node->[NODE_SWITCH_END][NODE_ORIG],
+         );
+      }
+      push @errors, $self->_error($case, $msg);
+    }
+    if ($result) {
+      return (@errors, $self->process($content));
+    }
+  }
+
+  return @errors;
+}
+
+sub _process_comp {
+  my ($self, $node) = @_;
+
+  return map $self->process($_), @{$node}[NODE_COMP_FIRST .. $#$node];
+}
+
+sub _process_tag {
+  my ($self, $node) = @_;
+
+  my $name = $node->[NODE_TAG_NAME];
+  my $replaced = 0;
+  my $tag_method = "tag_$name";
+  if ($self->[ACTS]{$name} || $self->[TMPLT]->can($tag_method)) {
+    my $value;
+    if (eval { $value = $self->[TMPLT]->low_perform($self->[ACTS], $name, $node->[NODE_TAG_ARGS], $node->[NODE_ORIG]); 1 }) {
+      return $value;
+    }
+    my $msg = $@;
+    unless ($msg =~ /\bENOIMPL\b/) {
+      return $self->_error($node, $msg);
+    }
+  }
+
+  return Squirrel::Template::Deparser->deparse($node);
+}
+
+1;
+
+=head1 NAME
+
+Squirrel::Template::Processor - process a parsed template
+
+=head1 SYNOPSIS
+
+  use Squirrel::Template;
+  my $tmpl = Squirrel::Template->new(...);
+  my $proc = Squirrel::Template::Processor->new(\%acts, $tmpl);
+  my @content = $proc->process($node);
+
+=head DESCRIPTION
+
+Processes a parsed template node producing text.
+
+Calls back into the templater to find and parse wrapper files, to set
+wrap parameters and  to evaluate some tags.
+
+=head1 METHODS
+
+=over
+
+=item new(\%acts, $tmpl)
+
+Create a new processor.  A third C<$wrapped> parameter can be supplied
+when processing wrapped subtemplates.
+
+=item process($node)
+
+Process a parsed template node returning the results as a list.
+
+=head1 AUTHOR
+
+Tony Cook <tony@develop-help.com>
+
+=back
diff --git a/site/cgi-bin/modules/Squirrel/Template/Tokenizer.pm b/site/cgi-bin/modules/Squirrel/Template/Tokenizer.pm
new file mode 100644 (file)
index 0000000..2e612d5
--- /dev/null
@@ -0,0 +1,282 @@
+package Squirrel::Template::Tokenizer;
+use strict;
+use Squirrel::Template::Constants qw(:token);
+
+our $VERSION = "1.002";
+
+use constant QUEUE => 0;
+use constant TEXT => 1;
+use constant LINE => 2;
+use constant NAME => 3;
+use constant TMPLT => 4;
+use constant INCLUDES => 5;
+
+use constant TRACE => 0;
+
+sub new {
+  my ($class, $text, $name, $templater) = @_;
+
+  return bless [ [], $text, 1, $name, $templater, [] ], $class;
+}
+
+my $tag_head = qr/(?:\s+<:-|<:-?)/;
+my $tag_tail = qr/(?:-:>\s*|:>)/;
+
+# simple to tokenize directives
+my @simple = qw(endwrap switch endswitch eif or);
+
+my $simple_re = join('|', @simple);
+
+# starting keywords that are reserved (we catch them when used correctly)
+my @reserved = qw(if iterator with wrap include);
+push @reserved, @simple;
+
+my $reserved_re = join('|', @reserved);
+
+sub get {
+  my ($self) = @_;
+
+  my ($name, $line, $queue) = @{$self}[NAME, LINE, QUEUE];
+
+  if (@$queue) {
+    print STDERR "GET: @{$queue->[0]}[0,2,3] (queued) (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+    return shift @$queue;
+  }
+  unless (length $self->[TEXT]) {
+    print STDERR "GET: none (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+    return;
+  }
+
+  if ($self->[TEXT] =~ s/\A(.*?)(($tag_head)\s*(.*?)\s*($tag_tail))//s) {
+    my ($content, $tag, $head, $body, $tail) = ($1, $2, $3, $4, $5);
+
+    if (length $content) {
+      push @$queue, [ "content", $content, $line, $name ];
+      $self->[LINE] += $content =~ tr/\n//;
+      $line = $self->[LINE];
+    }
+
+    $self->[LINE] += $tag =~ tr/\n//;
+    if ($body =~ /\A($simple_re)(?:\s+(\S.*))?\z/s) {
+      push @$queue, [ $1 => $tag, $line, $name, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ m!\Ainclude\s+([\w/.-]+)(?:\s+([\w,]+))?\z!) {
+      if (@{$self->[INCLUDES]} <= 10) {
+       my ($newtext, $filename, $error) = $self->[TMPLT]->include($1, $2);
+       if ($error) {
+         push @$queue, [ error => $tag, $line, $name, $newtext ];
+       }
+       else {
+         if (length $newtext) {
+           push @{$self->[INCLUDES]}, [ @{$self}[TEXT, NAME, LINE] ];
+           @{$self}[TEXT, NAME, LINE] = ( $newtext, $filename, 1 );
+         }
+         return $self->get if !@$queue && length $self->[TEXT];
+       }
+      }
+      else {
+       push @$queue, [ error => $tag, $line, $name, 'Too many levels of includes' ];
+      }
+    }
+    elsif ($body =~ /\Aiterator\s+begin\s+(\w+)\s*(?:\s+(\S.*))?\z/s) {
+      push @$queue, [ itbegin => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ /\Aiterator\s+separator(?:\s+(\w+))\z/) {
+      push @$queue, [ itsep => $tag, $line, $name, $1 ];
+    }
+    elsif ($body =~ /\Aiterator\s+end(?:\s+(\w+))\z/) {
+      push @$queue, [ itend => $tag, $line, $name, $1 ];
+    }
+    elsif ($body =~ /\Awith\s+begin\s+(\w+)\s*(?:\s+(\S.*))?\z/s) {
+      push @$queue, [ withbegin => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ s/\Awith\s+end(?:\s+(\w+))?\z//) {
+      push @$queue, [ withend => $tag, $line, $name, $1 ];
+    }
+    elsif ($body =~ /\Aif\s*([A-Z]\w+)(?:\s+(\S.*))?\z/s) {
+      push @$queue, [ if => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ /\Acase\s+(\w+)(?:\s+(\S.*))?\z/) {
+      push @$queue, [ case => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ /\Awrap\s+here\z/) {
+      push @$queue, [ wraphere => $tag, $line, $name ];
+    }
+    elsif ($body =~ m!\Awrap\s+([\w/.-]+)(?:\s+(\S.*))?\z!s) {
+      push @$queue, [ wrap => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ /\A($reserved_re)\b/) {
+      push @$queue, [ error => $tag, $line, $name, "Syntax error: incorrect use of '$1'" ];
+    }
+    elsif ($body =~ /\A(\w+)(?:\s+(\S.*))?\z/s) {
+      push @$queue, [ tag => $tag, $line, $name, $1, defined $2 ? $2 : '' ];
+    }
+    elsif ($body =~ /\A\#\s*(.*)\z/s) {
+      push @$queue, [ comment => $tag, $line, $name, $1 ];
+    }
+    else {
+      my $start = length $body > 20 ? substr($body, 0, 17) . "..." : $body;
+      push @$queue, [ error => $tag, $line, $name, "Syntax error: unknown tag start '$start'" ];
+    }
+  }
+  elsif ($self->[TEXT] =~ s/\A(.*?)(($tag_head)\s*(.*))\z//s) {
+    my ($content, $tag, $head, $name_maybe) = ($1, $2, $3, $4);
+    if (length $content) {
+      push @$queue, [ "content", $content, $line, $name ];
+      $self->[LINE] += $content =~ tr/\n//;
+    }
+    my $tag_name = $name_maybe =~ /^(\.?\w+)/ ? $1 : "(no name found)";
+    push @$queue, [ error => $tag, $self->[LINE], $name, "Unclosed tag '$tag_name'" ];
+    $self->[LINE] += $tag =~ tr/\n//;
+  }
+  else {
+    my $text = $self->[TEXT];
+    $self->[TEXT] = '';
+    my $line = $self->[LINE];
+    $self->[LINE] += $text =~ tr/\n//;
+    push @$queue, [ "content", $text, $line, $name ];
+  }
+
+  while ($self->[TEXT] eq '' && @{$self->[INCLUDES]}) {
+    @{$self}[TEXT, NAME, LINE] = @{pop @{$self->[INCLUDES]}};
+  }
+  if ($self->[TEXT] eq '') {
+    push @$queue, [ eof => '', $self->[LINE], $self->[NAME] ];
+  }
+
+  #use Devel::Peek;
+  #Dump($self->[TEXT]);
+
+  print STDERR "GET: @{$queue->[0]}[0,2,3] (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+
+  return shift @$queue;
+}
+
+sub unget {
+  my ($self, $token) = @_;
+
+  print STDERR "UNGET: @{$token}[0,2,3] (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+
+  unshift @{$self->[QUEUE]}, $token;
+}
+
+sub peek {
+  my ($self) = @_;
+
+  if (@{$self->[QUEUE]}) {
+    print STDERR "PEEK: @{$self->[QUEUE][0]}0,2,3] (queued) (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+    return $self->[QUEUE][0];
+  }
+  else {
+    if ($self->[TEXT] eq '') {
+      print STDERR "PEEK: none (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+      return;
+    }
+    my $result = $self->get;
+    unshift @{$self->[QUEUE]}, $result;
+
+    print STDERR "PEEK: @{$result}[0,2,3] (", join(":", (caller)[0, 2]), ")\n" if TRACE;
+
+    return $result;
+  }
+}
+
+sub peek_type {
+  my ($self) = @_;
+
+  my $token = $self->peek
+    or return '';
+  return $token->[0];
+}
+
+1;
+
+=head1 NAME
+
+Squirrel::Template::Tokenizer - generate a stream of tokens from a template
+
+=head1 SYNOPSIS
+
+  use Squirrel::Template::Constants qw(:token);
+  my $t = Squirrel::Template::Tokenizer->new($text, $filename, $templater);
+
+  my $token = $t->get;
+  $t->unget($token);
+  my $next_token = $t->peek;
+  my $next_type = $t->peek_type;
+
+  my $type = $token->[TOKEN_TYPE];
+  my $original = $token->[TOKEN_ORIG];
+  my $line = $token->[TOKEN_LINE];
+  my $filename = $token->[TOKE_FILENAME];
+
+=head1 DESCRIPTION
+
+Incrementally returns a stream of tokens from the supplied text,
+processing any include directives.
+
+Each token is returned as an array reference, where the first four members are:
+
+=over
+
+=item *
+
+token type - a simple identifier for the token, such as C<tag> or C<content>.
+
+=item *
+
+original text - the original text representing that token in the
+source text.  For a C<content> token this is the actualy content.
+
+=item *
+
+line number - the starting line number of the token.  A token may
+continue over several lines and for a non-content token with a
+white-space eating leader it may not be obvious that the token starts
+on this line.
+
+=item *
+
+file name - the name of the file this token was read from.  For the
+original text this will be the C<$filename> supplied to the
+constructor, but it will change for included files.
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item new($text, $filename, $templater)
+
+Create a new tokenizer.  C<$text> is the text to parse.  C<$filename>
+is the source file of the text. C<$templater> is a
+L<Squirrel::Template> object.
+
+=item get()
+
+Returns the next token from the stream, consuming it.  The token
+stream is always terminated by an C<eof> token.  Returns nothing once
+the C<eof> token has been returned.
+
+=item unget($token)
+
+Adds C<$token> to the front of the queue of tokens to be retrieved.
+
+=item peek()
+
+Retrieve the next token from the stream without consuming it.
+
+=item peek_type()
+
+Returns the type of the next token.  If there is no token returns an
+empty string.
+
+=back
+
+=head1 AUTHOR
+
+Tony Cook <tony@develop-help.com>
+
+=cut
+
diff --git a/site/docs/Squirrel::Template.html b/site/docs/Squirrel::Template.html
new file mode 100644 (file)
index 0000000..260621c
--- /dev/null
@@ -0,0 +1,386 @@
+<?xml version="1.0" ?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+<title>Squirrel::Template - simple templating system</title>
+<meta http-equiv="content-type" content="text/html; charset=utf-8" />
+<link rev="made" href="mailto:root@localhost" />
+</head>
+
+<body style="background-color: white">
+
+
+<!-- INDEX BEGIN -->
+<div name="index">
+<p><a name="__index__"></a></p>
+
+<ul>
+
+       <li><a href="#name">NAME</a></li>
+       <li><a href="#synopsis">SYNOPSIS</a></li>
+       <li><a href="#description">DESCRIPTION</a></li>
+       <li><a href="#methods">METHODS</a></li>
+       <li><a href="#template_syntax">TEMPLATE SYNTAX</a></li>
+       <li><a href="#wrapping">WRAPPING</a></li>
+       <li><a href="#tag_evaluation">TAG EVALUATION</a></li>
+       <ul>
+
+               <li><a href="#simple_tag_evaluation">Simple tag evaluation</a></li>
+               <li><a href="#conditional_tag_evaluation">Conditional tag evaluation</a></li>
+               <li><a href="#iterator_tag_evaluation">Iterator tag evaluation</a></li>
+       </ul>
+
+       <li><a href="#special_actions">SPECIAL ACTIONS</a></li>
+       <li><a href="#see_also">SEE ALSO</a></li>
+       <li><a href="#history">HISTORY</a></li>
+</ul>
+
+<hr name="index" />
+</div>
+<!-- INDEX END -->
+
+<p>
+</p>
+<h1><a name="name">NAME</a></h1>
+<pre>
+  Squirrel::Template - simple templating system</pre>
+<p>
+</p>
+<hr />
+<h1><a name="synopsis">SYNOPSIS</a></h1>
+<pre>
+  use Squirrel::Template;
+  my $templater = Squirrel::Template-&gt;new(template_dir =&gt; $some_dir);
+  my $result = $templater-&gt;show_page($base, $filename, \%acts, undef, $alt);
+  my $result = $templater-&gt;replace_template($text, \%acts, undef, $display_name);
+  my @errors = $templater-&gt;errors;
+  my @args = $templater-&gt;get_parms($args, \%acts, $keep_unknown)</pre>
+<p>
+</p>
+<hr />
+<h1><a name="description">DESCRIPTION</a></h1>
+<p>BSE's template engine.</p>
+<p>
+</p>
+<hr />
+<h1><a name="methods">METHODS</a></h1>
+<dl>
+<dt><strong><a name="new" class="item"><code>new()</code></a></strong></dt>
+
+<dd>
+<pre>
+  $templater = Squirrel::Template-&gt;new(%opts);</pre>
+<p>Create a new templating object.</p>
+<p>Possible options are:</p>
+<dl>
+<dt><strong><a name="verbose" class="item">verbose</a></strong></dt>
+
+<dd>
+<p>If a tag isn't found in the actions then it is replaced with an error
+message rather than being left in place.</p>
+</dd>
+<dt><strong><a name="template_dir" class="item">template_dir</a></strong></dt>
+
+<dd>
+<p>Used to find wrapper and include templates.  See <em>WRAPPING</em> below.
+This can be either a scalar, or a reference to an array of locations
+to search for the wrapper.</p>
+</dd>
+<dt><strong><a name="utf8" class="item">utf8</a></strong></dt>
+
+<dd>
+<p>If this is true then the template engine works in unicode internally.
+Template files are read into memory using the charecter set specified
+by <a href="#charset"><code>charset</code></a>.</p>
+</dd>
+<dt><strong><a name="charset" class="item">charset</a></strong></dt>
+
+<dd>
+<p>Ignored unless <a href="#utf8"><code>utf8</code></a> is true.  Specifies the character encoding used
+by template files.  Defaults to <code>&quot;utf-8&quot;</code>.</p>
+</dd>
+<dt><strong><a name="cache" class="item">cache</a></strong></dt>
+
+<dd>
+<p>A BSE::Cache object to use for caching compiled templates.  Note that
+templates are currently only cached by filename.</p>
+</dd>
+</dl>
+</dd>
+<dt><strong><a name="show_page" class="item"><code>show_page()</code></a></strong></dt>
+
+<dd>
+<pre>
+  $text = $templ-&gt;show_page($base, $template, \%acts, $iter)</pre>
+<p>Performs template replacement on the text from the file $template in
+directory $base.</p>
+</dd>
+<dt><strong><a name="replace_template" class="item"><code>replace_template()</code></a></strong></dt>
+
+<dd>
+<pre>
+  $text = $templ-&gt;replace_template($intext, \%acts, $iter, $name)</pre>
+<p>Performs template replacement on <code>$intext</code> using the tags in
+<code>%acts</code>.  <code>$iter</code> is accepted only for backward compatibility and it
+no longer used.  Errors are reported as if <code>$intext</code> had been read
+from a file called <code>$name</code>.</p>
+</dd>
+<dt><strong><a name="errors" class="item"><code>errors()</code></a></strong></dt>
+
+<dd>
+<p>Return errors from the last <a href="#show_page"><code>show_page()</code></a> or <a href="#replace_template"><code>replace_template()</code></a>.</p>
+<p>This can include:</p>
+<ul>
+<li>
+<p>tokenization errors - an unknown token was found in the template</p>
+</li>
+<li>
+<p>parsing errors - mismatched if/eif, etc</p>
+</li>
+<li>
+<p>processing errors - die from tag handlers, etc</p>
+</li>
+<li>
+<p>file errors - missing include or wrap files, and recursion from those.</p>
+</li>
+</ul>
+<p>Returns a list of error tokens, each of which is an array reference
+with:</p>
+<ul>
+<li>
+<p>The text &quot;error&quot;.</p>
+</li>
+<li>
+<p>An template text that caused the error.  This may be blank some cases.</p>
+</li>
+<li>
+<p>The line number.</p>
+</li>
+<li>
+<p>The filename.  If you called <a href="#replace_template"><code>replace_template()</code></a> this will be the
+<code>$name</code> supplied to <a href="#replace_template"><code>replace_template()</code></a>.</p>
+</li>
+<li>
+<p>An error message.</p>
+</li>
+</ul>
+</dd>
+<dt><strong><a name="get_parms" class="item"><code>get_parms()</code></a></strong></dt>
+
+<dd>
+<pre>
+  my @args = get_parms($args, $acts, $keep_unknown)</pre>
+<p>Does simple and stupid processing of <code>$args</code> parsing it for a list of
+arguments.</p>
+<p>Possible arguments that are parsed are:</p>
+<ul>
+<li>
+<p><code>[</code><em>tagname</em> <em>arguments</em><code>]</code> - return the results of calling the
+specified tag.  Only a limited amount of nesting is parsed.</p>
+</li>
+<li>
+<p><code>&quot;</code><em>text</em><code>&quot;</code> - quoted text.  No escaping is done on the text.</p>
+</li>
+<li>
+<p><em>text</em> - plain text not containing any <code>[</code> or <code>]</code>.</p>
+</li>
+</ul>
+<p>Returns a list of parsed arguments.</p>
+<p>If <em>tagname</em> in <code>$args</code> isn't defined, dies with an <code>ENOIMPL\n</code>
+message.</p>
+</dd>
+</dl>
+<p>
+</p>
+<hr />
+<h1><a name="template_syntax">TEMPLATE SYNTAX</a></h1>
+<p>In general, if the tag has no definition the original tag directive is
+left in place.  If the tag has sub-components (like <code>if</code> or
+<code>iterate</code>) tag replacement is done on the sub-components.</p>
+<p>Directives available in templates:</p>
+<ul>
+<li>
+<p><code>&lt;: name args :&gt;</code></p>
+<p>Replaced with the value of the tag.  See <a href="#simple_tag_evaluation">Simple tag evaluation</a>.</p>
+</li>
+<li>
+<p><code>&lt;: iterator begin name args :&gt; text &lt;: iterator separator name :&gt; separator &lt;: iterator end name :&gt;</code></p>
+<p><code>&lt;: iterator begin name args :&gt; text &lt;: iterator end name :&gt;</code></p>
+<p>Replaced with repeated templating of <em>text</em> separated by <em>separator</em>.</p>
+<p>See <a href="#iterator_tag_evaluation">Iterator tag evaluation</a>.</p>
+</li>
+<li>
+<p><code>&lt;: ifName args :&gt; true &lt;: or :&gt; false &lt;: eif :&gt;</code></p>
+<p><code>&lt;: if Name args :&gt; true &lt;: or Name :&gt; false &lt;: eif Name :&gt;</code></p>
+<p>Emits <em>true</em> if the tag evaluates to a true value, otherwise the
+<em>false</em> text.  See <a href="#conditional_tag_evaluation">Conditional tag evaluation</a>.</p>
+<p>Note that only the <code>if</code> now requires the <code>Name</code>.  The <code>or</code> and
+<code>eif</code> may include the name, but it is not required.  If the <code>Name</code>
+is supplied it must match the <code>if</code> <code>Name</code> or an error will be
+returned.</p>
+</li>
+<li>
+<p><code>&lt;: with begin name args :&gt; replaced &lt;: with end name :&gt;</code></p>
+<p>Calls <code>$acts-&gt;{&quot;with_name&quot;}-&gt;($args, $replaced, &quot;&quot;, \%acts,
+$name, $templaer)</code> where <code>$replaced</code> is the processed text and
+inserts that.</p>
+</dd>
+<dt><strong><a name="your_comment" class="item">&lt;: # <em>your comment</em> :&gt;</a></strong></dt>
+
+<dd>
+<p>A comment, not included in the output.</p>
+</dd>
+<dt><strong><a name="switch_case_name_optional_args_content_endswitch" class="item">&lt;:switch:&gt;&lt;:case <em>Name</em> <em>optional-args</em> :&gt;<em>content</em> ... &lt;:endswitch:&gt;</a></strong></dt>
+
+<dd>
+<p>Replaced with the first matching conditional where <code>&lt;:case Name
+optional-args :&gt;</code> is treated like an <code>if</code>.</p>
+<p>A <code>&lt;:case default:&gt;</code> is always true.</p>
+</li>
+<li>
+<p><code>&lt;: include filename options :&gt;</code></p>
+<p>Replaced with the content of the supplied filename.</p>
+<p>If the file <em>filename</em> is not found, this results in an error being
+inserted (and reported via <a href="#errors">errors()</a>) unless <em>options</em> contains
+<code>optional</code>.</p>
+<p>No more than 10 levels of include can be nested.</p>
+</li>
+</ul>
+<p>
+</p>
+<hr />
+<h1><a name="wrapping">WRAPPING</a></h1>
+<p>If you define the template_dir option when you create your templating
+object, then a mechnism to wrap the current template with another is
+enabled.</p>
+<p>For the wrapping to occur:</p>
+<ul>
+<li>
+<p>The template specified in the call to <a href="#replace_template"><code>replace_template()</code></a> or
+<a href="#show_page"><code>show_page()</code></a> needs to start with:</p>
+<p>&lt;: wrap <em>templatename</em> :&gt;</p>
+<p>or:</p>
+<p>&lt;: wrap <em>templatename</em> <em>name</em> =&gt; <em>value</em>, ... :&gt;</p>
+</li>
+<li>
+<p>The template specified in the &lt;: wrap ... :&gt; tag must exist in the
+directory specified by the <em>template_dir</em> option.</p>
+</li>
+<li>
+<p>The template specified in the &lt;: wrap ... :&gt; tag must contain a:</p>
+<pre>
+   &lt;: wrap here :&gt;</pre>
+<p>tag.</p>
+</li>
+</ul>
+<p>The current template text is then replaced with the contents of the
+template specified by <em>templatename</em>, with the &lt;: wrap here :&gt;
+replaced by the original template text.</p>
+<p>This is then repeated for the new template text.</p>
+<p>
+</p>
+<hr />
+<h1><a name="tag_evaluation">TAG EVALUATION</a></h1>
+<p>
+</p>
+<h2><a name="simple_tag_evaluation">Simple tag evaluation</a></h2>
+<p>Tag definitions in <code>%acts</code> can be in any of five forms:</p>
+<ul>
+<li>
+<p>A simple scalar - the value of the scalar is returned.</p>
+</li>
+<li>
+<p>A scalar reference - the referred to scalar is returned.</p>
+</li>
+<li>
+<p>A code reference - the code reference is called as:</p>
+<pre>
+  $code-&gt;($args, \%acts, $tagname, $templater)</pre>
+</li>
+<li>
+<p>An array reference starting with a code reference, followed by
+arguments, eg <code>[ \&amp;tag_sometag, $foo, $bar ]</code>.  This is called
+as:</p>
+<pre>
+  $code-&gt;($foo, $bar, \%acts, $tagname, $templater)</pre>
+</li>
+<li>
+<p>An array reference starting with a scalar, followed by an object or
+class name, followed by arguments, eg <code>[ method =&gt; $obj, $foo, $bar
+]</code>.  This is called as:</p>
+<pre>
+  $obj-&gt;$method($foo, $bar, \%acts, $tagname, $templater)</pre>
+</li>
+</ul>
+<p>A warning is produced if the tag returns an undef value.</p>
+<p>
+</p>
+<h2><a name="conditional_tag_evaluation">Conditional tag evaluation</a></h2>
+<p>Given a <code>ifSomeName</code>, does <a href="#simple_tag_evaluation">Simple tag evaluation</a> on the
+first tag of <code>ifSomeName</code> or <code>someName</code> found.</p>
+<p>Unlike simple tag evaluation this does not warn if the result is undef.</p>
+<p>
+</p>
+<h2><a name="iterator_tag_evaluation">Iterator tag evaluation</a></h2>
+<p>This uses two members of <code>%acts</code>:</p>
+<ul>
+<li>
+<p><code>iterate_name_reset</code> - called to start iteration.  Optional
+but recommended.</p>
+</li>
+<li>
+<p><code>iterate_name</code> - called until it returns false for each
+iteration.</p>
+</li>
+</ul>
+<p>Either can be any of:</p>
+<ul>
+<li>
+<p>a code reference - called as:</p>
+<pre>
+  $code-&gt;($args, \%acts, $name, $templater)</pre>
+</li>
+<li>
+<p>an array reference starting with a code reference:</p>
+<pre>
+  $arrayref-&gt;[0]-&gt;(@{$arrayref}[1 .. $#$arrayref], \%acts, $name, $templater);</pre>
+</li>
+<li>
+<p>an array reference starting with a scalar:</p>
+<pre>
+  $arrayref-&gt;[1]-&gt;$method(@{$arrayref}[2 .. $#$arrayref], \%acts, $name, $templater);</pre>
+</li>
+</ul>
+<p>
+</p>
+<hr />
+<h1><a name="special_actions">SPECIAL ACTIONS</a></h1>
+<p>So far there's just one:</p>
+<dl>
+<dt><strong><a name="_format" class="item">_format</a></strong></dt>
+
+<dd>
+<p>If the _format action is defined in your $acts then if a function tag
+has |text at the end of it then the function is evaluated, and the
+resulting text and the text after the | is passed to the format
+function.</p>
+</dd>
+</dl>
+<p>
+</p>
+<hr />
+<h1><a name="see_also">SEE ALSO</a></h1>
+<p>Squirrel::Row(3p), Squirel::Table(3p)</p>
+<p>
+</p>
+<hr />
+<h1><a name="history">HISTORY</a></h1>
+<p>Started as a quick hack from seeing the hacky template replacement
+done by an employer.</p>
+<p>It grew.</p>
+<p>Largely rewritten in 2012 to avoid processing the same string a few
+hundred times.</p>
+
+</body>
+
+</html>
index f0b456b..6cc2883 100644 (file)
@@ -438,6 +438,12 @@ their results.  Default: 1.
 The name of the file to generate for static articles when the link is
 terminated by "/".  Default: C<index.html>.
 
+=item cache_templates
+
+If true, BSE will cache compiled templates using the configured BSE
+cache, if any.  Depending on the configured cache this may slow things
+down.  Default: disabled.
+
 =back
 
 =head2 [mail]
index 58e64b3..358a7eb 100644 (file)
@@ -14,6 +14,7 @@ my @targets =
    'Generate::Article.html',
    'Generate::Product.html',
    'Generate::Catalog.html',
+   'Squirrel::Template.html',
    'search.html',
    'shop.html',
    'add.html',
diff --git a/site/util/bse_template_check.pl b/site/util/bse_template_check.pl
new file mode 100644 (file)
index 0000000..0adef41
--- /dev/null
@@ -0,0 +1,36 @@
+#!perl -w
+use strict;
+use Getopt::Long;
+use FindBin;
+use lib "$FindBin::Bin/../cgi-bin/modules";
+use BSE::API qw(bse_init bse_cfg);
+use Squirrel::Template;
+
+bse_init("../cgi-bin");
+
+Getopt::Long::Configure('bundling');
+my $verbose;
+my @includes;
+my $utf8 = 1;
+my $charset = "utf-8";
+GetOptions("v", \$verbose,
+          "I|include=s" =>\@includes,
+          "utf8" => \$utf8,
+          "c|charset" => \$charset
+         );
+$verbose = defined $verbose;
+
+my $cfg = bse_cfg();
+
+my $templater = Squirrel::Template->new
+  (
+   utf8 => $utf8,
+   charset => $charset,
+   template_dir => \@includes,
+  );
+
+my $file = shift
+  or usage("No filename supplied");
+my $p = $templater->parse_file($file);
+print $_->[3], ":", $_->[2], ": ", $_->[4], "\n" for $templater->errors;
+
index fa103dc..3f16fe9 100644 (file)
@@ -1,7 +1,7 @@
 #!perl -w
 # Basic tests for Squirrel::Template
 use strict;
-use Test::More tests => 25;
+use Test::More tests => 41;
 
 sub template_test($$$$;$);
 
@@ -12,6 +12,7 @@ SKIP: {
 
   my $flag = 0;
   my $str = "ABC";
+  my $str2 = "DEF";
   my ($repeat_limit, $repeat_value);
 
   my %acts =
@@ -24,9 +25,12 @@ SKIP: {
      repeat => \$repeat_value,
      strref => \$str,
      str => $str,
+     str2 => $str2,
      with_upper => \&tag_with_upper,
      cat => \&tag_cat,
      ifFalse => 0,
+     dead => sub { die "foo\n" },
+     noimpl => sub { die "ENOIMPL\n" },
     );
   template_test("<:str:>", "ABC", "simple", \%acts);
   template_test("<:strref:>", "ABC", "scalar ref", \%acts);
@@ -43,6 +47,13 @@ TEMPLATE
                "cond1", \%acts);
   template_test('<:if Eq [str] "ABC":>YES<:or Eq:>NO<:eif Eq:>', "YES", 
                "cond2", \%acts);
+  template_test("<:dead:>", "* foo\n *", "dead", \%acts);
+  template_test("<:noimpl:>", "<:noimpl:>", "noimpl", \%acts);
+  template_test("<:unknown:>", "<:unknown:>", "unknown tag", \%acts);
+  template_test("<:ifDead:><:str:><:or:><:str2:><:eif:>",
+               "* foo\n *<:ifDead:>ABC<:or:>DEF<:eif:>", "ifDead", \%acts);
+  template_test("<:ifNoimpl:><:str:><:or:><:str2:><:eif:>",
+               "<:ifNoimpl:>ABC<:or:>DEF<:eif:>", "ifNoimpl", \%acts);
   template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "in");
 <:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
 <:param menu:>
@@ -52,6 +63,97 @@ TEMPLATE
 Alpha
 1
 abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap", \%acts, "both");
+Before
+<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" -:>
+Alpha
+<:param menu:>
+<:param showtitle:>
+<:-endwrap-:>
+After
+TEMPLATE
+Before
+<title>foo ABC</title>
+Alpha
+1
+abc
+After
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap with too much parameter text", \%acts, "in");
+<:wrap wraptest.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" junk :>Alpha
+<:param menu:>
+<:param showtitle:>
+TEMPLATE
+* WARNING: Extra data after parameters ' junk' *<title>foo ABC</title>
+Alpha
+1
+abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap recursive", \%acts, "both");
+<:wrap wrapself.tmpl title=>[cat "foo " [str]], menu => 1, showtitle => "abc" :>Alpha
+<:param menu:>
+<:param showtitle:>
+TEMPLATE
+* Error starting wrap: Too many levels of wrap for 'wrapself.tmpl' *<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+<title>foo ABC</title>
+Alpha
+1
+abc
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "wrap unknown", \%acts, "both");
+<:wrap unknown.tmpl:>
+Body
+TEMPLATE
+* Loading wrap: File unknown.tmpl not found *
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "unwrapped wrap here", \%acts, "both");
+before
+<:wrap here:>
+after
+TEMPLATE
+before
+* wrap here without being wrapped *
+after
+OUTPUT
+
+  # undefined iterator - replacement should happen on the inside
+  template_test(<<TEMPLATE, <<OUTPUT, "undefined iterator", \%acts);
+<:iterator begin unknown:>
+<:if Eq "1" "1":>TRUE<:or:>FALSE<:eif:>
+<:iterator separator unknown:>
+<:if Eq "1" "0":>TRUE<:or:>FALSE<:eif:>
+<:iterator end unknown:>
+TEMPLATE
+<:iterator begin unknown:>
+TRUE
+<:iterator separator unknown:>
+FALSE
+<:iterator end unknown:>
+OUTPUT
+
+  template_test(<<TEMPLATE, <<OUTPUT, "multi wrap", \%acts, "in");
+<:wrap wrapinner.tmpl title => "ABC":>
+Test
+TEMPLATE
+<title>ABC</title>
+
+<head1>ABC</head1>
+
+Test
 OUTPUT
 
   my $switch = <<IN;
@@ -72,15 +174,40 @@ IN
   $str = "ABC";
   template_test($switch2, "ONE", "switch without ignored", \%acts, "both");
 
-  template_test(<<IN, <<OUT, "unimplemented switch", \%acts, "both");
+  template_test(<<IN, <<OUT, "unimplemented switch (by die)", \%acts, "both");
 <foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Eq [unknown] "ABC":><:endswitch:>
 IN
 <foo>ABC</foo><:switch:><:case Eq [unknown] "ABC":><:endswitch:>
 OUT
 
+  template_test(<<IN, <<OUT, "unimplemented switch (by missing)", \%acts, "both");
+<foo><:strref bar |h:></foo><:switch:><:case Eq [strref] "XYZ":>FAIL<:case Unknown:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
+IN
+<foo>ABC</foo><:switch:><:case Unknown:>ABC<:case Eq [unknown] "ABC":>DEF<:endswitch:>
+OUT
+
+  template_test(<<IN, <<OUT, "switch with die in case and unknown", \%acts, "both");
+<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case Eq [unknown] "ABC":><:str2:><:endswitch:>
+IN
+* foo
+ *<:switch:><:case Eq [unknown] "ABC":>DEF<:endswitch:>
+OUT
+
+  template_test(<<IN, <<OUT, "switch with die no matches", \%acts, "both");
+<:switch:><:case Eq [strref] "XYZ":>FAIL<:case Dead:><:str:><:case False:><:str2:><:endswitch:>
+IN
+* foo
+ *
+OUT
+
   template_test("<:with begin upper:>Alpha<:with end upper:>", "ALPHA", "with", \%acts);
+
+  template_test("<:with begin unknown:>Alpha<:str:><:with end unknown:>", <<EOS, "with", \%acts, "out");
+<:with begin unknown:>AlphaABC<:with end unknown:>
+EOS
+
   template_test("<:include doesnt/exist optional:>", "", "optional include", \%acts);
-  template_test("<:include doesnt/exist:>", "** cannot find include doesnt/exist in path **", "failed include", \%acts);
+  template_test("<:include doesnt/exist:>", "* cannot find include doesnt/exist in path *", "failed include", \%acts);
   template_test("x<:include included.include:>z", "xyz", "include", \%acts);
 
   template_test <<IN, <<OUT, "nested in undefined if", \%acts;
diff --git a/t/templater/00load.t b/t/templater/00load.t
new file mode 100644 (file)
index 0000000..3b91bb6
--- /dev/null
@@ -0,0 +1,4 @@
+#!perl -w
+use strict;
+use Test::More tests => 1;
+use_ok("Squirrel::Template");
diff --git a/t/templater/10token.t b/t/templater/10token.t
new file mode 100644 (file)
index 0000000..086d32a
--- /dev/null
@@ -0,0 +1,353 @@
+#!perl -w
+use strict;
+use Test::More tests => 35;
+use Squirrel::Template;
+use Squirrel::Template::Constants qw(:token);
+
+sub test_tokens($$$);
+
+# test the interface
+my $templater = Squirrel::Template->new();
+my $t = Squirrel::Template::Tokenizer->new("content\n<:sometag foo:>", "<test>", $templater);
+
+ok($t, "make a tokenizer");
+
+my $peek = $t->peek;
+my $token = $t->get;
+is_deeply($peek, $token, "peek should be the same as following get");
+is($t->peek_type, "tag", "tag type coming up next");
+$t->unget($token);
+is($t->peek_type, "content", "unget of content means type of next should be content");
+$t->get;
+is($t->peek_type, "tag", "consume, and next should be tag again");
+$t->get;
+is($t->peek_type, "eof", "consume, and next should be eof");
+$t->get;
+is($t->peek_type, "", "consume, and next type should be empty string");
+is($t->peek, undef, "peek should be nothing");
+is($t->get, undef, "get should be nothing");
+
+
+# test the token stream
+
+test_tokens("abc",
+           [
+            [ content => "abc", 1, '<string>' ],
+            [ eof => "", 1, "<string>" ]
+           ], "simple");
+test_tokens("abc\n",
+           [
+            [ content => "abc\n", 1, '<string>' ],
+            [ eof => "", 2, "<string>" ]
+           ], "simple nl");
+test_tokens("<:foo:>",
+           [
+            [ tag => "<:foo:>", 1, "<string>", "foo", "" ],
+            [ eof => "", 1, "<string>" ],
+           ], "simple tag");
+test_tokens("<:foo\nsplit\nover lines:>",
+           [
+            [ tag => "<:foo\nsplit\nover lines:>", 1, "<string>", "foo", "split\nover lines" ],
+            [ eof => "", 3, "<string>" ],
+           ], "simple tag split over lines");
+           
+test_tokens("<:ifFoo:>TRUE\n<:or:>FALSE\n<:eif\n:>\n",
+           [
+            [ if => "<:ifFoo:>", 1, "<string>", "Foo", "" ],
+            [ content => "TRUE\n", 1, "<string>" ],
+            [ or => "<:or:>", 2, "<string>", "" ],
+            [ content => "FALSE\n", 2, "<string>" ],
+            [ eif => "<:eif\n:>", 3, "<string>", "" ],
+            [ content => "\n", 4, "<string>" ],
+            [ eof => "", 5, "<string>" ],
+           ], "tight cond");
+
+test_tokens("<:if Foo:>YES\n<:or Foo:>NO\n<:eif\nFoo:>\n",
+           [
+            [ if => "<:if Foo:>", 1, "<string>", "Foo", "" ],
+            [ content => "YES\n", 1, "<string>" ],
+            [ or => "<:or Foo:>", 2, "<string>", "Foo" ],
+            [ content => "NO\n", 2, "<string>" ],
+            [ eif => "<:eif\nFoo:>", 3, "<string>", "Foo" ],
+            [ content => "\n", 4, "<string>" ],
+            [ eof => "", 5, "<string>" ],
+           ], "loose cond");
+
+test_tokens("<:ifFoo args:><:if Bar more args:>",
+           [
+            [ if => "<:ifFoo args:>", 1, "<string>", "Foo", "args" ],
+            [ if => "<:if Bar more args:>", 1, "<string>", "Bar", "more args" ],
+            [ eof => "", 1, "<string>" ],
+           ], "tight cond");
+
+test_tokens("<:include notfoundfile:>",
+           [
+            [ error => "<:include notfoundfile:>", 1, "<string>",
+              "cannot find include notfoundfile in path" ],
+            [ eof => "", 1, "<string>" ],
+           ], "failed include");
+test_tokens("<:include notfoundfile optional:>",
+           [
+            [ eof => "", 1, "<string>" ],
+           ], "failed optional include");
+test_tokens("<:include notfoundfile optional:>abc",
+           [
+            [ content => "abc", 1, "<string>" ],
+            [ eof => "", 1, "<string>" ],
+           ], "failed optional include with following content");
+test_tokens("<:include included.include:>",
+           [
+            [ content => "y", 1, "t/templates/included.include" ],
+            [ eof => "", 1, "<string>" ],
+           ], "successful include");
+test_tokens("<:include included.recursive:>",
+           [
+            [ error => "<:include included.recursive:>", 1,
+              "t/templates/included.recursive", "Too many levels of includes" ],
+            [ eof => "", 1, "<string>" ],
+           ], "include loop");
+test_tokens(<<EOS,
+<:iterator begin foo test -:>
+stuff here
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo test -:>\n", 1, "<string>",
+              "foo", "test" ],
+            [ content => "stuff here\n", 2, "<string>" ],
+            [ itend => "<:iterator end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple iterator");
+
+test_tokens(<<EOS,
+<:iterator begin foo test -:>
+stuff here
+<:iterator separator foo:>
+more stuff
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo test -:>\n", 1, "<string>",
+              "foo", "test" ],
+            [ content => "stuff here\n", 2, "<string>" ],
+            [ itsep => "<:iterator separator foo:>", 3, "<string>", "foo" ],
+            [ content => "\nmore stuff\n", 3, "<string>" ],
+            [ itend => "<:iterator end foo:>", 5, "<string>", "foo" ],
+            [ content => "\n", 5, "<string>" ],
+            [ eof => "", 6, "<string>" ],
+           ], "iterator with sep");
+
+test_tokens(<<EOS,
+<:iterator begin foo:>
+stuff here
+<:iterator end foo:>
+EOS
+           [
+            [ itbegin => "<:iterator begin foo:>", 1, "<string>", "foo", "" ],
+            [ content => "\nstuff here\n", 1, "<string>" ],
+            [ itend => "<:iterator end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple iterator, no args");
+
+test_tokens(<<EOS,
+<:with begin foo:>
+stuff here
+<:with end foo:>
+EOS
+           [
+            [ withbegin => "<:with begin foo:>", 1, "<string>", "foo", "" ],
+            [ content => "\nstuff here\n", 1, "<string>" ],
+            [ withend => "<:with end foo:>", 3, "<string>", "foo" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "simple with, no args");
+
+test_tokens(<<EOS,
+<:with begin foo blargh:>
+EOS
+           [
+            [ withbegin => "<:with begin foo blargh:>", 1, "<string>", "foo", "blargh" ],
+            [ content => "\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "simple with, with args");
+
+test_tokens(<<EOS,
+<:switch:>
+<:case Foo y -:>
+<:case Bar x:>
+<:case default:>
+<:endswitch -:>
+EOS
+           [
+            [ switch => "<:switch:>", 1, "<string>", "" ],
+            [ content => "\n", 1, "<string>" ],
+            [ case => "<:case Foo y -:>\n", 2, "<string>", "Foo", "y" ],
+            [ case => "<:case Bar x:>", 3, "<string>", "Bar", "x" ],
+            [ content => "\n", 3, "<string>" ],
+            [ case => "<:case default:>", 4, "<string>", "default", "" ],
+            [ content => "\n", 4, "<string>" ],
+            [ endswitch => "<:endswitch -:>\n", 5, "<string>", "" ],
+            [ eof => "", 6, "<string>" ],
+           ], "switch");
+
+test_tokens(<<EOS,
+<:wrap foo.tmpl a => 1, b => "2", c => [test]:>
+<:wrap bar.tmpl :>
+<:param a:>
+EOS
+           [
+            [ wrap => '<:wrap foo.tmpl a => 1, b => "2", c => [test]:>', 1, "<string>",
+              "foo.tmpl", 'a => 1, b => "2", c => [test]' ],
+            [ content => "\n", 1, "<string>" ],
+            [ wrap => '<:wrap bar.tmpl :>', 2, "<string>", "bar.tmpl", '' ],
+            [ content => "\n", 2, "<string>" ],
+            [ tag => "<:param a:>", 3, "<string>", "param", "a" ],
+            [ content => "\n", 3, "<string>" ],
+            [ eof => "", 4, "<string>" ],
+           ], "top wrap");
+
+test_tokens(<<EOS,
+alpha <:wrap here:> beta
+EOS
+           [
+            [ content => "alpha ", 1, "<string>" ],
+            [ wraphere => "<:wrap here:>", 1, "<string>" ],
+            [ content => " beta\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "wrap here");
+
+test_tokens(<<EOS,
+<: rubbish
+EOS
+           [
+            [ error => "<: rubbish\n", 1, "<string>", "Unclosed tag 'rubbish'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag with name");
+
+test_tokens(<<EOS,
+<:
+EOS
+           [
+            [ error => "<:\n", 1, "<string>", "Unclosed tag '(no name found)'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag without name");
+
+test_tokens(<<EOS,
+some content <:
+EOS
+           [
+            [ content => "some content ", 1, "<string>" ],
+            [ error => "<:\n", 1, "<string>", "Unclosed tag '(no name found)'" ],
+            [ eof => "", 2, "<string>" ],
+           ], "incomplete tag without name, with some content before");
+
+test_tokens(<<EOS,
+<:iterator xbegin foo:>
+EOS
+           [
+            [ error => "<:iterator xbegin foo:>", 1, "<string>", "Syntax error: incorrect use of 'iterator'" ],
+            [ content => "\n", 1, "<string>" ],
+            [ eof => "", 2, "<string>" ],
+           ], "syntax error - bad use of reserved word with bad syntax");
+
+test_tokens(<<EOS,
+<:*&:>
+<:*&*&*&*&*&*&*&*&*&*&*&:>
+EOS
+           [
+            [ error => "<:*&:>", 1, "<string>", "Syntax error: unknown tag start '*&'" ],
+            [ content => "\n", 1, "<string>" ],
+            [ error => "<:*&*&*&*&*&*&*&*&*&*&*&:>", 2, "<string>", "Syntax error: unknown tag start '*&*&*&*&*&*&*&*&*...'" ],
+            [ content => "\n", 2, "<string>" ],
+            [ eof => "", 3, "<string>" ],
+           ], "syntax error - unknown tag start");
+
+test_tokens(<<EOS,
+<:# some comment text:>
+<:#
+  multi-line
+  comment
+:>
+EOS
+           [
+            [ comment => "<:# some comment text:>", 1, "<string>", "some comment text" ],
+            [ content => "\n", 1, "<string>" ],
+            [ comment => "<:#\n  multi-line\n  comment\n:>", 2, "<string>",
+              "multi-line\n  comment" ],
+            [ content => "\n", 5, "<string>" ],
+            [ eof => "", 6, "<string>" ],
+           ], "comment");
+
+sub test_tokens($$$) {
+  my ($text, $tokens, $name) = @_;
+
+  my $tmpl = Squirrel::Template->new(template_dir=>'t/templates');
+  my $tok = Squirrel::Template::Tokenizer->new($text, "<string>", $tmpl);
+
+  my @rtokens;
+  while (my $token = $tok->get) {
+    push @rtokens, $token;
+  }
+  #use Data::Dumper;
+  #diag(Dumper \@rtokens);
+  my $result = 1;
+  my $tb= Test::Builder->new;
+  my $cmp_index = @rtokens < @$tokens ? $#rtokens : $#$tokens;
+  CMP: for my $i (0 .. $cmp_index) {
+    my $fe = _format_token($tokens->[$i]);
+    my $ff = _format_token($rtokens[$i]);
+    if ($fe ne $ff) {
+      $result = $tb->ok(0, $name);
+      diag(<<EOS);
+Mismatch at index $i:
+Expected: $fe
+Found   : $ff
+EOS
+      last CMP;
+    }
+  }
+  if ($result) {
+    if (@rtokens < @$tokens) {
+      $result = $tb->ok(0, $name);
+      my $fe = _format_token($tokens->[$cmp_index+1]);
+      diag(<<EOS)
+Found shorter than expected:
+Expected: $fe
+Found   : no entry
+EOS
+    }
+    elsif (@rtokens > @$tokens) {
+      $result = $tb->ok(0, $name);
+      my $ff = _format_token($rtokens[$cmp_index+1]);
+      diag(<<EOS)
+Found longer than expected:
+Expected: no entry
+Found   : $ff
+EOS
+    }
+  }
+  if ($result) {
+    $tb->ok(1, $name);
+  }
+  #print "F: ", _format_token($_), "\n" for @rtokens;
+  #print "E: ", _format_token($_), "\n" for @$tokens;
+
+  #is_deeply(\@rtokens, $tokens, $name);
+
+  return $result;
+}
+
+sub _format_token {
+  my ($token) = @_;
+
+  if (!$token) {
+    return "undef";
+  }
+  else {
+    my $result = "[ {" . join('}{', @$token) . "} ]";
+    $result =~ s/\n/\\n/g;
+    return $result;
+  }
+}
diff --git a/t/templater/20parse.t b/t/templater/20parse.t
new file mode 100644 (file)
index 0000000..cb399a0
--- /dev/null
@@ -0,0 +1,415 @@
+#!perl -w
+use strict;
+use Test::More tests => 34;
+use Squirrel::Template;
+
+sub test_parse($$$);
+
+{
+  # test the API
+  my $templater = Squirrel::Template->new();
+  my $t = Squirrel::Template::Tokenizer->new(<<EOS, "<text>", $templater);
+test <:foo bar:><:with end bar:><:with unknown:>
+EOS
+  my $p = Squirrel::Template::Parser->new($t, $templater);
+  ok($p, "make a parser");
+  my $tree = $p->parse;
+  is_deeply($tree,
+           [ comp => "", 1, "<text>",
+             [ content => "test ", 1, "<text>" ],
+             [ tag => "<:foo bar:>", 1, "<text>", "foo", "bar" ],
+             [ error => "<:with end bar:>", 1, "<text>", "Expected eof but found withend" ],
+             [ error => "<:with unknown:>", 1, "<text>", "Syntax error: incorrect use of 'with'" ],
+             [ content => "\n", 1, "<text>" ],
+           ], "check parse result");
+  is_deeply([ $p->errors ],
+           [
+             [ error => "<:with end bar:>", 1, "<text>", "Expected eof but found withend" ],
+            [ error => "<:with unknown:>", 1, "<text>", "Syntax error: incorrect use of 'with'" ],
+           ], "check errors");
+}
+
+test_parse(<<EOS,
+simple text
+EOS
+          [ "content", "simple text\n", 1, "<string>" ], "simple");
+
+test_parse(<<EOS,
+tag test <:sometag foo -:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ content => "tag test ", 1, "<string>" ],
+            [ tag => "<:sometag foo -:>\n", 1, "<string>", "sometag", "foo" ]
+          ], "simple tag");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or:>FALSE<:eif -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ content => "FALSE", 1, "<string>" ],
+            [ or => "<:or:>", 1, "<string>", '' ],
+            [ eif => "<:eif -:>\n", 1, "<string>", '' ],
+          ], "simple cond");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or Foo:>FALSE<:eif Foo -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ content => "FALSE", 1, "<string>" ],
+            [ or => "<:or Foo:>", 1, "<string>", 'Foo' ],
+            [ eif => "<:eif Foo -:>\n", 1, "<string>", 'Foo' ],
+          ], "named cond with named or/eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:eif -:>
+EOS
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ eif => "<:eif -:>\n", 1, "<string>", "" ],
+          ], "simple cond, no else");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or -:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ or => "<:or -:>\n", 1, "<string>", '' ],
+              [ eif => "<:eif:>", 2, "<string>" ], # synthesized
+            ],
+            [ error => "", 2, "<string>", "Expected 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE\n", 1, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ empty => "", 2, "<string>" ],
+              [ eif => "", 2, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'or' or 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse(<<EOS,
+<:if Foo:>TRUE<:or Bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "\n", 1, "<string>" ],
+              [ or => "<:or Bar:>", 1, "<string>", "Bar" ],
+              [ eif => "<:eif:>", 2, "<string>" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'or Bar'" ],
+            [ error => "", 2, "<string>", "Expected 'eif' tag for if starting <string>:1 but found eof" ]
+          ], "simple cond, with or, no eif");
+
+test_parse("<:if Foo:>TRUE<:or Bar:>FALSE<:eif:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "FALSE", 1, "<string>" ],
+              [ or => "<:or Bar:>", 1, "<string>", "Bar" ],
+              [ eif => "<:eif:>", 1, "<string>", "" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'or Bar'" ],
+          ], "if with or name mismatch");
+
+test_parse("<:if Foo:>TRUE<:or:>FALSE<:eif Bar:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ content => "FALSE", 1, "<string>" ],
+              [ or => "<:or:>", 1, "<string>", "" ],
+              [ eif => "<:eif Bar:>", 1, "<string>", "Bar" ],
+            ],
+            [ error => "", 1, "<string>", "'eif' for 'if Foo' starting <string>:1 expected but found 'eif Bar'" ],
+          ], "if with or, eif name mismatch");
+
+test_parse("<:if Foo:>TRUE<:eif Bar:>",
+          [ comp => "", 1, "<string>",
+            [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+              [ content => "TRUE", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ eif => "<:eif Bar:>", 1, "<string>", "Bar" ],
+            ],
+            [ error => "", 1, "<string>", "'or' or 'eif' for 'if Foo' starting <string>:1 expected but found 'eif Bar'" ],
+          ], "if with no or, eif name mismatch");
+
+test_parse("<:if Foo:>TRUE<:eif Foo:>",
+          [ cond => "<:if Foo:>", 1, "<string>", "Foo", "",
+            [ content => "TRUE", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ empty => "", 1, "<string>" ],
+            [ eif => "<:eif Foo:>", 1, "<string>", "Foo" ],
+          ], "if with no or, eif name matches");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ itend => "\n<:- iterator end foo:>", 1, "<string>", "foo" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple iterator");
+
+test_parse(<<EOS,
+<:iterator begin foo [bar]:>LOOP
+<:- iterator separator foo:>SEP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo [bar]:>", 1, "<string>", "foo", "[bar]",
+              [ content => "LOOP", 1, "<string>" ],
+              [ content => "SEP", 2, "<string>" ],
+              [ itsep => "\n<:- iterator separator foo:>", 1, "<string>", "foo" ],
+              [ itend => "\n<:- iterator end foo:>", 2, "<string>", "foo" ],
+            ],
+            [ content => "\n", 3, "<string>" ]
+          ], "iterator with sep");
+
+test_parse(<<EOS,
+<:iterator begin foo [bar]:>LOOP
+<:- iterator separator bar:>SEP
+<:- iterator end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo [bar]:>", 1, "<string>", "foo", "[bar]",
+              [ content => "LOOP", 1, "<string>" ],
+              [ content => "SEP", 2, "<string>" ],
+              [ itsep => "\n<:- iterator separator bar:>", 1, "<string>", "bar" ],
+              [ itend => "\n<:- iterator end foo:>", 2, "<string>", "foo" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'iterator separator foo' for 'iterator begin foo' at <string>:1 but found 'iterator separator bar'" ],
+            [ content => "\n", 3, "<string>" ]
+          ], "iterator with sep with name mismatch");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:- iterator end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ empty => "", 1, "<string>" ],
+              [ itend => "\n<:- iterator end bar:>", 1, "<string>", "bar" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found 'iterator end bar'" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple iterator, name mismatch");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+MORE
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\nMORE\n", 1, "<string>" ],
+              [ empty => "", 3, "<string>" ],
+              [ empty => "", 3, "<string>" ],
+              [ itend => "<:iterator end foo:>", 3, "<string>" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator separator foo' or 'iterator end foo' for 'iterator begin foo' at <string>:1 but found eof" ],
+          ], "simple iterator, unterminated");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:iterator separator foo:>MORE
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ content => "MORE\n", 2, "<string>" ],
+              [ itsep => "<:iterator separator foo:>", 2, "<string>", "foo" ],
+              [ itend => "<:iterator end foo:>", 3, "<string>" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found eof" ],
+          ], "iterator with separator, unterminated");
+
+test_parse(<<EOS,
+<:iterator begin foo:>LOOP
+<:iterator separator foo:>MORE
+<:iterator end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ iterator => "<:iterator begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ content => "MORE\n", 2, "<string>" ],
+              [ itsep => "<:iterator separator foo:>", 2, "<string>", "foo" ],
+              [ itend => "<:iterator end bar:>", 3, "<string>", "bar" ],
+            ],
+            [ error => "", 3, "<string>", "Expected 'iterator end foo' for 'iterator begin foo' at <string>:1 but found 'iterator end bar'" ],
+            [ content => "\n", 3, "<string>" ],
+          ], "iterator with separator, name mismatch on end");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+<:- with end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ withend => "\n<:- with end foo:>", 1, "<string>", "foo" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple wwith");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+<:- with end bar:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP", 1, "<string>" ],
+              [ withend => "\n<:- with end bar:>", 1, "<string>", "bar" ],
+            ],
+            [ error => "", 1, "<string>", "Expected 'with end foo' for 'with begin foo' at <string>:1 but found 'with end bar'" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "simple with, name mismatch");
+
+test_parse(<<EOS,
+<:with begin foo:>LOOP
+EOS
+          [ comp => "", 1, "<string>",
+            [ with => "<:with begin foo:>", 1, "<string>", "foo", "",
+              [ content => "LOOP\n", 1, "<string>" ],
+              [ withend => "<:with end foo:>", 2, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'with end foo' for 'with begin foo' at <string>:1 but found eof" ],
+          ], "simple with, unterminated");
+
+test_parse(<<EOS,
+<:switch:>IGNORED
+<:case Foo:>FOO
+<:case Bar x:>BAR
+<:case default:>DEFAULT
+<:endswitch:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ switch => "<:switch:>", 1, "<string>", "",
+              [ 
+               [ 
+                [ case => "<:case Foo:>", 2, "<string>", "Foo", "" ],
+                [ content => "FOO\n", 2, "<string>" ],
+               ],
+               [
+                [ case => "<:case Bar x:>", 3, "<string>", "Bar", "x" ],
+                [ content => "BAR\n", 3, "<string>" ],
+               ],
+               [
+                [ case => "<:case default:>", 4, "<string>", "default", "" ],
+                [ content => "DEFAULT\n", 4, "<string>" ],
+               ],
+              ],
+              [ endswitch => "<:endswitch:>", 5, "<string>", "" ],
+            ],
+            [ content => "\n", 5, "<string>" ]
+          ], "simple switch");
+
+test_parse("<:switch:><:case Foo:>",
+          [ comp => "", 1, "<string>",
+            [ switch => "<:switch:>", 1, "<string>", "",
+              [
+               [
+                [ case => "<:case Foo:>", 1, "<string>", "Foo", "" ],
+                [ empty => "", 1, "<string>" ],
+               ]
+              ],
+              [ endswitch => "<:endswitch:>", 1, "<string>" ],
+            ],
+            [ error => "", 1, "<string>", "Expected case or endswitch for switch starting <string>:1 but found eof" ],
+          ], "unterminated switch");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+EOS
+          [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+            'base.tmpl', 'foo => "1"',
+            [ content => "WRAPPED\n", 1, "<string>" ],
+          ], "endless wrap");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+<:endwrap:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+              'base.tmpl', 'foo => "1"',
+              [ content => "WRAPPED\n", 1, "<string>" ],
+            ],
+            [ content => "\n", 2, "<string>" ]
+          ], "ended wrap");
+
+test_parse(<<EOS,
+<:wrap base.tmpl foo => "1":>WRAPPED
+<:with end foo:>
+EOS
+          [ comp => "", 1, "<string>",
+            [ wrap => q(<:wrap base.tmpl foo => "1":>), 1, "<string>",
+              'base.tmpl', 'foo => "1"',
+              [ content => "WRAPPED\n", 1, "<string>" ],
+            ],
+            [ error => "", 2, "<string>", "Expected 'endwrap' or eof for wrap started <string>:1 but found withend" ],
+            [ error => "<:with end foo:>", 2, "<string>", "Expected eof but found withend" ],
+            [ content => "\n", 2, "<string>" ]
+          ], "badly terminated wrap");
+
+test_parse("abc <:with end foo:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ error => "<:with end foo:>", 1, "<string>", "Expected eof but found withend" ],
+            [ content => " def", 1, "<string>" ],
+          ], "with end without with");
+
+test_parse("abc <:*&:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ error => "<:*&:>", 1, "<string>", "Syntax error: unknown tag start '*&'" ],
+            [ content => " def", 1, "<string>" ],
+          ], "passthrough of error tokens");
+
+test_parse("abc <:# some comment:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ content => " def", 1, "<string>" ],
+          ], "comment tags are dropped");
+
+test_parse("abc <:wrap here:> def",
+          [ comp => "", 1, "<string>",
+            [ content => "abc ", 1, "<string>" ],
+            [ wraphere => "<:wrap here:>", 1, "<string>" ],
+            [ content => " def", 1, "<string>" ],
+          ], "wrap here");
+
+sub test_parse($$$) {
+  my ($text, $parse, $name) = @_;
+
+  my $tmpl = Squirrel::Template->new();
+  my $tok = Squirrel::Template::Tokenizer->new($text, "<string>", $tmpl);
+  my $parser = Squirrel::Template::Parser->new($tok, $tmpl);
+
+  my $rtree = $parser->parse;
+
+  use Data::Dumper;
+$Data::Dumper::Indent = 0;
+print Dumper($rtree), "\n", Dumper($parse), "\n";
+
+  print Squirrel::Template::Deparser->deparse($rtree), "\n";
+
+  return is_deeply($rtree, $parse, $name);
+}
diff --git a/t/templates/included.recursive b/t/templates/included.recursive
new file mode 100644 (file)
index 0000000..06c2e4e
--- /dev/null
@@ -0,0 +1 @@
+<:include included.recursive:>
\ No newline at end of file
diff --git a/t/templates/wrapinner.tmpl b/t/templates/wrapinner.tmpl
new file mode 100644 (file)
index 0000000..4d9ee58
--- /dev/null
@@ -0,0 +1,3 @@
+<:wrap wraptest.tmpl:>
+<head1><:param title:></head1>
+<:wrap here -:>
\ No newline at end of file
diff --git a/t/templates/wrapself.tmpl b/t/templates/wrapself.tmpl
new file mode 100644 (file)
index 0000000..d2d62ad
--- /dev/null
@@ -0,0 +1,3 @@
+<:wrap wrapself.tmpl -:>
+<title><:param title:></title>
+<: wrap here -:>