UCW/Temple.pm

   1 # A really simple template engine
   2 # (c) 2004--2012 Martin Mares <mj@ucw.cz>
   3
   4 package UCW::Temple;
   5
   6 use strict;
   7 use warnings;
   8 no strict 'vars';
   9
  10 require Exporter;
  11 our $VERSION = 1.0;
  12 our @ISA = qw(Exporter);
  13 our @EXPORT = qw(out);
  14 our @EXPORT_OK = qw();
  15
  16 use IO::File;
  17
  18 our $arguments;
  19 our @cond;
  20
  21 sub out {
  22         $T::out_func->(@_);
  23         return;
  24 }
  25
  26 our %deps = ();
  27
  28 sub add_depend($) {
  29         $deps{$_[0]} = 1;
  30 }
  31
  32 my $current_file_name;
  33 my $current_string;
  34 my $current_pos;
  35
  36 sub error($;$) {
  37         my ($msg, $offset) = @_;
  38         if (defined $current_file_name) {
  39                 #
  40                 #  This is rather tricky. We want to report the exact place, where the error
  41                 #  occurred, but the cost of keeping track of the current line number is too high.
  42                 #  Hence we keep just the current position inside the input stream and convert
  43                 #  it to the line number only when reporting an error.
  44                 #
  45                 my $input = substr(${$current_string}, 0, $current_pos);
  46                 my @newlines = ($input =~ m{\n}g);
  47                 my $line = @newlines + ($offset // 1);
  48                 die "$current_file_name:$line: $msg\n";
  49         } else {
  50                 die "$msg\n";
  51         }
  52 }
  53
  54 sub get_nested($$$) {
  55         my ($r, $left, $right) = @_;
  56         pos $$r = pos($$r) - 1;
  57         my $z = "";
  58         my $nest = 0;
  59         do {
  60                 if ($$r =~ /\G([^$left$right]+)/cgs) {
  61                 } elsif ($$r =~ /\G([$left])/cgs) {
  62                         $nest++;
  63                 } elsif ($$r =~ /\G([$right])/cgs) {
  64                         $nest--;
  65                 } else {
  66                         error "File ended when looking for matching $right";
  67                 }
  68                 $z .= $1;
  69         } while ($nest);
  70         return $z;
  71 }
  72
  73 sub eval_if_ok($) {
  74         if ($cond[0] > 0) {
  75                 my $x = shift;
  76                 my $res = eval "package T; $x";
  77                 return $res unless $@;
  78                 my $m = $@;
  79                 chomp $m;
  80                 if (my ($msg, $line) = $m =~ m{(.*) at \(eval \d+\) line (\d+)\.$}) {
  81                         error $msg, $line;
  82                 } else {
  83                         error $m;
  84                 }
  85         } else {
  86                 return "";
  87         }
  88 }
  89
  90 sub eval_func($$) {
  91         my ($f, $a) = @_;
  92         if ($f =~ /^(if|fi|else|elif)$/) {
  93                 if ($f eq "if") {
  94                         $a ne "()" or error "\@if requires an argument";
  95                         if ($cond[0] > 0) {
  96                                 unshift @cond, (eval_if_ok($a) ? 1 : -1);
  97                         } else {
  98                                 unshift @cond, 0;
  99                         }
 100                 } elsif ($f eq "fi") {
 101                         $a eq "()" or error "\@fi takes no arguments";
 102                         $#cond or error "\@fi without \@if";
 103                         shift @cond;
 104                 } elsif ($f eq "else") {
 105                         $a eq "()" or error "\@else takes no arguments";
 106                         $#cond or error "\@else without \@if";
 107                         $cond[0] = -$cond[0];
 108                 } elsif ($f eq "elif") {
 109                         $a ne "()" or error "\@elif requires an argument";
 110                         $#cond or error "\@elif without \@if";
 111                         if ($cond[0] > 0) {
 112                                 $cond[0] = 0;
 113                         } elsif ($cond[0] < 0) {
 114                                 $cond[0] = 1;
 115                                 $cond[0] = (eval_if_ok($a) ? 1 : -1);
 116                         }
 117                 }
 118                 # print "Cond stack: @cond\n";
 119         } else {
 120                 my $res = eval_if_ok("$f $a");
 121                 out $res if defined $res;
 122         }
 123 }
 124
 125 sub parse_string($$) {
 126         my ($t, $name) = @_;
 127         my ($old_fn, $old_str, $old_pos) = ($current_file_name, $current_string, $current_pos);
 128         $current_file_name = $name;
 129         $current_string = \$t;
 130         pos $t = 0;
 131         for (;;) {
 132                 $current_pos = pos $t;
 133                 if ($t =~ /\G([^\@]+)/cgs) {
 134                         out $1 if $cond[0] > 0;
 135                 } elsif ($t =~ /\G\@\s*\n/cgs) {
 136                         # @ at end of line is ignored and eats the end of line
 137                 } elsif ($t =~ /\G\@#[^\n]*\n/cgs) {
 138                         # a comment, which is ignored
 139                 } elsif ($t =~ /\G\@\@/cgs) {
 140                         out "\@" if $cond[0] > 0;
 141                 } elsif ($t =~ /\G\@{/cgs) {
 142                         my $x = get_nested(\$t, "{", "}");
 143                         out eval_if_ok($x);
 144                 } elsif ($t =~ /\G\@\[/cgs) {
 145                         my $x = get_nested(\$t, '\[', '\]');
 146                         $x =~ s/^\[//;
 147                         $x =~ s/\]$//;
 148                         eval_if_ok($x);
 149                 } elsif ($t =~ /\G\@\(/cgs) {
 150                         my $x = get_nested(\$t, '\(', '\)');
 151                         $x =~ s/^\(//;
 152                         $x =~ s/\)$//;
 153                         out (defined($arguments->{$x}) ? $arguments->{$x} : "");
 154                 } elsif ($t =~ /\G\@(\w+)\(/cgs) {
 155                         my $func = $1;
 156                         my $args = get_nested(\$t, '(', ')');
 157                         eval_func($func, $args);
 158                 } elsif ($t =~ /\G\@(\w+)([^\n]*)\n/cgs) {
 159                         eval_func($1, "($2)");
 160                 } elsif ($t =~ /\G\@(\$\w+)/cgs) {
 161                         out eval_if_ok($1);
 162                 } elsif ($t =~ /\G(\@[^\n]*)/cgs) {
 163                         error "Unknown control sequence $1";
 164                 } elsif ($t =~ /\G$/cgs) {
 165                         last;
 166                 } elsif ($t =~ /\G([^\n]*)/cgs) {
 167                         error "Internal parser error";
 168                 } else { die; }
 169         }
 170         ($current_file_name, $current_string, $current_pos) = ($old_fn, $old_str, $old_pos);
 171 }
 172
 173 sub parse_file($) {
 174         my ($name) = @_;
 175         add_depend($name);
 176         my $fh = new IO::File $name;
 177         error "Unable to open $name: $!" unless defined $fh;
 178         my $text;
 179         { local $/; undef $/; $text = <$fh>; }
 180         undef $fh;
 181         parse_string($text, $name);
 182 }
 183
 184 sub start(;$) {
 185         $arguments = $_[0];
 186         @cond = (1);
 187 }
 188
 189 sub finish() {
 190         $#cond and error "Unterminated \@if (depth $#cond)";
 191 }
 192
 193 sub process_file($;$) {
 194         my ($name, $args) = @_;
 195         start($args);
 196         parse_file($name);
 197         finish();
 198 }
 199
 200 sub process_string($;$) {
 201         my ($string, $args) = @_;
 202         start($args);
 203         parse_string($string, '<string>');
 204         finish();
 205 }
 206
 207 ### Perl commands embedded in the templates are evaluated in this package ###
 208
 209 package T;
 210
 211 import UCW::Temple;
 212
 213 # Beware: Functions in the T package should report errors via die(), not error().
 214
 215 our $temp;
 216 our $out_func = sub { print @_; };
 217
 218 sub include {
 219         my $fn = shift @_;
 220         while (@_) {
 221                 my $v = shift @_;
 222                 $temp = shift @_;
 223                 UCW::Temple::eval_if_ok("\$$v = \$temp");
 224         }
 225         UCW::Temple::parse_file($fn);
 226         return;
 227 }
 228
 229 sub load {
 230         my $f = shift @_;
 231         (!defined($f) || @_) and die "\@load requires only one argument";
 232         UCW::Temple::add_depend($f);
 233         require $f;
 234         return;
 235 }
 236
 237 1;