File Coverage

blib/lib/WebDyne/HTML/Tiny.pm
Criterion Covered Total %
statement 199 473 42.0
branch 36 164 21.9
condition 9 97 9.2
subroutine 30 48 62.5
pod 1 18 5.5
total 275 800 34.3


line stmt bran cond sub pod time code
1             #
2             # This file is part of WebDyne.
3             #
4             # This software is copyright (c) 2026 by Andrew Speer .
5             #
6             # This is free software; you can redistribute it and/or modify it under
7             # the same terms as the Perl 5 programming language system itself.
8             #
9             # Full license text is available at:
10             #
11             #
12             #
13             package WebDyne::HTML::Tiny;
14              
15              
16             # Pragma
17             #
18 7     7   42 use strict qw(vars);
  7         13  
  7         336  
19 7     7   32 use vars qw($VERSION);
  7         12  
  7         298  
20 7     7   32 use warnings;
  7         11  
  7         518  
21              
22              
23             # Constants, inheritance
24             #
25             our $AUTOLOAD;
26             our @ISA=qw(HTML::Tiny);
27              
28              
29             # External Modules
30             #
31 7     7   3563 use HTML::Tiny;
  7         22815  
  7         240  
32             #use CGI::Simple;
33 7     7   44 use Data::Dumper;
  7         10  
  7         376  
34 7     7   6713 use HTML::Element;
  7         170166  
  7         39  
35              
36              
37             # WebDyne Modules
38             #
39 7     7   393 use WebDyne::Constant;
  7         12  
  7         88  
40 7     7   53 use WebDyne::Util;
  7         13  
  7         93  
41 7     7   39 use WebDyne::CGI;
  7         13  
  7         296  
42              
43              
44             # Constants
45             #
46             use constant {
47              
48 7         6187 URL_ENCODED => 'application/x-www-form-urlencoded',
49             MULTIPART => 'multipart/form-data'
50              
51 7     7   33 };
  7         13  
52              
53              
54             # Package state
55             #
56             my %Package;
57              
58              
59             # Version information
60             #
61             $VERSION='2.075';
62              
63              
64             # Debug load
65             #
66             0 && debug("Loading %s version $VERSION", __PACKAGE__);
67              
68              
69             # Trick to allow use of illegal subroutine name to suppport treebuilder comment format
70             #
71             *{'WebDyne::HTML::Tiny::~comment'}=\&_comment;
72 379     379   9319 *{'WebDyne::HTML::Tiny::entity_encode'}=sub { return $_[1] };
73              
74              
75             # All done. Positive return
76             #
77             return ${&_init()} || err('error running init code');
78              
79              
80             #==================================================================================================
81              
82              
83             sub new {
84              
85              
86             # Start new instance
87             #
88 22     22 1 87 my ($class, @param)=@_;
89 22         42 my %param;
90 22 50       74 if (ref($param[0]) eq 'HASH') {
91 0         0 %param=%{$param[0]};
  0         0  
92             }
93             else {
94 22         82 %param=@param;
95             }
96 22         34 0 && debug("$class new, %s", Dumper(\%param));
97            
98            
99             # Shortcuts (start_html, start_form etc.) enabled by default.
100             #
101             &shortcut_enable() unless
102 22 50       141 $param{'noshortcut'}; # no sense before ? was || $Package{'_shortcut_enable'};
103            
104            
105             # Get HTML::Tiny ref
106             #
107 22   33     235 my $self=$class->SUPER::new( mode=>(delete($param{'mode'}) || $WEBDYNE_HTML_TINY_MODE));
108            
109            
110             # Save away other supplied params into self ref
111             #
112 22         1415 $self->{'_r'}=$param{'r'};
113            
114              
115             # Done
116             #
117 22         242 return $self;
118              
119             }
120              
121              
122             sub Vars {
123              
124             # Get CGI::Simple Vars to ensure we can find values needed to persist choices across form submissions
125             #
126 0     0 0 0 my $self=shift();
127 0         0 0 && debug("$self Vars");
128 0   0     0 return ($self->{'_Vars'} ||= $self->CGI()->Vars());
129              
130             }
131              
132              
133             sub CGI {
134              
135            
136             # Get CGI::Simple object ref
137             #
138 9     9 0 16 my $self=shift();
139 9         18 0 && debug("$self CGI");
140 9   66     136 return ($self->{'_CGI'} ||= WebDyne::CGI->new($self->{'_r'}));
141            
142             }
143              
144              
145             sub _init {
146              
147              
148             # Initialise various subs
149             #
150 7   33 7   57 *HTML::Tiny::start=\&HTML::Tiny::open || *HTML::Tiny::start; # || *HTML::Tiny::Start stops warning
151 7   33     49 *HTML::Tiny::end=\&HTML::Tiny::close || *HTML::Tiny::end; # || as above
152              
153              
154             # Translate CGI.pm shortcut field to HTML::Tiny equiv
155             #
156 7         54 my %type=(
157             textfield => 'text',
158             password_field => 'password',
159             filefield => 'file',
160             defaults => 'submit',
161             image_button => 'image',
162             button => 'button'
163             );
164            
165              
166             # Which tags do we need to persist value ?
167             #
168 7         23 my %persist=(
169             textfield => 1,
170             password_field => 1,
171             filefield => 1
172             );
173              
174              
175             # Re-impliment CGI input shortcut tags
176             #
177 7         22 foreach my $tag (qw(textfield password_field filefield button submit reset defaults image_button hidden button)) {
178            
179 56         126 *{$tag}=sub {
180 9     9   25 my ($self, $attr_hr, @param)=@_;
181 9         14 0 && debug("$self $tag, attr_hr: %s", Dumper($attr_hr));
182 9 50       26 if (defined($attr_hr)) {
183             # Copy attr so don't pollute ref
184 9         15 my %attr=%{$attr_hr};
  9         33  
185 9         23 my $label=delete $attr{'label'};
186             #my $param_hr=$self->Vars();
187 9         28 my $param_hr=$self->CGI->Vars();
188 9 50       471 if ($persist{$tag}) {
189 0 0 0     0 if ($attr{'name'} && (my $value=$param_hr->{$attr{'name'}}) && !$attr{'force'}) {
      0        
190 0         0 $attr{'value'}=$value;
191             }
192             }
193            
194             # Wrap in label if needed
195             #
196 9 50       19 if ($label) {
197 0         0 return $self->label(join('', grep {$_} @param, $label) . $self->input({type => $type{tag}, %attr}));
  0         0  
198             }
199             else {
200 9   33     108 return $self->input({type => $type{$tag} || $tag, %attr}, @param);
201             }
202             }
203             else {
204 0   0     0 return $self->input({type => $type{$tag} || $tag}, @param)
205             }
206              
207 70 100       489 } unless UNIVERSAL::can(__PACKAGE__, $tag);
208             }
209              
210              
211             # Isindex deprecated but reimplement anyway
212             #
213 7         16 foreach my $tag (qw(isindex)) {
214              
215 7     7   58 no strict qw(refs);
  7         11  
  7         1794  
216 7     0   20 *{$tag}=sub {shift()->closed($tag, @_)}
  0         0  
217 7 50       59 unless UNIVERSAL::can(__PACKAGE__, $tag);
218              
219             }
220              
221              
222             # Done return OK
223             #
224 7         118 return \1;
225              
226             }
227              
228              
229             sub shortcut {
230              
231             # Set or return passthough flag which flags us to ignore all start_* methods
232             #
233 0     0 0 0 my $self=shift();
234 0         0 0 && debug("self: $self, shortcut: %s", Dumper(\@_));
235 0 0       0 if (@_) {
236 0 0       0 return shift() ? $self->shortcut_enable() : $self->shortcut_disable()
237             }
238             else {
239 0         0 return $self->{'_shortcut'}
240             }
241              
242             }
243              
244              
245             sub shortcut_disable {
246              
247 7     7   158 no warnings qw(redefine);
  7         17  
  7         2653  
248 44     44 0 76 0 && debug('shortcut_disable: %s', Dumper(\@_));
249 44         89 foreach my $sub (grep {/^(?:_start|_end)/} keys %{__PACKAGE__ . '::'}) {
  7822         11418  
  44         1973  
250 264         598 (my $sub_start=$sub)=~s/^_//;
251              
252             #print "disable $sub_start=>$sub";
253 264 50       1054 if (my ($action, $tag)=($sub_start=~/^(start|end)_([^:]+)$/)) {
254              
255             #print "action: $action, tag: $tag\n";
256 264     7   800 *{$sub_start}=sub {shift()->$action($tag, @_)};
  264         937  
  7         20  
257             }
258             }
259 44         533 delete $Package{'_shortcut_enable'};
260            
261             # || *start_html to remove warnings
262 44   33 12   305 *start_html=sub {shift()->_start_html_bare(@_)} || *start_html
  12         38  
263              
264             }
265              
266              
267             sub shortcut_enable {
268              
269 7     7   50 no warnings qw(redefine);
  7         18  
  7         41380  
270 66     66 0 185 0 && debug('shortcut_enable: %s', Dumper(\@_));
271 66         110 foreach my $sub (grep {/^(?:_start|_end])/} keys %{__PACKAGE__ . '::'}) {
  11693         19251  
  66         2693  
272 330         832 (my $sub_start=$sub)=~s/^_//;
273              
274             #if ( *{__PACKAGE__ . "::${sub_start}"}{'CODE'} eq \&{$sub} ) {
275             # debug("code for $sub_start exists, skipping");
276             # last;
277             #}
278             #else {
279             # debug("code for $sub_start needed, creating");
280             #}
281              
282 330         448 0 && debug("enable $sub_start=>$sub, %s", *{__PACKAGE__ . "::${sub_start}"}{'CODE'});
283 330         439 *{$sub_start}=\&{$sub};
  330         1181  
  330         731  
284             }
285 66         862 $Package{'_shortcut_enable'}++;
286              
287             #*start_html=\&_start_html_bare;
288              
289             }
290              
291              
292             # Start_html shorcut and include DTD
293             #
294             sub _start_html {
295              
296              
297             # Get self ref and any attributes passed
298             #
299 33     33   98 my ($self, $attr_hr, @param)=@_;
300 33         48 0 && debug("$self _start_html, attr: %s, param: %s", Dumper($attr_hr, \@param));
301              
302             #return $self->SUPER::start_html($attr_hr, @param) if $self->{'_passthrough'};
303              
304              
305             # Attributes we are going to use
306             #
307 33         56 0 && debug('WEBDYNE_START_HTML_PARAM: %s', Dumper($WEBDYNE_START_HTML_PARAM));
308             my %attr=(
309 33         105 %{$WEBDYNE_HTML_PARAM},
310 33         84 %{$WEBDYNE_START_HTML_PARAM},
311 33         57 %{$attr_hr}
  33         114  
312             );
313 33         62 0 && debug('attr: %s', Dumper(\%attr));
314              
315              
316             # If no attributes passed used defaults from constants file
317             #
318             #keys %{$attr_hr} || ($attr_hr=$WEBDYNE_HTML_PARAM);
319              
320              
321             # Pull out meta attributes leaving rest presumably native html tag attribs
322             #
323 2         10 my %attr_page=map {$_ => delete $attr{$_}} grep { exists($attr{$_}) } (qw(
  726         1156  
324             title
325             meta
326             style
327             base
328             target
329             author
330             script
331             include
332             include_script
333             include_style
334             static
335             cache
336             handler
337             h1
338             h2
339             h3
340             h4
341             h5
342             h6
343             hr
344 33         112 ), keys %{$WEBDYNE_START_HTML_SHORTCUT_HR});
  33         139  
345 33         62 0 && debug('start_html %s', Dumper(\%attr_page));
346              
347              
348             # Start with the DTD
349             #
350 33         86 my @html=$WEBDYNE_DTD;
351              
352              
353             # Static, cache ? If so mark as such in HTML::Tiny object to be
354             # reviewed at end of parse by Treebuilder. Not ideal, good enough
355             #
356 33         85 foreach my $attr (qw(static cache handler)) {
357 99 100       272 if (my $value=$attr_page{$attr}) {
358 1         2 0 && debug("found attr: $attr, setting to value: $value");
359 1         5 $self->{"_${attr}"}=$value;
360 1 50 0     5 $self->{'_static'} ||=1 if ($attr eq 'cache');
361             }
362             }
363            
364            
365             # Shortcuts ? Add to relevant attributes
366             #
367 33         63 foreach my $shortcut (grep {$attr_page{$_}} keys %{$WEBDYNE_START_HTML_SHORTCUT_HR}) {
  66         162  
  33         107  
368 0         0 my $shortcut_hr=$WEBDYNE_START_HTML_SHORTCUT_HR->{$shortcut};
369 0         0 0 && debug("found shortcut tag: $shortcut, content: %s", Dumper($shortcut_hr));
370 0         0 while (my($type, $href_ar)=each %{$shortcut_hr}) {
  0         0  
371 0 0       0 unless (ref($href_ar) eq 'ARRAY') { $href_ar=[$href_ar] }
  0         0  
372 0         0 0 && debug("processing type: $type, href: %s", Dumper($href_ar));
373 0 0       0 if (my $type_attr_value_ar=$attr_page{$type}) {
374 0 0       0 unless (ref($type_attr_value_ar) eq 'ARRAY') { $type_attr_value_ar=[$type_attr_value_ar] }
  0         0  
375 0         0 0 && debug("found existing start_html attr type: $type, content: %s", Dumper($type_attr_value_ar));
376 0         0 push @{$type_attr_value_ar}, @{$href_ar};
  0         0  
  0         0  
377 0         0 $attr_page{$type}=$type_attr_value_ar;
378 0         0 0 && debug("updated start_html attr type: $type to: %s", Dumper($type_attr_value_ar));
379             }
380             else {
381 0         0 0 && debug("no start_hrml attr type: $type found, creating with content: %s", Dumper($href_ar));
382 0         0 $attr_page{$type}=$href_ar
383             }
384             }
385             }
386              
387              
388             # Add meta section
389             #
390 33         85 my @meta;
391 33 100       106 if (my $hr=$attr_page{'meta'}) {
392 1         2 0 && debug('have meta hr: %s', Dumper($hr));
393 1         10 @meta=$self->meta({content => $attr_page{'meta'}});
394 1         3 0 && debug('processed to: %s', Dumper(\@meta));
395             }
396             else {
397 32         49 0 && debug('no meta run');
398             }
399            
400            
401             # Logic error below, replaced by above
402             #
403             #my @meta=$self->meta({ content=>$attr_page{'meta'} })
404             # if $attr_page{'meta'};
405             ##debug('meta: %s', Dumper(\@meta));
406             ##while (my ($name, $content)=each %{$attr_page{'meta'}}) {
407             ## push @meta, $self->meta({name => $name, content => $content});
408             ##}
409             # Used to do this
410             #while (my ($name, $content)=each %{$WEBDYNE_META}) {
411             #push @meta, $self->meta({$name => $content});
412              
413             #}
414             # Now this
415             ##push @meta, $self->meta({ content => $WEBDYNE_META }) unless
416              
417              
418             # Base and/or target
419             #
420 33         46 my @base;
421 33 50 33     185 if ($attr_page{'base'} || $attr_page{'target'}) {
422 0         0 my %attr_base;
423 0 0       0 $attr_base{'href'} = $attr_page{'base'} if $attr_page{'base'};
424 0 0       0 $attr_base{'target'} = $attr_page{'target'} if $attr_page{'target'};
425 0         0 push @base, $self->base(\%attr_base);
426             }
427            
428              
429             # Add any stylesheets
430             #
431 33         58 my @link;
432 33 50       100 if (my $style=$attr_page{'style'}) {
433            
434             # Generate HTML for link tag stylheet
435             #
436 0         0 push @link, $self->_start_html_tag('link', 'href', $style,
437             { rel=>'stylesheet'});
438              
439             }
440 33 50       113 if (my $include_style=$attr_page{'include_style'}) {
441              
442             # Generate HTML to make an include section for any styles user wants, wrap in