added methods: joinlist, printscrap and scrap2file

[selfforum.git] / selfforum-cgi / shared / Template.pm

diff --git a/selfforum-cgi/shared/Template.pm b/selfforum-cgi/shared/Template.pm
index d02949392a017cc1097e7d67c8509c7cfcd3fadd..50103d2e5d12b468ea390a134a80cc8a5147cd2b 100644 (file)
--- a/selfforum-cgi/shared/Template.pm
+++ b/selfforum-cgi/shared/Template.pm
@@ -1,150 +1,282 @@
-# Template.pm
+package Template;

 
 

-# ====================================================
-# Autor: n.d.p. / 2001-01-06
-# lm   : n.d.p. / 2001-01-25
-# ====================================================
-# Funktion:
-#      Ausfuellen von Templates
-# ====================================================
+################################################################################
+#                                                                              #
+# File:        shared/Template.pm                                              #
+#                                                                              #
+# Authors:     André Malo       <nd@o3media.de>, 2001-07-01                    #
+#              Frank Schoenmann <fs@tower.de>,   2001-06-04                    #
+#                                                                              #
+# Description: Handle XML based HTML-Templates                                 #
+#                                                                              #
+################################################################################

 
 use strict;
 
 use strict;

+use vars qw(
+  $xml_dom_used
+  $VERSION
+);
+
+use Carp qw(
+  croak
+  confess
+);
+
+BEGIN {
+  $xml_dom_used = eval q[
+    local $SIG{__DIE__};
+    use XML::DOM;
+    1;
+  ];
+}

 
 

-package Template;
-
-use CGI::Carp qw(croak);
-use XML::DOM;
+################################################################################
+#
+# Version check
+#
+$VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

 
 

-# ====================================================
-# Methoden
-# ====================================================

 
 

-################################
-# sub new
+### sub new ####################################################################
+#
+# constructor
+#
+# Params: ~none~
+#
+# Return: Template object

 #
 #

-# Konstruktor
-################################
-

 sub new {
 sub new {

-  my $instance=shift;
-  my $class=(ref($instance) or $instance);
+  my $instance = shift;

 
 

-  my $self = {};
-  $self = bless $self,$class;
+  my $self = bless {} => ref($instance) || $instance;

 
   $self -> file (+shift);
 
 
   $self -> file (+shift);
 

-  # Rueckgabe
+  # return

   $self;
 }
 
   $self;
 }
 

-################################
-# sub file
+### sub file ###################################################################
+#
+# assign new template file to object
+# parse the template file
+#
+# Params: $new - (optional) new template file
+#
+# Return: scalar - old filename or if there's no old filename given

 #
 #

-# Datei zuweisen und parsen
-################################
-

 sub file {
   my $self = shift;
 sub file {
   my $self = shift;

-  my $old = $self -> {file};
-  my $new = shift;
+  my $new  = shift;
+  my $old  = $self -> {file};

 
   $self -> {file} = $new if (defined $new);
   $self -> parse_file;
 
 
   $self -> {file} = $new if (defined $new);
   $self -> parse_file;
 

+  # return

   $old;
 }
 
   $old;
 }
 

-################################
-# sub insert
+### sub insert #################################################################
+#
+# return the placeholder surrounded by meta delimiters
+#
+# Params: $name - name of placeholder
+#
+# Return: scalar - placeholder surrounded by meta delimiters

 #
 #

-# Bezeichner in Metazeichen
-# eingeschlossen zurueckgeben
-################################
-

 sub insert {
 sub insert {

-  my $self=shift;
-  croak "no template file specified" unless (defined $self -> {file});
+  my $self = shift;
+  my $name = shift;

 
 

-  my $name=shift;
+  croak "no template file specified"
+    unless (defined $self -> {file});

 
 

-  # Rueckgabe
+  # return

   $self -> {metaon} . $name . $self -> {metaoff};
 }
 
   $self -> {metaon} . $name . $self -> {metaoff};
 }
 

-################################
-# sub list
+### sub list ###################################################################
+#
+# fill in a complete list
+#
+# Params: $name  - name of the atomic scrap
+#         $array - list of hashes (same strcuture like the hash used by 'scrap')
+#
+# Return: scalar reference - filled in list

 #
 #

-# komplette Liste einsetzen
-################################
-

 sub list {
 sub list {

-  my $self=shift;
-  my $name=shift;
+  my $self = shift;

 
 

-  croak "no template file specified" unless (defined $self->{file});
+  croak "no template file specified"
+    unless (defined $self -> {file});

 
 

-  my $list = join '', map { ${ $self -> scrap ($name, $_) } } @{ +shift };
+  $self -> joinlist ('' => @_);
+}
+
+### sub joinlist ###############################################################
+#
+# fill in a complete list, using a scrap between the list elements
+#
+# Params: $join  - joining string (or stringref)
+#         $name  - name of the atomic list scrap
+#         $array - list of hashes (same strcuture like the hash used by 'scrap')
+#
+# Return: scalar reference - filled in list
+#
+sub joinlist {
+  my $self = shift;
+  my $join = shift;
+  $join = $$join if ref($join);
+  my $name = shift;
+
+  my $list = join $join => map { ${ $self -> scrap ($name, $_) } } @{ +shift };

 
 

-  # Rueckgabe
+  # return

   \$list;
 }
 
   \$list;
 }
 

-################################
-# sub scrap
+### sub scrap ##################################################################
+#
+# fill in a template scrap
+#
+# Params: $name    name of the scrap
+#         ...
+#         $no_nl   1 - remove newlines (\n)
+#                  0 - do no such thing
+#
+# Return: scalar reference - filled in scrap

 #
 #

-# Schnipsel ausfuellen
-################################
-

 sub scrap {
 sub scrap {

-  my $self=shift;
-  my $name=shift;
+  my $self = shift;
+  my $name = shift;

 
 

-  croak "no template file specified" unless (defined $self->{file});
+  my $no_nl;
+  if (!ref $_[$#_]) {
+      $no_nl = pop @_;
+  }

 
 

-  my %params;
+  croak "no template file specified"
+    unless (defined $self -> {file});

 
 

-  # Parameter holen
-  # Als Values werden nur die Referenzen gespeichert
-  %params = map { my $ref = $_; map { ($_ => ( (ref ($ref -> {$_} ) )?$ref -> {$_}: \($ref -> {$_} ) ) ) } keys %$ref } splice @_;
+  return \'' unless (defined $name and defined ($self -> {parsed} -> {$name}));

 
 

-  # und einsetzen
-  my $scrap=$self->{parsed}->{$name};
-  my $qmon=quotemeta $self->{metaon};
-  my $qmoff=quotemeta $self->{metaoff};
+  # fetch parameters
+  # (and normalize - save only the references in %params)
+  #
+  my %params;
+  %params = map {
+    my $ref = $_;
+    map {
+      ($_ => (
+        ref ($ref -> {$_})
+        ? (defined ${$ref -> {$_}} ? $ref -> {$_} : \'')
+        : \(defined $ref -> {$_} ? $ref -> {$_} : ''))
+      )
+    } keys %$ref
+  } splice @_;
+
+  # fill in...
+  #
+  my $scrap = $self -> {parsed} -> {$name};
+  my $qmon  = quotemeta $self -> {metaon};
+  my $qmoff = quotemeta $self -> {metaoff};

 
 

-  # und zwar solange, bis nichts mehr da ist
-  while ($scrap =~ s<$qmon\s*([_a-zA-Z]\S*)\s*$qmoff>[
-    my $x='';
-    if ( exists ( $params{$1} ) ) { $x = ${$params{$1}} }
-    elsif (exists ( $self -> {parsed} -> {$1} ) ) { $x = $self -> {parsed} -> {$1}}
-    $x;]geo ){};
+  # ...until we've replaced all placeholders
+  #
+  1 while (
+      $scrap =~ s
+      <
+        $qmon \s*
+        ([_a-zA-Z] \S*)
+        \s* $qmoff
+      >
+      [ (exists ( $params{$1} ) )
+        ? ${$params{$1}}
+        : ( exists ( $self -> {parsed} -> {$1} )
+            ? $self -> {parsed} -> {$1}
+            : ''
+          );
+      ]gex
+    );
+
+  # parse conditional blocks
+  #
+  $self -> parse_if (
+    \$scrap,
+    \%params
+  );

 
 

-  $self -> parse_if (\$scrap,\%params);
+  # remove newlines
+  #
+  $scrap =~ s/\015\012|\015|\012//g if ($no_nl);

 
 

-  # Rueckgabe
+  # return

   \$scrap;
 }
 
   \$scrap;
 }
 

-# ====================================================
-# Private Funktionen/Methoden
-# ====================================================
+### printscrap () ##############################################################
+#
+# fill in a template scrap and print to STDOUT
+#
+# Params: $name    name of the scrap
+#         ...
+#         $no_nl   1 - remove newlines (\n)
+#                  0 - do no such thing
+#
+# Return: success code (boolean)
+#
+sub printscrap {
+  my $self = shift;
+
+  $self -> scrap2file (\*STDOUT, @_);
+}

 
 

-################################
-# sub parse_file
+### scrap2file () ##############################################################

 #
 #

-# Template einlesen & parsen
-################################
+# fill in a template scrap and print to a file handle
+#
+# Params: $handle  filehandle
+#         $name    name of the scrap
+#         ...
+#         $no_nl   1 - remove newlines (\n)
+#                  0 - do no such thing
+#
+# Return: success code (boolean)
+#
+sub scrap2file {
+  my $self = shift;
+  my $handle = shift;
+
+  print $handle ${$self->scrap(@_)};
+}

 
 

+### sub parse_file #############################################################
+#
+# read in and parse template file
+#
+# Params: ~none~
+#
+# Return: Status Code (Boolean)
+#

 sub parse_file {
   my $self = shift;
 sub parse_file {
   my $self = shift;

+  my $filename = $self -> {file};
+
+  if ($xml_dom_used) {
+
+    # parse template using XML::DOM
+    #
+    my $xml = eval {
+      local $SIG{__DIE__};
+      new XML::DOM::Parser -> parsefile ($filename);
+    };
+    croak "error while parsing template file '$filename': $@" if ($@);

 
 

-  if (-f $self -> {file}) {
-    my $filename = $self -> {file};
-    my $xml = new XML::DOM::Parser -> parsefile ($filename);

     my $template = $xml -> getElementsByTagName ('Template', 0) -> item (0);
 
     my $template = $xml -> getElementsByTagName ('Template', 0) -> item (0);
 

-    # Metas bestimmen
+    # extract meta delimiters
+    #

     $self -> {metaon}  = $template -> getAttribute ('metaon');
     $self -> {metaoff} = $template -> getAttribute ('metaoff');
 
     $self -> {metaon}  = $template -> getAttribute ('metaon');
     $self -> {metaoff} = $template -> getAttribute ('metaoff');
 


@@ -161,69 +293,128 @@ sub parse_file {
       $self -> {parsed} -> {$name} = $_ -> getFirstChild -> getData;
       $self -> {parsed} -> {$name} =~ s/^\s+|\s+$//g;}
 
       $self -> {parsed} -> {$name} = $_ -> getFirstChild -> getData;
       $self -> {parsed} -> {$name} =~ s/^\s+|\s+$//g;}
 

-    return 1; # alles klar
+    return 1; # looks fine

   }
   }

+  else {
+    # XML::DOM not available...
+    # parse the template using both hands ;)
+    #
+
+    my ($xml, $root, $template);
+    local (*FILE, $/);
+
+    open FILE, "< $filename" or croak "error while reading template file '$filename': $!";
+    $xml = <FILE>;
+    close FILE or croak "error while closing template file '$filename' after reading: $!";
+
+    ($root, $template) = ($1, $2) if ($xml =~ m|(<Template\s+[^>"]*(?:"[^"]*"[^>"]*)*>)(.*)</Template\s*>|s);
+    croak "error while parsing template file '$filename': missing root element 'Template'"
+      unless (defined $root and defined $template);
+
+    # extract meta delimiters
+    #
+    $self -> {metaon}  = $1 if ($root =~ /\smetaon\s*=\s*"([^"]+)"/);
+    $self -> {metaoff} = $1 if ($root =~ /\smetaoff\s*=\s*"([^"]+)"/);
+
+    croak "missing meta defintion(s) in template file '$filename'." unless ($self -> {metaon} and $self -> {metaoff});

 
 

-  0;
+    # don't use any other entities than &quot; &apos; &lt; &gt; and &amp;
+    # (while using non XML::DOM - version)
+    #
+    for ('metaon', 'metaoff') {
+      $self -> {$_} =~ s/&quot;/"/g;  $self -> {$_} =~ s/&apos;/'/g;
+      $self -> {$_} =~ s/&lt;/</g;    $self -> {$_} =~ s/&gt;/>/g;
+      $self -> {$_} =~ s/&amp;/&/g;
+    }
+
+    $self -> {parsed} = {};
+    while ($template =~ m|<Scrap\s+(?:id\s*=\s*"([^"]+)")?\s*>\s*<!\[CDATA\[([^\]]*(?:\](?!\]>)[^\]]*)*)\]\]>\s*</Scrap\s*>|g) {
+
+      my ($name, $content) = ($1, $2);
+
+      croak "Element 'Scrap' requires attribute 'id' in template file '$filename'"
+        unless (defined $name and length $name);
+
+      croak "double defined id '$name' in template file '$filename'"
+        if (exists ($self -> {parsed} -> {$name}));
+
+      croak "use '/^[_a-zA-Z]\\S*\$/' for 'Scrap'-ids in template file '$filename' (wrong: '$name')"
+        unless ($name =~ /^[_a-zA-Z]\S*$/);
+
+      $content =~ s/^\s+//; $content =~ s/\s+$//;
+      $self -> {parsed} -> {$name} = $content;
+    }
+
+    return 1; # looks fine
+  }
+
+  return; # anything failed (??)

 }
 
 }
 

-################################
-# sub parse_if
+### sub parse_if ###############################################################
+#
+# parse conditional blocks
+#
+# Params: $scrap  - scalar reference of the template scrap
+#         $params - hash reference: values from the application
+#
+# Return: ~none~, ($$scrap will be modified)

 #
 #

-# %IF - Anweisungen parsen
-################################
-

 sub parse_if {
   my $self = shift;
 sub parse_if {
   my $self = shift;

-  my ($scrap,$params) = @_;
+  my ($scrap, $params) = @_;

 
   my $qmon  = quotemeta $self -> {metaon};
   my $qmoff = quotemeta $self -> {metaoff};
 
 
   my $qmon  = quotemeta $self -> {metaon};
   my $qmoff = quotemeta $self -> {metaoff};
 

-  # der folgende Regex ist ein bisschen fies ...
-  # ... aber er funktioniert :-)
-  #
-  # pfff - rekursive Strukturen iterativ parsen ist nicht wirklich witzig
-  while ($$scrap=~s[ ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # Wenn IF oder ELSE von
-                     (?=$qmon\s*%IF\s+.+?\s*$qmoff)           # IF gefolgt werden, soll
-                                                              # dieses Stueck uebersprungen
-                                                              # werden und erstmal mit der
-                                                              # naechsten Ebene weitergemacht
-                                                              # werden.
-
-                    |(                                        # hier beginnt $2
-                      $qmon\s*%IF\s+(.+?)\s*$qmoff            # IF
-                      (.*?)                                   # $4
-                      (?:
-                        $qmon\s*%ENDIF\s*$qmoff               # gefolgt von ENDIF
-                       |                                      # oder
-                        $qmon\s*%ELSE\s*$qmoff                # von ELSE... ($4 ELSE $5) $5 $6
-                        (.*?)
-                        $qmon\s*%ENDIF\s*$qmoff               # und ENDIF
-                      )
-                     )
-                   ]
-                   [my $ret;
-                    if ($2) {
-                      my ($t4,$t5,$t6) = ($4,$5,$6);
-                      my $flag=0;
-                      foreach (split /\s+/,$3) {
-                        if (exists($params->{$_}) and length(${$params->{$_}})) {$ret = $t4; $flag=1;last;}}
-                      $ret = $t5 unless ($flag);}
-                    else {$ret=$1;}
-                    $ret;
-                   ]gosex) {};
+  # the following regex is just not optimized,
+  # but it works ;)
+
+  1 while ($$scrap =~ s {
+    ($qmon\s*%(?:IF|ELSE)\s+.+?\s*$qmoff.*?) # skip this part
+    (?=$qmon\s*%IF\s+.+?\s*$qmoff)           # if %IF or %ELSE are followed by %IF
+
+   |(                                        # $2 starts here
+     $qmon\s*%IF\s+(.+?)\s*$qmoff            # %IF
+     (.*?)                                   # $4
+     (?:
+       $qmon\s*%ENDIF\s*$qmoff               # followed by %ENDIF
+      |                                      # or
+       $qmon\s*%ELSE\s*$qmoff                # %ELSE...
+       (.*?)                                 # $5
+       $qmon\s*%ENDIF\s*$qmoff               # ...and ENDIF
+     )
+    )
+  }
+  { my $ret;
+    if ($2) {
+      my ($t3, $t4, $t5) = ($3, $4, $5);
+
+      for (split /\s+/,$t3) {
+        next unless (
+          exists($params->{$_})
+          and defined ${$params->{$_}}
+          and length ${$params->{$_}}
+        );
+
+        $ret = $t4; last;
+      }
+
+      $ret = $t5 || '' unless (defined $ret);
+    }
+    else {
+      $ret=$1;
+    }
+
+    $ret;
+  }gsex);

 
   return;
 }
 
 
   return;
 }
 

-# ====================================================
-# Modulinitialisierung
-# ====================================================
-
-# making require happy
+# keep 'require' happy

 1;
 
 1;
 

-# ====================================================
-# end of Template
-# ====================================================
\ No newline at end of file
+#
+#
+### end of Template ############################################################
\ No newline at end of file