| blib/lib/WebDyne/HTML/TreeBuilder.pm | |||
|---|---|---|---|
| Criterion | Covered | Total | % |
| statement | 203 | 398 | 51.0 |
| branch | 56 | 132 | 42.4 |
| condition | 29 | 65 | 44.6 |
| subroutine | 30 | 50 | 60.0 |
| pod | 7 | 27 | 25.9 |
| total | 325 | 672 | 48.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::TreeBuilder; | ||||||
| 14 | |||||||
| 15 | |||||||
| 16 | # Compiler Pragma | ||||||
| 17 | # | ||||||
| 18 | 5 | 5 | 31 | use strict qw(vars); | |||
| 5 | 11 | ||||||
| 5 | 257 | ||||||
| 19 | 5 | 5 | 27 | use vars qw($VERSION @ISA %CGI_TAG_WEBDYNE %CGI_TAG_FORM %CGI_TAG_IMPLICIT %CGI_TAG_SPECIAL); | |||
| 5 | 9 | ||||||
| 5 | 424 | ||||||
| 20 | 5 | 5 | 28 | use warnings; | |||
| 5 | 10 | ||||||
| 5 | 312 | ||||||
| 21 | 5 | 5 | 26 | no warnings qw(uninitialized redefine once); | |||
| 5 | 22 | ||||||
| 5 | 240 | ||||||
| 22 | |||||||
| 23 | |||||||
| 24 | # WebDyne Modules | ||||||
| 25 | # | ||||||
| 26 | 5 | 5 | 27 | use WebDyne; | |||
| 5 | 10 | ||||||
| 5 | 255 | ||||||
| 27 | 5 | 5 | 35 | use WebDyne::Constant; | |||
| 5 | 11 | ||||||
| 5 | 45 | ||||||
| 28 | 5 | 5 | 38 | use WebDyne::HTML::Tiny; | |||
| 5 | 10 | ||||||
| 5 | 146 | ||||||
| 29 | 5 | 5 | 25 | use WebDyne::Util; | |||
| 5 | 7 | ||||||
| 5 | 63 | ||||||
| 30 | |||||||
| 31 | |||||||
| 32 | # External Modules. Keep HTML::Entities or nullification of encode/decode | ||||||
| 33 | # subs will not work below | ||||||
| 34 | # | ||||||
| 35 | 5 | 5 | 4293 | use HTML::TreeBuilder; | |||
| 5 | 49633 | ||||||
| 5 | 73 | ||||||
| 36 | 5 | 5 | 263 | use HTML::Entities; | |||
| 5 | 14 | ||||||
| 5 | 493 | ||||||
| 37 | 5 | 5 | 35 | use HTML::Tagset; | |||
| 5 | 17 | ||||||
| 5 | 124 | ||||||
| 38 | 5 | 5 | 42 | use IO::File; | |||
| 5 | 10 | ||||||
| 5 | 997 | ||||||
| 39 | 5 | 5 | 38 | use Data::Dumper; | |||
| 5 | 11 | ||||||
| 5 | 15120 | ||||||
| 40 | |||||||
| 41 | |||||||
| 42 | # Inheritance | ||||||
| 43 | # | ||||||
| 44 | @ISA=qw(HTML::TreeBuilder); | ||||||
| 45 | |||||||
| 46 | |||||||
| 47 | # Version information | ||||||
| 48 | # | ||||||
| 49 | $VERSION='2.075'; | ||||||
| 50 | |||||||
| 51 | |||||||
| 52 | # Debug load | ||||||
| 53 | # | ||||||
| 54 | 0 && debug("Loading %s version $VERSION", __PACKAGE__); | ||||||
| 55 | |||||||
| 56 | |||||||
| 57 | # Form based tags we don't want to compile as their value may change if keeping state | ||||||
| 58 | # | ||||||
| 59 | %CGI_TAG_FORM=map {$_ => 1} (qw( | ||||||
| 60 | |||||||
| 61 | textfield | ||||||
| 62 | textarea | ||||||
| 63 | password_field | ||||||
| 64 | checkbox | ||||||
| 65 | checkbox_group | ||||||
| 66 | radio_group | ||||||
| 67 | popup_menu | ||||||
| 68 | scrolling_list | ||||||
| 69 | |||||||
| 70 | )); | ||||||
| 71 | |||||||
| 72 | |||||||
| 73 | # Make a hash of our implictly closed tags. | ||||||
| 74 | # | ||||||
| 75 | %CGI_TAG_IMPLICIT=map {$_ => 1} (keys(%CGI_TAG_FORM), qw( | ||||||
| 76 | |||||||
| 77 | filefield | ||||||
| 78 | hidden | ||||||
| 79 | submit | ||||||
| 80 | reset | ||||||
| 81 | defaults | ||||||
| 82 | image_button | ||||||
| 83 | isindex | ||||||
| 84 | dump | ||||||
| 85 | include | ||||||
| 86 | json | ||||||
| 87 | |||||||
| 88 | )); | ||||||
| 89 | |||||||
| 90 | |||||||
| 91 | # Update - get from CGI module, add special dump tag | ||||||
| 92 | # | ||||||
| 93 | #%CGI_TAG_IMPLICIT=map {$_ => 1} ( | ||||||
| 94 | # | ||||||
| 95 | # @{$CGI::EXPORT_TAGS{':form'}}, | ||||||
| 96 | # 'dump' | ||||||
| 97 | #D# | ||||||
| 98 | #); | ||||||
| 99 | #delete @CGI_TAG_IMPLICIT{qw( | ||||||
| 100 | # button | ||||||
| 101 | #)}; | ||||||
| 102 | |||||||
| 103 | |||||||
| 104 | # Get WebDyne tags from main module | ||||||
| 105 | # | ||||||
| 106 | %CGI_TAG_WEBDYNE=%WebDyne::CGI_TAG_WEBDYNE; | ||||||
| 107 | |||||||
| 108 | |||||||
| 109 | # The tags below need to be handled specially at compile time - see the method | ||||||
| 110 | # associated with each tag below. | ||||||
| 111 | # | ||||||
| 112 | #map {$CGI_TAG_SPECIAL{$_}++} qw(perl script style start_html end_html include); | ||||||
| 113 | map {$CGI_TAG_SPECIAL{$_}++} qw( | ||||||
| 114 | perl | ||||||
| 115 | script | ||||||
| 116 | style | ||||||
| 117 | start_html | ||||||
| 118 | end_html | ||||||
| 119 | start_form | ||||||
| 120 | end_form | ||||||
| 121 | start_multipart_form | ||||||
| 122 | end_multipart_form | ||||||
| 123 | include | ||||||
| 124 | div | ||||||
| 125 | api | ||||||
| 126 | json | ||||||
| 127 | htmx | ||||||
| 128 | table | ||||||
| 129 | ); | ||||||
| 130 | |||||||
| 131 | |||||||
| 132 | # Nullify Entities encode & decode | ||||||
| 133 | # | ||||||
| 134 | 0 | *HTML::Entities::encode=sub { }; | |||||
| 135 | 425 | *HTML::Entities::decode=sub { }; | |||||
| 136 | |||||||
| 137 | |||||||
| 138 | # Add to islist items in TreeBuilder | ||||||
| 139 | # | ||||||
| 140 | map {$HTML::Tagset::isList{$_}++} keys %CGI_TAG_WEBDYNE; | ||||||
| 141 | |||||||
| 142 | |||||||
| 143 | # Need to tell HTML::TagSet about our special elements. | ||||||
| 144 | # | ||||||
| 145 | # Update - used to do this but now done in table() method below | ||||||
| 146 | # | ||||||
| 147 | #map {$HTML::Tagset::isTableElement{$_}++} keys %CGI_TAG_WEBDYNE; | ||||||
| 148 | |||||||
| 149 | |||||||
| 150 | # Add to valid body elements - means Treebuilder will automatically | ||||||
| 151 | # create html,head,body sections and include this - for truly lazy | ||||||
| 152 | # that just create a .psp file with no leading start_html | ||||||
| 153 | # | ||||||
| 154 | map { $HTML::Tagset::isBodyElement{$_}++ } qw(htmx json dump); | ||||||
| 155 | |||||||
| 156 | |||||||
| 157 | # And that we also block tag closures |
||||||
| 158 | # | ||||||
| 159 | push @HTML::Tagset::p_closure_barriers, keys %CGI_TAG_WEBDYNE; | ||||||
| 160 | |||||||
| 161 | |||||||
| 162 | # All done. Positive return | ||||||
| 163 | # | ||||||
| 164 | 1; | ||||||
| 165 | |||||||
| 166 | |||||||
| 167 | #================================================================================================== | ||||||
| 168 | |||||||
| 169 | |||||||
| 170 | sub new { | ||||||
| 171 | |||||||
| 172 | |||||||
| 173 | # Instantiate new WebDyne::HTML::TreeBuilder object | ||||||
| 174 | # | ||||||
| 175 | 36 | 36 | 1 | 246 | my ($class, %param)=@_; | ||
| 176 | 36 | 76 | 0 && debug('in %s new(), class: %s, param: %s', __PACKAGE__, (ref($class) || $class), Dumper(\%param)); | ||||
| 177 | 36 | 50 | 281 | my $self=$class->SUPER::new(%param) || | |||
| 178 | return err('unable to initialize from %s, using ISA: %s', ref($class) || $class, Dumper(\@ISA)); | ||||||
| 179 | |||||||
| 180 | |||||||
| 181 | # We do need a HTML::Tiny object that has been ideally already been instantiated. | ||||||
| 182 | # | ||||||
| 183 | $self->{'_html_tiny_or'}=($param{'html_tiny_or'} || | ||||||
| 184 | 36 | 33 | 11916 | WebDyne::HTML::Tiny->new(mode => $WEBDYNE_HTML_TINY_MODE, r=>$param{'r'})); | |||
| 185 | |||||||
| 186 | |||||||
| 187 | # Done | ||||||
| 188 | # | ||||||
| 189 | 36 | 185 | return $self; | ||||
| 190 | |||||||
| 191 | } | ||||||
| 192 | |||||||
| 193 | |||||||
| 194 | sub line_no_debug { | ||||||
| 195 | |||||||
| 196 | 0 | 0 | 0 | 0 | my $self=shift(); | ||
| 197 | 0 | 0 | return sprintf("self $self, line_no: %s, line_no_start: %s, line_no_next: %s", @{$self}{qw(_line_no _line_no_start _line_no_next)}); | ||||
| 0 | 0 | ||||||
| 198 | |||||||
| 199 | } | ||||||
| 200 | |||||||
| 201 | |||||||
| 202 | sub parse_fh { | ||||||
| 203 | |||||||
| 204 | |||||||
| 205 | # Get self ref, file handle | ||||||
| 206 | # | ||||||
| 207 | 36 | 36 | 0 | 103 | my ($tree_or, $html_fh)=@_; | ||
| 208 | 36 | 223 | 0 && debug("parse $html_fh"); | ||||
| 209 | |||||||
| 210 | |||||||
| 211 | # Delete any left over wedge segments | ||||||
| 212 | # | ||||||
| 213 | 36 | 79 | delete $tree_or->{'_html_wedge_ar'}; | ||||
| 214 | |||||||
| 215 | |||||||
| 216 | # Read over file handle until we get to the first non-comment line (ignores auto added copyright statements) | ||||||
| 217 | # | ||||||
| 218 | 36 | 77 | while (1) { | ||||
| 219 | 38 | 135 | my $pos=tell($html_fh); | ||||
| 220 | 38 | 1134 | my $line=<$html_fh>; | ||||
| 221 | 38 | 100 | 204 | if ($line=~/^#/) { | |||
| 222 | 2 | 100 | 15 | ($tree_or->{'_line_no'} ||= 0)++; | |||
| 223 | 2 | 6 | $tree_or->{'_line_no_next'}=$tree_or->{'_line_no'}+1; | ||||
| 224 | 2 | 6 | next; | ||||
| 225 | } | ||||||
| 226 | else { | ||||||
| 227 | 36 | 332 | seek($html_fh, $pos, 0); | ||||
| 228 | 36 | 92 | last; | ||||
| 229 | } | ||||||
| 230 | } | ||||||
| 231 | |||||||
| 232 | |||||||
| 233 | # Return closure code ref that understands how to count line | ||||||
| 234 | # numbers and wedge in extra code | ||||||
| 235 | # | ||||||
| 236 | my $parse_cr=sub { | ||||||
| 237 | |||||||
| 238 | |||||||
| 239 | # Read in lines of HTML, allowing for "wedged" bits, e.g. from start_html | ||||||
| 240 | # | ||||||
| 241 | 280 | 280 | 450 | my $line; | |||
| 242 | 280 | 100 | 407 | my $html=@{$tree_or->{'_html_wedge_ar'}} ? shift @{$tree_or->{'_html_wedge_ar'}} : ($line=<$html_fh>); | |||
| 280 | 1544 | ||||||
| 33 | 80 | ||||||
| 243 | 280 | 100 | 708 | if ($line) { | |||
| 244 | 211 | 290 | 0 && debug("line *$line*"); | ||||
| 245 | 211 | 368 | 0 && debug($tree_or->line_no_debug()); | ||||
| 246 | 211 | 836 | my @cr=($line=~/\n/g); | ||||
| 247 | 211 | 100 | 726 | $tree_or->{'_line_no'}=($tree_or->{'_line_no_next'} || 1); | |||
| 248 | 211 | 478 | $tree_or->{'_line_no_next'}=$tree_or->{'_line_no'}+@cr; | ||||
| 249 | # Stop auto vivification via hash slice | ||||||
| 250 | #debug("Line %s, Line_no_next %s, Line_no_start %s cr %s", @{$tree_or}{qw(_line_no _line_no_next _line_no_start)}, scalar @cr); | ||||||
| 251 | 211 | 404 | 0 && debug("Line %s, Line_no_next %s, Line_no_start %s cr %s", (map {$tree_or->{$_}} qw(_line_no _line_no_next _line_no_start)), scalar @cr); | ||||
| 252 | } | ||||||
| 253 | |||||||
| 254 | |||||||
| 255 | # To this or last line not processed by HTML::Parser properly (in one chunk) if no CR | ||||||
| 256 | # | ||||||
| 257 | 280 | 100 | 100 | 1031 | if ($html_fh->eof() && $html) { | ||
| 258 | 36 | 888 | 0 && debug("add CR at EOF"); | ||||
| 259 | 36 | 100 | 310 | $html.=$/ unless $html=~/(?:\r?\n|\r)$/; | |||
| 260 | } | ||||||
| 261 | |||||||
| 262 | |||||||
| 263 | # Ugly hack to fix @ type attribute names in Alpine and Vue. Need to be done in the Parser properly at | ||||||
| 264 | # some stage | ||||||
| 265 | # | ||||||
| 266 | 280 | 50 | 2046 | if (my $attr_convert=$WEBDYNE_ALPINE_VUE_ATTRIBUTE_HACK_ENABLE) { | |||
| 267 | 280 | 50 | 687 | if ($html =~ s{ | |||
| 268 | (<\s*[\w:-]+ # match the start of an HTML tag | ||||||
| 269 | (?:\s+[^>]*?)?) # non-greedy match of attributes | ||||||
| 270 | \s@([\w\.-]+) # match attribute like @click or @keydown.enter | ||||||
| 271 | (\s*=\s*["'][^"']*["']) # match = "value" or = 'value' | ||||||
| 272 | }{ | ||||||
| 273 | 0 | 0 | "$1 ${attr_convert}:$2$3" | ||||
| 274 | }egx) { #" # Fake quote to re-enable syntax highlighting | ||||||
| 275 | 0 | 0 | 0 && debug("match on AlpineJS attribute syntax hack, line now: $line"); | ||||
| 276 | } | ||||||
| 277 | else { | ||||||
| 278 | 280 | 455 | 0 && debug('no match on AlpineJS attribute syntax hack') | ||||
| 279 | } | ||||||
| 280 | } | ||||||
| 281 | |||||||
| 282 | |||||||
| 283 | # Done, return HTML | ||||||
| 284 | # | ||||||
| 285 | 280 | 2052 | return $html; | ||||
| 286 | |||||||
| 287 | 36 | 295 | }; | ||||
| 288 | 36 | 147 | return $parse_cr; | ||||
| 289 | |||||||
| 290 | } | ||||||
| 291 | |||||||
| 292 | |||||||
| 293 | sub delete { | ||||||
| 294 | |||||||
| 295 | |||||||
| 296 | # Destroy tree, reset any globals | ||||||
| 297 | # | ||||||
| 298 | 0 | 0 | 1 | 0 | my $self=shift(); | ||
| 299 | 0 | 0 | 0 && debug('delete'); | ||||
| 300 | |||||||
| 301 | |||||||
| 302 | # Reset script and line number vars | ||||||
| 303 | # | ||||||
| 304 | 0 | 0 | delete $self->{'_html_wedge_ar'}; | ||||
| 305 | |||||||
| 306 | |||||||
| 307 | # Run real deal from parent | ||||||
| 308 | # | ||||||
| 309 | 0 | 0 | $self->SUPER::delete(@_); | ||||
| 310 | |||||||
| 311 | |||||||
| 312 | } | ||||||
| 313 | |||||||
| 314 | |||||||
| 315 | sub tag_parse { | ||||||
| 316 | |||||||
| 317 | |||||||
| 318 | # Get our self ref | ||||||
| 319 | # | ||||||
| 320 | 772 | 772 | 0 | 1340 | my ($self, $method)=(shift, shift); | ||
| 321 | |||||||
| 322 | |||||||
| 323 | # Get the tag, tag attr | ||||||
| 324 | # | ||||||
| 325 | 772 | 1390 | my ($tag, $attr_hr)=@_; | ||||
| 326 | |||||||
| 327 | |||||||
| 328 | # Get rid of attribute multi-line value if the start with subst chars | ||||||
| 329 | # | ||||||
| 330 | 772 | 1041 | foreach my $attr (keys %{$attr_hr}) { | ||||
| 772 | 2178 | ||||||
| 331 | 244 | 363 | my $attr_value=$attr_hr->{$attr}; | ||||
| 332 | 244 | 100 | 576 | if ($attr_value=~/([\$@%!+*^])\{(\1?)/) { | |||
| 333 | # Get rid of cr/lf | ||||||
| 334 | 2 | 50 | 24 | if ($attr_value=~s/\s*[\r\n]+\s*/ /g) { | |||
| 335 | 0 | 0 | $attr_hr->{$attr}=$attr_value; | ||||
| 336 | } | ||||||
| 337 | } | ||||||
| 338 | } | ||||||
| 339 | #map { $attr_hr->{$_}=($attr_hr->{$_}=~s/\s*[\r\n]+\s*/ /gr) } keys %{$attr_hr}; | ||||||
| 340 | |||||||
| 341 | |||||||
| 342 | # Debug. Amended to stop autovivification | ||||||
| 343 | # | ||||||
| 344 | #debug("tag_parse $method, tag: *%s*, line_no: %s, line_no_start: %s, attr_hr:%s ", $tag, @{$self}{qw(_line_no _line_no_start)}, Dumper($attr_hr)); | ||||||
| 345 | 772 | 1001 | 0 && debug("tag_parse $method, tag: *%s*, line_no: %s, line_no_start: %s, attr_hr:%s ", $tag, (map {$self->{$_}} qw(_line_no _line_no_start)), Dumper($attr_hr)); | ||||
| 346 | |||||||
| 347 | |||||||
| 348 | # Get the parent tag | ||||||
| 349 | # | ||||||
| 350 | 772 | 1096 | my $pos; | ||||
| 351 | my $tag_parent=( | ||||||
| 352 | $pos=$self->{'_pos'} || $self | ||||||
| 353 | 772 | 66 | 2368 | )->{'_tag'}; | |||
| 354 | 772 | 896 | 0 && debug("tag $tag, tag_parent $tag_parent"); | ||||
| 355 | |||||||
| 356 | |||||||
| 357 | # Is chomp detected ? | ||||||
| 358 | # | ||||||
| 359 | 772 | 50 | 1588 | if (delete $attr_hr->{'chomp'}) { | |||
| 360 | |||||||
| 361 | # Yes, flag for later processing | ||||||
| 362 | # | ||||||
| 363 | 0 | 0 | 0 && debug('chomp attribute detected, setting flag'); | ||||
| 364 | 0 | 0 | $self->{'_chomp'}++; | ||||
| 365 | |||||||
| 366 | } | ||||||
| 367 | |||||||
| 368 | |||||||
| 369 | # Var to hold returned html element object ref | ||||||
| 370 | # | ||||||
| 371 | 772 | 965 | my $html_or; | ||||
| 372 | |||||||
| 373 | |||||||
| 374 | # If it is an below an implicit parent tag close that tag now. | ||||||
| 375 | # | ||||||
| 376 | #if ($CGI_TAG_IMPLICIT{$tag_parent} || $tag_parent=~/^start_/i || $tag_parent=~/^end_/i) { | ||||||
| 377 | 772 | 100 | 66 | 7331 | if ($CGI_TAG_IMPLICIT{$tag_parent} || ($tag_parent=~/^(?:start_|end_)/i)) { | ||
| 50 | 66 | ||||||
| 50 | 66 | ||||||
| 100 | 66 | ||||||
| 50 | 33 | ||||||
| 50 | |||||||
| 100 | |||||||
| 378 | |||||||
| 379 | # End implicit parent if it was an implicit tag | ||||||
| 380 | # | ||||||
| 381 | 15 | 26 | 0 && debug("ending implicit parent tag $tag_parent"); | ||||
| 382 | 15 | 52 | $self->end($tag_parent); | ||||
| 383 | 15 | 85 | $html_or=$self->$method(@_); | ||||
| 384 | |||||||
| 385 | } | ||||||
| 386 | |||||||
| 387 | |||||||
| 388 | # Special case where |
||||||
| 389 | # head is always under html - we have to hack. | ||||||
| 390 | # | ||||||
| 391 | elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'head')) { | ||||||
| 392 | |||||||
| 393 | # Debug and modify tree | ||||||
| 394 | # | ||||||
| 395 | 0 | 0 | 0 && debug("found $tag_parent above $tag, modifying tree"); | ||||
| 396 | 0 | 0 | $self->{'_head'}->preinsert($pos); | ||||
| 397 | 0 | 0 | $self->{'_head'}->detach(); | ||||
| 398 | 0 | 0 | $pos->push_content($self->{'_head'}); | ||||
| 399 | 0 | 0 | $html_or=$self->$method(@_); | ||||
| 400 | |||||||
| 401 | } | ||||||
| 402 | |||||||
| 403 | |||||||
| 404 | # Same for body tag as above | ||||||
| 405 | # | ||||||
| 406 | elsif ($CGI_TAG_WEBDYNE{$tag_parent} && ($tag eq 'body')) { | ||||||
| 407 | |||||||
| 408 | 0 | 0 | 0 && debug("found $tag_parent above $tag, modifying tree"); | ||||
| 409 | 0 | 0 | $self->{'_body'}->preinsert($pos); | ||||
| 410 | 0 | 0 | $self->{'_body'}->detach(); | ||||
| 411 | 0 | 0 | $pos->push_content($self->{'_body'}); | ||||
| 412 | 0 | 0 | $html_or=$self->$method(@_); | ||||
| 413 | |||||||
| 414 | } | ||||||
| 415 | |||||||
| 416 | |||||||
| 417 | # If it is an custom webdyne tag, massage with methods below | ||||||
| 418 | # before processing | ||||||
| 419 | # | ||||||
| 420 | elsif ($CGI_TAG_SPECIAL{$tag} && ($method ne 'SUPER::text')) { | ||||||
| 421 | |||||||
| 422 | |||||||
| 423 | # Yes, is WebDyne tag | ||||||
| 424 | # | ||||||
| 425 | 35 | 53 | 0 && debug("webdyne tag_special ($tag) dispatch"); | ||||
| 426 | 35 | 164 | $html_or=$self->$tag($method, $tag, $attr_hr); | ||||
| 427 | |||||||
| 428 | } | ||||||
| 429 | |||||||
| 430 | |||||||
| 431 | elsif ((my ($modifier, $tag_actual)=($tag=~/^(start_|end_)(.*)/i)) && ($method ne 'SUPER::text')) { | ||||||
| 432 | |||||||
| 433 | |||||||
| 434 | # Yes, is WebDyne tag | ||||||
| 435 | # | ||||||
| 436 | 0 | 0 | 0 && debug("webdyne tag start|end ($tag) dispatch, method $method"); | ||||
| 437 | #if ($modifier=~/end_/) { | ||||||
| 438 | # debug('end tag so changing method to SUPER::end'); | ||||||
| 439 | # $method='SUPER::end' | ||||||
| 440 | #} | ||||||
| 441 | |||||||
| 442 | 0 | 0 | $html_or=$self->tag_parse($method, $tag_actual, $attr_hr); | ||||
| 443 | |||||||
| 444 | } | ||||||
| 445 | |||||||
| 446 | |||||||
| 447 | # If it is an custom CGI tag that we need to close implicityly | ||||||
| 448 | # | ||||||
| 449 | #elsif ($CGI_TAG_IMPLICIT{$tag_parent} || $tag=~/^start_/i || $tag=~/^end_/) { | ||||||
| 450 | elsif ($CGI_TAG_IMPLICIT{$tag_parent}) { | ||||||
| 451 | |||||||
| 452 | |||||||
| 453 | # Yes, is CGI tag | ||||||
| 454 | # | ||||||
| 455 | 0 | 0 | 0 && debug("webdyne tag_implicit ($tag) dispatch"); | ||||
| 456 | 0 | 0 | $html_or=$self->$method(@_); | ||||
| 457 | 0 | 0 | $self->end($tag) | ||||
| 458 | |||||||
| 459 | } | ||||||
| 460 | |||||||
| 461 | |||||||
| 462 | # If its parent was a custom webdyne tag, the turn off implicitness | ||||||
| 463 | # before processing | ||||||
| 464 | # | ||||||
| 465 | elsif ($CGI_TAG_WEBDYNE{$tag_parent}) { | ||||||
| 466 | |||||||
| 467 | |||||||
| 468 | # Turn off implicitness here to stop us from being moved | ||||||
| 469 | # around in the parse tree if we are under a table or some | ||||||
| 470 | # such | ||||||
| 471 | # | ||||||
| 472 | 2 | 4 | 0 && debug('turning off implicit tags'); | ||||
| 473 | 2 | 22 | $self->implicit_tags(0); | ||||
| 474 | |||||||
| 475 | |||||||
| 476 | # Run the WebDyne tag method. | ||||||
| 477 | # | ||||||
| 478 | 2 | 23 | 0 && debug("webdyne tag_parent ($tag_parent) dispatch"); | ||||
| 479 | 2 | 8 | $html_or=$self->$tag_parent($method, $tag, $attr_hr); | ||||
| 480 | |||||||
| 481 | |||||||
| 482 | # Turn implicitness back on again | ||||||
| 483 | # | ||||||
| 484 | 2 | 307 | 0 && debug('turning on implicit tags'); | ||||
| 485 | 2 | 8 | $self->implicit_tags(1); | ||||
| 486 | |||||||
| 487 | |||||||
| 488 | } | ||||||
| 489 | else { | ||||||
| 490 | |||||||
| 491 | |||||||
| 492 | # Pass onto our base class for further processing | ||||||
| 493 | # | ||||||
| 494 | 720 | 972 | 0 && debug("base class method $method, %s", Dumper(\@_)); | ||||
| 495 | 720 | 2306 | $html_or=$self->$method(@_); | ||||
| 496 | |||||||
| 497 | |||||||
| 498 | } | ||||||
| 499 | |||||||
| 500 | |||||||
| 501 | # Do we have a HTML::Element object ? | ||||||
| 502 | # | ||||||
| 503 | 772 | 100 | 66 | 67893 | if ((my $ref=ref($html_or)) eq 'HTML::Element') { | ||
| 50 | |||||||
| 504 | |||||||
| 505 | # Yes | ||||||
| 506 | # | ||||||
| 507 | 279 | 423 | 0 && debug("parse returned $ref object, tag: %s, inserting line no", $html_or->tag()); | ||||
| 508 | 279 | 400 | @{$html_or}{'_line_no', '_line_no_tag_end'}=@{$self}{qw(_line_no_start _line_no)}; | ||||
| 279 | 756 | ||||||
| 279 | 641 | ||||||
| 509 | |||||||
| 510 | |||||||
| 511 | } | ||||||
| 512 | elsif ($ref && ($ref ne 'WebDyne::HTML::TreeBuilder')) { | ||||||
| 513 | |||||||
| 514 | # That's weird .. | ||||||
| 515 | # | ||||||
| 516 | 0 | 0 | return err("parse returned $ref object, expected 'WebDyne::HTML::Element'"); | ||||
| 517 | |||||||
| 518 | } | ||||||
| 519 | else { | ||||||
| 520 | |||||||
| 521 | # Text | ||||||
| 522 | # | ||||||
| 523 | 493 | 655 | 0 && debug('parse returned text (scalar) object'); | ||||
| 524 | |||||||
| 525 | } | ||||||
| 526 | |||||||
| 527 | |||||||
| 528 | # Returm object ref | ||||||
| 529 | # | ||||||
| 530 | 772 | 2097 | $html_or; | ||||
| 531 | |||||||
| 532 | |||||||
| 533 | } | ||||||
| 534 | |||||||
| 535 | |||||||
| 536 | sub block { | ||||||
| 537 | |||||||
| 538 | |||||||
| 539 | # No special handling needed, just log for debugging purposes | ||||||
| 540 | # | ||||||
| 541 | 0 | 0 | 0 | 0 | my ($self, $method)=(shift, shift); | ||
| 542 | 0 | 0 | 0 && debug("block self $self, method $method, *%s* text_block_tag %s", join('*', @_), $self->_text_block_tag()); | ||||
| 543 | 0 | 0 | $self->$method(@_); | ||||
| 544 | |||||||
| 545 | } | ||||||
| 546 | |||||||
| 547 | |||||||
| 548 | sub script { | ||||||
| 549 | |||||||
| 550 | 0 | 0 | 0 | 0 | my ($self, $method, $tag, $attr_hr, @param)=@_; | ||
| 551 | 5 | 5 | 45 | no warnings 'qw'; | |||
| 5 | 10 | ||||||
| 5 | 24583 | ||||||
| 552 | 0 | 0 | 0 && debug("$self script, attr: %s", Dumper($attr_hr)); | ||||
| 553 | 0 | 0 | my $script_or=$self->$method($tag, $attr_hr, @param); | ||||
| 554 | 0 | 0 | 0 | if ($attr_hr->{'type'} eq 'application/perl') { | |||
| 555 | |||||||
| 556 | 0 | 0 | my $perl_or=HTML::Element->new('perl', inline => 1); | ||||
| 557 | 0 | 0 | push @{$self->{'_script_stack'}}, [$script_or, 'perl', $perl_or]; | ||||
| 0 | 0 | ||||||
| 558 | 0 | 0 | 0 && debug('perl script !'); | ||||
| 559 | |||||||
| 560 | } | ||||||
| 561 | else { | ||||||
| 562 | |||||||
| 563 | 0 | 0 | push @{$self->{'_script_stack'}}, undef; | ||||
| 0 | 0 | ||||||
| 564 | 0 | 0 | 0 | $self->_text_block_tag('script') unless $self->_text_block_tag(); | |||
| 565 | } | ||||||
| 566 | |||||||
| 567 | #$self->$method($tag, $attr_hr, @param); | ||||||
| 568 | 0 | 0 | return $script_or; | ||||
| 569 | |||||||
| 570 | } | ||||||
| 571 | |||||||
| 572 | |||||||
| 573 | sub json0 { | ||||||
| 574 | |||||||
| 575 | |||||||
| 576 | # No special handling needed, just log for debugging purposes | ||||||
| 577 | # | ||||||
| 578 | 0 | 0 | 0 | 0 | my ($self, $method, @param)=@_; | ||
| 579 | 0 | 0 | 0 | $self->_text_block_tag('json') unless $self->_text_block_tag(); | |||
| 580 | 0 | 0 | 0 && debug("self $self, tag: json, method: $method text_block_tag %s", $self->_text_block_tag()); | ||||
| 581 | 0 | 0 | return $self->$method(@param); | ||||
| 582 | |||||||
| 583 | } | ||||||
| 584 | |||||||
| 585 | |||||||
| 586 | sub table { | ||||||
| 587 | |||||||
| 588 | |||||||
| 589 | # Modify HTML::Tagset to allow perl/block/htmx tags within a table tag, then pull them out | ||||||
| 590 | # when the table tag closes. | ||||||
| 591 | # | ||||||
| 592 | 0 | 0 | 0 | 0 | my ($self, $method, @param)=@_; | ||
| 593 | 0 | 0 | 0 && debug("self $self, tag: api, method: $method"); | ||||
| 594 | 0 | 0 | 0 | if ($method eq 'SUPER::start') { | |||
| 0 | |||||||
| 595 | 0 | 0 | map { $HTML::Tagset::isTableElement{$_}=1 } qw(perl block htmx) | ||||
| 0 | 0 | ||||||
| 596 | } | ||||||
| 597 | elsif ($method eq 'SUPER::end') { | ||||||
| 598 | 0 | 0 | map { delete $HTML::Tagset::isTableElement{$_} } qw(perl block htmx) | ||||
| 0 | 0 | ||||||
| 599 | } | ||||||
| 600 | 0 | 0 | return $self->$method(@param); | ||||
| 601 | |||||||
| 602 | } | ||||||
| 603 | |||||||
| 604 | |||||||
| 605 | sub htmx { | ||||||
| 606 | |||||||
| 607 | |||||||
| 608 | # Handle normally but set flag showing we are an |
||||||
| 609 | # | ||||||
| 610 | 3 | 3 | 0 | 8 | my ($self, $method, $tag, $attr_hr, @param)=@_; | ||
| 611 | 3 | 5 | 0 && debug("self $self, tag: htmx, method: $method, param: %s", Dumper($attr_hr)); | ||||
| 612 | 3 | 50 | 33 | 16 | $self->{'_webdyne_compact'}=$tag if ($attr_hr->{'compact'} || $attr_hr->{'bare'}); | ||
| 613 | 3 | 50 | 8 | if (delete $attr_hr->{'perl'}) { | |||
| 614 | 0 | 0 | my $html_perl_or=$self->$method($tag, $attr_hr); | ||||
| 615 | 0 | 0 | $self->_html_perl_or($html_perl_or); | ||||
| 616 | 0 | 0 | 0 | $self->_text_block_tag($tag) unless $self->_text_block_tag(); | |||
| 617 | 0 | 0 | return $html_perl_or; | ||||
| 618 | } | ||||||
| 619 | else { | ||||||
| 620 | 3 | 19 | return $self->$method($tag, $attr_hr, @param); | ||||
| 621 | } | ||||||
| 622 | |||||||
| 623 | } | ||||||
| 624 | |||||||
| 625 | |||||||
| 626 | sub api { | ||||||
| 627 | |||||||
| 628 | |||||||
| 629 | # Handle normally but set flag showing we are an |
||||||
| 630 | # | ||||||
| 631 | 1 | 1 | 0 | 2 | my ($self, $method, $tag, $attr_hr, @param)=@_; | ||
| 632 | 1 | 1 | 0 && debug("self $self, tag: api, method: $method"); | ||||
| 633 | 1 | 3 | $self->{'_webdyne_compact'}=$tag; | ||||
| 634 | 1 | 50 | 2 | if (delete $attr_hr->{'perl'}) { | |||
| 635 | 1 | 7 | my $html_perl_or=$self->$method($tag, $attr_hr); | ||||
| 636 | 1 | 150 | $self->_html_perl_or($html_perl_or); | ||||
| 637 | 1 | 50 | 15 | $self->_text_block_tag($tag) unless $self->_text_block_tag(); | |||
| 638 | 1 | 2 | return $html_perl_or; | ||||
| 639 | } | ||||||
| 640 | else { | ||||||
| 641 | 0 | 0 | return $self->$method($tag, $attr_hr, @param); | ||||
| 642 | } | ||||||
| 643 | |||||||
| 644 | } | ||||||
| 645 | |||||||
| 646 | |||||||
| 647 | sub json { | ||||||
| 648 | |||||||
| 649 | |||||||
| 650 | # No special handling needed, just log for debugging purposes | ||||||
| 651 | # | ||||||
| 652 | 0 | 0 | 0 | 0 | my ($self, $method, $tag, $attr_hr, @param)=@_; | ||
| 653 | 0 | 0 | 0 && debug("self $self, tag: api, method: $method"); | ||||
| 654 | 0 | 0 | 0 | if (delete $attr_hr->{'perl'}) { | |||
| 655 | 0 | 0 | my $html_perl_or=$self->$method($tag, $attr_hr); | ||||
| 656 | 0 | 0 | $self->_html_perl_or($html_perl_or); | ||||
| 657 | 0 | 0 | 0 | $self->_text_block_tag($tag) unless $self->_text_block_tag(); | |||
| 658 | 0 | 0 | return $html_perl_or; | ||||
| 659 | } | ||||||
| 660 | else { | ||||||
| 661 | 0 | 0 | return $self->$method($tag, $attr_hr, @param); | ||||
| 662 | } | ||||||
| 663 | |||||||
| 664 | } | ||||||
| 665 | |||||||
| 666 | |||||||
| 667 | sub style { | ||||||
| 668 | |||||||
| 669 | 0 | 0 | 0 | 0 | my ($self, $method)=(shift, shift); | ||
| 670 | 0 | 0 | 0 && debug('style'); | ||||
| 671 | 0 | 0 | 0 | $self->_text_block_tag('style') unless $self->_text_block_tag(); | |||
| 672 | 0 | 0 | return $self->$method(@_); | ||||
| 673 | |||||||
| 674 | } | ||||||
| 675 | |||||||
| 676 | |||||||
| 677 | sub perl { | ||||||
| 678 | |||||||
| 679 | |||||||
| 680 | # Special handling of perl tag | ||||||
| 681 | # | ||||||
| 682 | 0 | 0 | 0 | 0 | my ($self, $method, $tag, $attr_hr)=@_; | ||
| 683 | 0 | 0 | 0 && debug("tag: *$tag* method: $method"); | ||||
| 684 | |||||||
| 685 | |||||||
| 686 | # Call SUPER method, check if inline | ||||||
| 687 | # | ||||||
| 688 | 0 | 0 | my $html_perl_or=$self->$method($tag, $attr_hr); | ||||
| 689 | 0 | 0 | my $inline; | ||||
| 690 | 0 | 0 | 0 | if ($tag eq 'perl') { | |||
| 691 | 0 | 0 | 0 | unless (grep {exists $attr_hr->{$_}} qw(package method handler)) { | |||
| 0 | 0 | ||||||
| 692 | 0 | 0 | $html_perl_or->attr(inline => ++$inline); | ||||
| 693 | 0 | 0 | 0 && debug("inline: $inline"); | ||||
| 694 | } | ||||||
| 695 | } | ||||||
| 696 | 0 | 0 | 0 | if ($inline) { | |||
| 697 | |||||||
| 698 | # Inline tag, set global var to this element so any extra text can be | ||||||
| 699 | # added here | ||||||
| 700 | # | ||||||
| 701 | 0 | 0 | $self->_html_perl_or($html_perl_or); | ||||
| 702 | 0 | 0 | 0 | $self->_text_block_tag($tag) unless $self->_text_block_tag(); | |||
| 703 | |||||||
| 704 | |||||||
| 705 | # And return it | ||||||
| 706 | # | ||||||
| 707 | 0 | 0 | return $html_perl_or; | ||||
| 708 | |||||||
| 709 | } | ||||||
| 710 | else { | ||||||
| 711 | |||||||
| 712 | |||||||
| 713 | # Not inline, just return object | ||||||
| 714 | # | ||||||
| 715 | 0 | 0 | return $html_perl_or; | ||||
| 716 | |||||||
| 717 | } | ||||||
| 718 | |||||||
| 719 | |||||||
| 720 | } | ||||||
| 721 | |||||||
| 722 | |||||||
| 723 | sub process { | ||||||
| 724 | |||||||
| 725 | # Rough and ready process handler, try to handle perl code in . Not sure if I really | ||||||
| 726 | # want to support this yet ... | ||||||
| 727 | # | ||||||
| 728 | 19 | 19 | 1 | 101 | my ($self, $text)=@_; | ||
| 729 | 19 | 41 | 0 && debug("process $text"); | ||||
| 730 | |||||||
| 731 | # Create perl HTMl::Object | ||||||
| 732 | # | ||||||
| 733 | 19 | 81 | my $html_or=HTML::Element->new('perl', inline => 1, perl => $text); | ||||
| 734 | 19 | 842 | 0 && debug("insert line_no: %s into object ref $html_or", $self->{'_line_no'}); | ||||
| 735 | 19 | 41 | @{$html_or}{'_line_no', '_line_no_tag_end'}=@{$self}{qw(_line_no _line_no)}; | ||||
| 19 | 71 | ||||||
| 19 | 55 | ||||||
| 736 | 19 | 55 | return $self->tag_parse('SUPER::text', $html_or) | ||||
| 737 | |||||||
| 738 | } | ||||||
| 739 | |||||||
| 740 | |||||||
| 741 | sub start { | ||||||
| 742 | |||||||
| 743 | |||||||
| 744 | # Ugly, make sure if in perl or script tag, whatever we see counts | ||||||
| 745 | # as text | ||||||
| 746 | # | ||||||
| 747 | 346 | 346 | 1 | 873 | my ($self, $tag)=(shift, shift); | ||
| 748 | 346 | 556 | my $text=$_[2]; | ||||
| 749 | 346 | 50 | 789 | ref($tag) || ($tag=lc($tag)); | |||
| 750 | 346 | 552 | 0 && debug("$self start tag '$tag' line_no: %s, %s", $self->{'_line_no'}, Dumper(\@_)); | ||||
| 751 | |||||||
| 752 | 346 | 483 | my $html_or; | ||||
| 753 | 346 | 50 | 9087 | if ($self->_text_block_tag()) { | |||
| 754 | 0 | 0 | $html_or=$self->text($text) | ||||
| 755 | } | ||||||
| 756 | else { | ||||||
| 757 | 346 | 759 | my @cr=($text=~/\n/g); | ||||
| 758 | 346 | 704 | $self->{'_line_no_start'}=$self->{'_line_no'}-@cr; | ||||
| 759 | # Amend to stop autovivification | ||||||
| 760 | #debug("tag $tag line_no: %s, line_no_start: %s", @{$self}{qw(_line_no _line_no_start)}); | ||||||
| 761 | 346 | 429 | 0 && debug("tag $tag line_no: %s, line_no_start: %s", (map {$self->{$_}} qw(_line_no _line_no_start))); | ||||
| 762 | 346 | 858 | $html_or=$self->tag_parse('SUPER::start', $tag, @_); | ||||
| 763 | |||||||
| 764 | } | ||||||
| 765 | 346 | 2380 | $html_or; | ||||
| 766 | |||||||
| 767 | } | ||||||
| 768 | |||||||
| 769 | |||||||
| 770 | sub end { | ||||||
| 771 | |||||||
| 772 | |||||||
| 773 | # Ugly special case conditions, ensure end tag between perl or script | ||||||
| 774 | # blocks are treated as text | ||||||
| 775 | # | ||||||
| 776 | 150 | 150 | 1 | 4146 | my ($self, $tag)=(shift, shift); | ||
| 777 | 150 | 100 | 419 | ref($tag) || ($tag=lc($tag)); | |||
| 778 | 150 | 182 | 0 && debug("$self end tag: %s,%s text_block_tag: %s, line_no: %s", Dumper($tag, \@_), $self->_text_block_tag(), $self->{'_line_no'}); | ||||
| 779 | 150 | 222 | 0 && debug($self->line_no_debug()); | ||||
| 780 | #debug('self: %s', Dumper($self)); | ||||||
| 781 | |||||||
| 782 | |||||||
| 783 | # Var to hold HTML::Element ref if returned, but most methods don't seem to return a HTML ref, just an integer ? | ||||||
| 784 | # | ||||||
| 785 | 150 | 212 | my $ret; | ||||
| 786 | |||||||
| 787 | |||||||
| 788 | # Div tag gets handles specially as start tag might have been a webdyne tag aliases into a div tag (see div tag for more details) | ||||||
| 789 | # | ||||||
| 790 | 150 | 50 | 582 | if ($tag eq 'div') { | |||
| 50 | |||||||
| 791 | |||||||
| 792 | # Hit on div, check | ||||||
| 793 | # | ||||||
| 794 | 0 | 0 | 0 && debug("hit on div tag: $tag"); | ||||
| 795 | |||||||
| 796 | |||||||
| 797 | # Can we pop an array ref off div_stack ? If so means was webdyne tag | ||||||
| 798 | # | ||||||
| 799 | #if (my $div_ar=pop(@div_stack)) { | ||||||
| 800 | 0 | 0 | 0 | if (my $div_ar=pop(@{$self->{'_div_stack'}})) { | |||
| 0 | 0 | ||||||
| 801 | |||||||
| 802 | |||||||
| 803 | # Yes, separate out to components stored by div subroutine | ||||||
| 804 | # | ||||||
| 805 | 0 | 0 | my ($div_or, $webdyne_tag, $webdyne_tag_or)=@{$div_ar}; | ||||
| 0 | 0 | ||||||
| 806 | 0 | 0 | 0 && debug("popped div tag: $div_or, %s, about to end webdyne tag: $webdyne_tag (%s)", $div_or->tag(), $webdyne_tag_or->tag()); | ||||
| 807 | |||||||
| 808 | |||||||
| 809 | # Set the Text_fg to whatever the webdyne tag was (e.g. perl, etc), that way they will see a match and | ||||||
| 810 | # turn off text mode. NOTE: Not sure this works ? | ||||||
| 811 | # | ||||||
| 812 | 0 | 0 | 0 | $self->_text_block_tag($webdyne_tag_or->tag()) if $self->_text_block_tag(); | |||
| 813 | 0 | 0 | 0 && debug("text_block_tag now %s, ending $webdyne_tag", $self->_text_block_tag()); | ||||
| 814 | 0 | 0 | 0 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 815 | 0 | 0 | $self->SUPER::end($webdyne_tag, @_); | ||||
| 816 | |||||||
| 817 | # Now end the original div tag | ||||||
| 818 | # | ||||||
| 819 | 0 | 0 | 0 && debug("ending $tag now"); | ||||
| 820 | 0 | 0 | 0 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 821 | 0 | 0 | $ret=$self->SUPER::end($tag, @_); | ||||
| 822 | |||||||
| 823 | |||||||
| 824 | # Can now unset text flag. See NOTE above, need to check this | ||||||
| 825 | # | ||||||
| 826 | 0 | 0 | $self->_text_block_tag(undef); | ||||
| 827 | |||||||
| 828 | |||||||
| 829 | # Now replace div tag with webdyne output unless a wrap attribute exists or class etc. given - in which | ||||||
| 830 | # case the output will be wrapped in that tag and any class, style or id tags presevered | ||||||
| 831 | # | ||||||
| 832 | 0 | 0 | my @div_attr_name=grep {$div_or->attr($_)} qw(class style id); | ||||
| 0 | 0 | ||||||
| 833 | 0 | 0 | 0 | 0 | if ((my $tag=$div_or->attr('wrap')) || @div_attr_name) { | ||
| 834 | |||||||
| 835 | # Want to wrap output in another tag or use if class etc. given but no tag |
||||||
| 836 | # | ||||||
| 837 | 0 | 0 | 0 | $tag ||= 'div'; | |||
| 838 | 0 | 0 | $webdyne_tag_or->push_content($div_or->detach_content()); | ||||
| 839 | my %tag_attr=( | ||||||
| 840 | 0 | 0 | map {$_ => $div_or->attr($_)} | ||||
| 0 | 0 | ||||||
| 841 | @div_attr_name | ||||||
| 842 | ); | ||||||
| 843 | 0 | 0 | 0 && debug("tag: $tag, tag_attr: %s", Dumper(\%tag_attr)); | ||||
| 844 | 0 | 0 | my $tag_or=HTML::Element->new($tag, %tag_attr); | ||||
| 845 | 0 | 0 | $tag_or->push_content($webdyne_tag_or); | ||||
| 846 | 0 | 0 | $div_or->replace_with($tag_or); | ||||
| 847 | |||||||
| 848 | } | ||||||
| 849 | else { | ||||||
| 850 | 0 | 0 | $webdyne_tag_or->push_content($div_or->detach_content()); | ||||
| 851 | 0 | 0 | $div_or->replace_with($webdyne_tag_or); | ||||
| 852 | } | ||||||
| 853 | 0 | 0 | return $ret; | ||||
| 854 | |||||||
| 855 | } | ||||||
| 856 | else { | ||||||
| 857 | |||||||
| 858 | |||||||
| 859 | # Vanilla div tag, nothing to do | ||||||
| 860 | # | ||||||
| 861 | 0 | 0 | 0 && debug('undef pop off div stack'); | ||||
| 862 | 0 | 0 | 0 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 863 | 0 | 0 | return $ret=$self->SUPER::end($tag, @_); | ||||
| 864 | } | ||||||
| 865 | } | ||||||
| 866 | elsif ($tag eq 'script') { | ||||||
| 867 | |||||||
| 868 | |||||||
| 869 | # Script tag, presumably of type application/perl | ||||||
| 870 | # | ||||||
| 871 | 0 | 0 | 0 && debug('hit on script tag'); | ||||
| 872 | |||||||
| 873 | |||||||
| 874 | # Can we pop an array ref off script_stack ? If so means was webdyne tag | ||||||
| 875 | # | ||||||
| 876 | 0 | 0 | 0 | if (my $script_ar=pop(@{$self->{'_script_stack'}})) { | |||
| 0 | 0 | ||||||
| 877 | |||||||
| 878 | |||||||
| 879 | # Get vars from array ref | ||||||
| 880 | # | ||||||
| 881 | 0 | 0 | my ($script_or, $perl_tag, $perl_tag_or)=@{$script_ar}; | ||||
| 0 | 0 | ||||||
| 882 | 0 | 0 | 0 && debug("popped script tag: $script_or, %s, about to end perl tag: $perl_tag (%s)", $script_or->tag(), $perl_tag_or->tag()); | ||||
| 883 | |||||||
| 884 | |||||||
| 885 | # End perl tag | ||||||
| 886 | # | ||||||
| 887 | 0 | 0 | 0 && debug("end $perl_tag now"); | ||||
| 888 | 0 | 0 | 0 | $self->_text_block_tag($perl_tag_or->tag()) if $self->_text_block_tag(); | |||
| 889 | 0 | 0 | 0 && debug("text_block_tag now %s, ending $perl_tag", $self->_text_block_tag()); | ||||
| 890 | 0 | 0 | $self->SUPER::end($perl_tag, @_); | ||||
| 891 | |||||||
| 892 | |||||||
| 893 | # End script tag | ||||||
| 894 | # | ||||||
| 895 | 0 | 0 | 0 && debug("end $tag now"); | ||||
| 896 | 0 | 0 | 0 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 897 | 0 | 0 | $self->SUPER::end($tag, @_); | ||||
| 898 | 0 | 0 | $self->_text_block_tag(undef); | ||||
| 899 | |||||||
| 900 | |||||||
| 901 | # Re-arrange tree | ||||||
| 902 | # | ||||||
| 903 | 0 | 0 | 0 && debug('script content %s', Dumper($script_or->content_list)); | ||||
| 904 | |||||||
| 905 | #$perl_tag_or->push_content($script_or->detach_content()); | ||||||
| 906 | 0 | 0 | $perl_tag_or->attr('perl', $script_or->detach_content()); | ||||
| 907 | 0 | 0 | $script_or->replace_with($perl_tag_or); | ||||
| 908 | 0 | 0 | return 1; | ||||
| 909 | |||||||
| 910 | } | ||||||
| 911 | 0 | 0 | elsif (0) { | ||||
| 912 | |||||||
| 913 | 0 && debug('null script stack pop, ignoring'); | ||||||
| 914 | $self->_text_block_tag(undef); | ||||||
| 915 | return $ret=$self->SUPER::end($tag, @_); | ||||||
| 916 | } | ||||||
| 917 | } | ||||||
| 918 | |||||||
| 919 | |||||||
| 920 | 150 | 100 | 66 | 4049 | if ($self->_text_block_tag() && ($tag eq $self->_text_block_tag())) { | ||
| 50 | 66 | ||||||
| 50 | |||||||
| 921 | 1 | 1 | 0 && debug("match on tag $tag to text_block_tag %s, clearing text_block_tag", $self->_text_block_tag()); | ||||
| 922 | 1 | 31 | $self->_text_block_tag(undef); | ||||
| 923 | 1 | 50 | 8 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 924 | 1 | 24 | $ret=$self->SUPER::end($tag, @_) | ||||
| 925 | } | ||||||
| 926 | elsif ($self->_text_block_tag()) { | ||||||
| 927 | 0 | 0 | 0 && debug('text segment via text_block_tag %s, passing to text handler', $self->_text_block_tag()); | ||||
| 928 | 0 | 0 | 0 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 929 | 0 | 0 | $ret=$self->text($_[0]) | ||||
| 930 | } | ||||||
| 931 | elsif (!$_[0] && delete($self->{'_end_ignore'})) { | ||||||
| 932 | # In this case $_[0] is the actual text of the end tag from the document. If the parser is signalling and end of a tag | ||||||
| 933 | # but $_[0] is empty it means it is an implicit close. We might want to ignore it, especially if it is triggered by a | ||||||
| 934 | # type tag. |
||||||
| 935 | 0 | 0 | 0 && debug("attempt to close tag: $tag with active _div_stack, ignoring"); | ||||
| 936 | 0 | 0 | $ret=undef; | ||||
| 937 | } | ||||||
| 938 | else { | ||||||
| 939 | 149 | 199 | 0 && debug("normal tag end: $tag, %s", $self->pos()->tag()); | ||||
| 940 | 149 | 100 | 552 | $self->pos()->{'_line_no_tag_end'}=$self->{'_line_no'} if (ref($self->pos()) eq 'HTML::Element'); | |||
| 941 | 149 | 2644 | $ret=$self->SUPER::end($tag, @_) | ||||
| 942 | } | ||||||
| 943 | |||||||
| 944 | |||||||
| 945 | # Done, return | ||||||
| 946 | # | ||||||
| 947 | 150 | 11152 | 0 && debug("end ret $ret"); | ||||
| 948 | 150 | 590 | return $ret; | ||||
| 949 | |||||||
| 950 | |||||||
| 951 | } | ||||||
| 952 | |||||||
| 953 | |||||||
| 954 | # Reminder to self. Keep this in, or implicit CGI tags will not be closed | ||||||
| 955 | # if text block follows implicit CGI tag immediately | ||||||
| 956 | # | ||||||
| 957 | sub text { | ||||||
| 958 | |||||||
| 959 | |||||||
| 960 | # get self ref, text we will process | ||||||
| 961 | # | ||||||
| 962 | 473 | 473 | 1 | 2959 | my ($self, $text)=@_; | ||
| 963 | 473 | 631 | 0 && debug('text *%s*, text_block_tag %s, pos: %s', $text, $self->_text_block_tag(), $self->{'_pos'}); | ||||
| 964 | |||||||
| 965 | |||||||
| 966 | # Are we chomping text ? | ||||||
| 967 | # | ||||||
| 968 | 473 | 50 | 1126 | if (delete $self->{'_chomp'}) { | |||
| 969 | |||||||
| 970 | # Yes. It's actually includes a "pre-chomp" as newline will be at start of the string | ||||||
| 971 | # | ||||||
| 972 | 0 | 0 | 0 && debug('chomp flag detected, chomping text'); | ||||
| 973 | 0 | 0 | $text=~s/^\n//; | ||||
| 974 | |||||||
| 975 | } | ||||||
| 976 | |||||||
| 977 | |||||||
| 978 | # Ignore empty text. UPDATE - don't ignore or you will mangle CR in sections, especially if they contain tags |
||||||
| 979 | # like in the section. Process and keep them inline. See also fact that trailing and leading CR's are |
||||||
| 980 | # converted to space characters by HTML::Parser as per convention. | ||||||
| 981 | # | ||||||
| 982 | # Leave this here as a reminder. | ||||||
| 983 | # | ||||||
| 984 | #return if ($text =~ /^\r?\n?$/); | ||||||
| 985 | |||||||
| 986 | |||||||
| 987 | # Are we in an inline perl block ? | ||||||
| 988 | # | ||||||
| 989 | #if ($self->_text_block_tag() eq 'perl') { | ||||||
| 990 | 473 | 100 | 66 | 834 | if (grep { $self->_text_block_tag() eq $_ } qw(perl htmx api json)) { | ||
| 1892 | 100 | 43010 | |||||
| 50 | |||||||
| 991 | |||||||
| 992 | |||||||
| 993 | # Yes. We have inline perl code, not text. Just add to perl attribute, which | ||||||
| 994 | # is treated specially when rendering | ||||||
| 995 | # | ||||||
| 996 | 50 | 77 | 0 && debug('in |
||||
| 997 | 50 | 1164 | my $html_perl_or=$self->_html_perl_or(); | ||||
| 998 | 50 | 144 | $html_perl_or->{'perl'}.=$text; | ||||
| 999 | 50 | 109 | $html_perl_or->{'_line_no_tag_end'}=$self->{'_line_no'}; | ||||
| 1000 | |||||||
| 1001 | |||||||
| 1002 | } | ||||||
| 1003 | |||||||
| 1004 | # Used to do this so __PERL__ block would only count if at end of file. | ||||||
| 1005 | #elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/) && !$self->{'_pos'}) { | ||||||
| 1006 | elsif (($text=~/^\W*__CODE__/ || $text=~/^\W*__PERL__/)) { | ||||||
| 1007 | |||||||
| 1008 | |||||||
| 1009 | # Close off any HTML | ||||||
| 1010 | # | ||||||
| 1011 | 16 | 50 | 72 | delete $self->{'_pos'} if $self->{'_pos'}; | |||
| 1012 | |||||||
| 1013 | |||||||
| 1014 | # Perl code fragment. Will be last thing we do, as __PERL__ must be at the | ||||||
| 1015 | # bottom of the file. | ||||||
| 1016 | # | ||||||
| 1017 | 16 | 26 | 0 && debug('found __PERL__ tag'); | ||||
| 1018 | 16 | 424 | $self->_text_block_tag('perl'); | ||||
| 1019 | 16 | 102 | $self->implicit(0); | ||||
| 1020 | |||||||
| 1021 | 16 | 343 | my $html_perl_or; | ||||
| 1022 | 16 | 71 | $self->push_content($self->_html_perl_or($html_perl_or=HTML::Element->new('perl', inline => 1))); | ||||
| 1023 | # Amended to stop autovivification | ||||||
| 1024 | # | ||||||
| 1025 | #debug('insert line_no: %s into object ref: %s', @{$self}{qw(_line_no _html_perl_or)}); | ||||||
| 1026 | 16 | 281 | 0 && debug('insert line_no: %s into object ref: %s', (map {$self->{$_}} qw(_line_no _html_perl_or))); | ||||
| 1027 | 16 | 44 | @{$html_perl_or}{qw(_line_no _line_no_tag_end)}=@{$self}{qw(_line_no _line_no)}; | ||||
| 16 | 42 | ||||||
| 16 | 45 | ||||||
| 1028 | 16 | 46 | $html_perl_or->{'_code'}++; | ||||
| 1029 | |||||||
| 1030 | |||||||
| 1031 | } | ||||||
| 1032 | elsif ($text=~/^\W*__END__/) { | ||||||
| 1033 | |||||||
| 1034 | |||||||
| 1035 | # End of file | ||||||
| 1036 | # | ||||||
| 1037 | 0 | 0 | 0 && debug('found __END__ tag, running eof'); | ||||
| 1038 | 0 | 0 | $self->eof(); | ||||
| 1039 | |||||||
| 1040 | } | ||||||
| 1041 | else { | ||||||
| 1042 | |||||||
| 1043 | # Normal text, process by parent class after handling any subst flags in code | ||||||
| 1044 | # | ||||||
| 1045 | 407 | 50 | 716 | if ($text=~/([\$!+\^*]+)\{([\$!+]?)(.*?)\2\}/s) { | |||
| 1046 | |||||||
| 1047 | # Meeds subst. Get rid of cr's at start and end of text after a sections |
||||||
| 1048 | # | ||||||
| 1049 | # Amend to stop autovivification | ||||||
| 1050 | # | ||||||
| 1051 | #debug("found subst tag line_no_start: %s, line_no: %s, text '$text', script_stack: %s, %s", @{$self}{qw(_line_no_start _line_no _script_stack)}, Dumper($self->{'_script_stack'})); | ||||||
| 1052 | 0 | 0 | 0 && debug("found subst tag line_no_start: %s, line_no: %s, text '$text', script_stack: %s, %s", (map {$self->{$_}} qw(_line_no_start _line_no _script_stack)), Dumper($self->{'_script_stack'})); | ||||
| 1053 | |||||||
| 1054 | #my @cr=($text=~/\n/g); | ||||||
| 1055 | #if (my $html_or=$self->{'_pos'}) { | ||||||
| 1056 | # debug("parent %s", $html_or->tag()); | ||||||
| 1057 | # if (($html_or->tag() eq 'perl') && !$html_or->attr('inline')) { | ||||||
| 1058 | # debug('hit !'); | ||||||
| 1059 | # | ||||||
| 1060 | # # Why did I comment this out ? | ||||||
| 1061 | # # | ||||||
| 1062 | # #$text=~s/^\n//; | ||||||
| 1063 | # #$text=~s/\n$//; | ||||||
| 1064 | # } | ||||||
| 1065 | #} | ||||||
| 1066 | |||||||
| 1067 | # If in |