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