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