selfforum-cgi/shared/Template.pm

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