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