File Coverage

blib/lib/HTML/XHTML/DVSM.pm
Criterion Covered Total %
statement 365 637 57.3
branch 111 248 44.7
condition 31 62 50.0
subroutine 30 49 61.2
pod 7 36 19.4
total 544 1032 52.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             # Copyright © 2007-2010 Stuart Butler (perldev@yahoo.co.uk) and Grant Holman (grant@collegeroad.eclipse.co.uk).
3             # This program is distributed under the terms of the The GNU General Public License (GPL), which can be viewed at http://www.opensource.org/licenses/gpl-license.php
4             #
5             package HTML::XHTML::DVSM;
6 1     1   28094 use Carp;
  1         3  
  1         99  
7             BEGIN {
8 1     1   17 $VERSION = '1.2';
9             }
10 1     1   5 use vars qw( $VERSION );
  1         3  
  1         42  
11 1     1   9 use strict;
  1         1  
  1         12533  
12             my $ELEMENT = 1;
13             my $PROC_INSTR = 2;
14             my $COMMENT = 3;
15             my $DOCUMENT_ROOT = 0;
16            
17             sub new {
18 1     1 1 13 my $class = shift;
19 1         3 my $self = {};
20 1         3 bless($self, $class );
21 1         6 $self->sbInit();
22 1         2 $self->{MarkupCache} = {};
23 1         4 $self->{SubsCache} = {};
24 1         3 $self->{StopOnError} = 0;
25 1         3 $self->{EvalPackage} = "main";
26 1 50       7 $self->{Stream} = *STDOUT if ( ! $self->{Stream} );
27 1         4 return $self;
28             }
29            
30             sub sbGetLastError() {
31 0     0 0 0 my $self = shift;
32 0         0 my $lasterror = $self->{LastError};
33 0         0 return $lasterror;
34             }
35            
36             sub sbSetStopOnError {
37 1     1 1 12 my $self = shift;
38 1         5 my $sbStopOnError = shift;
39 1         3 $self->{StopOnError} = $sbStopOnError;
40             }
41             sub sbIsStopOnError {
42 0     0 0 0 my $self = shift;
43 0         0 return $self->{StopOnError};
44             }
45            
46             sub sbSetEvalPackage {
47 0     0 0 0 my $self = shift;
48 0         0 my $pkg = shift;
49 0 0       0 $pkg = "main" if ( ! $pkg );
50 0         0 $self->{EvalPackage} = $pkg;
51 0         0 return $pkg;
52             }
53             sub sbManageError {
54 0     0 0 0 my $self = shift;
55 0         0 my $error = shift;
56 0 0       0 return if ( ! $error );
57 0         0 warn( $error );
58 0         0 $self->{LastError} = $error;
59 0 0       0 die( $error ) if ( $self->{StopOnError} );
60             }
61            
62             sub sbHash2String {
63 0     0 0 0 my $self = shift;
64 0         0 my $hash = shift;
65 0 0       0 return "" if ( ! $hash );
66 0         0 my $res = "";
67 0         0 foreach my $k ( keys %$hash ) {
68 0         0 $res .= "$k => $$hash{$k}, ";
69             }
70 0         0 return $res;
71             }
72            
73             sub sbPrintHash {
74 0     0 0 0 my $self = shift;
75 0         0 my $pre = shift;
76 0         0 my $post = shift;
77 0         0 my $hash = shift;
78 0         0 print STDERR $pre;
79 0         0 print STDERR $self->sbHash2String($hash);
80 0         0 print STDERR $post;
81             }
82            
83             sub sbGetContents {
84 0     0 0 0 my $self = shift;
85 0         0 my $htmldir = shift;
86 0         0 my $file_name = shift;
87 0         0 my $instr_file = shift;
88 0         0 my $contents = shift;
89 0         0 my $instructions = shift;
90 0         0 my $subs = shift;
91            
92 0 0 0     0 open( FIL, "< $htmldir/$file_name" ) || open( FIL, "< $file_name" ) || die( "Can't open file $file_name: $!" );
93             {
94 0         0 local $/;
  0         0  
95 0         0 $$contents = ;
96             }
97 0         0 close( FIL );
98 0 0       0 if ( $instr_file ) {
99 0         0 local $/; #read all file in one go, slurp mode.
100 0 0       0 open( FIL, "< $instr_file" ) || return "Can't find instruction file $instr_file";
101 0         0 $$contents .= ; # load all instructions into a string
102 0         0 close( FIL );
103             }
104 0         0 return $self->sbAnalyseContents( $htmldir, $contents, $instructions, $subs )
105             }
106            
107             sub sbAnalyseContents {
108 12     12 0 437 my $self = shift;
109 12         14 my $htmldir = shift;
110 12         13 my $contents = shift;
111 12         11 my $instructions = shift;
112 12         13 my $subs = shift;
113            
114 12   50     50 my $SCRIPT_TAG = ($self->{SCRIPT_TAG} || "DVSM" );
115 12   50     60 my $SUBS_TAG = ($self->{SUBS_TAG} || "DSUBS");
116 12         175 while ( $$contents =~ m#(<(\?|!--)${SCRIPT_TAG}_include\s+(.*?)\s*(--|\?)>)#gsi ) {
117 0         0 my $label = $1;
118 0         0 my $snippet = $3;
119 0         0 my $snippet_txt = "";
120 0 0 0     0 open( FIL, "< $htmldir/$snippet" ) || open( FIL, "< $snippet" ) || die( "Can't find snippet $snippet: $!" );
121             {
122 0         0 local $/;
  0         0  
123 0         0 $snippet_txt =
124             }
125 0         0 close( FIL );
126 0         0 $$contents =~ s#$label#$snippet_txt#gsie;
  0         0  
127             }
128            
129 12         63 while ( $$contents =~ s|<\?${SCRIPT_TAG}(.*?)\?>\n*||si ) {
130 0         0 $$instructions .= $1;
131             }
132 12         123 while ( $$contents =~ s|\n*||si ) {
133 12         102 $$instructions .= $1;
134             }
135 12         58 while ( $$contents =~ s|<\?${SUBS_TAG}(.*?)\?>\n*||si ) {
136 0         0 $$subs .= $1;
137             }
138 12         112 while ( $$contents =~ s|\n*||si ) {
139 10         54 $$subs .= $1;
140             }
141 12         19 $$subs .= "\nreturn 1;\n";
142 12 50 33     37 if ( $self->{DEBUG} && open( D, "> /tmp/dvsmsubs$$.pl") ) {
143 0         0 print D $$subs;
144 0         0 close( D );
145             }
146 12         25 return 1;
147             }
148            
149             sub sbParseInstructions {
150 9     9 0 13 my $self = shift;
151 9         10 my $instructionsStr = shift; # reference to a string
152 9         13 my $instructions = shift; # reference to an array of instructions
153 9         55 my @lines = split( /\n/, $$instructionsStr );
154 9         28 for ( my $i = 0; $i < @lines; $i++ ) {
155 20         28 my $line = $lines[$i];
156 20 100       181 if ( $line =~ m|^\s*set\s+(\S+)\s+to\s+"([^"]+)"\s+where\s+(\S+)\s*=\s*"([^"]+)"|i ) {
    100          
    50          
    100          
    100          
    100          
    50          
    0          
157             #set textnode to getTitle('Login') where tagname = title
158 6         9 my %instr = ();
159 6         12 $instr{cmd} = "set";
160 6         12 $instr{target} = $1;
161 6         12 $instr{exec} = $2;
162 6         11 $instr{where} = $3;
163 6         9 $instr{value} = $4;
164 6 50       29 if ( $line =~ m|\bif\s+"([^"]+)"|i ) {
165 0         0 $instr{condition} = $1;
166             }
167 6         21 push( @$instructions, \%instr ); #add instruction structure to the array of instructions
168             }
169             elsif ( $line =~ m|^\s*toggle\s+(\S+)\s+to\s+"([^"]+)"\s+where\s+(\S+)\s*=\s*"([^"]+)"|i ) {
170             #toggle checked to "canAddProject()" where name = "canaddproj"
171 1         3 my %instr = ();
172 1         3 $instr{cmd} = "toggle";
173 1         6 $instr{target} = $1;
174 1         2 $instr{exec} = $2;
175 1         3 $instr{where} = $3;
176 1         2 $instr{value} = $4;
177 1         5 push( @$instructions, \%instr ); #add instruction structure to the array of instructions
178             }
179             elsif ( $line =~ m|^\s*load\s+module\s+"([^"]+)"|i ) {
180             #load module "routines.pl"
181 0 0       0 if ( $1 ) {
182 0         0 my %instr = ();
183 0         0 $instr{cmd} = "load";
184 0         0 $instr{exec} = $1;
185 0         0 push( @$instructions, \%instr ); #add instruction structure to the array of instructions
186             }
187             }
188             elsif ( $line =~ m|^\s*run\s+"([^"]+)"|i ) {
189             #run "rSecurity()"
190 2 50       8 if ( $1 ) {
191 2         4 my %instr = ();
192 2         4 $instr{cmd} = "run";
193 2         5 $instr{exec} = $1;
194 2 100       11 if ( $line =~ m|\s+where\s+(\S+)\s*=\s*"([^"]+)"|i ) {
195 1         3 $instr{where} = $1;
196 1         3 $instr{value} = $2;
197             }
198 2         7 push( @$instructions, \%instr ); #add instruction structure to the array of instructions
199             }
200             }
201             elsif ( $line =~ m|^\s*(while\|if)\s+"([^"]+)"\s+where\s+(\S+)\s*=\s*"([^"]+)"|i ) {
202             #while "nextRole()" where name = "template"
203             #end while
204 3         8 my $cmd = lc( $1 );
205 3         6 my %instr = ();
206 3         8 $instr{cmd} = $cmd;
207 3         7 $instr{exec} = $2;
208 3         8 $instr{where} = $3;
209 3         7 $instr{value} = $4;
210 3         4 my $subinstr = "";
211 3         6 my @subinstr = ();
212 3         5 my $pop = 1;
213             WHILELOOP:
214 3         9 for ( ++$i; $i < @lines; $i++ ) {
215 7 50       24 $pop++ if ( $lines[$i] =~ m#^\s*(while|if)\b#i );
216 7 100       23 if ( $lines[$i] =~ m#^\s*end\b#i ){
217 3         3 $pop--;
218 3 50       6 die( $instr{cmd}." START/END stack not even\n" ) if ( $pop < 0 );
219 3 50       7 if ( $pop <= 0 ) {
220 3         4 last WHILELOOP;
221             }
222             }
223 4         14 $subinstr .= $lines[$i]."\n";
224             }
225 3         25 $self->sbParseInstructions( \$subinstr, \@subinstr ); # get child instructions for this while or if loop
226             #{
227 3         6 my @mychildren = @subinstr;
228 3         14 my %myinstr = %instr;
229 3         9 $myinstr{children} = \@mychildren; # add child instructions to the instruction's children attribute.
230 3         14 push( @$instructions, \%myinstr ); #add instruction structure to the array of instructions
231             #}
232             #if ( $lines[$i] =~ m#^\s*else\b#i ) {
233             # $pop = 1;
234             # $subinstr = "";
235             # @subinstr = ();
236             # my $ifinstr = $$instructions[@$instructions - 1];
237             # $instr{cmd} = "else";
238             # $instr{exec} = "";
239             # $instr{if} = $ifinstr;
240             # #$instr{where} is same
241             # #$instr{value} is same
242             # delete( $instr{children} );
243             # goto WHILELOOP;
244             #}
245             }
246             elsif ( $line =~ m|^\s*delete\s+where\s+(\S+)\s*=\s*"([^"]+)"|i ) {
247             #delete where name = "deleteme"
248 2         6 my %instr = ();
249 2         6 $instr{cmd} = "delete";
250 2         5 $instr{where} = $1;
251 2         6 $instr{value} = $2;
252 2         13 push( @$instructions, \%instr ); #add instruction structure to the array of instructions
253             }
254             elsif ( $line =~ m|^\s*$| ) {
255 6         20 next; # empty line
256             }
257             elsif ( $line =~ m|^\s*#| ) {
258 0         0 next; # comment
259             }
260             else {
261 0         0 $self->sbManageError( "ERROR: Invalid command: $line" );
262             }
263             }
264 9         23 return "";
265             }
266            
267            
268             sub sbTrim {
269 82     82 0 97 my $class = shift;
270 82         87 my $str = shift;
271 82         139 $str =~ s/^\s+//s;
272 82         133 $str =~ s/\s+$//s;
273 82         154 return $str;
274             }
275            
276             sub sbTrimStr {
277 0     0 0 0 my $class = shift;
278 0         0 my $str = shift;
279 0         0 my $trm = shift;
280 0         0 $str =~ s#^$trm##s;
281 0         0 $str =~ s#$trm$##s;
282 0         0 return $str;
283             }
284            
285             #sbOnEndTag - Called to process an
286             sub sbOnEndTag {
287 41     41 0 49 my $self = shift;
288 41         37 my $endtag = shift; # reference to a string containing tag name if to be terminated by
289 41         33 my $orphantext = shift; #text not within tags - e.g. A | B - the | is orphaned
290 41         73 my $currenttag = 0;
291 41         52 my $sbTagparents = $self->{Tagparents};
292 41         45 my $sbInstrstack = $self->{Instrstack};
293 41         40 while( @{$sbTagparents} ) { # loop tags that are still open, e.g if we are now a tr typically might have still open
  41         97  
294 41         55 $currenttag = pop( @$sbTagparents ); # get the most recent tag on the list of open tags.
295 41 50       75 if ( ! $currenttag ) { # there should be one, else we don't have an opening
296 0         0 warn( "Found no tag for endtag=$$endtag" );
297 0         0 last;
298             }
299 41         137 my $instructionarr = $$currenttag{instructions}; #Get the instructions for this current tag
300 41         66 foreach my $instr ( @$instructionarr ) { # loop through the tag's instructions
301 18 100       48 next if ( ! $$instr{children} ); # If there are no child instructions to this instruction, go get the next instruction
302 3         10 for( my $i = 1; $i < @$sbInstrstack ; $i++ ) { # Now try to find that array of child instructions in our global instruction stack
303 3 50       10 next if ( $$instr{children} != $$sbInstrstack[$i] ); # if this is not it keep on search
304 3         8 for ( ; $i < @$sbInstrstack; $i++ ) {
305             #printHash( "POP INSTRSTACK FOR $$endtag", "\n", $instr );
306 3         10 delete( $$sbInstrstack[$i] ); # we have found the top of the global instruction stack, so we can pop them - don't need them any more
307             }
308 3         8 last;
309             }
310             }
311 41 50       110 next if ( $$currenttag{tagend} ); # This tag is a self close one - tagend is /
312 41 50       435 next if ( $$currenttag{tag} !~ m|^$$endtag$|i ); # This current tag is not our endtag, so continue searching
313 41         63 $$currenttag{orphantext} = $orphantext; # Save any text that comes at the end of the so we keep exact format
314 41         185 last; # finished
315             }
316             }
317            
318             #sbOnTag - called when the start of a tag is found
319             sub sbOnTag {
320 47     47 0 52 my $self = shift;
321 47         46 my $tag = shift; # reference to a string with tagname in it
322 47         46 my $type = shift; # reference to the tag type 1 for ELEMENT
323 47         44 my $tagend = shift; # Reference to the tagend string - "/" or "" if terminated with
324 47         37 my $attribstr = shift; # Reference to a string with the attributes e.g. src="something.pl" border="0"
325 47         42 my $attribs = shift; # Reference to a hash of the attributes e.g. src => somethinth.pl, border => 0
326 47         44 my $text = shift; # Reference to textnode text between text
327 47         41 my $orphantext = shift; # reference to orphantext to be output after the tag
328 47         41 my $pretext = shift; # Reference to orphantext to be output before the tag
329 47         284 my %tagdata = ( tag => $$tag, # save tag as plain string
330             type => $$type, # save type as plain int string
331             tagend => $$tagend, # save tagend as reference
332             attribs => $attribs, # save attribute hash as reference
333             attribstr => $attribstr, # save attribute string as reference
334             text => $text, # save text as reference
335             orphantext => $orphantext, # save any orphan text if self closing "

stuf"

336             pretext => $pretext, # save any text that came before the tag
337             );
338 47         89 $tagdata{instructions} = []; # initialise instructions to a reference to an empty array
339 47         61 my $sbInstrstack = $self->{Instrstack};
340 47         52 my $sbTagparents = $self->{Tagparents};
341 47 50       91 my $instructions = $$sbInstrstack[$#{$sbInstrstack}] if ( @$sbInstrstack ); # Get the current array of instructions
  47         72  
342 47 50       88 if ( ! $instructions ) {
343 0         0 warn( "NO INSTRUCTIONS for <$$tag $$attribstr>" );
344             }
345 47 100       81 if ( $$type == $DOCUMENT_ROOT ) { # this is the first
346 6         9 $self->{Markup} = \%tagdata;
347 6         12 push( @$sbTagparents, \%tagdata );
348 6         15 return;
349             }
350             else {
351 41         40 my $currenttag = $$sbTagparents[$#{$sbTagparents}];
  41         51  
352 41         49 my $children = $$currenttag{ children };
353 41 100       83 $children = [] if ( ! $children );
354 41         60 push( @$children, \%tagdata );
355 41         52 $$currenttag{ children } = $children;
356 41 50       77 if ( $$type == $ELEMENT ) {
357 41 50       64 if ( $$tagend !~ m|/| ) {
358 41         52 push( @$sbTagparents, \%tagdata );
359             }
360 41 100       81 if ( ! $$currenttag{pop_child_instructions} ) {
361 28         32 my $instructarr = $$currenttag{instructions};
362 28         40 foreach my $instr ( @$instructarr ) {
363 6         10 my $childinstrs = $$instr{children};
364 6 100 66     20 next if ( ! $childinstrs || ! @$childinstrs );
365 3         8 push( @$sbInstrstack, $childinstrs );
366             #see if there are any instructions that are relevant for the parent tag
367             }
368 28         38 $$currenttag{pop_child_instructions} = 1;
369 28 50       54 $instructions = $$sbInstrstack[$#{$sbInstrstack}] if ( @$sbInstrstack );
  28         52  
370             }
371             }
372             }
373 41 50       71 return if ( ! $instructions );
374 41         88 $self->sbAllocateInstr( $instructions, \%tagdata );
375             }
376            
377             sub sbAllocateInstr {
378 58     58 0 60 my $self = shift;
379 58         63 my $instructions = shift;
380 58         51 my $tagdata = shift;
381 58         63 my $norecurse = shift;
382 58         85 my $tag = $$tagdata{tag};
383 58         65 my $attribs = $$tagdata{attribs};
384 58         373 foreach my $instr ( @$instructions ) {
385 72 50 66     1297 if ( $$instr{where} && $$instr{where} =~ m|^tagname$|i
    100 33        
    100 33        
      100        
      100        
      100        
      33        
      66        
386             && $$instr{value} && $$instr{value} =~ m|^$tag$|i ) {
387 0         0 my $instructionarr = $$tagdata{instructions};
388 0         0 push( @$instructionarr, $instr );
389 0 0       0 $self->sbAllocateInstr( $$instr{children}, $tagdata, 1 )
390             if ( ! $norecurse ); # for while and if can be child instructions that are relevant
391             }
392             elsif ( $$instr{where} && exists( $$attribs{$$instr{where}} )
393             && $$instr{value} =~ m|^$$attribs{$$instr{where}}$|i ) {
394 17         24 my $instructionarr = $$tagdata{instructions};
395 17         33 push( @$instructionarr, $instr );
396 17 50       290 $self->sbAllocateInstr( $$instr{children}, $tagdata, 1 )
397             if ( ! $norecurse ); # for while and if can be child instructions that are relevant
398             }
399             elsif ( ! $$instr{allocated} && ! $$instr{where}
400             && ( $$instr{cmd} eq "load" || $$instr{cmd} eq "run" ) ) {
401 1         3 my $instructionarr = $$tagdata{instructions}; # for while and if can be child instructions that are relevant
402 1         2 push( @$instructionarr, $instr );
403 1         3 $$instr{allocated} = 1;
404             }
405             }
406             }
407            
408             sub sbGetAttribs {
409 41     41 0 43 my $self = shift;
410 41         37 my $tag = shift;
411 41         38 my $attribstr = shift;
412 41         36 my $attribs = shift;
413 41         55 $$attribstr = $$tag;
414 41         126 $$attribstr =~ s#^\s*(\S+)##s;
415 41         56 my $save_attribstr = $$attribstr;
416 41         68 $$tag = $1;
417 41         111 while( $$attribstr =~ m#\s*([^=\s]+)#gs ) { #=(["'][^"']*["']|\S+)|\S+)
418 25         38 my $attrib = $1;
419 25         45 $$attribstr = substr( $$attribstr, pos( $$attribstr ) );
420 25         28 my $value = undef;
421 25 50       82 if ( $$attribstr =~ m#^\s*=\s*#s ) {
422 25         50 $$attribstr = $';
423 25 50       77 if ( $$attribstr =~ m#^"([^"]*)"#s ) {
    0          
    0          
424 25         42 $value = $1;
425 25         36 $$attribstr = $';
426             }
427             elsif ( $$attribstr =~ m#^'([^']*)'#s ) {
428 0         0 $value = $1;
429 0         0 $$attribstr = $';
430             }
431             elsif ( $attribstr =~ m#^(\S+)#s ) {
432 0         0 $value = $1;
433 0         0 $attribstr = $';
434             }
435             }
436 25         93 $$attribs{$attrib} = $value;
437             }
438 41         51 $$attribstr = $save_attribstr;
439 41         57 return "";
440             }
441            
442             sub sbParseMarkup {
443 6     6 0 9 my $self = shift;
444 6         7 my $contents = shift;
445 6         8 my $gotelement = 0;
446 6 100       16 $self->{documentroot} = "_document_root_" if ( ! $self->{documentroot} );
447 6         12 my $root = $self->{documentroot};
448 6         7 my $root_type = $DOCUMENT_ROOT;
449 6         6 my $root_attribs = "";
450 6         35 $self->sbOnTag( \$root, \$root_type, \"", \"", {}, \"" , \"" );
451 6         23 while ( $$contents =~ m#<#gm ) {
452 82         199 $$contents = substr( $$contents, pos( $$contents ) );
453 82 50       712 if ( $$contents =~ m#(^!\[CDATA\[.*?\]\])>([^<]*)#s ) { # // ...
    50          
    50          
    50          
    100          
    50          
454 0         0 my $tag = $1;
455 0         0 my $orphantext = $2;
456 0         0 my $type = $COMMENT;
457 0         0 $$contents = $';
458 0         0 $self->sbOnTag( \$tag, \$type, \"", \"", {}, \"" , \$orphantext );
459             }
460             elsif ( $$contents =~ m#(^!--.*?--)>([^<]*)#s ) { # ...
461 0         0 my $tag = $1;
462 0         0 my $orphantext = $2;
463 0         0 my $type = $COMMENT;
464 0         0 $$contents = $';
465 0         0 $self->sbOnTag( \$tag, \$type, \"", \"", {}, \"" , \$orphantext );
466             }
467             elsif ( $$contents =~ m#(^!.*?)>([^<]*)#s ) { # ...
468 0         0 my $tag = $1;
469 0         0 my $orphantext = $2;
470 0         0 my $type = $COMMENT;
471 0         0 $$contents = $';
472 0         0 $self->sbOnTag( \$tag, \$type, \"", \"", {}, \"" , \$orphantext );
473             }
474             elsif ( $$contents =~ m#(^\?.*?\?)>([^<]*)#s ) { # ...
475 0         0 my $tag = $1;
476 0         0 my $orphantext = $2;
477 0         0 my $type = $PROC_INSTR;
478 0         0 $$contents = $';
479 0         0 $self->sbOnTag( \$tag, \$type, \"", \"", {}, \"" , \$orphantext );
480             }
481             elsif ( $$contents =~ m#^\s*\/([^>]+)>([^<]*)#s ) { # ...
482 41         74 my $tag = $1;
483 41         64 my $orphantext = $2;
484 41         63 $$contents = $';
485 41         201 $tag = $self->sbTrim( $tag );
486 41         107 $self->sbOnEndTag( \$tag, \$orphantext );
487             }
488             elsif ( $$contents =~ m#(^[^>]+)>([^<]*)#s ) { # ...
489 41         86 my $tag = $1;
490 41         57 my $text = $2;
491 41         78 $$contents = $';
492 41         79 $tag = $self->sbTrim( $tag );
493 41         225 my $notextnode = "";
494 41 50       86 $notextnode = "/" if ( $tag =~ s#/$##s );
495 41         50 my $type = $ELEMENT;
496 41         38 my $attribstr = "";
497 41         51 my %attribs = ();
498 41         88 $self->sbGetAttribs( \$tag, \$attribstr, \%attribs );
499 41         110 $self->sbOnTag( \$tag, \$type, \$notextnode, \$attribstr, \%attribs, \$text, \"" );
500             }
501             else {
502 0         0 warn( "sbParseMarkup - no tag regexp worked: $$contents" );
503             }
504             }
505             }
506            
507             sub sbPrintTag {
508 37     37 0 40 my $self = shift;
509 37         38 my $indent = shift;
510 37         35 my $tag = shift;
511 37         55 my $stream = $self->{Stream};
512 37         39 my $text = $$tag{text};
513 37         39 my $orphantext = $$tag{orphantext}; # often white space which helps keep format, but can be text between text e.g. A | B - the " | " is orphan
514 37 50       65 if ( ! $text ) {
515 0         0 my $txt = "";
516 0         0 $text = \$txt;
517 0         0 $$tag{text} = $text;
518             }
519 37         41 my $attribs = $$tag{attribs};
520 37         149 print $stream "<$$tag{tag}";
521 37         755 foreach my $attrib ( keys %$attribs ) {
522 24 50       108 next if ( ! defined( $attrib ));
523 24 50       40 $$attribs{$attrib} = "" if ( ! defined( $$attribs{$attrib} ) );
524 24         81 print $stream " $attrib=\"$$attribs{$attrib}\"";
525             }
526 37         405 print $stream "$$tag{tagend}>$$text";
527 37         622 $self->sbMergeDocument( $indent + 1, $$tag{children});
528 37 50 33     549 print $stream "" if ( $$tag{type} == $ELEMENT && ! $$tag{tagend} );
529 37 50       613 print $stream $$orphantext if ( $orphantext );
530             }
531            
532             sub sbGetCurrentTagValue {
533 3     3 1 5 my $self = shift;
534 3         4 my $attrib = shift;
535 3         5 my $sbCurrentTag = $self->{CurrentTag};
536 3 50 33     12 return "" if ( ! $sbCurrentTag || ! $attrib );
537 3 50       8 return $$sbCurrentTag{tag} if ( $attrib eq "tagname" );
538 3 50       5 return $$sbCurrentTag{text} if ( $attrib eq "textnode" );
539 3         4 my $attribs = $$sbCurrentTag{attribs};
540 3 50       5 return "" if ( ! $attribs );
541 3         70 return $$attribs{$attrib};
542             }
543            
544             sub sbDebugCurrentTag {
545 0     0 0 0 my $self = shift;
546 0         0 my $attrib = shift;
547 0         0 my $sbCurrentTag = $self->{CurrentTag};
548 0         0 my $res="<$$sbCurrentTag{tag} ${$$sbCurrentTag{attribstr}}>";
  0         0  
549 0         0 return $res;
550             }
551            
552             sub sbCopyTag {
553 43     43 0 38 my $self = shift;
554 43         40 my $origtag = shift;
555 43         42 my %copytag = %{$origtag};
  43         309  
556 43         83 my $tag = \%copytag;
557 43         50 my $text = $$tag{text};
558 43 50       82 $text = \"" if ( ! $text );
559 43         56 my $copytext = $$text;
560 43         159 $$tag{text} = \$copytext;
561 43         54 my $attribs = $$tag{attribs};
562 43 50       68 $attribs = {} if ( ! $attribs );
563 43         43 my %copyattribs = %{$attribs};
  43         121  
564 43         68 $$tag{attribs} = \%copyattribs;
565 43         86 return $tag;
566             }
567            
568            
569             #sbMergeDocument - merges data into the markup and prints it
570             sub sbMergeDocument {
571 43     43 0 47 my $self = shift;
572 43         45 my $indent = shift;
573 43         50 my $tags = shift;
574 43         50 my $error;
575             TAGLOOP:
576 43         80 foreach my $origtag ( @$tags ) {
577 40         208 my $run = 0;
578 40         46 my $cmd = "";
579 40         43 my $exec = "";
580 40         31 my $inrepeat = 0;
581 40         39 do { # while inrepeat
582 43         128 my $tag = $self->sbCopyTag($origtag);
583 43         59 $self->{CurrentTag} = $tag;
584 43         86 my $text = $$tag{text};
585 43 50       81 if ( ! $text ) {
586 0         0 my $txt = "";
587 0         0 $text = \$txt;
588 0         0 $$tag{text} = $text;
589             }
590 43         46 my $attribstr = $$tag{attribstr};
591 43 50       64 $attribstr = \"" if ( ! $attribstr );
592 43         81 my $attribs = $$tag{attribs};
593 43         44 my $instructionarr = $$tag{instructions};
594 43         297 $run = 0;
595 43         52 for ( my $count = 0; ;$count++ ) {
596 81 100 66     305 my $instruction = $$instructionarr[$count] if ( $instructionarr && $count < @$instructionarr );
597 81 100 100     238 $run = 1 if ( $count == 0 && ! $instruction );
598 81 100 100     226 last if ( $count > 0 && ! $instruction );
599 44 100       78 next if ! ( $instruction );
600 24         45 $cmd = lc( $$instruction{cmd} );
601 24         28 $exec = $$instruction{exec};
602 24 50       102 if ( $cmd eq "load" ) {
    100          
    100          
    100          
    100          
    100          
    50          
603 0         0 require $exec;
604 0 0       0 if ( $@ ) {
605 0         0 $error = "ERROR: $exec: $@";
606 0         0 $self->sbManageError( $error );
607             }
608 0         0 $run = 1;
609             }
610             elsif ( $cmd eq "run" ) {
611 2         116 eval "package ".$self->{EvalPackage}."; ".$exec;
612 2 50       44 if ( $@ ) {
613 0         0 $error = "ERROR: $exec: $@";
614 0         0 $self->sbManageError( $error );
615             }
616 2         3 $run = 1;
617             }
618             elsif ( $cmd eq "set" ) {
619 9         11 my $cond = 1;
620 9 50       21 $cond = eval "package ".$self->{EvalPackage}."; ".$$instruction{condition} if ( $$instruction{condition} );
621 9 50       20 if ( $cond ) {
622 9         498 my $res = eval "package ".$self->{EvalPackage}."; ".$$instruction{exec};
623 9 50       28 if ( $@ ) {
624 0         0 $error = "ERROR: $exec: $@";
625 0         0 $self->sbManageError( $error );
626             }
627 9 100       25 if ( lc($$instruction{target}) eq "textnode" ) {
628 8         12 $$text = $res;
629             }
630             else {
631 1         3 $$attribs{$$instruction{target}} = $res;
632             }
633             }
634 9         10 $run = 1;
635             }
636             elsif( $cmd eq "toggle" ) {
637 3         182 my $res = eval "package ".$self->{EvalPackage}."; ".$$instruction{exec};
638 3 50       19 if ( $@ ) {
639 0         0 $error = "ERROR: $exec: $@";
640 0         0 $self->sbManageError( $error );
641             }
642 3 100       6 if ( $res ) {
643 1         3 $$attribs{$$instruction{target}} = "true";
644             }
645             else {
646 2         5 delete( $$attribs{$$instruction{target}} );
647             }
648 3         7 $run = 1;
649             }
650             elsif( $cmd eq "delete" ) {
651 4         14 next TAGLOOP;
652             }
653             elsif( $cmd eq "if" ) {
654 2         120 $run = eval "package ".$self->{EvalPackage}."; ".$exec;
655 2 50       10 if ( $@ ) {
656 0         0 $error = "ERROR: $exec: $@";
657 0         0 $self->sbManageError( $error );
658             }
659             #$$instruction{lastresult} = $run;
660             }
661             #elsif( $cmd eq "else" ) {
662             # my $ifinstr = $$instruction{if};
663             # if ( ! $ifinstr ) {
664             # $error = "ERROR: else has no if instruction";
665             # $self->sbManageError( $error );
666             # }
667             # if ( ! exists( $$ifinstr{lastresult} ) ) {
668             # $error = "ERROR: if related to else does not have lastresult";
669             # $self->sbManageError( $error );
670             # }
671             # $run = 1;
672             # $run = 0 if ( $$ifinstr{lastresult} );
673             #}
674             elsif ( $cmd eq "while" ) {
675 4         246 $run = eval "package ".$self->{EvalPackage}."; ".$exec;
676 4         13 $inrepeat = $run;
677 4 50       10 if ( $@ ) {
678 0         0 $error = "ERROR: $exec: $@";
679 0         0 $self->sbManageError( $error );
680             }
681             }
682             else {
683 0         0 $error = "ERROR: Invalid cmd $cmd";
684 0         0 $self->sbManageError( $error );
685             }
686 20 100       49 last if ( ! $run );
687             } # for ($count;; )
688 39 100       136 $self->sbPrintTag( $indent, $tag ) if ( $run );
689             } while( $inrepeat );
690             }
691             }
692            
693             sub sbPrintDocument {
694 6     6 1 28 my $self = shift;
695 6         11 my $document = $self->{Markup};
696 6         21 $self->sbMergeDocument( 0, $$document{children} );
697             }
698            
699             sub sbDebugPrintDocument {
700 0     0 0 0 my $self = shift;
701 0         0 my $indent = shift;
702 0         0 my $tags = shift;
703 0         0 my $stream = $self->{Stream};
704 0         0 foreach my $tag ( @$tags ) {
705 0         0 my $text = $$tag{text};
706 0 0       0 $text = \"" if ( ! $text );
707 0         0 my $attribstr = $$tag{attribstr};
708 0 0       0 $attribstr = \"" if ( ! $attribstr );
709 0         0 my $orphantext = $$tag{orphantext};
710 0 0       0 $orphantext = \"" if ( ! $orphantext );
711 0         0 my $attribs = $$tag{attribs};
712 0         0 print $stream "<$$tag{tag}";
713 0         0 foreach my $attrib ( keys %$attribs ) {
714 0         0 print $stream " $attrib=\"$$attribs{$attrib}\"";
715             }
716 0         0 print $stream "$$tag{tagend}>$$text";
717 0         0 my $instructions = $$tag{instructions};
718 0 0       0 print $stream "\n", "-" x 80, "\n" if ( @$instructions );
719 0         0 foreach my $instr ( @$instructions ) {
720 0         0 print $stream $self->sbHash2String( $instr ), "\n";
721             }
722 0 0       0 print $stream "-" x 80, "\n" if ( @$instructions );
723 0         0 $self->sbDebugPrintDocument( $indent + 1, $$tag{children});
724 0 0 0     0 print $stream "" if ( $$tag{type} == $ELEMENT && ! $$tag{tagend} );
725 0         0 print $stream "$$orphantext";
726             }
727             }
728             sub sbDebugPrintInstructions {
729 0     0 0 0 my $self = shift;
730 0         0 my $indent = shift;
731 0         0 my $instructions = shift;
732 0         0 my $stream = $self->{Stream};
733 0         0 foreach my $instr ( @$instructions ) {
734 0         0 print $stream " " x $indent, $self->sbHash2String( $instr ), "\n";
735 0 0       0 if ( $$instr{cmd} eq "load" ) {
736 0         0 require $$instr{exec};
737             }
738             else {
739 0         0 print $stream " " x $indent, "FUNCTION RETURN=[", eval "package ".$self->{EvalPackage}."; ".$$instr{exec}, "] \n";
740 0 0       0 print $stream " " x $indent, "ERROR: $$instr{exec}=$@\n" if $@;
741             }
742 0 0       0 if ( $$instr{children} ) {
743 0         0 $self->sbDebugPrintInstructions( $indent + 2, $$instr{children} );
744             }
745             }
746             }
747             sub sbDebugPrint {
748 0     0 0 0 my $self = shift;
749 0         0 my $stream = $self->{Stream};
750 0         0 $self->sbDebugPrintInstructions( 0, $self->{Instructions} );
751 0         0 print $stream "-" x 80, "\n";
752 0         0 my $document = $self->{Markup};
753 0         0 $self->sbDebugPrintDocument( 0, $$document{children} );
754             }
755             sub sbDebugDumpTags {
756 0     0 0 0 my $self = shift;
757 0         0 my $indent = shift; # The number of dots to print to indent children under parents.
758 0         0 my $tags = shift; # A reference to an array of references to tag data to dump
759 0         0 my $stream = $self->{Stream};
760 0         0 foreach my $tag ( @$tags ) {
761 0 0       0 my $attribstr_ref = ( $$tag{attribstr} ? $$tag{attribstr} : \"" ); # get the attribute string from the tag data e.g. 'src="something.html" border="1"'
762 0         0 my $attribstr = $$attribstr_ref;
763 0 0       0 if ( $attribstr ) {
764 0         0 $attribstr = "$attribstr>";
765             } else {
766 0         0 $attribstr = ">";
767             }
768 0         0 print $stream "." x $indent, "<$$tag{tag}$attribstr"; # output the start of the tag and it's attributes
769 0         0 my $text = $$tag{text}; # get the reference to the text string from the tag data
770 0 0       0 my $txt = $$text if $text; # dereference the text into a simple string variable.
771 0         0 $txt =~ s|\n| |gs; # strip out newlines
772 0 0       0 print $stream substr( $txt, 0, 30 ), ( length( $txt ) > 30 ? "..." : "" ) if ( $txt );
    0          
773             # print a chopped string, max length 30, and with ... if it has been chopped
774            
775 0         0 my $instructions = $$tag{instructions}; # get the instructions to be applied to this tag
776 0         0 foreach my $instr ( @$instructions ) { # loop round the instructions
777 0   0     0 my $exec = $$instr{exec} || "";
778 0   0     0 my $cmd = $$instr{cmd} || "";
779 0         0 print $stream ":$cmd $exec"; # print the cmd (set,toggle,etc) and exec (function call) values
780             }
781 0         0 print $stream "\n"; # This tag now becomes the current parent.
782 0         0 $self->sbDebugDumpTags( $indent + 2, $$tag{children} ); # Recursively call sbDebugDumpTags to print the children if any.
783 0 0       0 print $stream "." x $indent, "\n" if ( $$tag{type} == $ELEMENT ); # close the parent.
784             }
785             }
786             sub sbDebugDump{
787 0     0 0 0 my $self = shift;
788 0         0 my $document = $self->{Markup};
789 0         0 $self->sbDebugDumpTags( 0, $$document{children} );
790             }
791            
792             sub sbClearCache {
793 0     0 1 0 my $self = shift;
794 0         0 my $cachename = shift;
795 0         0 my $sbMarkupCache = $self->{MarkupCache};
796 0         0 my $sbSubsCache = $self->{SubsCache};
797 0 0       0 if ( $cachename ) {
798 0         0 delete( $$sbMarkupCache{$cachename} );
799 0         0 delete( $$sbSubsCache{$cachename} );
800             }
801             else {
802 0         0 $self->{MarkupCache} = {};
803 0         0 $self->{SubsCache} = {};
804             }
805 0         0 return 1;
806             }
807            
808             ### Initialise page from string input
809             sub sbInitMarkup {
810 6     6 0 38 my $self = shift;
811 6         7 my $htmldir = shift;
812 6         7 my $markup_ref = shift;
813            
814 6         8 my $instructions = "";
815 6         8 my $subs = "";
816 6         14 $self->sbAnalyseContents( $htmldir, $markup_ref, \$instructions, \$subs );
817 6 50       15 if ( $subs ) {
818 6     2   880 eval "package ".$self->{EvalPackage}."; ".$subs;
  2     1   245  
  2     2   22  
  1     3   3  
  2     6   3  
  2     3   5  
  2     1   46  
  3     4   8  
  3     1   88  
  3         22  
  6         26  
  6         44  
  3         6  
  1         26  
  1         14  
  4         7  
  4         10  
  4         46  
  1         7  
819 6 50       24 if ( $@ ) {
820 0         0 my $error = "ERROR: in subroutines in markup: $@";
821 0         0 $self->sbManageError( $error );
822             }
823             }
824 6         21 $self->sbParseInstructions( \$instructions, $self->{Instructions} );
825 6         20 $self->sbParseMarkup( $markup_ref );
826 6         16 return 1;
827             }
828            
829             ## Initialise page from file input
830             sub sbInitPage {
831 0     0 1 0 my $self = shift;
832 0         0 my $cachename = shift;
833 0         0 my $htmldir = shift;
834 0         0 my $page = shift;
835 0         0 my $instrfile = shift;
836 0         0 my $sbMarkupCache = $self->{MarkupCache};
837 0         0 my $sbSubsCache = $self->{SubsCache};
838 0 0       0 $cachename = $page if ( ! $cachename );
839 0 0       0 my $cachedmarkup = $$sbMarkupCache{$cachename} if ( $cachename );
840 0 0       0 my $subs = $$sbSubsCache{$cachename} if ( $cachename );
841 0 0       0 $subs = "" if ( ! defined( $subs ));
842            
843 0 0       0 if ( $cachedmarkup ) {
844             #warn( "$$ Getting cached version for $cachename" );
845 0         0 $self->{Markup} = $cachedmarkup;
846 0         0 $self->{Subs} = $subs;
847 0         0 my $sbSubs = $$subs;
848 0 0       0 if ( $sbSubs ) {
849 0         0 eval "package ".$self->{EvalPackage}."; ".$sbSubs; # must always re-eval as other evals redefine common func names
850 0 0       0 if ( $@ ) {
851 0         0 my $error = "ERROR: in subroutines on page $page: $@";
852 0         0 $self->sbManageError( $error );
853             }
854             }
855             }
856             else {
857             #warn( "$$ First time for $cachename" );
858 0         0 my $sbContents;
859             my $sbInstructions;
860 0         0 my $sbSubs;
861 0         0 $self->sbGetContents( $htmldir, $page, $instrfile, \$sbContents, \$sbInstructions, \$sbSubs );
862 0 0       0 if ( $sbSubs ) {
863 0         0 eval "package ".$self->{EvalPackage}."; ".$sbSubs;
864 0 0       0 if ( $@ ) {
865 0         0 my $error = "ERROR: in subroutines on page $page: $@";
866 0         0 $self->sbManageError( $error );
867             }
868             }
869 0         0 $self->sbParseInstructions( \$sbInstructions, $self->{Instructions} );
870 0         0 $self->sbParseMarkup( \$sbContents );
871 0         0 my %copymarkup = %{$self->{Markup}};
  0         0  
872 0         0 ${$self->{MarkupCache}}{$cachename} = \%copymarkup;
  0         0  
873 0         0 my $copySubs = $sbSubs;
874 0         0 ${$self->{SubsCache}}{$cachename} = \$copySubs;
  0         0  
875             }
876 0         0 return 0;
877             }
878            
879            
880             sub sbInit() {
881 7     7 1 1959 my $self = shift;
882 7         14 my @sbInstructions = ();
883 7         12 my %sbMarkup = ();
884 7         9 my @sbTagparents = ();
885 7         20 my @sbInstrstack = (\@sbInstructions);
886 7         18 $self->{Instructions} = \@sbInstructions;
887 7         14 $self->{Markup} = \%sbMarkup;
888 7         14 $self->{Tagparents} = \@sbTagparents;
889 7         69 $self->{Instrstack} = \@sbInstrstack;
890 7         19 $self->{LastError} = "";
891 7         20 $self->{CurrentTag} = 0;
892             }
893            
894             sub sbGetPath {
895 0     0 0   my $class = shift;
896 0           my $path = shift;
897 0           $path =~ s#\\#/#g;
898 0 0         if ( $path =~ m#(.+)/([^/]+$)# ) {
899 0           $path = $1;
900 0           my $file = $2;
901 0 0         return ( $path, $file ) if ( wantarray() );
902 0           return $path;
903             }
904             else {
905 0 0         return ( "", $path ) if ( wantarray() );
906 0           return "";
907             }
908             }
909            
910             sub sbBasename {
911 0     0 0   my $class = shift;
912 0           my $pathname = shift;
913 0           my ( $path, $filename ) = sbGetPath( $pathname );
914 0           return $path;
915             }
916            
917             sub sbFilename {
918 0     0 0   my $class = shift;
919 0           my $pathname = shift;
920 0           my ( $path, $filename ) = sbGetPath( $pathname );
921 0           return $filename;
922             }
923            
924             return 1;
925            
926            
927             __END__