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