selfforum-cgi/shared/Template.pm

   1 package Template;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Template.pm                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-04-12                          #
   8 #                                                                              #
   9 # Description: Handle XML based HTML-Templates                                 #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw($xml_dom_used);
  15
  16 use Carp qw(croak confess);
  17
  18 BEGIN {
  19   $xml_dom_used = eval q[
  20     local $SIG{__DIE__};
  21     use XML::DOM;
  22     1;
  23   ];
  24 }
  25
  26 ### sub new ####################################################################
  27 #
  28 # constructor
  29 #
  30 # Params: ~none~
  31 #
  32 # Return: Template object
  33 #
  34 sub new {
  35   my $instance = shift;
  36
  37   my $self = bless {} => ref($instance) || $instance;
  38
  39   $self -> file (+shift);
  40
  41   # return
  42   $self;
  43 }
  44
  45 ### sub file ###################################################################
  46 #
  47 # assign new template file to object
  48 # parse the template file
  49 #
  50 # Params: $new - (optional) new template file
  51 #
  52 # Return: scalar - old filename or if there's no old filename given
  53 #
  54 sub file {
  55   my $self = shift;
  56   my $new  = shift;
  57   my $old  = $self -> {file};
  58
  59   $self -> {file} = $new if (defined $new);
  60   $self -> parse_file;
  61
  62   # return
  63   $old;
  64 }
  65
  66 ### sub insert #################################################################
  67 #
  68 # return the placeholder surrounded by meta delimiters
  69 #
  70 # Params: $name - name of placeholder
  71 #
  72 # Return: scalar - placeholder surrounded by meta delimiters
  73 #
  74 sub insert {
  75   my $self = shift;
  76   my $name = shift;
  77
  78   croak "no template file specified"
  79     unless (defined $self -> {file});
  80
  81   # return
  82   $self -> {metaon} . $name . $self -> {metaoff};
  83 }
  84
  85 ### sub list ###################################################################
  86 #
  87 # fill in a complete list
  88 #
  89 # Params: $name  - name of the atomic scrap
  90 #         $array - list of hashes (same strcuture like the hash used by 'scrap')
  91 #
  92 # Return: scalar reference - filled in list
  93 #
  94 sub list {
  95   my $self = shift;
  96   my $name = shift;
  97
  98   croak "no template file specified"
  99     unless (defined $self -> {file});
 100
 101 #  no warnings 'uninitialized';
 102   my $list = join '' => map { ${ $self -> scrap ($name, $_) } } @{ +shift };
 103
 104   # return
 105   \$list;
 106 }
 107
 108 ### sub scrap ##################################################################
 109 #
 110 # fill in a template scrap
 111 #
 112 # Params: $name - name of the scrap
 113 #
 114 # Return: scalar reference - filled in scrap
 115 #
 116 sub scrap {
 117   my $self = shift;
 118   my $name = shift;
 119
 120   croak "no template file specified"
 121     unless (defined $self -> {file});
 122
 123   return \'' unless (defined $name and defined ($self -> {parsed} -> {$name}));
 124
 125   # fetch parameters
 126   # (and normalize - save only the references in %params)
 127   #
 128   my %params;
 129   %params = map {
 130     my $ref = $_;
 131     map {
 132       ($_ => (
 133         ref ($ref -> {$_})
 134         ? (defined ${$ref -> {$_}} ? $ref -> {$_} : \'')
 135         : \(defined $ref -> {$_} ? $ref -> {$_} : ''))
 136       )
 137     } keys %$ref
 138   } splice @_;
 139
 140   # fill in...
 141   #
 142   my $scrap = $self -> {parsed} -> {$name};
 143   my $qmon  = quotemeta $self -> {metaon};
 144   my $qmoff = quotemeta $self -> {metaoff};
 145
 146   # ...until we've replaced all placeholders
 147   #
 148   1 while (
 149       $scrap =~ s
 150       <
 151         $qmon \s*
 152         ([_a-zA-Z] \S*)
 153         \s* $qmoff
 154       >
 155       [ (exists ( $params{$1} ) )
 156         ? ${$params{$1}}
 157         : ( exists ( $self -> {parsed} -> {$1} )
 158             ? $self -> {parsed} -> {$1}
 159             : ''
 160           );
 161       ]gex
 162     );
 163
 164   # parse conditional blocks
 165   #
 166   $self -> parse_if (
 167     \$scrap,
 168     \%params
 169   );
 170
 171   # return
 172   \$scrap;
 173 }
 174
 175 ### sub parse_file #############################################################
 176 #
 177 # read in and parse template file
 178 #
 179 # Params: ~none~
 180 #
 181 # Return: Status Code (Boolean)
 182 #
 183 sub parse_file {
 184   my $self = shift;
 185   my $filename = $self -> {file};
 186
 187   if ($xml_dom_used) {
 188
 189     # parse template using XML::DOM
 190     #
 191     my $xml = eval {
 192       local $SIG{__DIE__};
 193       new XML::DOM::Parser -> parsefile ($filename);
 194     };
 195     croak "error while parsing template file '$filename': $@" if ($@);
 196
 197     my $template = $xml -> getElementsByTagName ('Template', 0) -> item (0);
 198
 199     # extract meta delimiters
 200     #
 201     $self -> {metaon}  = $template -> getAttribute ('metaon');
 202     $self -> {metaoff} = $template -> getAttribute ('metaoff');
 203
 204     croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});
 205
 206     $self -> {parsed} = {};
 207     foreach ($template -> getElementsByTagName ('Scrap', 0)) {
 208       my $name = $_ -> getAttribute ('id');
 209
 210       croak "Element 'Scrap' requires attribute 'id' in template file '$filename'." unless (length ($name));
 211       croak "double defined id '$name' in template file '$filename'." if (exists ($self -> {parsed} -> {$name}));
 212       croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')." unless ($name =~ /^[_a-zA-Z]\S*$/);
 213
 214       $self -> {parsed} -> {$name} = $_ -> getFirstChild -> getData;
 215       $self -> {parsed} -> {$name} =~ s/^\s+|\s+$//g;}
 216
 217     return 1; # looks fine
 218   }
 219   else {
 220     # XML::DOM not available...
 221     # parse the template using both hands ;)
 222     #
 223
 224     my ($xml, $root, $template);
 225     local (*FILE, $/);
 226
 227     open FILE, "< $filename" or croak "error while reading template file '$filename': $!";
 228     $xml = <FILE>;
 229     close FILE or croak "error while closing template file '$filename' after reading: $!";
 230
 231     ($root, $template) = ($1, $2) if ($xml =~ m|(<Template\s+[^>"]*(?:"[^"]*"[^>"]*)*>)(.*)</Template\s*>|s);
 232     croak "error while parsing template file '$filename': missing root element 'Template'"
 233       unless (defined $root and defined $template);
 234
 235     # extract meta delimiters
 236     #
 237     $self -> {metaon}  = $1 if ($root =~ /\smetaon\s*=\s*"([^"]+)"/);
 238     $self -> {metaoff} = $1 if ($root =~ /\smetaoff\s*=\s*"([^"]+)"/);
 239
 240     croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});
 241
 242     # don't use any other entities than &quot; &apos; &lt; &gt; and &amp;
 243     # (while using non XML::DOM - version)
 244     #
 245     for ('metaon', 'metaoff') {
 246       $self -> {$_} =~ s/&quot;/"/g;  $self -> {$_} =~ s/&apos;/'/g;
 247       $self -> {$_} =~ s/&lt;/</g;    $self -> {$_} =~ s/&gt;/>/g;
 248       $self -> {$_} =~ s/&amp;/&/g;
 249     }
 250
 251     $self -> {parsed} = {};
 252     while ($template =~ m|<Scrap\s+(?:id\s*=\s*"([^"]+)")?\s*>\s*<!\[CDATA\[([^\]]*(?:\](?!\]>)[^\]]*)*)\]\]>\s*</Scrap\s*>|g) {
 253
 254       my ($name, $content) = ($1, $2);
 255
 256       croak "Element 'Scrap' requires attribute 'id' in template file '$filename'"
 257         unless (defined $name and length $name);
 258
 259       croak "double defined id '$name' in template file '$filename'"
 260         if (exists ($self -> {parsed} -> {$name}));
 261
 262       croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')"
 263         unless ($name =~ /^[_a-zA-Z]\S*$/);
 264
 265       $content =~ s/^\s+//; $content =~ s/\s+$//;
 266       $self -> {parsed} -> {$name} = $content;
 267     }
 268
 269     return 1; # looks fine
 270   }
 271
 272   return; # anything failed (??)
 273 }
 274
 275 ### sub parse_if ###############################################################
 276 #
 277 # parse conditional blocks
 278 #
 279 # Params: $scrap  - scalar reference of the template scrap
 280 #         $params - hash reference: values from the application
 281 #
 282 # Return: ~none~, ($$scrap will be modified)
 283 #
 284 sub parse_if {
 285   my $self = shift;
 286   my ($scrap, $params) = @_;
 287
 288   my $qmon  = quotemeta $self -> {metaon};
 289   my $qmoff = quotemeta $self -> {metaoff};
 290
 291   # the following regex is just not optimized,
 292   # but it works ;)
 293
 294   1 while ($$scrap =~ s {
 295     ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # skip this part
 296     (?=$qmon\s*%IF\s+.+?\s*$qmoff)           # if %IF or %ELSE are followed by %IF
 297
 298    |(                                        # $2 starts here
 299      $qmon\s*%IF\s+(.+?)\s*$qmoff            # %IF
 300      (.*?)                                   # $4
 301      (?:
 302        $qmon\s*%ENDIF\s*$qmoff               # followed by %ENDIF
 303       |                                      # or
 304        $qmon\s*%ELSE\s*$qmoff                # %ELSE...
 305        (.*?)                                 # $5
 306        $qmon\s*%ENDIF\s*$qmoff               # ...and ENDIF
 307      )
 308     )
 309   }
 310   { my $ret;
 311     if ($2) {
 312       my ($t3, $t4, $t5) = ($3, $4, $5);
 313
 314       for (split /\s+/,$t3) {
 315         next unless (
 316           exists($params->{$_})
 317           and defined ${$params->{$_}}
 318           and length ${$params->{$_}}
 319         );
 320
 321         $ret = $t4; last;
 322       }
 323
 324       $ret = $t5 || '' unless (defined $ret);
 325     }
 326     else {
 327       $ret=$1;
 328     }
 329
 330     $ret;
 331   }gsex);
 332
 333   return;
 334 }
 335
 336 # keeping 'require' happy
 337 1;
 338
 339 #
 340 #
 341 ### end of Template ############################################################