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