File Coverage

blib/lib/DeltaX/Page.pm
Criterion Covered Total %
statement 151 196 77.0
branch 62 100 62.0
condition 3 9 33.3
subroutine 10 11 90.9
pod 3 3 100.0
total 229 319 71.7


line stmt bran cond sub pod time code
1             #-----------------------------------------------------------------
2             package DeltaX::Page;
3             #-----------------------------------------------------------------
4             # $Id: Page.pm,v 1.3 2003/09/03 08:15:28 spicak Exp $
5             #
6             # (c) DELTA E.S., 2002 - 2003
7             # This package is free software; you can use it under "Artistic License" from
8             # Perl.
9             #
10             # This package uses some ideas from Perl Embeding Engine
11             # (from William Tan, you can see it at pee.sourceforge.net)
12             #-----------------------------------------------------------------
13              
14             $DeltaX::Page::VERSION = '1.3';
15              
16 1     1   439 use strict;
  1         1  
  1         27  
17 1     1   2 use Carp;
  1         1  
  1         1590  
18              
19             #-----------------------------------------------------------------
20             sub new {
21             #-----------------------------------------------------------------
22             # CONSTRUCTOR
23             #
24 2     2 1 28 my $pkg = shift;
25 2         2 my $self = {};
26 2         3 bless ($self, $pkg);
27              
28 2         2 my $filename = shift;
29 2 50       4 croak ("You must supply filename!") unless defined $filename;
30 2         8 $self->{filename} = $filename;
31 2         3 $self->{error} = '';
32 2         6 $self->{defs} = [];
33              
34 2 50       5 croak ("$pkg created with odd number of parameters".
35             " - should be of the form option => value")
36             if (@_ % 2);
37 2         7 for (my $x = 0; $x <= $#_; $x += 2) {
38 6 100       10 if ($_[$x] eq '_defs') {
39 2         5 $self->{defs} = $_[$x+1];
40             }
41             else {
42 4         12 $self->{special}{$_[$x]} = $_[$x+1];
43             }
44             }
45              
46 2         4 return $self;
47             }
48             # END OF new()
49              
50             #-----------------------------------------------------------------s
51             sub compile {
52             #-----------------------------------------------------------------
53             #
54 2     2 1 18 my $self = shift;
55 2         3 my $do_prints = shift;
56 2 50       4 if (!defined $do_prints) { $do_prints = 1; }
  2         3  
57              
58 2 50       5 if ($self->{filename} =~ /^string:/) {
59 0         0 $self->{buffer} = substr($self->{filename}, 7);
60             }
61             else {
62             # read file
63 2 50       52 if (! open (INF, $self->{filename})) {
64 0         0 $self->{error} = "Cannot open file: $!";
65 0         0 return 0;
66             }
67              
68 2         4 $self->{buffer} = '';
69 2         26 while () { $self->{buffer} .= $_; }
  23         36  
70 2         8 close INF;
71             }
72              
73 2         4 $self->{cursor} = 0;
74 2         2 $self->{blength} = length($self->{buffer});
75              
76 2         2 my $token;
77 2         2 my $type = 0;
78 2         4 $self->{translated} = '';
79              
80 2         2 $self->{do_output} = 1;
81 2         2 $self->{if_level} = 0;
82 2         4 $self->{if_count} = [];
83              
84 2         6 while ( ($type = $self->_next_token(\$token)) != -1 ) {
85 23 100       23 if ($type == 0) { # NORMAL BLOCK => print
86 11 100       17 if (!$self->{do_output}) { next; }
  1         2  
87 10 100       27 if ($token =~ /^[\s\n]*$/gs) { next; }
  8         10  
88 2         3 $token = _escape($token);
89 2 50       9 $self->{translated} .= "print \"$token\";\n" if $do_prints;
90             } else { # CODE
91 12         53 $token =~ s/<\?(.*)\?>/$1/gs;
92            
93 12 100       39 if ($token =~ /^-.*$/s) { # comment
    100          
    100          
    100          
94 1         2 next;
95             }
96             elsif ($token =~ /^=(.*)$/s) {
97 2 50       3 if (!$self->{do_output}) { next; }
  0         0  
98 2         6 $self->{translated} .= "print ($1);\n";
99             }
100             elsif ($token =~ /^!(.*)$/sm) {
101 3 50       7 if (!$self->{do_output}) { next; }
  0         0  
102             # special command
103 3         5 my $tmp = $self->_special($1);
104 3 50       10 if (!defined $tmp) { return 0; }
  0         0  
105 3         6 $self->{translated} .= $tmp;
106             }
107             elsif ($token =~ /^:(.*)$/s) {
108             # command
109 5 50       7 if (!$self->_command($1)) { return 0; }
  0         0  
110             } else {
111             # normal code
112 1 50       3 if (!$self->{do_output}) { next; }
  0         0  
113 1         2 $self->{translated} .= $token;
114             }
115             }
116              
117             }
118              
119 2         1 $self->{buffer} = '';
120 2         6 return 1;
121             }
122             # END OF compile()
123              
124             #-----------------------------------------------------------------
125             sub get_error {
126             #-----------------------------------------------------------------
127             #
128 0     0 1 0 my $self = shift;
129              
130 0         0 return $self->{error};
131             }
132             # END OF get_error()
133              
134             #-----------------------------------------------------------------
135             sub _next_token {
136             #-----------------------------------------------------------------
137             #
138 25     25   16 my $self = shift;
139 25         19 my $token = shift;
140            
141 25 100       36 if ($self->{cursor} == ($self->{blength} - 1)) {
142 2         3 $$token = '';
143 2         4 return -1; # no more data
144             }
145              
146 23         23 my $pos = index($self->{buffer}, '{cursor});
147 23 50       36 if ($pos == -1) {
    100          
148 0         0 $$token = substr($self->{buffer}, $self->{cursor});
149 0         0 $self->{cursor} = $self->{blength} - 1;
150 0         0 return 0; # normal text
151             } elsif ($pos > $self->{cursor}) {
152 11         15 $$token = substr($self->{buffer}, $self->{cursor}, $pos - $self->{cursor});
153 11         9 $self->{cursor} = $pos;
154 11         19 return 0; # till here normal text
155             } else {
156 12         11 my $end = index ($self->{buffer}, '?>', $pos);
157 12 50       15 if ($end == -1) {
158 0         0 $$token = substr($self->{buffer}, $self->{cursor});
159 0         0 $self->{cursor} = $self->{blength} - 1;
160 0         0 return 1; # code
161             }
162 12         19 $$token = substr($self->{buffer}, $pos, ($end - $pos + 2));
163 12         12 $self->{cursor} = $end + 2;
164 12         18 return 1;
165             }
166              
167             }
168             # END OF _next_token()
169              
170             #-----------------------------------------------------------------
171             sub _special {
172             #-----------------------------------------------------------------
173             #
174 3     3   1 my $self = shift;
175 3         4 my $token = shift;
176              
177 3         8 $token =~ s/^\s*//g;
178            
179 3 100       8 if ($token =~ /^include/) {
180 1         3 $token =~ /^include\s+([\S ]+)\s*$/;
181 1         3 return $self->_include($1, 'include');
182             }
183 2 50       3 if ($token =~ /^package/) {
184 0         0 $token =~ /^package\s+([\S ]+)\s*$/;
185 0         0 return $self->_include($1, 'package');
186             }
187              
188 2         5 $token =~ /^(\S+)\s*(.*)$/s;
189 2         2 my @args;
190 2 50       5 if ($2) { @args = split(/,/, $2); }
  2         5  
191             # other special command
192 2 0 33     9 if (! exists $self->{special}{$1} and ! exists $self->{special}{'*'}) {
193 0 0       0 if ($#args > -1) { return "$1($2);\n"; }
  0         0  
194 0         0 else { return "$1();\n"; }
195             }
196 2         3 my $tmp = $1;
197 2 50       7 $tmp = '*' if !exists $self->{special}{$tmp};
198 2 50       4 unshift @args, $1 if $tmp eq '*';
199 2         6 return $self->{special}{$tmp}->(@args);
200              
201             }
202             # END OF _special
203              
204             #-----------------------------------------------------------------
205             sub _include {
206             #-----------------------------------------------------------------
207             #
208 1     1   1 my $self = shift;
209 1         2 my $arg = shift;
210 1         1 my $type = shift;
211              
212 1         1 my @defs = @{$self->{defs}};
  1         4  
213              
214 1         2 my $am_i_string = $self->{filename} =~ /^string:/;
215              
216             # relative path!
217 1 50 33     4 if ($arg !~ /^\// || $am_i_string) {
218 1 50 33     6 if ($self->{filename} =~ /^(.*)\/[^\/]*$/ || $am_i_string) {
219 1 50       2 if ($self->{special}{$type}) {
220 0         0 my @tmp;
221 0         0 ($arg, @tmp) = $self->{special}{$type}->($arg);
222 0         0 push @defs, @tmp;
223             } else {
224 1         3 $arg = "$1/$arg";
225             }
226             }
227             }
228 1 50       3 if (!$arg) {
229 0         0 $self->{error} = "$type: no file found";
230 0         0 return undef;
231             }
232              
233 1         1 my @spec;
234 1         1 foreach my $s (sort keys %{$self->{special}}) {
  1         8  
235 2         3 push @spec, $s, $self->{special}{$s}
236             }
237 1         6 push @spec, '_defs', \@defs;
238 1         3 my $inc = new DeltaX::Page($arg, @spec);
239 1 50       3 if ($inc->compile()) {
240 1 50       2 if (!$am_i_string) {
241 1         8 return "\n#START $type $arg\n".$inc->{translated}."#END $type $arg\n\n\n";
242             }
243             else {
244 0         0 return "\n#START $type\n".$inc->{translated}."#END $type\n\n\n";
245             }
246             } else {
247 0         0 $self->{error} = "include: unable to compile '$arg': ". $inc->get_error();
248 0         0 return undef;
249             }
250             }
251             # END OF _include()
252              
253             #-----------------------------------------------------------------
254             sub _escape {
255             #-----------------------------------------------------------------
256             #
257 2     2   3 my $text = shift;
258              
259 2         2 $text =~ s/\\/\\\\/g;
260 2         4 $text =~ s/\n/\\n/g;
261 2         2 $text =~ s/\t/\\t/g;
262 2         3 $text =~ s/'/\\'/g;
263 2         2 $text =~ s/"/\\"/g;
264 2         2 $text =~ s/\$/\\\$/g;
265 2         1 $text =~ s/\%/\\\%/g;
266 2         2 $text =~ s/\@/\\\@/g;
267 2         3 $text =~ s/&/\\&/g;
268 2         1 $text =~ s/`/\\`/g;
269 2         2 $text =~ s/\|/\\\|/g;
270              
271 2         2 return $text;
272             }
273             # END OF escape()
274              
275             #-----------------------------------------------------------------
276             sub _command {
277             #-----------------------------------------------------------------
278              
279 5     5   2 my $self = shift;
280 5         5 my $arg = shift;
281              
282 5         5 my $command;
283             my @other_args;
284 5         14 ($command, $arg, @other_args) = split(/\s/, $arg);
285            
286 5 100       15 if ($command eq 'if') {
    100          
    100          
    100          
    50          
287 1 50       3 if (!$self->{do_output}) { return 1; }
  0         0  
288 1         2 $self->{if_level}++;
289 1         2 $self->{if_count}->[$self->{if_level}]++;
290 1         1 my $test = $arg;
291 1 50       2 if ($arg =~ /^!/) {
292 0         0 $test = substr($test, 1);
293 0 0       0 if (grep (/^$test$/, @{$self->{defs}})) {
  0         0  
294 0         0 $self->{do_output} = 0;
295             }
296             else {
297 0         0 $self->{do_output} = 1;
298             }
299             }
300             else {
301 1 50       1 if (grep (/^$arg$/, @{$self->{defs}})) {
  1         22  
302 1         1 $self->{do_output} = 1;
303             }
304             else {
305 0         0 $self->{do_output} = 0;
306             }
307             }
308             }
309             elsif ($command eq 'else') {
310 1 50       4 if (!$self->{if_level}) {
311 0         0 $self->{error} = "else without if";
312 0         0 return;
313             }
314 1         3 $self->{do_output} = !$self->{do_output};
315             }
316             elsif ($command eq 'end') {
317 1 50       3 if (!$self->{if_level}) {
318 0         0 $self->{error} = "end without if";
319 0         0 return;
320             }
321 1         2 $self->{do_output} = 1;
322 1         3 $self->{if_count}->[$self->{if_level}]--;
323 1 50       6 $self->{if_level}-- if !$self->{if_count}->[$self->{if_level}];
324             }
325             elsif ($command eq 'for') {
326 1 50       3 if (!$self->{do_output}) { return 1; }
  0         0  
327 1         1 $self->{for_level}++;
328 1         6 $self->{translated} .= "for $arg ".join(' ', @other_args)." {\n";
329             }
330             elsif ($command eq 'done') {
331 1 50       4 if (!$self->{for_level}) {
332 0         0 $self->{error} = "done without for";
333 0         0 return;
334             }
335 1         2 $self->{translated} .= "}\n";
336 1         1 $self->{for_level}--;
337             }
338             else {
339 0         0 $self->{error} = "Uknown conditional '$command' [$arg]";
340 0         0 return 0;
341             }
342              
343 5         20 return 1;
344             }
345             # END OF _command()
346              
347             #-----------------------------------------------------------------
348             sub DESTROY {
349             #-----------------------------------------------------------------
350             #
351 2     2   5 my $self = shift;
352              
353             }
354             # END OF DESTROY()
355              
356             1;
357              
358             =head1 NAME
359              
360             DeltaX::Page - Perl module for parsing pages for masser
361              
362             _____
363             / \ _____ ______ ______ ___________
364             / \ / \\__ \ / ___// ___// __ \_ __ \
365             / Y \/ __ \_\___ \ \___ \\ ___/| | \/
366             \____|__ (____ /____ >____ >\___ >__|
367             \/ \/ \/ \/ \/ project
368              
369              
370             =head1 SYNOPSIS
371              
372             use DeltaX::Page;
373              
374             my $page = new DeltaX::Page('myfile.pg');
375             if (!$page->compile()) {
376             # write some error
377             }
378             else {
379             my $code = $page->{translated};
380             }
381              
382             =head1 FUNCTIONS
383              
384             =head2 new()
385              
386             Constructor. It has one required parameter - name of file to parse. This name
387             can be prefixed with string: so module it uses as code itself, without reading
388             the file.
389              
390             Other parameters are in "directive => sub reference" form (see L<"DIRECTIVES">).
391              
392             You can define values for conditional output as an array reference to _defs
393             argument to new() this way:
394              
395             my $page = new DeltaX::Page('somepage.pg', dir1=>\&dir,
396             _defs=>['defined1', 'defined2']);
397              
398             =head2 compile()
399              
400             Tries to compile given file to perl code (which can be evaled). See L<"FILE
401             SYNTAX"> for more information. Returns true in case of success, otherwise
402             returns false.
403              
404             =head2 get_error()
405              
406             Returns textual representation of error (only valid after compile() call).
407              
408             =head1 FILE SYNTAX
409              
410             This module is parsing page code for masser (see masser.sourceforge.net) - it's
411             something like perl code embeded in HTML (or XML or other) code. It compiles
412             everything to print statements, except this:
413              
414             =over
415              
416             =item *
417              
418             everything between is a comment and is ignored
419              
420             =item *
421              
422             everything between is a perl code and is included unchanged
423              
424             =item *
425              
426             is translated to print token; (remember this semicolon!)
427              
428             =item *
429              
430             is used for conditional and looped output; you can use following:
431              
432             =over
433              
434             =item if
435              
436             for example
437              
438             =item else
439              
440             for example:
441              
442            
443             some output
444            
445             some other output
446            
447              
448             =item end
449              
450             end of block for if/else
451              
452             =item for..done
453              
454             for example:
455              
456            
457             ...
458            
459              
460            
461             ...
462            
463              
464             =back
465              
466             Condition instructions can be embedded.
467              
468             =item *
469              
470             is processed externally (see L<"DIRECTIVES">)
471              
472             =back
473              
474             Example:
475              
476             Source code:
477            
478            

Hi, welcome to !

479            
480             It's
481            
482             my (undef, undef, undef, $day, $mon, $yer) = localtime();
483             $mon++; $yer+=1900;
484             print sprintf("%02d.%02d.%04d", $day, $mon, $yer);
485             ?>
486            
487             See you later...
488            
489             Compiled code:
490             print "

Hi, welcome to ";

491             print $app_name;
492             print "!";
493             print "\n\n";
494             print "It's\n";
495             my (undef, undef, undef, $day, $mon, $yer) = localtime();
496             $mon++; $yer+=1900;
497             print sprintf("%02d.%02d.%04d", $day, $mon, $yer);
498             print "\n
\nSee you later\n";
499              
500             [code was made a little bit readable :-)]
501              
502             =head1 DIRECTIVES
503              
504             Everything in is a special directive. Module knows
505             these directives:
506              
507             =over
508              
509             =item include
510              
511             - includes given file, this means tries to read and compile
512             this file and (in case of success) includes resulting code into actual code.
513              
514             =item package
515              
516             - works as include
517              
518             =item everything other
519              
520             Every other directive must be defined in new() function and apropriate function
521             will be called (arguments will be given to this function - if there are any).
522             Everything which is returned by this function is included in the code (function
523             must return true value - at least one space, if it returns false, it is detected
524             as an error).
525              
526             You can define directive in new() for include and package too, but this doesn't
527             change include or package itself, but module expects that called function
528             returns real full path to file to be included. Other returned values are got as
529             additional defines for conditional instructions (see _defs in new()) - but only
530             for included file.
531              
532             There is special directive definition *, which means 'everything other', so if
533             undefined directive is found, function assigned to it will be called.
534              
535             Example:
536              
537             sub my_include {
538             my $filename = shift;
539             # only relative path
540             return substr($filename, rindex($filename,'/')+1);
541             }
542              
543             sub my_javascript {
544             my $javascript_name = shift;
545             # code to give someone know that JavaScript code must be generated...
546             return "$cgi->add_javascript('$javascript_name');";
547             }
548              
549             sub my_other {
550             my ($directive, @args) = @_;
551             # return code according to $directory
552             }
553            
554             my $page = new DeltaX::Page('test.pg',include=>\&my_include,
555             javascript=>\&my_javascript, '*'=>\&my_other);
556              
557             =back