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