UCW/Temple.pm

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