File Coverage

Qtpl.pm
Criterion Covered Total %
statement 146 247 59.1
branch 29 86 33.7
condition 1 3 33.3
subroutine 14 32 43.7
pod 14 27 51.8
total 204 395 51.6


line stmt bran cond sub pod time code
1             package Template::Qtpl;
2              
3             ###########################################################################
4             # Copyright (c) 2000 barnabÓs debreceni [cranx@scene.hu]
5             # Original PHP version.
6             #
7             # Copyright(c) 2000-2001 Alexey Presnyakov [alexey_pres@sourceforge.net]
8             # Perl port and extension.
9             #
10             # This library is free software; you can redistribute it and/or
11             # modify it under the same terms as Perl itself.
12             #
13             # $Author: alexey_pres $, $Date: 2001/10/18 09:39:24 $
14             # $Revision: 1.2 $
15             ###########################################################################
16              
17              
18 1     1   2801 use strict;
  1         3  
  1         51  
19 1     1   7 use Carp;
  1         2  
  1         124  
20 1     1   8 use File::Basename;
  1         6  
  1         2112  
21              
22             $Template::Qtpl::VERSION = '0.5';
23             $Template::Qtpl::file_delim = "\{FILE\s*\"(.+?)\"\s*\}";
24             $Template::Qtpl::block_start_delim = '';
26             $Template::Qtpl::block_start_word = 'BEGIN:';
27             $Template::Qtpl::block_end_word = 'END:';
28             $Template::Qtpl::var_begin = '{';
29             $Template::Qtpl::var_end = '}';
30              
31              
32             ############################ variable set functions ################
33             sub block_start_delim {
34 0     0 1 0 my ($v) = shift;
35 0         0 my $ret;
36 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
37 0         0 $ret = $Template::Qtpl::block_start_delim;
38 0 0       0 $Template::Qtpl::block_start_delim = $v if (length $v);
39 0         0 return $ret;
40             }
41              
42             sub block_end_delim {
43 0     0 1 0 my ($v) = shift;
44 0         0 my $ret;
45 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
46 0         0 $ret = $Template::Qtpl::block_end_delim;
47 0 0       0 $Template::Qtpl::block_end_delim = $v if (length $v);
48 0         0 return $ret;
49             }
50              
51             sub block_start_word {
52 0     0 1 0 my ($v) = shift;
53 0         0 my $ret;
54 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
55 0         0 $ret = $Template::Qtpl::block_start_word;
56 0 0       0 $Template::Qtpl::block_start_word = $v if (length $v);
57 0         0 return $ret;
58             }
59              
60             sub block_end_word {
61 0     0 1 0 my ($v) = shift;
62 0         0 my $ret;
63 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
64 0         0 $ret = $Template::Qtpl::block_end_word;
65 0 0       0 $Template::Qtpl::block_end_word = $v if (length $v);
66 0         0 return $ret;
67             }
68              
69             sub var_begin {
70 0     0 1 0 my ($v) = shift;
71 0         0 my $ret;
72 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
73 0         0 $ret = $Template::Qtpl::var_begin;
74 0 0       0 $Template::Qtpl::block_start_word = $v if (length $v);
75 0         0 return $ret;
76             }
77              
78             sub var_end {
79 0     0 1 0 my ($v) = shift;
80 0         0 my $ret;
81 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
82 0         0 $ret = $Template::Qtpl::var_end;
83 0 0       0 $Template::Qtpl::block_end_word = $v if (length $v);
84 0         0 return $ret;
85             }
86              
87             sub file_delim {
88 0     0 1 0 my ($v) = shift;
89 0         0 my $ret;
90 0 0       0 $v = shift if ((ref $v) eq 'Template::Qtpl');
91 0         0 $ret = $Template::Qtpl::file_delim;
92 0 0       0 $Template::Qtpl::file_delim = $v if (length $v);
93 0         0 return $ret;
94             }
95              
96             ############################ new ###################################
97             sub new {
98 1     1 1 11 my $class = shift;
99 1         3 my $self = {};
100 1         2 bless $self, $class;
101 1         6 $self->init(@_);
102 1         3 return $self;
103             }
104             ############################## init ################################
105             sub init {
106 1     1 0 3 my $self = shift;
107 1         3 my ($filename, $mainblock) = @_;
108             ##### set vars
109 1         7 $self->{filecontents} = '';
110 1         4 $self->{blocks} = {};
111 1         3 $self->{parsed_blocks} = {};
112 1         4 $self->{block_parse_order} = [];
113 1         3 $self->{sub_blocks} = {};
114 1         2 $self->{VARS} = {};
115             #this makes the delimiters look like: if you use my syntax.
116 1         4 $self->{NULL_STRING} = {''=>''};
117 1         5 $self->{NULL_BLOCK} = {''=>''};
118 1         3 $self->{mainblock} = '';
119 1         3 $self->{ERROR} = '';
120 1         3 $self->{AUTORESET} = 1;
121             ####### init variables
122 1         1 $self->{mainblock} = $mainblock;
123 1         3 $self->{FILENAME} = $filename;
124 1         6 $self->{filecontents} = $self->r_getfile($filename);
125 1         6 $self->{blocks} = $self->maketree($self->{filecontents}, $mainblock);
126 1         6 $self->scan_globals();
127 1         2 return $self;
128             }
129              
130             sub assign {
131 3     3 1 421 my $self = shift;
132 3         5 my ($k, $v);
133 3         8 while (scalar(@_)){
134 3         4 $k = shift;
135 3         4 $v = shift;
136 3         14 $self->{VARS}{$k} = $v;
137             }
138             }
139              
140             sub get_var{
141 6     6 0 6 my $self = shift;
142 6         7 my $v = shift; #variable name for subst
143 6         4 my $need_encode = 0;
144 6 50       10 if ($v =~ /^\~(.+)$/){
145 0         0 $v = $1;
146 0         0 $need_encode = 1;
147             }
148 6         14 my @sub = split(/\./,$v);
149 6         6 my $var;
150 6 100       17 if ($sub[0] =~ /^main::(.+)$/){
151 1     1   9 no strict;
  1         2  
  1         4351  
152 2         9 my $varname = $sub[0];
153 2 50       4 if (scalar(@sub)>1) {
154 2         6 $var = \%$varname;
155 2         2 shift @sub;
156 2         7 goto FROM_GLOBALS;
157             } else {
158 0         0 $var = $$varname;
159             }
160             } else {
161 4         6 $var=$self->{VARS};
162 6         4 FROM_GLOBALS:
163             my $sv;
164 6         7 foreach $sv (@sub){
165 9         18 $var = $var->{$sv};
166             }
167             }
168 6 50       12 if ($need_encode) {
169 0         0 $var =~ s/\"/\"/g;
170             }
171 6         22 return $var;
172             }
173              
174             sub _if_subst {
175 0     0   0 my $self = shift;
176 0         0 my ($if, $body) = @_;
177 0         0 my $if_val = $self->get_var($if);
178 0         0 my @parts = split(/$Template::Qtpl::var_begin[E]LSE$Template::Qtpl::var_end/, $body);
179 0 0       0 if (length $if_val) {
180 0         0 return $parts[0];
181             } else {
182 0         0 return $parts[1];
183             }
184             }
185              
186             sub parse {
187 4     4 1 13 my $self = shift;
188 4         5 my ($bname) = @_;
189 4         8 my $copy = $self->{blocks}->{$bname};
190              
191 4 50       10 $self->set_error("parse: blockname [$bname] does not exist")
192             unless (defined($self->{blocks}->{$bname}));
193              
194 4         77 while ($self->{blocks}->{$bname} =~
195             /$Template::Qtpl::var_begin([\~\w\.\:]+)$Template::Qtpl::var_end/g) {
196 9         15 my $v = $1;
197 9 50       14 next if ($v =~ /^IF\s+/);
198 9 50       12 next if ($v =~ /^(ELSE|ENDIF)$/);
199 9 100       20 if ($v =~ /^_BLOCK_\.(.+)$/) {
200 3         5 my $bname2=$1;
201 3         4 my $var=$self->{parsed_blocks}->{$bname2};
202 3 50       9 my $nul=(!exists($self->{NULL_BLOCK}->{$bname2})) ?
203             $self->{NULL_BLOCK}{''} :
204             $self->{NULL_BLOCK}->{$bname2};
205 3 50       7 $var=(!defined($var))?$nul:$var;
206 3         32 $copy =~ s/$Template::Qtpl::var_begin$v$Template::Qtpl::var_end/$var/eg;
  3         26  
207             } else {
208 6         13 my $var = $self->get_var($v);
209 6 50       15 my $nul=(!exists($self->{NULL_STRING}{$v})) ?
210             $self->{NULL_STRING}{''} :
211             $self->{NULL_STRING}{$v};
212 6 100       10 $var=(!length($var))?$nul:$var;
213 6 50       73 $copy =~ s/$Template::Qtpl::var_begin$v$Template::Qtpl::var_end/$var/eg
  6         51  
214             unless ($v =~ /^\d/);
215             }
216             }
217             # parse if tags
218 4         24 $copy =~ s/$Template::Qtpl::var_begin[I]F\s+(.+?)\s*$Template::Qtpl::var_end(.*?)$Template::Qtpl::var_begin[E]NDIF$Template::Qtpl::var_end/$self->_if_subst($1, $2)/egs;
  0         0  
219              
220 4         7 my ($bname_new) = split(/\:/, $bname);
221             #save as to parsed
222 4         10 $self->{parsed_blocks}->{$bname_new}.=$copy;
223             #reset sub-blocks
224 4         3 my ($bname3);
225 4 50       10 if ($self->{AUTORESET}) {
226 4 50       9 if (exists($self->{sub_blocks}->{$bname_new})) {
227 4         3 foreach $bname3 (@{$self->{sub_blocks}->{$bname_new}}){
  4         8  
228 7 50       11 next unless length ($bname_new);
229 7         13 $self->reset($bname3);
230             }
231             }
232             }
233             }
234              
235             #***[ rparse ]**************************************************************/
236             #* returns the parsed text for a block, including all sub-blocks.
237             sub rparse {
238 0     0 0 0 my $self = shift;
239 0         0 my $bname = shift;
240 0 0       0 if (exists($self->{sub_blocks}->{$bname})) {
241 0         0 my ($bname3);
242 0         0 foreach $bname3 (@{$self->{sub_blocks}->{$bname}}){
  0         0  
243 0 0       0 next if (!length $bname3);
244 0         0 $self->rparse($bname3);
245             }
246             }
247 0         0 $self->parse($bname);
248             }
249              
250             #***[ text ]****************************************************************/
251             #* returns the parsed text for a block
252             sub text {
253 0     0 1 0 my $self = shift;
254 0         0 my ($bname) = @_;
255 0 0       0 if (!length($bname)) {
256 0         0 $bname=$self->{mainblock};
257             }
258 0         0 return $self->{parsed_blocks}->{$bname};
259             }
260              
261             #/***[ out ]*****************************************************************/
262             #/* prints the parsed text
263             sub out {
264 0     0 1 0 my $self = shift;
265 0         0 my ($bname) = @_;
266 0         0 print $self->text($bname);
267             }
268              
269             #/***[ reset ]***************************************************************/
270             #/* resets the parsed text
271             sub reset {
272 7     7 0 7 my $self = shift;
273 7         8 my ($bname) = @_;
274 7         20 $self->{parsed_blocks}->{$bname}='';
275             }
276              
277             #***[ parsed ]**************************************************************/
278             #* returns true if block was parsed, false if not
279             sub parsed {
280 0     0 0 0 my $self = shift;
281 0         0 my ($bname) = @_;
282 0         0 return (defined($self->{parsed_blocks}->{$bname}));
283             }
284              
285             #***[ SetNullString ]*******************************************************/
286             #* sets the string to replace in case the var was not assigned
287             sub SetNullString {
288 0     0 0 0 my $self = shift;
289 0         0 my ($str, $varname) = @_;
290 0         0 $self->{NULL_STRING}{$varname}=$str;
291             }
292              
293             #***[ SetNullBlock ]********************************************************/
294             #* sets the string to replace in case the block was not parsed
295             sub SetNullBlock {
296 0     0 0 0 my $self = shift;
297 0         0 my ($str, $bname) = @_;
298 0         0 $self->{NULL_BLOCK}{$bname}=$str;
299             }
300              
301             #***[ set_autoreset ]*******************************************************/
302             #* sets AUTORESET to 1. (default is 1)
303             # if set to 1, parse() automatically resets the parsed blocks' sub blocks
304             # (for multiple level blocks)
305             sub set_autoreset {
306 0     0 1 0 my $self = shift;
307 0         0 $self->{AUTORESET}=1;
308             }
309              
310             #/***[ clear_autoreset ]*****************************************************/
311             #/*
312             # sets AUTORESET to 0. (default is 1)
313             # if set to 1, parse() automatically resets the parsed blocks' sub blocks
314             # (for multiple level blocks)
315             sub clear_autoreset {
316 0     0 1 0 my $self = shift;
317 0         0 $self->{AUTORESET}=0;
318             }
319              
320             #/***[ scan_globals ]********************************************************/
321             #/*
322             # scans global variables
323             #*/
324             sub scan_globals {
325 1     1 0 2 my $self = shift;
326 1         5 $self->assign("PHP",\%ENV);
327             #* access global variables as {ENV.HTTP_HOST} in your template! */
328             }
329              
330             #/******
331             #
332             # WARNING
333             # PUBLIC FUNCTIONS BELOW THIS LINE DIDN'T GET TESTED
334             #
335             #******/
336              
337              
338             #/***************************************************************************/
339             #/***[ private stuff ]*******************************************************/
340             #/***************************************************************************/
341             #/***[ maketree ]************************************************************/
342             #/*
343             # generates the array containing to-be-parsed stuff:
344             # $blocks["main"],$blocks["main.table"],$blocks["main.table.row"], etc.
345             # also builds the reverse parse order.
346             #*/
347             sub maketree {
348 1     1 0 3 my $self = shift;
349 1         2 my ($con, $block) = @_;
350 1         25 my @con2=split($Template::Qtpl::block_start_delim,$con);
351 1         4 my $level=0;
352 1         3 my @block_names = ('');
353 1         3 my %blocks=();
354 1         1 my $parent_name;
355 1         2 my ($k,$v, @res);
356 1         2 my %added_to_parent = ();
357 1         4 foreach $v (@con2){
358 9         26 my $patt="($Template::Qtpl::block_start_word|$Template::Qtpl::block_end_word)\\s*([\\w\\.\\:]+)\\s*$Template::Qtpl::block_end_delim(.*)";
359 9 100       163 if ($v =~ /$patt/is) {
360             # $res[1] = BEGIN or END
361             # $res[2] = block name
362             # $res[3] = kinda content
363 8         122 $res[1] = $1;
364 8         13 $res[2] = $2;
365 8         18 $res[3] = $3;
366 8 100       39 if ($res[1] eq $Template::Qtpl::block_start_word) {
    50          
367 4 50       12 $parent_name=@block_names ? join(".", @block_names) : '';
368 4         12 $parent_name =~ s/^\.//; #hack
369 4         10 $block_names[++$level ] = $res[2];
370             #/* add one level - array("main","table","row")*/
371 4         11 my @block_nm = @block_names;
372 4         5 shift @block_nm;
373 4         10 my $cur_block_name=join(".",@block_nm);
374             #/* make block name (main.table.row) */
375 4         5 push @{$self->{block_parse_order}}, $cur_block_name;
  4         8  
376             #/* build block parsing order (reverse) */
377 4         14 $blocks{$cur_block_name}.=$res[3];
378              
379 4         9 my ($cur_block_name_new) = split(/\:/, $cur_block_name);
380             #/* add contents */
381             #/* add {_BLOCK_.blockname} string to parent block */
382 4 50       14 if (!$added_to_parent{$cur_block_name_new}) {
383 4         23 $blocks{$parent_name}.=$Template::Qtpl::var_begin."_BLOCK_.$cur_block_name_new".$Template::Qtpl::var_end;
384             #/* store sub block names for autoresetting
385             # and recursive parsing */
386 4         5 push @{$self->{sub_blocks}->{$parent_name}},
  4         19  
387             $cur_block_name_new;
388             #/* store sub block names for autoresetting */
389 4         5 push @{$self->{sub_blocks}->{$cur_block_name_new}},'';
  4         15  
390             }
391 4         15 $added_to_parent{$cur_block_name_new}++;
392             } elsif ($res[1] eq $Template::Qtpl::block_end_word) {
393 4         8 splice(@block_names, $level--, 1);
394 4         10 $parent_name=join(".",@block_names);
395 4         58 $parent_name =~ s/^\.//; #hack
396 4         24 $blocks{$parent_name}.=$res[3];
397             #/* add rest of block to parent block */
398             } else { #if there is not block
399 0         0 $parent_name=join(".",@block_names);
400 0         0 $parent_name =~ s/^\.//; #hack
401 0         0 $blocks{$parent_name}.=$Template::Qtpl::block_start_delim . $v;
402             } }
403             }
404 1         7 return \%blocks;
405             }
406              
407              
408              
409             #/***[ error stuff ]*********************************************************/
410             #/*
411             # sets and gets error
412             #*/
413             sub get_error {
414 0     0 0 0 my $self = shift;
415 0 0       0 return ($self->{ERROR} eq '') ? 0 : $self->{ERROR};
416             }
417              
418              
419             sub set_error {
420 0     0 0 0 my $self = shift;
421 0         0 my $str = shift;
422 0         0 $self->{ERROR}=$str;
423 0         0 die "$self->{ERROR}\n";
424             }
425              
426             #/***[ getfile ]*************************************************************/
427             #/* returns the contents of a file
428             sub getfile {
429 1     1 0 2 my $self = shift;
430 1         2 my $file = shift;
431 1 50       4 if (!length($file)) {
432 0         0 $self->set_error("Empty file name!");
433 0         0 return '';
434             }
435             #find path of original template
436 1 50 33     6 if (($self->{FILENAME} ne $file) && dirname($self->{FILENAME})){
437 0         0 $file = dirname($self->{FILENAME}) . '/' .$file;
438             }
439 1 50       48 unless (open(XTPLFILE, $file)){
440 0         0 $self->set_error("Cannot open file: $file or file not exists");
441 0         0 return '';
442             }
443 1         49 my @file_text = ;
444 1         13 close(XTPLFILE);
445 1         12 return join('',@file_text);
446             }
447              
448             #/***[ r_getfile ]***********************************************************/
449             #/*
450             # recursively gets the content of a file with {FILE "filename.tpl"} directives
451             #*/
452             sub r_getfile($file) {
453 1     1 0 1 my $self = shift;
454 1         2 my $file = shift;
455 1         5 my $text=$self->getfile($file);
456 1         7 while ($text =~ /(\{FILE\s*")(.+?)(\"\s*\})/g){
457 0         0 my $full = $1.$2.$3;
458 0         0 my $text2=$self->getfile($2);
459 0         0 $text =~ s/$full/$text2/gi;
460             }
461 1         3 return $text;
462             }
463              
464             1;
465              
466             __END__