SL/Template/Simple.pm

   1 #====================================================================
   2 # LX-Office ERP
   3 # Copyright (C) 2004
   4 # Based on SQL-Ledger Version 2.1.9
   5 # Web http://www.lx-office.org
   6 #
   7 #====================================================================
   8
   9 package SL::Template::Simple;
  10
  11 use strict;
  12
  13 use Scalar::Util qw(blessed);
  14
  15 # Parameters:
  16 #   1. The template's file name
  17 #   2. A reference to the Form object
  18 #   3. A reference to the myconfig hash
  19 #
  20 # Returns:
  21 #   A new template object
  22 sub new {
  23   my $type = shift;
  24   my $self = {};
  25
  26   bless($self, $type);
  27   $self->_init(@_);
  28
  29   return $self;
  30 }
  31
  32 sub _init {
  33   my ($self, %params) = @_;
  34
  35   $params{myconfig}  ||= \%::myconfig;
  36   $params{userspath} ||= $::lx_office_conf{paths}->{userspath};
  37
  38   $self->{$_} = $params{$_} for keys %params;
  39
  40   $self->{variable_content_types}        ||= {};
  41   $self->{variable_content_types}->{$_}    = lc $self->{variable_content_types}->{$_} for keys %{ $self->{variable_content_types} };
  42   $self->{default_variable_content_type}   = 'text';
  43
  44   $self->{error}     = undef;
  45   $self->{quot_re}   = '"';
  46
  47   $self->set_tag_style('<%', '%>');
  48 }
  49
  50 sub set_tag_style {
  51   my $self                    = shift;
  52   my $tag_start               = shift;
  53   my $tag_end                 = shift;
  54
  55   $self->{custom_tag_style}   = 1;
  56   $self->{tag_start}          = $tag_start;
  57   $self->{tag_end}            = $tag_end;
  58   $self->{tag_start_qm}       = quotemeta $tag_start;
  59   $self->{tag_end_qm}         = quotemeta $tag_end;
  60
  61   $self->{substitute_vars_re} = "$self->{tag_start_qm}(.+?)$self->{tag_end_qm}";
  62 }
  63
  64 sub set_use_template_toolkit {
  65   my $self                    = shift;
  66   my $value                   = shift;
  67
  68   $self->{use_template_toolkit} = $value;
  69 }
  70
  71 sub cleanup {
  72   my ($self) = @_;
  73 }
  74
  75 # Parameters:
  76 #   1. A typeglob for the file handle. The output will be written
  77 #      to this file handle.
  78 #
  79 # Returns:
  80 #   1 on success and undef or 0 if there was an error. In the latter case
  81 #   the calling function can retrieve the error message via $obj->get_error()
  82 sub parse {
  83   my $self = $_[0];
  84   local *OUT = $_[1];
  85
  86   print(OUT "Hallo!\n");
  87 }
  88
  89 sub get_error {
  90   my $self = shift;
  91
  92   return $self->{"error"};
  93 }
  94
  95 sub uses_temp_file {
  96   return 0;
  97 }
  98
  99 sub _get_loop_variable {
 100   my ($self, $var, $get_array, @indices) = @_;
 101   my $form      = $self->{form};
 102   my ($value, @methods);
 103
 104   if ($var =~ m/\./) {
 105     ($var, @methods) = split m/\./, $var;
 106   }
 107
 108   if (($get_array || @indices) && (ref $form->{TEMPLATE_ARRAYS} eq 'HASH') && (ref $form->{TEMPLATE_ARRAYS}->{$var} eq 'ARRAY')) {
 109     $value = $form->{TEMPLATE_ARRAYS}->{$var};
 110   } else {
 111     $value = $form->{$var};
 112   }
 113
 114   for (my $i = 0; $i < scalar(@indices); $i++) {
 115     last unless (ref($value) eq "ARRAY");
 116     $value = $value->[$indices[$i]];
 117   }
 118
 119   for my $part (@methods) {
 120     if (ref($value) =~ m/^(?:Form|HASH)$/) {
 121       $value = $value->{$part};
 122     } elsif (blessed($value) && $value->can($part)) {
 123       $value = $value->$part;
 124     } else {
 125       $value = '';
 126       last;
 127     }
 128   }
 129
 130   return $value;
 131 }
 132
 133 sub substitute_vars {
 134   my ($self, $text, @indices) = @_;
 135
 136   my $form = $self->{"form"};
 137
 138   while ($text =~ /$self->{substitute_vars_re}/) {
 139     my ($tag_pos, $tag_len) = ($-[0], $+[0] - $-[0]);
 140     my ($var, @option_list) = split(/\s+/, $1);
 141     my %options             = map { ($_ => 1) } @option_list;
 142
 143     my $value               = $self->_get_loop_variable($var, 0, @indices);
 144     $value                  = $form->parse_amount({ numberformat => $::myconfig{output_numberformat} || $::myconfig{numberformat} }, $value) if     $options{NOFORMAT};
 145     $value                  = $self->format_string($value, $var)                                                                             unless $options{NOESCAPE};
 146
 147     substr($text, $tag_pos, $tag_len, $value);
 148   }
 149
 150   return $text;
 151 }
 152
 153 sub _parse_block_if {
 154   $main::lxdebug->enter_sub();
 155
 156   my $self         = shift;
 157   my $contents     = shift;
 158   my $new_contents = shift;
 159   my $pos_if       = shift;
 160   my @indices      = @_;
 161
 162   $$new_contents .= $self->substitute_vars(substr($$contents, 0, $pos_if), @indices);
 163   substr($$contents, 0, $pos_if) = "";
 164
 165   if ($$contents !~ m/^$self->{tag_start_qm}if
 166                      \s*
 167                      (not\b|\!)?           # $1 -- Eventuelle Negierung
 168                      \s+
 169                      (\b.+?\b)             # $2 -- Name der zu überprüfenden Variablen
 170                      (                     # $3 -- Beginn des optionalen Vergleiches
 171                        \s*
 172                        ([!=])              # $4 -- Negierung des Vergleiches speichern
 173                        ([=~])              # $5 -- Art des Vergleiches speichern
 174                        \s*
 175                        (                   # $6 -- Gequoteter String oder Bareword
 176                          $self->{quot_re}
 177                          (.*?)(?<!\\)      # $7 -- Gequoteter String -- direkter Vergleich mit eq bzw. ne oder Patternmatching; Escapete Anführungs als Teil des Strings belassen
 178                          $self->{quot_re}
 179                        |
 180                          (\b.+?\b)         # $8 -- Bareword -- als Index für $form benutzen
 181                        )
 182                      )?
 183                      \s*
 184                      $self->{tag_end_qm}
 185                     /x) {
 186     $self->{"error"} = "Malformed $self->{tag_start}if$self->{tag_end}.";
 187     $main::lxdebug->leave_sub();
 188     return undef;
 189   }
 190
 191   my $not           = $1;
 192   my $var           = $2;
 193   my $comparison    = $3; # Optionaler Match um $4..$8
 194   my $operator_neg  = $4; # '=' oder '!' oder undef, wenn kein Vergleich erkannt
 195   my $operator_type = $5; # '=' oder '~' für Stringvergleich oder Regex
 196   my $quoted_word   = $7; # nur gültig, wenn quoted string angegeben (siehe unten); dann "value" aus <%if var == "value" %>
 197   my $bareword      = $8; # undef, falls quoted string angegeben wurde; andernfalls "othervar" aus <%if var == othervar %>
 198
 199   $not = !$not if ($operator_neg && $operator_neg eq '!');
 200
 201   substr($$contents, 0, length($&)) = "";
 202
 203   my $block;
 204   ($block, $$contents) = $self->find_end($$contents, 0, "$var $comparison", $not);
 205   if (!$block) {
 206     $self->{"error"} = "Unclosed $self->{tag_start}if$self->{tag_end}." unless ($self->{"error"});
 207     $main::lxdebug->leave_sub();
 208     return undef;
 209   }
 210
 211   my $value = $self->_get_loop_variable($var, 0, @indices);
 212   $value    = scalar(@{ $value }) if (ref($value) || '') eq 'ARRAY';
 213   my $hit   = 0;
 214
 215   if ($operator_type) {
 216     my $compare_to = $bareword ? $self->_get_loop_variable($bareword, 0, @indices) : $quoted_word;
 217     if ($operator_type eq '=') {
 218       $hit         = ($not && !($value eq $compare_to))     || (!$not && ($value eq $compare_to));
 219     } else {
 220       $hit         = ($not && !($value =~ m/$compare_to/i)) || (!$not && ($value =~ m/$compare_to/i));
 221     }
 222
 223   } else {
 224     $hit           = ($not && ! $value)                     || (!$not &&  $value);
 225   }
 226
 227   if ($hit) {
 228     my $new_text = $self->parse_block($block, @indices);
 229     if (!defined($new_text)) {
 230       $main::lxdebug->leave_sub();
 231       return undef;
 232     }
 233     $$new_contents .= $new_text;
 234   }
 235
 236   $main::lxdebug->leave_sub();
 237
 238   return 1;
 239 }
 240
 241 1;