UCW/Temple.pm

   1 #!/usr/bin/perl
   2 # A really simple template engine
   3 # (c) 2004--2008 Martin Mares <mj@ucw.cz>
   4
   5 package UCW::Temple;
   6
   7 use strict;
   8 use warnings;
   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();
  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 get_nested($$$) {
  28         my ($r,$left,$right) = @_;
  29         pos $$r = pos($$r)-1;
  30         my $z = "";
  31         my $nest = 0;
  32         do {
  33                 if ($$r =~ /\G([^$left$right]+)/cgs) {
  34                 } elsif ($$r =~ /\G([$left])/cgs) {
  35                         $nest++;
  36                 } elsif ($$r =~ /\G([$right])/cgs) {
  37                         $nest--;
  38                 } else {
  39                         die "File ended when looking for matching $right";
  40                 }
  41                 $z .= $1;
  42         } while ($nest);
  43         return $z;
  44 }
  45
  46 sub eval_if_ok($) {
  47         if ($cond[0] > 0) {
  48                 my $x = shift;
  49                 my $res = eval "package T; $x";
  50                 return $res unless $@;
  51                 die "Error evaluating $x: $@";
  52         } else {
  53                 return "";
  54         }
  55 }
  56
  57 sub eval_func($$) {
  58         my ($f, $a) = @_;
  59         if ($f =~ /^(if|fi|else|elif)$/) {
  60                 if ($f eq "if") {
  61                         $a ne "()" or die "\@if requires an argument";
  62                         if ($cond[0] > 0) {
  63                                 unshift @cond, (eval_if_ok($a) ? 1 : -1);
  64                         } else {
  65                                 unshift @cond, 0;
  66                         }
  67                 } elsif ($f eq "fi") {
  68                         $a eq "()" or die "\@fi takes no arguments";
  69                         $#cond or die "\@fi without \@if";
  70                         shift @cond;
  71                 } elsif ($f eq "else") {
  72                         $a eq "()" or die "\@else takes no arguments";
  73                         $#cond or die "\@else without \@if";
  74                         $cond[0] = -$cond[0];
  75                 } elsif ($f eq "elif") {
  76                         $a ne "()" or die "\@elif requires an argument";
  77                         $#cond or die "\@elif without \@if";
  78                         if ($cond[0] > 0) {
  79                                 $cond[0] = 0;
  80                         } elsif ($cond[0] < 0) {
  81                                 $cond[0] = 1;
  82                                 $cond[0] = (eval_if_ok($a) ? 1 : -1);
  83                         }
  84                 }
  85                 # print "Cond stack: @cond\n";
  86         } else {
  87                 my $res = eval_if_ok("$f $a");
  88                 out $res if defined $res;
  89         }
  90 }
  91
  92 sub parse_string($) {
  93         my ($t) = @_;
  94         pos $t = 0;
  95         for(;;) {
  96                 if ($t =~ /\G([^\@]+)/cgs) {
  97                         out $1 if $cond[0] > 0;
  98                 } elsif ($t =~ /\G\@\s*\n/cgs) {
  99                         # @ at end of line is ignored and eats the end of line
 100                 } elsif ($t =~ /\G\@#[^\n]*\n/cgs) {
 101                         # a comment, which is ignored
 102                 } elsif ($t =~ /\G\@\@/cgs) {
 103                         out "\@";
 104                 } elsif ($t =~ /\G\@{/cgs) {
 105                         my $x = get_nested(\$t, "{", "}");
 106                         out eval_if_ok($x);
 107                 } elsif ($t =~ /\G\@\[/cgs) {
 108                         my $x = get_nested(\$t, '\[', '\]');
 109                         $x =~ s/^\[//;
 110                         $x =~ s/\]$//;
 111                         eval_if_ok($x);
 112                 } elsif ($t =~ /\G@\(/cgs) {
 113                         my $x = get_nested(\$t, '\(', '\)');
 114                         $x =~ s/^\(//;
 115                         $x =~ s/\)$//;
 116                         out (defined($arguments->{$x}) ? $arguments->{$x} : "");
 117                 } elsif ($t =~ /\G\@(\w+)\(/cgs) {
 118                         my $func = $1;
 119                         my $args = get_nested(\$t, '(', ')');
 120                         eval_func($func, $args);
 121                 } elsif ($t =~ /\G\@(\w+)([^\n]*)\n/cgs) {
 122                         eval_func($1, "($2)");
 123                 } elsif ($t =~ /\G\@(\$\w+)/cgs) {
 124                         out eval_if_ok($1);
 125                 } elsif ($t =~ /\G(\@[^\n]*)/cgs) {
 126                         die "Unknown control sequence $1";
 127                 } elsif ($t =~ /\G$/cgs) {
 128                         last;
 129                 } elsif ($t =~ /\G([^\n]*)/cgs) {
 130                         die "Internal parser error at $1 (pos " . pos($t) . ")";
 131                 } else { die; }
 132         }
 133 }
 134
 135 sub parse_file($) {
 136         my ($name) = @_;
 137         my $fh = new IO::File $name;
 138         die "Unable to open $name: $!" unless defined $fh;
 139         my $text;
 140         { local $/; undef $/; $text = <$fh>; }
 141         undef $fh;
 142         parse_string($text);
 143 }
 144
 145 sub start($)
 146 {
 147         $arguments = $_[0];
 148         @cond = (1);
 149 }
 150
 151 sub finish()
 152 {
 153         $#cond and die "Unterminated \@if (depth $#cond)";
 154 }
 155
 156 sub process_file($;$) {
 157         my ($name, $args) = @_;
 158         start($args);
 159         parse_file($name);
 160         finish();
 161 }
 162
 163 sub process_string($;$) {
 164         my ($string, $args) = @_;
 165         start($args);
 166         parse_string($string);
 167         finish();
 168 }
 169
 170 ### Perl commands embedded in the templates are evaluated in this package ###
 171
 172 package T;
 173
 174 import UCW::Temple;
 175
 176 our $temp;
 177 our $out_func = sub { print @_; };
 178
 179 sub include {
 180         my $fn = shift @_;
 181         while (@_) {
 182                 my $v = shift @_;
 183                 $temp = shift @_;
 184                 UCW::Temple::eval_if_ok("\$$v = \$temp");
 185         }
 186         UCW::Temple::parse_file($fn);
 187         return;
 188 }
 189
 190 sub load {
 191         my $f = shift @_;
 192         (!defined($f) || @_) and die "\@load requires only one argument";
 193         require $f;
 194         return;
 195 }
 196
 197 1;