UCW/Temple.pm

   1 # A really simple template engine
   2 # (c) 2004--2015 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(set);
  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 sub set {
  27         my ($var, $val) = @_;
  28         $var = "T::$var";
  29         no strict 'refs';
  30         $$var = $val;
  31 }
  32
  33 our %deps = ();
  34
  35 sub add_depend($) {
  36         $deps{$_[0]} = 1;
  37 }
  38
  39 my $current_file_name;
  40 my $current_string;
  41 my $current_pos;
  42 my $reported_error;
  43
  44 sub error($;$) {
  45         my ($msg, $offset) = @_;
  46         if (defined $current_file_name && !$reported_error) {
  47                 #
  48                 #  This is rather tricky. We want to report the exact place, where the error
  49                 #  occurred, but the cost of keeping track of the current line number is too high.
  50                 #  Hence we keep just the current position inside the input stream and convert
  51                 #  it to the line number only when reporting an error.
  52                 #
  53                 my $input = substr(${$current_string}, 0, $current_pos);
  54                 my @newlines = ($input =~ m{\n}g);
  55                 my $line = @newlines + ($offset // 1);
  56                 $reported_error++;
  57                 die "$current_file_name:$line: $msg\n";
  58         } else {
  59                 die "$msg\n";
  60         }
  61 }
  62
  63 sub get_nested($$$) {
  64         my ($r, $left, $right) = @_;
  65         pos $$r = pos($$r) - 1;
  66         my $z = "";
  67         my $nest = 0;
  68         do {
  69                 if ($$r =~ /\G([^$left$right]+)/cgs) {
  70                 } elsif ($$r =~ /\G([$left])/cgs) {
  71                         $nest++;
  72                 } elsif ($$r =~ /\G([$right])/cgs) {
  73                         $nest--;
  74                 } else {
  75                         error "File ended when looking for matching $right";
  76                 }
  77                 $z .= $1;
  78         } while ($nest);
  79         return $z;
  80 }
  81
  82 # In addition to get_nested(), skip single-quoted and double-quoted string literals
  83 sub get_function_args($$$) {
  84         my ($r, $left, $right) = @_;
  85         pos $$r = pos($$r) - 1;
  86         my $z = "";
  87         my $nest = 0;
  88         do {
  89                 if ($$r =~ /\G([^$left$right"']+)/cgs
  90                         || $$r =~/\G("(\\.|[^"\\])*")/cgs               # double-quoted string
  91                         || $$r =~/\G('(\\.|[^'\\])*')/cgs               # single-quoted string
  92                 ) {
  93                 } elsif ($$r =~ /\G([$left])/cgs) {
  94                         $nest++;
  95                 } elsif ($$r =~ /\G([$right])/cgs) {
  96                         $nest--;
  97                 } else {
  98                         error "File ended when looking for matching $right";
  99                 }
 100                 $z .= $1;
 101         } while ($nest);
 102         return $z;
 103 }
 104
 105 sub eval_if_ok($) {
 106         if ($cond[0] > 0) {
 107                 my $x = shift;
 108                 my $res = eval "package T; $x";
 109                 return $res unless $@;
 110                 my $m = $@;
 111                 chomp $m;
 112                 if (my ($msg, $line) = $m =~ m{(.*) at \(eval \d+\) line (\d+)\.$}) {
 113                         error $msg, $line;
 114                 } else {
 115                         error $m;
 116                 }
 117         } else {
 118                 return "";
 119         }
 120 }
 121
 122 sub eval_func($$) {
 123         my ($f, $a) = @_;
 124         if ($f =~ /^(if|fi|else|elif)$/) {
 125                 if ($f eq "if") {
 126                         $a ne "()" or error "\@if requires an argument";
 127                         if ($cond[0] > 0) {
 128                                 unshift @cond, (eval_if_ok($a) ? 1 : -1);
 129                         } else {
 130                                 unshift @cond, 0;
 131                         }
 132                 } elsif ($f eq "fi") {
 133                         $a eq "()" or error "\@fi takes no arguments";
 134                         $#cond or error "\@fi without \@if";
 135                         shift @cond;
 136                 } elsif ($f eq "else") {
 137                         $a eq "()" or error "\@else takes no arguments";
 138                         $#cond or error "\@else without \@if";
 139                         $cond[0] = -$cond[0];
 140                 } elsif ($f eq "elif") {
 141                         $a ne "()" or error "\@elif requires an argument";
 142                         $#cond or error "\@elif without \@if";
 143                         if ($cond[0] > 0) {
 144                                 $cond[0] = 0;
 145                         } elsif ($cond[0] < 0) {
 146                                 $cond[0] = 1;
 147                                 $cond[0] = (eval_if_ok($a) ? 1 : -1);
 148                         }
 149                 }
 150                 # print "Cond stack: @cond\n";
 151         } else {
 152                 my $res = eval_if_ok("$f $a");
 153                 out $res if defined $res;
 154         }
 155 }
 156
 157 sub parse_string($$) {
 158         my ($t, $name) = @_;
 159         my ($old_fn, $old_str, $old_pos) = ($current_file_name, $current_string, $current_pos);
 160         $current_file_name = $name;
 161         $current_string = \$t;
 162         pos $t = 0;
 163         for (;;) {
 164                 $current_pos = pos $t;
 165                 # Scan for the first occurrence of an active character ("@", "~")
 166                 if ($t =~ /\G([^\@~]+)/cgs) {
 167                         out $1 if $cond[0] > 0;
 168                 } elsif ($t =~ /\G~/cgs) {
 169                         out $T::tilde if $cond[0] > 0;
 170                 } elsif ($t =~ /\G\@~/cgs) {
 171                         out "~" if $cond[0] > 0;
 172                 } elsif ($t =~ /\G\@\s*\n/cgs) {
 173                         # @ at end of line is ignored and eats the end of line
 174                 } elsif ($t =~ /\G\@#[^\n]*\n/cgs) {
 175                         # a comment, which is ignored
 176                 } elsif ($t =~ /\G\@\@/cgs) {
 177                         out "\@" if $cond[0] > 0;
 178                 } elsif ($t =~ /\G\@\{/cgs) {
 179                         my $x = get_nested(\$t, '\{', '\}');
 180                         out eval_if_ok($x);
 181                 } elsif ($t =~ /\G\@\[/cgs) {
 182                         my $x = get_nested(\$t, '\[', '\]');
 183                         $x =~ s/^\[//;
 184                         $x =~ s/\]$//;
 185                         eval_if_ok($x);
 186                 } elsif ($t =~ /\G\@\(/cgs) {
 187                         my $x = get_nested(\$t, '\(', '\)');
 188                         $x =~ s/^\(//;
 189                         $x =~ s/\)$//;
 190                         out (defined($arguments->{$x}) ? $arguments->{$x} : "");
 191                 } elsif ($t =~ /\G\@(\w+)\(/cgs) {
 192                         my $func = $1;
 193                         my $args = get_function_args(\$t, '(', ')');
 194                         eval_func($func, $args);
 195                 } elsif ($t =~ /\G\@(\w+)([^\n]*)\n/cgs) {
 196                         eval_func($1, "($2)");
 197                 } elsif ($t =~ /\G\@(\$\w+)/cgs) {
 198                         out eval_if_ok($1);
 199                 } elsif ($t =~ /\G(\@[^\n]*)/cgs) {
 200                         error "Unknown control sequence $1";
 201                 } elsif ($t =~ /\G$/cgs) {
 202                         last;
 203                 } elsif ($t =~ /\G([^\n]*)/cgs) {
 204                         error "Internal parser error";
 205                 } else { die; }
 206         }
 207         ($current_file_name, $current_string, $current_pos) = ($old_fn, $old_str, $old_pos);
 208 }
 209
 210 sub parse_file($) {
 211         my ($name) = @_;
 212         add_depend($name);
 213         my $fh = new IO::File $name;
 214         error "Unable to open $name: $!" unless defined $fh;
 215         my $text;
 216         { local $/; undef $/; $text = <$fh>; }
 217         undef $fh;
 218         parse_string($text, $name);
 219 }
 220
 221 sub start(;$) {
 222         $arguments = $_[0];
 223         @cond = (1);
 224         $reported_error = 0;
 225 }
 226
 227 sub finish() {
 228         $#cond and error "Unterminated \@if (depth $#cond)";
 229 }
 230
 231 sub process_file($;$) {
 232         my ($name, $args) = @_;
 233         start($args);
 234         parse_file($name);
 235         finish();
 236 }
 237
 238 sub process_string($;$) {
 239         my ($string, $args) = @_;
 240         start($args);
 241         parse_string($string, '<string>');
 242         finish();
 243 }
 244
 245 ### Perl commands embedded in the templates are evaluated in this package ###
 246
 247 package T;
 248
 249 import UCW::Temple;
 250
 251 # Beware: Functions in the T package should report errors via die(), not error().
 252
 253 our $temp;
 254 our $out_func = sub { print @_; };
 255 our $tilde = '~';
 256
 257 sub include {
 258         my $fn = shift @_;
 259         while (@_) {
 260                 my $v = shift @_;
 261                 $temp = shift @_;
 262                 UCW::Temple::eval_if_ok("\$$v = \$temp");
 263         }
 264         UCW::Temple::parse_file($fn);
 265         return;
 266 }
 267
 268 sub load {
 269         my $f = shift @_;
 270         (!defined($f) || @_) and die "\@load requires only one argument";
 271         UCW::Temple::add_depend($f);
 272         require $f;
 273         return;
 274 }
 275
 276 sub arg {
 277         return $UCW::Temple::arguments->{$_[0]};
 278 }
 279
 280 1;