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-07-01                    #
   8 #              Frank Schoenmann <fs@tower.de>,   2001-06-04                    #
   9 #                                                                              #
  10 # Description: Handle XML based HTML-Templates                                 #
  11 #                                                                              #
  12 ################################################################################
  13
  14 use strict;
  15 use vars qw(
  16   $xml_dom_used
  17   $VERSION
  18 );
  19
  20 use Carp qw(
  21   croak
  22   confess
  23 );
  24
  25 BEGIN {
  26   $xml_dom_used = eval q[
  27     local $SIG{__DIE__};
  28     use XML::DOM;
  29     1;
  30   ];
  31 }
  32
  33 ################################################################################
  34 #
  35 # Version check
  36 #
  37 $VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  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
 111   croak "no template file specified"
 112     unless (defined $self -> {file});
 113
 114   $self -> joinlist ('' => @_);
 115 }
 116
 117 ### sub joinlist ###############################################################
 118 #
 119 # fill in a complete list, using a scrap between the list elements
 120 #
 121 # Params: $join  - joining string (or stringref)
 122 #         $name  - name of the atomic list scrap
 123 #         $array - list of hashes (same strcuture like the hash used by 'scrap')
 124 #
 125 # Return: scalar reference - filled in list
 126 #
 127 sub joinlist {
 128   my $self = shift;
 129   my $join = shift;
 130   $join = $$join if ref($join);
 131   my $name = shift;
 132
 133   my $list = join $join => map { ${ $self -> scrap ($name, $_) } } @{ +shift };
 134
 135   # return
 136   \$list;
 137 }
 138
 139 ### sub scrap ##################################################################
 140 #
 141 # fill in a template scrap
 142 #
 143 # Params: $name    name of the scrap
 144 #         ...
 145 #         $no_nl   1 - remove newlines (\n)
 146 #                  0 - do no such thing
 147 #
 148 # Return: scalar reference - filled in scrap
 149 #
 150 sub scrap {
 151   my $self = shift;
 152   my $name = shift;
 153
 154   my $no_nl;
 155   if (!ref $_[$#_]) {
 156       $no_nl = pop @_;
 157   }
 158
 159   croak "no template file specified"
 160     unless (defined $self -> {file});
 161
 162   return \'' unless (defined $name and defined ($self -> {parsed} -> {$name}));
 163
 164   # fetch parameters
 165   # (and normalize - save only the references in %params)
 166   #
 167   my %params;
 168   %params = map {
 169     my $ref = $_;
 170     map {
 171       ($_ => (
 172         ref ($ref -> {$_})
 173         ? (defined ${$ref -> {$_}} ? $ref -> {$_} : \'')
 174         : \(defined $ref -> {$_} ? $ref -> {$_} : ''))
 175       )
 176     } keys %$ref
 177   } splice @_;
 178
 179   # fill in...
 180   #
 181   my $scrap = $self -> {parsed} -> {$name};
 182   my $qmon  = quotemeta $self -> {metaon};
 183   my $qmoff = quotemeta $self -> {metaoff};
 184
 185   # ...until we've replaced all placeholders
 186   #
 187   1 while (
 188       $scrap =~ s
 189       <
 190         $qmon \s*
 191         ([_a-zA-Z] \S*)
 192         \s* $qmoff
 193       >
 194       [ (exists ( $params{$1} ) )
 195         ? ${$params{$1}}
 196         : ( exists ( $self -> {parsed} -> {$1} )
 197             ? $self -> {parsed} -> {$1}
 198             : ''
 199           );
 200       ]gex
 201     );
 202
 203   # parse conditional blocks
 204   #
 205   $self -> parse_if (
 206     \$scrap,
 207     \%params
 208   );
 209
 210   # remove newlines
 211   #
 212   $scrap =~ s/\015\012|\015|\012//g if ($no_nl);
 213
 214   # return
 215   \$scrap;
 216 }
 217
 218 ### printscrap () ##############################################################
 219 #
 220 # fill in a template scrap and print to STDOUT
 221 #
 222 # Params: $name    name of the scrap
 223 #         ...
 224 #         $no_nl   1 - remove newlines (\n)
 225 #                  0 - do no such thing
 226 #
 227 # Return: success code (boolean)
 228 #
 229 sub printscrap {
 230   my $self = shift;
 231
 232   $self -> scrap2file (\*STDOUT, @_);
 233 }
 234
 235 ### scrap2file () ##############################################################
 236 #
 237 # fill in a template scrap and print to a file handle
 238 #
 239 # Params: $handle  filehandle
 240 #         $name    name of the scrap
 241 #         ...
 242 #         $no_nl   1 - remove newlines (\n)
 243 #                  0 - do no such thing
 244 #
 245 # Return: success code (boolean)
 246 #
 247 sub scrap2file {
 248   my $self = shift;
 249   my $handle = shift;
 250
 251   print $handle ${$self->scrap(@_)};
 252 }
 253
 254 ### sub parse_file #############################################################
 255 #
 256 # read in and parse template file
 257 #
 258 # Params: ~none~
 259 #
 260 # Return: Status Code (Boolean)
 261 #
 262 sub parse_file {
 263   my $self = shift;
 264   my $filename = $self -> {file};
 265
 266   if ($xml_dom_used) {
 267
 268     # parse template using XML::DOM
 269     #
 270     my $xml = eval {
 271       local $SIG{__DIE__};
 272       new XML::DOM::Parser -> parsefile ($filename);
 273     };
 274     croak "error while parsing template file '$filename': $@" if ($@);
 275
 276     my $template = $xml -> getElementsByTagName ('Template', 0) -> item (0);
 277
 278     # extract meta delimiters
 279     #
 280     $self -> {metaon}  = $template -> getAttribute ('metaon');
 281     $self -> {metaoff} = $template -> getAttribute ('metaoff');
 282
 283     croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});
 284
 285     $self -> {parsed} = {};
 286     foreach ($template -> getElementsByTagName ('Scrap', 0)) {
 287       my $name = $_ -> getAttribute ('id');
 288
 289       croak "Element 'Scrap' requires attribute 'id' in template file '$filename'." unless (length ($name));
 290       croak "double defined id '$name' in template file '$filename'." if (exists ($self -> {parsed} -> {$name}));
 291       croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')." unless ($name =~ /^[_a-zA-Z]\S*$/);
 292
 293       $self -> {parsed} -> {$name} = $_ -> getFirstChild -> getData;
 294       $self -> {parsed} -> {$name} =~ s/^\s+|\s+$//g;}
 295
 296     return 1; # looks fine
 297   }
 298   else {
 299     # XML::DOM not available...
 300     # parse the template using both hands ;)
 301     #
 302
 303     my ($xml, $root, $template);
 304     local (*FILE, $/);
 305
 306     open FILE, "< $filename" or croak "error while reading template file '$filename': $!";
 307     $xml = <FILE>;
 308     close FILE or croak "error while closing template file '$filename' after reading: $!";
 309
 310     ($root, $template) = ($1, $2) if ($xml =~ m|(<Template\s+[^>"]*(?:"[^"]*"[^>"]*)*>)(.*)</Template\s*>|s);
 311     croak "error while parsing template file '$filename': missing root element 'Template'"
 312       unless (defined $root and defined $template);
 313
 314     # extract meta delimiters
 315     #
 316     $self -> {metaon}  = $1 if ($root =~ /\smetaon\s*=\s*"([^"]+)"/);
 317     $self -> {metaoff} = $1 if ($root =~ /\smetaoff\s*=\s*"([^"]+)"/);
 318
 319     croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});
 320
 321     # don't use any other entities than &quot; &apos; &lt; &gt; and &amp;
 322     # (while using non XML::DOM - version)
 323     #
 324     for ('metaon', 'metaoff') {
 325       $self -> {$_} =~ s/&quot;/"/g;  $self -> {$_} =~ s/&apos;/'/g;
 326       $self -> {$_} =~ s/&lt;/</g;    $self -> {$_} =~ s/&gt;/>/g;
 327       $self -> {$_} =~ s/&amp;/&/g;
 328     }
 329
 330     $self -> {parsed} = {};
 331     while ($template =~ m|<Scrap\s+(?:id\s*=\s*"([^"]+)")?\s*>\s*<!\[CDATA\[([^\]]*(?:\](?!\]>)[^\]]*)*)\]\]>\s*</Scrap\s*>|g) {
 332
 333       my ($name, $content) = ($1, $2);
 334
 335       croak "Element 'Scrap' requires attribute 'id' in template file '$filename'"
 336         unless (defined $name and length $name);
 337
 338       croak "double defined id '$name' in template file '$filename'"
 339         if (exists ($self -> {parsed} -> {$name}));
 340
 341       croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')"
 342         unless ($name =~ /^[_a-zA-Z]\S*$/);
 343
 344       $content =~ s/^\s+//; $content =~ s/\s+$//;
 345       $self -> {parsed} -> {$name} = $content;
 346     }
 347
 348     return 1; # looks fine
 349   }
 350
 351   return; # anything failed (??)
 352 }
 353
 354 ### sub parse_if ###############################################################
 355 #
 356 # parse conditional blocks
 357 #
 358 # Params: $scrap  - scalar reference of the template scrap
 359 #         $params - hash reference: values from the application
 360 #
 361 # Return: ~none~, ($$scrap will be modified)
 362 #
 363 sub parse_if {
 364   my $self = shift;
 365   my ($scrap, $params) = @_;
 366
 367   my $qmon  = quotemeta $self -> {metaon};
 368   my $qmoff = quotemeta $self -> {metaoff};
 369
 370   # the following regex is just not optimized,
 371   # but it works ;)
 372
 373   1 while ($$scrap =~ s {
 374     ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # skip this part
 375     (?=$qmon\s*%IF\s+.+?\s*$qmoff)           # if %IF or %ELSE are followed by %IF
 376
 377    |(                                        # $2 starts here
 378      $qmon\s*%IF\s+(.+?)\s*$qmoff            # %IF
 379      (.*?)                                   # $4
 380      (?:
 381        $qmon\s*%ENDIF\s*$qmoff               # followed by %ENDIF
 382       |                                      # or
 383        $qmon\s*%ELSE\s*$qmoff                # %ELSE...
 384        (.*?)                                 # $5
 385        $qmon\s*%ENDIF\s*$qmoff               # ...and ENDIF
 386      )
 387     )
 388   }
 389   { my $ret;
 390     if ($2) {
 391       my ($t3, $t4, $t5) = ($3, $4, $5);
 392
 393       for (split /\s+/,$t3) {
 394         next unless (
 395           exists($params->{$_})
 396           and defined ${$params->{$_}}
 397           and length ${$params->{$_}}
 398         );
 399
 400         $ret = $t4; last;
 401       }
 402
 403       $ret = $t5 || '' unless (defined $ret);
 404     }
 405     else {
 406       $ret=$1;
 407     }
 408
 409     $ret;
 410   }gsex);
 411
 412   return;
 413 }
 414
 415 # keep 'require' happy
 416 1;
 417
 418 #
 419 #
 420 ### end of Template ############################################################