File Coverage

blib/lib/HTML/DOM/_Element.pm
Criterion Covered Total %
statement 402 1002 40.1
branch 221 742 29.7
condition 113 410 27.5
subroutine 53 113 46.9
pod 0 81 0.0
total 789 2348 33.6


line stmt bran cond sub pod time code
1             # This is a fork of HTML::Element. Eventually the code may be merged.
2              
3             package HTML::DOM::_Element;
4              
5 28     28   86 use strict;
  28         26  
  28         542  
6 28     28   77 use Carp ();
  28         21  
  28         269  
7 28     28   10819 use HTML::Entities ();
  28         99064  
  28         654  
8 28     28   10570 use HTML::Tagset ();
  28         22375  
  28         606  
9 28     28   10876 use integer; # vroom vroom!
  28         216  
  28         105  
10              
11 28     28   677 use vars qw( $VERSION );
  28         28  
  28         1226  
12             $VERSION = 4.2;
13              
14             # This contorls encoding entities on output.
15             # When set entities won't be re-encoded.
16             # Defaulting off because parser defaults to unencoding entities
17             our $encoded_content = 0;
18              
19 28     28   88 use vars qw($html_uc $Debug $ID_COUNTER %list_type_to_sub);
  28         24  
  28         220527  
20              
21             $Debug = 0 unless defined $Debug;
22              
23 0     0 0 0 sub Version { $VERSION; }
24              
25             my $nillio = [];
26              
27             *HTML::DOM::_Element::emptyElement = \%HTML::Tagset::emptyElement; # legacy
28             *HTML::DOM::_Element::optionalEndTag = \%HTML::Tagset::optionalEndTag; # legacy
29             *HTML::DOM::_Element::linkElements = \%HTML::Tagset::linkElements; # legacy
30             *HTML::DOM::_Element::boolean_attr = \%HTML::Tagset::boolean_attr; # legacy
31             *HTML::DOM::_Element::canTighten = \%HTML::Tagset::canTighten; # legacy
32              
33             # Constants for signalling back to the traverser:
34             my $travsignal_package = __PACKAGE__ . '::_travsignal';
35             my ( $ABORT, $PRUNE, $PRUNE_SOFTLY, $OK, $PRUNE_UP )
36             = map { my $x = $_; bless \$x, $travsignal_package; }
37             qw(
38             ABORT PRUNE PRUNE_SOFTLY OK PRUNE_UP
39             );
40              
41             ## Comments from Father Chrysostomos RT #58880
42             ## The sole purpose for empty parentheses after a sub name is to make it
43             ## parse as a 0-ary (nihilary?) function. I.e., ABORT+1 should parse as
44             ## ABORT()+1, not ABORT(+1). The parentheses also tell perl that it can
45             ### be inlined.
46             ##Deparse is really useful for demonstrating this:
47             ##$ perl -MO=Deparse,-p -e 'sub ABORT {7} print ABORT+8'
48             # Vs
49             # perl -MO=Deparse,-p -e 'sub ABORT() {7} print ABORT+8'
50             #
51             # With the parentheses, it not only makes it parse as a term.
52             # It even resolves the constant at compile-time, making the code run faster.
53              
54             ## no critic
55 0     0 0 0 sub ABORT () {$ABORT}
56 0     0 0 0 sub PRUNE () {$PRUNE}
57 0     0 0 0 sub PRUNE_SOFTLY () {$PRUNE_SOFTLY}
58 0     0 0 0 sub OK () {$OK}
59 0     0 0 0 sub PRUNE_UP () {$PRUNE_UP}
60             ## use critic
61              
62             $html_uc = 0;
63              
64             # set to 1 if you want tag and attribute names from starttag and endtag
65             # to be uc'd
66              
67             # regexs for XML names
68             # http://www.w3.org/TR/2006/REC-xml11-20060816/NT-NameStartChar
69             my $START_CHAR
70             = qr/(?:\:|[A-Z]|_|[a-z]|[\x{C0}-\x{D6}]|[\x{D8}-\x{F6}]|[\x{F8}-\x{2FF}]|[\x{370}-\x{37D}]|[\x{37F}-\x{1FFF}]|[\x{200C}-\x{200D}]|[\x{2070}-\x{218F}]|[\x{2C00}-\x{2FEF}]|[\x{3001}-\x{D7FF}]|[\x{F900}-\x{FDCF}]|[\x{FDF0}-\x{FFFD}]|[\x{10000}-\x{EFFFF}])/;
71              
72             # http://www.w3.org/TR/2006/REC-xml11-20060816/#NT-NameChar
73             my $NAME_CHAR
74             = qr/(?:$START_CHAR|-|\.|[0-9]|\x{B7}|[\x{0300}-\x{036F}]|[\x{203F}-\x{2040}])/;
75              
76             # Elements that does not have corresponding end tags (i.e. are empty)
77              
78             #==========================================================================
79              
80             #
81             # An HTML::DOM::_Element is represented by blessed hash reference, much like
82             # Tree::DAG_Node objects. Key-names not starting with '_' are reserved
83             # for the SGML attributes of the element.
84             # The following special keys are used:
85             #
86             # '_tag': The tag name (i.e., the generic identifier)
87             # '_parent': A reference to the HTML::DOM::_Element above (when forming a tree)
88             # '_pos': The current position (a reference to a HTML::DOM::_Element) is
89             # where inserts will be placed (look at the insert_element
90             # method) If not set, the implicit value is the object itself.
91             # '_content': A ref to an array of nodes under this.
92             # It might not be set.
93             #
94             # Example: Gisle's photo is represented like this:
95             #
96             # bless {
97             # _tag => 'img',
98             # src => 'gisle.jpg',
99             # alt => "Gisle's photo",
100             # }, 'HTML::DOM::_Element';
101             #
102              
103             sub new {
104 2151     2151 0 1829 my $class = shift;
105 2151   33     5407 $class = ref($class) || $class;
106              
107 2151         1672 my $tag = shift;
108 2151 50 33     6171 Carp::croak("No tagname") unless defined $tag and length $tag;
109 2151 50       4065 Carp::croak "\"$tag\" isn't a good tag name!"
110             if $tag =~ m/[<>\/\x00-\x20]/; # minimal sanity, certainly!
111 2151         3356 my $self = bless { _tag => scalar( $class->_fold_case($tag) ) }, $class;
112 2151         1796 my ( $attr, $val );
113 2151         4896 while ( ( $attr, $val ) = splice( @_, 0, 2 ) ) {
114             ## RT #42209 why does this default to the attribute name and not remain unset or the empty string?
115 1161 100       1805 $val = $attr unless defined $val;
116 1161         1621 $self->{ $class->_fold_case($attr) } = $val;
117             }
118 2151 100       3108 if ( $tag eq 'html' ) {
119 162         269 $self->{'_pos'} = undef;
120             }
121 2151         4344 return $self;
122             }
123              
124             sub attr {
125 9893     9893 0 12514 my $self = shift;
126 9893         11219 my $attr = scalar( $self->_fold_case(shift) );
127 9893 100       11557 if (@_) { # set
128 1405 100       1765 if ( defined $_[0] ) {
129 1342         1344 my $old = $self->{$attr};
130 1342         1486 $self->{$attr} = $_[0];
131 1342         2014 return $old;
132             }
133             else { # delete, actually
134 63         143 return delete $self->{$attr};
135             }
136             }
137             else { # get
138 8488         17784 return $self->{$attr};
139             }
140             }
141              
142             sub tag {
143 8631     8631 0 5845 my $self = shift;
144 8631 100       8594 if (@_) { # set
145 1         3 $self->{'_tag'} = $self->_fold_case( $_[0] );
146             }
147             else { # get
148 8630         16853 $self->{'_tag'};
149             }
150             }
151              
152             sub parent {
153 5548     5548 0 3828 my $self = shift;
154 5548 100       6220 if (@_) { # set
155 7 0 33     17 Carp::croak "an element can't be made its own parent"
      33        
156             if defined $_[0] and ref $_[0] and $self eq $_[0]; # sanity
157 7         12 $self->{'_parent'} = $_[0];
158             }
159             else {
160 5541         7851 $self->{'_parent'}; # get
161             }
162             }
163              
164             sub content_list {
165             return wantarray
166 5529 100       15013 ? @{ shift->{'_content'} || return () }
167 5725 100   5725 0 6528 : scalar @{ shift->{'_content'} || return 0 };
  196 100       702  
168             }
169              
170             # a read-only method! can't say $h->content( [] )!
171             sub content {
172 0     0 0 0 return shift->{'_content'};
173             }
174              
175             sub content_array_ref {
176 23   100 23 0 111 return shift->{'_content'} ||= [];
177             }
178              
179             sub content_refs_list {
180 0 0   0 0 0 return \( @{ shift->{'_content'} || return () } );
  0         0  
181             }
182              
183             sub implicit {
184 97     97 0 148 return shift->attr( '_implicit', @_ );
185             }
186              
187             sub pos {
188 18     18 0 19 my $self = shift;
189 18         20 my $pos = $self->{'_pos'};
190 18 50       38 if (@_) { # set
191 0         0 my $parm = shift;
192 0 0 0     0 if ( defined $parm and $parm ne $self ) {
193 0         0 $self->{'_pos'} = $parm; # means that element
194             }
195             else {
196 0         0 $self->{'_pos'} = undef; # means $self
197             }
198             }
199 18 50       61 return $pos if defined($pos);
200 0         0 return $self;
201             }
202              
203             sub all_attr {
204 0     0 0 0 return %{ $_[0] };
  0         0  
205              
206             # Yes, trivial. But no other way for the user to do the same
207             # without breaking encapsulation.
208             # And if our object representation changes, this method's behavior
209             # should stay the same.
210             }
211              
212             sub all_attr_names {
213 0     0 0 0 return keys %{ $_[0] };
  0         0  
214             }
215              
216             sub all_external_attr {
217 0     0 0 0 my $self = $_[0];
218             return map( ( length($_) && substr( $_, 0, 1 ) eq '_' )
219             ? ()
220 0 0 0     0 : ( $_, $self->{$_} ),
221             keys %$self );
222             }
223              
224             sub all_external_attr_names {
225 43   66 43 0 35 return grep !( length($_) && substr( $_, 0, 1 ) eq '_' ), keys %{ $_[0] };
  43         612  
226             }
227              
228             sub id {
229 997 50   997 0 1006 if ( @_ == 1 ) {
    0          
230 997         1750 return $_[0]{'id'};
231             }
232             elsif ( @_ == 2 ) {
233 0 0       0 if ( defined $_[1] ) {
234 0         0 return $_[0]{'id'} = $_[1];
235             }
236             else {
237 0         0 return delete $_[0]{'id'};
238             }
239             }
240             else {
241 0         0 Carp::croak '$node->id can\'t take ' . scalar(@_) . ' parameters!';
242             }
243             }
244              
245             sub _gensym {
246 0 0   0   0 unless ( defined $ID_COUNTER ) {
247              
248             # start it out...
249 0         0 $ID_COUNTER = sprintf( '%04x', rand(0x1000) );
250 0         0 $ID_COUNTER =~ tr<0-9a-f>; # yes, skip letter "oh"
251 0         0 $ID_COUNTER .= '00000';
252             }
253 0         0 ++$ID_COUNTER;
254             }
255              
256             sub idf {
257 0     0 0 0 my $nparms = scalar @_;
258              
259 0 0       0 if ( $nparms == 1 ) {
260 0         0 my $x;
261 0 0 0     0 if ( defined( $x = $_[0]{'id'} ) and length $x ) {
262 0         0 return $x;
263             }
264             else {
265 0         0 return $_[0]{'id'} = _gensym();
266             }
267             }
268 0 0       0 if ( $nparms == 2 ) {
269 0 0       0 if ( defined $_[1] ) {
270 0         0 return $_[0]{'id'} = $_[1];
271             }
272             else {
273 0         0 return delete $_[0]{'id'};
274             }
275             }
276 0         0 Carp::croak '$node->idf can\'t take ' . scalar(@_) . ' parameters!';
277             }
278              
279             sub push_content {
280 1694     1694 0 1222 my $self = shift;
281 1694 50       2274 return $self unless @_;
282              
283 1694   100     3704 my $content = ( $self->{'_content'} ||= [] );
284 1694         2308 for (@_) {
285 1710 50       2952 if ( ref($_) eq 'ARRAY' ) {
    100          
286              
287             # magically call new_from_lol
288 0         0 push @$content, $self->new_from_lol($_);
289 0         0 $content->[-1]->{'_parent'} = $self;
290             }
291             elsif ( ref($_) ) { # insert an element
292 1163 100       1832 $_->detach if $_->{'_parent'};
293 1163         1154 $_->{'_parent'} = $self;
294 1163         1753 push( @$content, $_ );
295             }
296             else { # insert text segment
297 547 50 66     1342 if ( @$content && !ref $content->[-1] ) {
298              
299             # last content element is also text segment -- append
300 0         0 $content->[-1] .= $_;
301             }
302             else {
303 547         969 push( @$content, $_ );
304             }
305             }
306             }
307 1694         2260 return $self;
308             }
309              
310             sub unshift_content {
311 8     8 0 10 my $self = shift;
312 8 50       15 return $self unless @_;
313              
314 8   100     29 my $content = ( $self->{'_content'} ||= [] );
315 8         16 for ( reverse @_ ) { # so they get added in the order specified
316 8 50       25 if ( ref($_) eq 'ARRAY' ) {
    50          
317              
318             # magically call new_from_lol
319 0         0 unshift @$content, $self->new_from_lol($_);
320 0         0 $content->[0]->{'_parent'} = $self;
321             }
322             elsif ( ref $_ ) { # insert an element
323 8 100       18 $_->detach if $_->{'_parent'};
324 8         10 $_->{'_parent'} = $self;
325 8         18 unshift( @$content, $_ );
326             }
327             else { # insert text segment
328 0 0 0     0 if ( @$content && !ref $content->[0] ) {
329              
330             # last content element is also text segment -- prepend
331 0         0 $content->[0] = $_ . $content->[0];
332             }
333             else {
334 0         0 unshift( @$content, $_ );
335             }
336             }
337             }
338 8         9 return $self;
339             }
340              
341             # Cf. splice ARRAY,OFFSET,LENGTH,LIST
342              
343             sub splice_content {
344 561     561 0 659 my ( $self, $offset, $length, @to_add ) = @_;
345 561 50       867 Carp::croak "splice_content requires at least one argument"
346             if @_ < 2; # at least $h->splice_content($offset);
347 561 50       727 return $self unless @_;
348              
349 561   100     879 my $content = ( $self->{'_content'} ||= [] );
350              
351             # prep the list
352              
353 561         430 my @out;
354 561 50       716 if ( @_ > 2 ) { # self, offset, length, ...
355 561         644 foreach my $n (@to_add) {
356 563 50       1127 if ( ref($n) eq 'ARRAY' ) {
    50          
357 0         0 $n = $self->new_from_lol($n);
358 0         0 $n->{'_parent'} = $self;
359             }
360             elsif ( ref($n) ) {
361 563         793 $n->detach;
362 563         830 $n->{'_parent'} = $self;
363             }
364             }
365 561         1087 @out = splice @$content, $offset, $length, @to_add;
366             }
367             else { # self, offset
368 0         0 @out = splice @$content, $offset;
369             }
370 561         588 foreach my $n (@out) {
371 548 100       895 $n->{'_parent'} = undef if ref $n;
372             }
373 561         929 return @out;
374             }
375              
376             sub detach {
377 711     711 0 963 my $self = $_[0];
378 711 100       1171 return unless ( my $parent = $self->{'_parent'} );
379 120         134 $self->{'_parent'} = undef;
380 120   50     186 my $cohort = $parent->{'_content'} || return $parent;
381 120   66     143 @$cohort = grep { not( ref($_) and $_ eq $self ) } @$cohort;
  344         1153  
382              
383             # filter $self out, if parent has any evident content
384              
385 120         154 return $parent;
386             }
387              
388             sub detach_content {
389 116   100 116 0 210 my $c = $_[0]->{'_content'} || return (); # in case of no content
390 57         123 for (@$c) {
391 55 50       182 $_->{'_parent'} = undef if ref $_;
392             }
393 57         109 return splice @$c;
394             }
395              
396             sub replace_with {
397 41     41 0 49 my ( $self, @replacers ) = @_;
398             Carp::croak "the target node has no parent"
399 41 50       90 unless my ($parent) = $self->{'_parent'};
400              
401 41         43 my $parent_content = $parent->{'_content'};
402 41 50 33     142 Carp::croak "the target node's parent has no content!?"
403             unless $parent_content and @$parent_content;
404              
405 41         29 my $replacers_contains_self;
406 41         54 for (@replacers) {
407 65 50       215 if ( !ref $_ ) {
    100          
    50          
    50          
408              
409             # noop
410             }
411             elsif ( $_ eq $self ) {
412              
413             # noop, but check that it's there just once.
414 23 50       51 Carp::croak "Replacement list contains several copies of target!"
415             if $replacers_contains_self++;
416             }
417             elsif ( $_ eq $parent ) {
418 0         0 Carp::croak "Can't replace an item with its parent!";
419             }
420             elsif ( ref($_) eq 'ARRAY' ) {
421 0         0 $_ = $self->new_from_lol($_);
422 0         0 $_->{'_parent'} = $parent;
423             }
424             else {
425 42         77 $_->detach;
426 42         74 $_->{'_parent'} = $parent;
427              
428             # each of these are necessary
429             }
430             } # for @replacers
431 41 100 66     49 @$parent_content = map { ( ref($_) and $_ eq $self ) ? @replacers : $_ }
  77         310  
432             @$parent_content;
433              
434 41 100       72 $self->{'_parent'} = undef unless $replacers_contains_self;
435              
436             # if replacers does contain self, then the parent attribute is fine as-is
437              
438 41         62 return $self;
439             }
440              
441             sub preinsert {
442 13     13 0 13 my $self = shift;
443 13 50       22 return $self unless @_;
444 13         37 return $self->replace_with( @_, $self );
445             }
446              
447             sub postinsert {
448 10     10 0 10 my $self = shift;
449 10 50       17 return $self unless @_;
450 10         25 return $self->replace_with( $self, @_ );
451             }
452              
453             sub replace_with_content {
454 0     0 0 0 my $self = $_[0];
455             Carp::croak "the target node has no parent"
456 0 0       0 unless my ($parent) = $self->{'_parent'};
457              
458 0         0 my $parent_content = $parent->{'_content'};
459 0 0 0     0 Carp::croak "the target node's parent has no content!?"
460             unless $parent_content and @$parent_content;
461              
462 0   0     0 my $content_r = $self->{'_content'} || [];
463 0 0 0     0 @$parent_content = map { ( ref($_) and $_ eq $self ) ? @$content_r : $_ }
  0         0  
464             @$parent_content;
465              
466 0         0 $self->{'_parent'} = undef; # detach $self from its parent
467              
468             # Update parentage link, removing from $self's content list
469 0 0       0 for ( splice @$content_r ) { $_->{'_parent'} = $parent if ref $_ }
  0         0  
470              
471 0         0 return $self; # note: doesn't destroy it.
472             }
473              
474             sub delete_content {
475 46     46 0 44 for (
476             splice @{
477 46 100       117 delete( $_[0]->{'_content'} )
478              
479             # Deleting it here (while holding its value, for the moment)
480             # will keep calls to detach() from trying to uselessly filter
481             # the list (as they won't be able to see it once it's been
482             # deleted)
483             || return ( $_[0] ) # in case of no content
484             },
485             0
486              
487             # the splice is so we can null the array too, just in case
488             # something somewhere holds a ref to it
489             )
490             {
491 61 50       172 $_->delete if ref $_;
492             }
493 38         71 $_[0];
494             }
495              
496             # two handy aliases
497 0     0 0 0 sub destroy { shift->delete(@_) }
498 0     0 0 0 sub destroy_content { shift->delete_content(@_) }
499              
500             sub delete {
501 176     176 0 132 my $self = $_[0];
502             $self->delete_content # recurse down
503 176 100 100     286 if $self->{'_content'} && @{ $self->{'_content'} };
  20         88  
504              
505 176 100 66     291 $self->detach if $self->{'_parent'} and $self->{'_parent'}{'_content'};
506              
507             # not the typical case
508              
509 176         253 %$self = (); # null out the whole object on the way out
510 176         245 return;
511             }
512              
513             sub clone {
514              
515             #print "Cloning $_[0]\n";
516 322     322 0 199 my $it = shift;
517 322 50       417 Carp::croak "clone() can be called only as an object method"
518             unless ref $it;
519 322 50       414 Carp::croak "clone() takes no arguments" if @_;
520              
521 322         959 my $new = bless {%$it}, ref($it); # COPY!!! HOOBOY!
522 322         503 delete @$new{ '_content', '_parent', '_pos', '_head', '_body' };
523              
524             # clone any contents
525 322 100 66     516 if ( $it->{'_content'} and @{ $it->{'_content'} } ) {
  137         325  
526             $new->{'_content'}
527 137         103 = [ ref($it)->clone_list( @{ $it->{'_content'} } ) ];
  137         346  
528 137         121 for ( @{ $new->{'_content'} } ) {
  137         175  
529 247 50       422 $_->{'_parent'} = $new if ref $_;
530             }
531             }
532              
533 322         434 return $new;
534             }
535              
536             sub clone_list {
537 137 50   137 0 213 Carp::croak "clone_list can be called only as a class method"
538             if ref shift @_;
539              
540             # all that does is get me here
541             return map {
542 137 50       125 ref($_)
  247         620  
543             ? $_->clone # copy by method
544             : $_ # copy by evaluation
545             } @_;
546             }
547              
548             sub normalize_content {
549 0     0 0 0 my $start = $_[0];
550 0         0 my $c;
551             return
552 0 0 0     0 unless $c = $start->{'_content'} and ref $c and @$c; # nothing to do
      0        
553             # TODO: if we start having text elements, deal with catenating those too?
554 0         0 my @stretches = (undef); # start with a barrier
555              
556             # I suppose this could be rewritten to treat stretches as it goes, instead
557             # of at the end. But feh.
558              
559             # Scan:
560 0         0 for ( my $i = 0; $i < @$c; ++$i ) {
561 0 0 0     0 if ( defined $c->[$i] and ref $c->[$i] ) { # not a text segment
562 0 0       0 if ( $stretches[0] ) {
563              
564             # put in a barrier
565 0 0       0 if ( $stretches[0][1] == 1 ) {
566              
567             #print "Nixing stretch at ", $i-1, "\n";
568 0         0 undef $stretches[0]; # nix the previous one-node "stretch"
569             }
570             else {
571              
572             #print "End of stretch at ", $i-1, "\n";
573 0         0 unshift @stretches, undef;
574             }
575             }
576              
577             # else no need for a barrier
578             }
579             else { # text segment
580 0 0       0 $c->[$i] = '' unless defined $c->[$i];
581 0 0       0 if ( $stretches[0] ) {
582 0         0 ++$stretches[0][1]; # increase length
583             }
584             else {
585              
586             #print "New stretch at $i\n";
587 0         0 unshift @stretches, [ $i, 1 ]; # start and length
588             }
589             }
590             }
591              
592             # Now combine. Note that @stretches is in reverse order, so the indexes
593             # still make sense as we work our way thru (i.e., backwards thru $c).
594 0         0 foreach my $s (@stretches) {
595 0 0 0     0 if ( $s and $s->[1] > 1 ) {
596              
597             #print "Stretch at ", $s->[0], " for ", $s->[1], "\n";
598 0         0 $c->[ $s->[0] ]
599             .= join( '', splice( @$c, $s->[0] + 1, $s->[1] - 1 ) )
600              
601             # append the subsequent ones onto the first one.
602             }
603             }
604 0         0 return;
605             }
606              
607             sub delete_ignorable_whitespace {
608              
609             # This doesn't delete all sorts of whitespace that won't actually
610             # be used in rendering, tho -- that's up to the rendering application.
611             # For example:
612             #
613             # [some whitespace]
614             #
615             # The WS between the two elements /will/ get used by the renderer.
616             # But here:
617             #
618             # [some whitespace]
619             #
620             # the WS between them won't be rendered in any way, presumably.
621              
622             #my $Debug = 4;
623 0 0   0 0 0 die "delete_ignorable_whitespace can be called only as an object method"
624             unless ref $_[0];
625              
626 0 0       0 print "About to tighten up...\n" if $Debug > 2;
627 0         0 my (@to_do) = ( $_[0] ); # Start off.
628 0         0 my ( $i, $sibs, $ptag, $this ); # scratch for the loop...
629 0         0 while (@to_do) {
630 0 0 0     0 if ( ( $ptag = ( $this = shift @to_do )->{'_tag'} ) eq 'pre'
      0        
631             or $ptag eq 'textarea'
632             or $HTML::Tagset::isCDATA_Parent{$ptag} )
633             {
634              
635             # block the traversal under those
636 0 0       0 print "Blocking traversal under $ptag\n" if $Debug;
637 0         0 next;
638             }
639 0 0 0     0 next unless ( $sibs = $this->{'_content'} and @$sibs );
640 0         0 for ( $i = $#$sibs; $i >= 0; --$i ) { # work backwards thru the list
641 0 0       0 if ( ref $sibs->[$i] ) {
642 0         0 unshift @to_do, $sibs->[$i];
643              
644             # yes, this happens in pre order -- we're going backwards
645             # thru this sibling list. I doubt it actually matters, tho.
646 0         0 next;
647             }
648 0 0       0 next if $sibs->[$i] =~ m<[^\n\r\f\t ]>s; # it's /all/ whitespace
649              
650             print "Under $ptag whose canTighten ",
651 0 0       0 "value is ", 0 + $HTML::DOM::_Element::canTighten{$ptag}, ".\n"
652             if $Debug > 3;
653              
654             # It's all whitespace...
655              
656 0 0       0 if ( $i == 0 ) {
    0          
657 0 0       0 if ( @$sibs == 1 ) { # I'm an only child
658 0 0       0 next unless $HTML::DOM::_Element::canTighten{$ptag}; # parent
659             }
660             else { # I'm leftmost of many
661             # if either my parent or sib are eligible, I'm good.
662             next
663             unless $HTML::DOM::_Element::canTighten{$ptag} # parent
664             or (ref $sibs->[1]
665             and $HTML::DOM::_Element::canTighten{ $sibs->[1]
666 0 0 0     0 {'_tag'} } # right sib
      0        
667             );
668             }
669             }
670             elsif ( $i == $#$sibs ) { # I'm rightmost of many
671             # if either my parent or sib are eligible, I'm good.
672             next
673             unless $HTML::DOM::_Element::canTighten{$ptag} # parent
674             or (ref $sibs->[ $i - 1 ]
675             and $HTML::DOM::_Element::canTighten{ $sibs->[ $i - 1 ]
676 0 0 0     0 {'_tag'} } # left sib
      0        
677             );
678             }
679             else { # I'm the piggy in the middle
680             # My parent doesn't matter -- it all depends on my sibs
681             next
682 0 0 0     0 unless ref $sibs->[ $i - 1 ]
683             or ref $sibs->[ $i + 1 ];
684              
685             # if NEITHER sib is a node, quit
686              
687             next if
688              
689             # bailout condition: if BOTH are INeligible nodes
690             # (as opposed to being text, or being eligible nodes)
691             ref $sibs->[ $i - 1 ]
692             and ref $sibs->[ $i + 1 ]
693             and !$HTML::DOM::_Element::canTighten{ $sibs->[ $i - 1 ]
694             {'_tag'} } # left sib
695             and !$HTML::DOM::_Element::canTighten{ $sibs->[ $i + 1 ]
696 0 0 0     0 {'_tag'} } # right sib
      0        
      0        
697             ;
698             }
699              
700             # Unknown tags aren't in canTighten and so AREN'T subject to tightening
701              
702 0 0       0 print " delendum: child $i of $ptag\n" if $Debug > 3;
703 0         0 splice @$sibs, $i, 1;
704             }
705              
706             # end of the loop-over-children
707             }
708              
709             # end of the while loop.
710              
711 0         0 return;
712             }
713              
714             sub insert_element {
715 860     860 0 848 my ( $self, $tag, $implicit ) = @_;
716 860 50       1205 return $self->pos() unless $tag; # noop if nothing to insert
717              
718 860         655 my $e;
719 860 100       998 if ( ref $tag ) {
720 554         383 $e = $tag;
721 554         624 $tag = $e->tag;
722             }
723             else { # just a tag name -- so make the element
724 306         474 $e = $self->element_class->new($tag);
725 306 50       650 ++( $self->{'_element_count'} ) if exists $self->{'_element_count'};
726              
727             # undocumented. see TreeBuilder.
728             }
729              
730 860 100       1385 $e->{'_implicit'} = 1 if $implicit;
731              
732 860         732 my $pos = $self->{'_pos'};
733 860 100       1176 $pos = $self unless defined $pos;
734              
735 860         1819 $pos->push_content($e);
736              
737             $self->{'_pos'} = $pos = $e
738 860 50 66     1180 unless $self->_empty_element_map->{$tag} || $e->{'_empty_element'};
739              
740 860         1616 $pos;
741             }
742              
743             #==========================================================================
744             # Some things to override in XML::Element
745              
746             sub _empty_element_map {
747 1492     1492   3382 \%HTML::DOM::_Element::emptyElement;
748             }
749              
750             sub _fold_case_LC {
751 13870 100   13870   14704 if (wantarray) {
752 167         142 shift;
753 167         427 map lc($_), @_;
754             }
755             else {
756 13703         23323 return lc( $_[1] );
757             }
758             }
759              
760             sub _fold_case_NOT {
761 0 0   0   0 if (wantarray) {
762 0         0 shift;
763 0         0 @_;
764             }
765             else {
766 0         0 return $_[1];
767             }
768             }
769              
770             *_fold_case = \&_fold_case_LC;
771              
772             #==========================================================================
773              
774             sub dump {
775 0     0 0 0 my ( $self, $fh, $depth ) = @_;
776 0 0       0 $fh = *STDOUT{IO} unless defined $fh;
777 0 0       0 $depth = 0 unless defined $depth;
778             print $fh " " x $depth, $self->starttag, " \@", $self->address,
779 0 0       0 $self->{'_implicit'} ? " (IMPLICIT)\n" : "\n";
780 0         0 for ( @{ $self->{'_content'} } ) {
  0         0  
781 0 0       0 if ( ref $_ ) { # element
782 0         0 $_->dump( $fh, $depth + 1 ); # recurse
783             }
784             else { # text node
785 0         0 print $fh " " x ( $depth + 1 );
786 0 0 0     0 if ( length($_) > 65 or m<[\x00-\x1F]> ) {
787              
788             # it needs prettyin' up somehow or other
789 0 0       0 my $x
790             = ( length($_) <= 65 )
791             ? $_
792             : ( substr( $_, 0, 65 ) . '...' );
793 0         0 $x =~ s<([\x00-\x1F])>
794 0         0 <'\\x'.(unpack("H2",$1))>eg;
795 0         0 print $fh qq{"$x"\n};
796             }
797             else {
798 0         0 print $fh qq{"$_"\n};
799             }
800             }
801             }
802             }
803              
804             sub as_HTML {
805 77     77 0 82 my ( $self, $entities, $indent, $omissible_map ) = @_;
806              
807             #my $indent_on = defined($indent) && length($indent);
808 77         81 my @html = ();
809              
810 77   100     182 $omissible_map ||= \%HTML::DOM::_Element::optionalEndTag;
811 77         209 my $empty_element_map = $self->_empty_element_map;
812              
813 77         67 my $last_tag_tightenable = 0;
814 77         53 my $this_tag_tightenable = 0;
815 77         60 my $nonindentable_ancestors = 0; # count of nonindentible tags over us.
816              
817 77         58 my ( $tag, $node, $start, $depth ); # per-iteration scratch
818              
819 77 50 33     158 if ( defined($indent) && length($indent) ) {
820             $self->traverse(
821             sub {
822 0     0   0 ( $node, $start, $depth ) = @_;
823 0 0       0 if ( ref $node ) { # it's an element
824              
825             # detect bogus classes. RT #35948, #61673
826 0 0       0 $node->can('starttag')
827             or Carp::confess( "Object of class "
828             . ref($node)
829             . " cannot be processed by HTML::DOM::_Element" );
830              
831 0         0 $tag = $node->{'_tag'};
832              
833 0 0 0     0 if ($start) { # on the way in
    0          
834 0 0 0     0 if (( $this_tag_tightenable
      0        
835             = $HTML::DOM::_Element::canTighten{$tag}
836             )
837             and !$nonindentable_ancestors
838             and $last_tag_tightenable
839             )
840             {
841 0         0 push
842             @html,
843             "\n",
844             $indent x $depth,
845             $node->starttag($entities),
846             ;
847             }
848             else {
849 0         0 push( @html, $node->starttag($entities) );
850             }
851 0         0 $last_tag_tightenable = $this_tag_tightenable;
852              
853             ++$nonindentable_ancestors
854             if $tag eq 'pre'
855 0 0 0     0 or $HTML::Tagset::isCDATA_Parent{$tag};
856              
857             }
858             elsif (
859             not( $empty_element_map->{$tag}
860             or $omissible_map->{$tag} )
861             )
862             {
863              
864             # on the way out
865 0 0 0     0 if ( $tag eq 'pre'
866             or $HTML::Tagset::isCDATA_Parent{$tag} )
867             {
868 0         0 --$nonindentable_ancestors;
869             $last_tag_tightenable
870 0         0 = $HTML::DOM::_Element::canTighten{$tag};
871 0         0 push @html, $node->endtag;
872              
873             }
874             else { # general case
875 0 0 0     0 if (( $this_tag_tightenable
      0        
876             = $HTML::DOM::_Element::canTighten{$tag}
877             )
878             and !$nonindentable_ancestors
879             and $last_tag_tightenable
880             )
881             {
882 0         0 push
883             @html,
884             "\n",
885             $indent x $depth,
886             $node->endtag,
887             ;
888             }
889             else {
890 0         0 push @html, $node->endtag;
891             }
892 0         0 $last_tag_tightenable = $this_tag_tightenable;
893              
894             #print "$tag tightenable: $this_tag_tightenable\n";
895             }
896             }
897             }
898             else { # it's a text segment
899              
900 0         0 $last_tag_tightenable = 0; # I guess this is right
901             HTML::Entities::encode_entities( $node, $entities )
902              
903             # That does magic things if $entities is undef.
904             unless (
905             ( defined($entities) && !length($entities) )
906              
907             # If there's no entity to encode, don't call it
908 0 0 0     0 || $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} }
      0        
      0        
909              
910             # To keep from amp-escaping children of script et al.
911             # That doesn't deal with descendants; but then, CDATA
912             # parents shouldn't /have/ descendants other than a
913             # text children (or comments?)
914             || $encoded_content
915             );
916 0 0       0 if ($nonindentable_ancestors) {
917 0         0 push @html, $node; # say no go
918             }
919             else {
920 0 0       0 if ($last_tag_tightenable) {
921 0         0 $node =~ s<[\n\r\f\t ]+>< >s;
922              
923             #$node =~ s< $><>s;
924 0         0 $node =~ s<^ ><>s;
925 0         0 push
926             @html,
927             "\n",
928             $indent x $depth,
929             $node,
930              
931             #Text::Wrap::wrap($indent x $depth, $indent x $depth, "\n" . $node)
932             ;
933             }
934             else {
935 0         0 push
936             @html,
937             $node,
938              
939             #Text::Wrap::wrap('', $indent x $depth, $node)
940             ;
941             }
942             }
943             }
944 0         0 1; # keep traversing
945             }
946 0         0 ); # End of parms to traverse()
947             }
948             else { # no indenting -- much simpler code
949             $self->traverse(
950             sub {
951 398     398   461 ( $node, $start ) = @_;
952 398 100       507 if ( ref $node ) {
953              
954              
955 339         391 $tag = $node->{'_tag'};
956 339 100 33     699 if ($start) { # on the way in
    100          
957 176         376 push( @html, $node->starttag($entities) );
958             }
959             elsif (
960             not( $empty_element_map->{$tag}
961             or $omissible_map->{$tag} )
962             )
963             {
964              
965             # on the way out
966 162         327 push( @html, $node->endtag );
967             }
968             }
969             else {
970              
971             # simple text content
972             HTML::Entities::encode_entities( $node, $entities )
973              
974             # That does magic things if $entities is undef.
975             unless (
976             ( defined($entities) && !length($entities) )
977              
978             # If there's no entity to encode, don't call it
979 59 50 33     342 || $HTML::Tagset::isCDATA_Parent{ $_[3]{'_tag'} }
      33        
      33        
980              
981             # To keep from amp-escaping children of script et al.
982             # That doesn't deal with descendants; but then, CDATA
983             # parents shouldn't /have/ descendants other than a
984             # text children (or comments?)
985             || $encoded_content
986             );
987 59         457 push( @html, $node );
988             }
989 398         382 1; # keep traversing
990             }
991 77         357 ); # End of parms to traverse()
992             }
993              
994 77 50 66     400 if ( $self->{_store_declarations} && defined $self->{_decl} ) {
995 0         0 unshift @html, sprintf "\n", $self->{_decl}->{text};
996             }
997              
998 77         18513 return join( '', @html );
999             }
1000              
1001             sub as_text {
1002              
1003             # Yet another iteratively implemented traverser
1004 16     16 0 21 my ( $this, %options ) = @_;
1005 16   100     67 my $skip_dels = $options{'skip_dels'} || 0;
1006 16         21 my (@pile) = ($this);
1007 16         15 my $tag;
1008 16         19 my $text = '';
1009 16         35 while (@pile) {
1010 98 50       158 if ( !defined( $pile[0] ) ) { # undef!
    100          
1011             # no-op
1012             }
1013             elsif ( !ref( $pile[0] ) ) { # text bit! save it!
1014 46         75 $text .= shift @pile;
1015             }
1016             else { # it's a ref -- traverse under it
1017 51 50       131 unshift @pile, @{ $this->{'_content'} || $nillio }
1018 52 100 33     245 unless ( $tag = ( $this = shift @pile )->{'_tag'} ) eq 'style'
      100        
      33        
1019             or $tag eq 'script'
1020             or ( $skip_dels and $tag eq 'del' );
1021             }
1022             }
1023 16         127 return $text;
1024             }
1025              
1026             # extra_chars added for RT #26436
1027             sub as_trimmed_text {
1028 0     0 0 0 my ( $this, %options ) = @_;
1029 0         0 my $text = $this->as_text(%options);
1030 0   0     0 my $extra_chars = $options{'extra_chars'} || '';
1031              
1032 0         0 $text =~ s/[\n\r\f\t$extra_chars ]+$//s;
1033 0         0 $text =~ s/^[\n\r\f\t$extra_chars ]+//s;
1034 0         0 $text =~ s/[\n\r\f\t$extra_chars ]+/ /g;
1035 0         0 return $text;
1036             }
1037              
1038 0     0 0 0 sub as_text_trimmed { shift->as_trimmed_text(@_) } # alias, because I forget
1039              
1040             # TODO: make it wrap, if not indent?
1041              
1042             sub as_XML {
1043              
1044             # based an as_HTML
1045 0     0 0 0 my ($self) = @_;
1046              
1047             #my $indent_on = defined($indent) && length($indent);
1048 0         0 my @xml = ();
1049 0         0 my $empty_element_map = $self->_empty_element_map;
1050              
1051 0         0 my ( $tag, $node, $start ); # per-iteration scratch
1052             $self->traverse(
1053             sub {
1054 0     0   0 ( $node, $start ) = @_;
1055 0 0       0 if ( ref $node ) { # it's an element
1056 0         0 $tag = $node->{'_tag'};
1057 0 0       0 if ($start) { # on the way in
1058              
1059 0         0 foreach my $attr ( $node->all_attr_names() ) {
1060 0 0 0     0 Carp::croak(
1061             "$tag has an invalid attribute name '$attr'")
1062             unless ( $attr eq '/' || $self->_valid_name($attr) );
1063             }
1064              
1065 0 0 0     0 if ( $empty_element_map->{$tag}
1066 0 0       0 and !@{ $node->{'_content'} || $nillio } )
1067             {
1068 0         0 push( @xml, $node->starttag_XML( undef, 1 ) );
1069             }
1070             else {
1071 0         0 push( @xml, $node->starttag_XML(undef) );
1072             }
1073             }
1074             else { # on the way out
1075 0 0 0     0 unless ( $empty_element_map->{$tag}
1076 0 0       0 and !@{ $node->{'_content'} || $nillio } )
1077             {
1078 0         0 push( @xml, $node->endtag_XML() );
1079             } # otherwise it will have been an <... /> tag.
1080             }
1081             }
1082             else { # it's just text
1083 0         0 _xml_escape($node);
1084 0         0 push( @xml, $node );
1085             }
1086 0         0 1; # keep traversing
1087             }
1088 0         0 );
1089              
1090 0         0 join( '', @xml, "\n" );
1091             }
1092              
1093             sub _xml_escape {
1094              
1095             # DESTRUCTIVE (a.k.a. "in-place")
1096             # Five required escapes: http://www.w3.org/TR/2006/REC-xml11-20060816/#syntax
1097             # We allow & if it's part of a valid escape already: http://www.w3.org/TR/2006/REC-xml11-20060816/#sec-references
1098 0     0   0 foreach my $x (@_) {
1099              
1100             # In strings with no encoded entities all & should be encoded.
1101 0 0       0 if ($encoded_content) {
1102 0         0 $x
1103             =~ s/&(?! # An ampersand that isn't followed by...
1104             (\#\d+; | # A hash mark, digits and semicolon, or
1105             \#x[\da-f]+; | # A hash mark, "x", hex digits and semicolon, or
1106             $START_CHAR$NAME_CHAR+; ) # A valid unicode entity name and semicolon
1107             )/&/gx; # Needs to be escaped to amp
1108             }
1109             else {
1110 0         0 $x =~ s/&/&/g;
1111             }
1112              
1113             # simple character escapes
1114 0         0 $x =~ s/
1115 0         0 $x =~ s/>/>/g;
1116 0         0 $x =~ s/"/"/g;
1117 0         0 $x =~ s/'/'/g;
1118             }
1119 0         0 return;
1120             }
1121              
1122             # NOTES:
1123             #
1124             # It's been suggested that attribute names be made :-keywords:
1125             # (:_tag "img" :border 0 :src "pie.png" :usemap "#main.map")
1126             # However, it seems that Scheme has no such data type as :-keywords.
1127             # So, for the moment at least, I tend toward simplicity, uniformity,
1128             # and universality, where everything a string or a list.
1129              
1130             sub as_Lisp_form {
1131 0     0 0 0 my @out;
1132              
1133             my $sub;
1134 0         0 my $depth = 0;
1135 0         0 my ( @list, $val );
1136             $sub = sub { # Recursor
1137 0     0   0 my $self = $_[0];
1138 0         0 @list = ( '_tag', $self->{'_tag'} );
1139 0 0       0 @list = () unless defined $list[-1]; # unlikely
1140              
1141 0         0 for ( sort keys %$self ) { # predictable ordering
1142             next
1143 0 0 0     0 if $_ eq '_content'
      0        
      0        
1144             or $_ eq '_tag'
1145             or $_ eq '_parent'
1146             or $_ eq '/';
1147              
1148             # Leave the other private attributes, I guess.
1149             push @list, $_, $val
1150 0 0       0 if defined( $val = $self->{$_} ); # and !ref $val;
1151             }
1152              
1153 0         0 for (@list) {
1154              
1155             # octal-escape it
1156 0         0 s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
1157 0         0 eg;
1158 0         0 $_ = qq{"$_"};
1159             }
1160 0         0 push @out, ( ' ' x $depth ) . '(' . join ' ', splice @list;
1161 0 0       0 if ( @{ $self->{'_content'} || $nillio } ) {
  0 0       0  
1162 0         0 $out[-1] .= " \"_content\" (\n";
1163 0         0 ++$depth;
1164 0         0 foreach my $c ( @{ $self->{'_content'} } ) {
  0         0  
1165 0 0       0 if ( ref($c) ) {
1166              
1167             # an element -- recurse
1168 0         0 $sub->($c);
1169             }
1170             else {
1171              
1172             # a text segment -- stick it in and octal-escape it
1173 0         0 push @out, $c;
1174 0         0 $out[-1] =~ s<([^\x20\x21\x23\x27-\x5B\x5D-\x7E])>
1175 0         0 eg;
1176              
1177             # And quote and indent it.
1178 0         0 $out[-1] .= "\"\n";
1179 0         0 $out[-1] = ( ' ' x $depth ) . '"' . $out[-1];
1180             }
1181             }
1182 0         0 --$depth;
1183 0         0 substr( $out[-1], -1 )
1184             = "))\n"; # end of _content and of the element
1185             }
1186             else {
1187 0         0 $out[-1] .= ")\n";
1188             }
1189 0         0 return;
1190 0         0 };
1191              
1192 0         0 $sub->( $_[0] );
1193 0         0 undef $sub;
1194 0         0 return join '', @out;
1195             }
1196              
1197             sub format {
1198 0     0 0 0 my ( $self, $formatter ) = @_;
1199 0 0       0 unless ( defined $formatter ) {
1200 0         0 require HTML::FormatText;
1201 0         0 $formatter = HTML::FormatText->new();
1202             }
1203 0         0 $formatter->format($self);
1204             }
1205              
1206             sub starttag {
1207 172     172 0 147 my ( $self, $entities ) = @_;
1208              
1209 172         158 my $name = $self->{'_tag'};
1210              
1211 172 50       262 return $self->{'text'} if $name eq '~literal';
1212 172 50       226 return "{'text'} . ">" if $name eq '~declaration';
1213 172 50       225 return "{'text'} . ">" if $name eq '~pi';
1214              
1215 172 50       233 if ( $name eq '~comment' ) {
1216 0 0 0     0 if ( ref( $self->{'text'} || '' ) eq 'ARRAY' ) {
1217              
1218             # Does this ever get used? And is this right?
1219             return
1220             "
1221 0         0 . join( ' ', map( "--$_--", @{ $self->{'text'} } ) ) . ">";
  0         0  
1222             }
1223             else {
1224 0         0 return "";
1225             }
1226             }
1227              
1228 172 50       334 my $tag = $html_uc ? "<\U$name" : "<\L$name";
1229 172         123 my $val;
1230 172         512 for ( sort keys %$self ) { # predictable ordering
1231 668 100 66     2328 next if !length $_ or m/^_/s or $_ eq '/';
      66        
1232 14         17 $val = $self->{$_};
1233 14 50       28 next if !defined $val; # or ref $val;
1234 14 0 33     45 if ($_ eq $val && # if attribute is boolean, for this element
    50 0        
1235             exists( $HTML::DOM::_Element::boolean_attr{$name} )
1236             && (ref( $HTML::DOM::_Element::boolean_attr{$name} )
1237             ? $HTML::DOM::_Element::boolean_attr{$name}{$_}
1238             : $HTML::DOM::_Element::boolean_attr{$name} eq $_
1239             )
1240             )
1241             {
1242 0 0       0 $tag .= $html_uc ? " \U$_" : " \L$_";
1243             }
1244             else { # non-boolean attribute
1245              
1246 14 50 33     32 if ( ref $val eq 'HTML::DOM::_Element'
1247             and $val->{_tag} eq '~literal' )
1248             {
1249 0         0 $val = $val->{text};
1250             }
1251             else {
1252 14 50 33     66 HTML::Entities::encode_entities( $val, $entities )
      33        
1253             unless (
1254             defined($entities) && !length($entities)
1255             || $encoded_content
1256              
1257             );
1258             }
1259              
1260 14         113 $val = qq{"$val"};
1261 14 50       47 $tag .= $html_uc ? qq{ \U$_\E=$val} : qq{ \L$_\E=$val};
1262             }
1263             } # for keys
1264 172 100 100     274 if ( scalar $self->content_list == 0
1265             && $self->_empty_element_map->{ $self->tag } )
1266             {
1267 9         32 return $tag . " />";
1268             }
1269             else {
1270 163         401 return $tag . ">";
1271             }
1272             }
1273              
1274             sub starttag_XML {
1275 0     0 0 0 my ($self) = @_;
1276              
1277             # and a third parameter to signal emptiness?
1278              
1279 0         0 my $name = $self->{'_tag'};
1280              
1281 0 0       0 return $self->{'text'} if $name eq '~literal';
1282 0 0       0 return '{'text'} . '>' if $name eq '~declaration';
1283 0 0       0 return "{'text'} . "?>" if $name eq '~pi';
1284              
1285 0 0       0 if ( $name eq '~comment' ) {
1286 0 0 0     0 if ( ref( $self->{'text'} || '' ) eq 'ARRAY' ) {
1287              
1288             # Does this ever get used? And is this right?
1289 0         0 $name = join( ' ', @{ $self->{'text'} } );
  0         0  
1290             }
1291             else {
1292 0         0 $name = $self->{'text'};
1293             }
1294 0         0 $name =~ s/--/--/g; # can't have double --'s in XML comments
1295 0         0 return "";
1296             }
1297              
1298 0         0 my $tag = "<$name";
1299 0         0 my $val;
1300 0         0 for ( sort keys %$self ) { # predictable ordering
1301 0 0 0     0 next if !length $_ or m/^_/s or $_ eq '/';
      0        
1302              
1303             # Hm -- what to do if val is undef?
1304             # I suppose that shouldn't ever happen.
1305 0 0       0 next if !defined( $val = $self->{$_} ); # or ref $val;
1306 0         0 _xml_escape($val);
1307 0         0 $tag .= qq{ $_="$val"};
1308             }
1309 0 0       0 @_ == 3 ? "$tag />" : "$tag>";
1310             }
1311              
1312             sub endtag {
1313 162 50   162 0 417 $html_uc ? "{'_tag'}>" : "{'_tag'}>";
1314             }
1315              
1316             # TODO: document?
1317             sub endtag_XML {
1318 0     0 0 0 "{'_tag'}>";
1319             }
1320              
1321             #==========================================================================
1322             # This, ladies and germs, is an iterative implementation of a
1323             # recursive algorithm. DON'T TRY THIS AT HOME.
1324             # Basically, the algorithm says:
1325             #
1326             # To traverse:
1327             # 1: pre-order visit this node
1328             # 2: traverse any children of this node
1329             # 3: post-order visit this node, unless it's a text segment,
1330             # or a prototypically empty node (like "br", etc.)
1331             # Add to that the consideration of the callbacks' return values,
1332             # so you can block visitation of the children, or siblings, or
1333             # abort the whole excursion, etc.
1334             #
1335             # So, why all this hassle with making the code iterative?
1336             # It makes for real speed, because it eliminates the whole
1337             # hassle of Perl having to allocate scratch space for each
1338             # instance of the recursive sub. Since the algorithm
1339             # is basically simple (and not all recursive ones are!) and
1340             # has few necessary lexicals (basically just the current node's
1341             # content list, and the current position in it), it was relatively
1342             # straightforward to store that information not as the frame
1343             # of a sub, but as a stack, i.e., a simple Perl array (well, two
1344             # of them, actually: one for content-listrefs, one for indexes of
1345             # current position in each of those).
1346              
1347             my $NIL = [];
1348              
1349             sub traverse {
1350 476     476 0 500 my ( $start, $callback, $ignore_text ) = @_;
1351              
1352 476 50       815 Carp::croak "traverse can be called only as an object method"
1353             unless ref $start;
1354              
1355 476 50 33     1624 Carp::croak('must provide a callback for traverse()!')
1356             unless defined $callback and ref $callback;
1357              
1358             # Elementary type-checking:
1359 476         369 my ( $c_pre, $c_post );
1360 476 100       1275 if ( UNIVERSAL::isa( $callback, 'CODE' ) ) {
    50          
1361 77         79 $c_pre = $c_post = $callback;
1362             }
1363             elsif ( UNIVERSAL::isa( $callback, 'ARRAY' ) ) {
1364 399         454 ( $c_pre, $c_post ) = @$callback;
1365 399 50 33     1489 Carp::croak(
1366             "pre-order callback \"$c_pre\" is true but not a coderef!")
1367             if $c_pre and not UNIVERSAL::isa( $c_pre, 'CODE' );
1368 399 50 33     678 Carp::croak(
1369             "pre-order callback \"$c_post\" is true but not a coderef!")
1370             if $c_post and not UNIVERSAL::isa( $c_post, 'CODE' );
1371 399 50 33     741 return $start unless $c_pre or $c_post;
1372              
1373             # otherwise there'd be nothing to actually do!
1374             }
1375             else {
1376 0 0       0 Carp::croak("$callback is not a known kind of reference")
1377             unless ref($callback);
1378             }
1379              
1380 476         756 my $empty_element_map = $start->_empty_element_map;
1381              
1382 476         787 my (@C) = [$start]; # a stack containing lists of children
1383 476         507 my (@I) = (-1); # initial value must be -1 for each list
1384             # a stack of indexes to current position in corresponding lists in @C
1385             # In each of these, 0 is the active point
1386              
1387             # scratch:
1388 476         343 my ($rv, # return value of callback
1389             $this, # current node
1390             $content_r, # child list of $this
1391             );
1392              
1393             # THE BIG LOOP
1394 476         779 while (@C) {
1395              
1396             # Move to next item in this frame
1397 9241 100 66     12336 if ( !defined( $I[0] ) or ++$I[0] >= @{ $C[0] } ) {
  9241         18359  
1398              
1399             # We either went off the end of this list, or aborted the list
1400             # So call the post-order callback:
1401 4565 100 66     9451 if ( $c_post
      100        
      66        
      66        
      33        
      33        
1402             and defined $I[0]
1403             and @C > 1
1404              
1405             # to keep the next line from autovivifying
1406             and defined( $this = $C[1][ $I[1] ] ) # sanity, and
1407             # suppress callbacks on exiting the fictional top frame
1408             and ref($this) # sanity
1409             and not(
1410             $this->{'_empty_element'}
1411             || ( $empty_element_map->{ $this->{'_tag'} || '' }
1412             && !@{ $this->{'_content'} } ) # RT #49932
1413             ) # things that don't get post-order callbacks
1414             )
1415             {
1416 163         117 shift @I;
1417 163         116 shift @C;
1418              
1419             #print "Post! at depth", scalar(@I), "\n";
1420 163         222 $rv = $c_post->(
1421              
1422             #map $_, # copy to avoid any messiness
1423             $this, # 0: this
1424             0, # 1: startflag (0 for post-order call)
1425             @I - 1, # 2: depth
1426             );
1427              
1428 163 50 33     524 if ( defined($rv) and ref($rv) eq $travsignal_package ) {
1429 0         0 $rv = $$rv; #deref
1430 0 0       0 if ( $rv eq 'ABORT' ) {
    0          
    0          
    0          
    0          
1431 0         0 last; # end of this excursion!
1432             }
1433             elsif ( $rv eq 'PRUNE' ) {
1434              
1435             # NOOP on post!!
1436             }
1437             elsif ( $rv eq 'PRUNE_SOFTLY' ) {
1438              
1439             # NOOP on post!!
1440             }
1441             elsif ( $rv eq 'OK' ) {
1442              
1443             # noop
1444             }
1445             elsif ( $rv eq 'PRUNE_UP' ) {
1446 0         0 $I[0] = undef;
1447             }
1448             else {
1449 0         0 die "Unknown travsignal $rv\n";
1450              
1451             # should never happen
1452             }
1453             }
1454             }
1455             else {
1456 4402         2830 shift @I;
1457 4402         3008 shift @C;
1458             }
1459 4565         6353 next;
1460             }
1461              
1462 4676         4042 $this = $C[0][ $I[0] ];
1463              
1464 4676 50       5339 if ($c_pre) {
1465 4676 100 66     10955 if ( defined $this and ref $this ) { # element
1466 4617         5329 $rv = $c_pre->(
1467              
1468             #map $_, # copy to avoid any messiness
1469             $this, # 0: this
1470             1, # 1: startflag (1 for pre-order call)
1471             @I - 1, # 2: depth
1472             );
1473             }
1474             else { # text segment
1475 59 50       71 next if $ignore_text;
1476 59         98 $rv = $c_pre->(
1477              
1478             #map $_, # copy to avoid any messiness
1479             $this, # 0: this
1480             1, # 1: startflag (1 for pre-order call)
1481             @I - 1, # 2: depth
1482             $C[1][ $I[1] ], # 3: parent
1483             # And there will always be a $C[1], since
1484             # we can't start traversing at a text node
1485             $I[0] # 4: index of self in parent's content list
1486             );
1487             }
1488 4676 50       8457 if ( not $rv ) { # returned false. Same as PRUNE.
    50          
1489 0         0 next; # prune
1490             }
1491             elsif ( ref($rv) eq $travsignal_package ) {
1492 0         0 $rv = $$rv; # deref
1493 0 0       0 if ( $rv eq 'ABORT' ) {
    0          
    0          
    0          
    0          
1494 0         0 last; # end of this excursion!
1495             }
1496             elsif ( $rv eq 'PRUNE' ) {
1497 0         0 next;
1498             }
1499             elsif ( $rv eq 'PRUNE_SOFTLY' ) {
1500 0 0 0     0 if (ref($this)
      0        
1501             and not( $this->{'_empty_element'}
1502             || $empty_element_map->{ $this->{'_tag'} || '' } )
1503             )
1504             {
1505              
1506             # push a dummy empty content list just to trigger a post callback
1507 0         0 unshift @I, -1;
1508 0         0 unshift @C, $NIL;
1509             }
1510 0         0 next;
1511             }
1512             elsif ( $rv eq 'OK' ) {
1513              
1514             # noop
1515             }
1516             elsif ( $rv eq 'PRUNE_UP' ) {
1517 0         0 $I[0] = undef;
1518 0         0 next;
1519              
1520             # equivalent of last'ing out of the current child list.
1521              
1522             # Used to have PRUNE_UP_SOFTLY and ABORT_SOFTLY here, but the code
1523             # for these was seriously upsetting, served no particularly clear
1524             # purpose, and could not, I think, be easily implemented with a
1525             # recursive routine. All bad things!
1526             }
1527             else {
1528 0         0 die "Unknown travsignal $rv\n";
1529              
1530             # should never happen
1531             }
1532             }
1533              
1534             # else fall thru to meaning same as \'OK'.
1535             }
1536              
1537             # end of pre-order calling
1538              
1539             # Now queue up content list for the current element...
1540 4676 100 66     25685 if (ref $this
      100        
1541             and not( # ...except for those which...
1542             not( $content_r = $this->{'_content'} and @$content_r )
1543              
1544             # ...have empty content lists...
1545             and $this->{'_empty_element'}
1546             || $empty_element_map->{ $this->{'_tag'} || '' }
1547              
1548             # ...and that don't get post-order callbacks
1549             )
1550             )
1551             {
1552 4089         3745 unshift @I, -1;
1553 4089   66     10487 unshift @C, $content_r || $NIL;
1554              
1555             #print $this->{'_tag'}, " ($this) adds content_r ", $C[0], "\n";
1556             }
1557             }
1558 476         662 return $start;
1559             }
1560              
1561             sub is_inside {
1562 1421     1421 0 1152 my $self = shift;
1563 1421 50       2111 return unless @_; # if no items specified, I guess this is right.
1564              
1565 1421         1001 my $current = $self;
1566              
1567             # the loop starts by looking at the given element
1568 1421   66     4410 while ( defined $current and ref $current ) {
1569 3962         3871 for (@_) {
1570 6246 100       6590 if (ref) { # element
1571 1027 100       2533 return 1 if $_ eq $current;
1572             }
1573             else { # tag name
1574 5219 100       8263 return 1 if $_ eq $current->{'_tag'};
1575             }
1576             }
1577 3780         8717 $current = $current->{'_parent'};
1578             }
1579 1239         3173 0;
1580             }
1581              
1582             sub is_empty {
1583 0     0 0 0 my $self = shift;
1584 0   0     0 !$self->{'_content'} || !@{ $self->{'_content'} };
1585             }
1586              
1587             sub pindex {
1588 65     65 0 43 my $self = shift;
1589              
1590 65   100     110 my $parent = $self->{'_parent'} || return;
1591 43   50     56 my $pc = $parent->{'_content'} || return;
1592 43         68 for ( my $i = 0; $i < @$pc; ++$i ) {
1593 69 100 66     309 return $i if ref $pc->[$i] and $pc->[$i] eq $self;
1594             }
1595 0         0 return; # we shouldn't ever get here
1596             }
1597              
1598             #--------------------------------------------------------------------------
1599              
1600             sub left {
1601 2 50   2 0 5 Carp::croak "left() is supposed to be an object method"
1602             unless ref $_[0];
1603 2   50     8 my $pc = ( $_[0]->{'_parent'} || return )->{'_content'}
1604             || die "parent is childless?";
1605              
1606 1 50       2 die "parent is childless" unless @$pc;
1607 1 50       3 return if @$pc == 1; # I'm an only child
1608              
1609 1 50       2 if (wantarray) {
1610 0         0 my @out;
1611 0         0 foreach my $j (@$pc) {
1612 0 0 0     0 return @out if ref $j and $j eq $_[0];
1613 0         0 push @out, $j;
1614             }
1615             }
1616             else {
1617 1         3 for ( my $i = 0; $i < @$pc; ++$i ) {
1618 2 50 66     13 return $i ? $pc->[ $i - 1 ] : undef
    100          
1619             if ref $pc->[$i] and $pc->[$i] eq $_[0];
1620             }
1621             }
1622              
1623 0         0 die "I'm not in my parent's content list?";
1624 0         0 return;
1625             }
1626              
1627             sub right {
1628 14 50   14 0 19 Carp::croak "right() is supposed to be an object method"
1629             unless ref $_[0];
1630 14   50     29 my $pc = ( $_[0]->{'_parent'} || return )->{'_content'}
1631             || die "parent is childless?";
1632              
1633 8 50       11 die "parent is childless" unless @$pc;
1634 8 100       12 return if @$pc == 1; # I'm an only child
1635              
1636 7 50       7 if (wantarray) {
1637 0         0 my ( @out, $seen );
1638 0         0 foreach my $j (@$pc) {
1639 0 0       0 if ($seen) {
1640 0         0 push @out, $j;
1641             }
1642             else {
1643 0 0 0     0 $seen = 1 if ref $j and $j eq $_[0];
1644             }
1645             }
1646 0 0       0 die "I'm not in my parent's content list?" unless $seen;
1647 0         0 return @out;
1648             }
1649             else {
1650 7         11 for ( my $i = 0; $i < @$pc; ++$i ) {
1651 7 50 33     38 return +( $i == $#$pc ) ? undef : $pc->[ $i + 1 ]
    50          
1652             if ref $pc->[$i] and $pc->[$i] eq $_[0];
1653             }
1654 0         0 die "I'm not in my parent's content list?";
1655 0         0 return;
1656             }
1657             }
1658              
1659             #--------------------------------------------------------------------------
1660              
1661             sub address {
1662 33 100   33 0 49 if ( @_ == 1 ) { # report-address form
1663 22   100     36 return join(
1664             '.',
1665             reverse( # so it starts at the top
1666             map( $_->pindex() || '0', # so that root's undef -> '0'
1667             $_[0], # self and...
1668             $_[0]->lineage )
1669             )
1670             );
1671             }
1672             else { # get-node-at-address
1673 11         24 my @stack = split( /\./, $_[1] );
1674 11         7 my $here;
1675              
1676 11 50 33     33 if ( @stack and !length $stack[0] ) { # relative addressing
1677 0         0 $here = $_[0];
1678 0         0 shift @stack;
1679             }
1680             else { # absolute addressing
1681 11 50       24 return unless 0 == shift @stack; # to pop the initial 0-for-root
1682 11         19 $here = $_[0]->root;
1683             }
1684              
1685 11         24 while (@stack) {
1686             return
1687             unless $here->{'_content'}
1688 16 50 33     19 and @{ $here->{'_content'} } > $stack[0];
  16         34  
1689              
1690             # make sure the index isn't too high
1691 16         18 $here = $here->{'_content'}[ shift @stack ];
1692 16 50 66     52 return if @stack and not ref $here;
1693              
1694             # we hit a text node when we expected a non-terminal element node
1695             }
1696              
1697 11         45 return $here;
1698             }
1699             }
1700              
1701             sub depth {
1702 0     0 0 0 my $here = $_[0];
1703 0         0 my $depth = 0;
1704 0   0     0 while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
1705 0         0 ++$depth;
1706             }
1707 0         0 return $depth;
1708             }
1709              
1710             sub root {
1711 526     526 0 472 my $here = my $root = shift;
1712 526   66     1702 while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
1713 1713         3858 $root = $here;
1714             }
1715 526         981 return $root;
1716             }
1717              
1718             sub lineage {
1719 22     22 0 15 my $here = shift;
1720 22         17 my @lineage;
1721 22   66     77 while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
1722 43         86 push @lineage, $here;
1723             }
1724 22         56 return @lineage;
1725             }
1726              
1727             sub lineage_tag_names {
1728 0     0 0 0 my $here = my $start = shift;
1729 0         0 my @lineage_names;
1730 0   0     0 while ( defined( $here = $here->{'_parent'} ) and ref($here) ) {
1731 0         0 push @lineage_names, $here->{'_tag'};
1732             }
1733 0         0 return @lineage_names;
1734             }
1735              
1736 0     0 0 0 sub descendents { shift->descendants(@_) }
1737              
1738             sub descendants {
1739 399     399 0 334 my $start = shift;
1740 399 50       523 if (wantarray) {
1741 399         293 my @descendants;
1742             $start->traverse(
1743             [ # pre-order sub only
1744             sub {
1745 4441     4441   3616 push( @descendants, $_[0] );
1746 4441         3711 return 1;
1747             },
1748             undef # no post
1749 399         1628 ],
1750             1, # ignore text
1751             );
1752 399         822 shift @descendants; # so $self doesn't appear in the list
1753 399         1463 return @descendants;
1754             }
1755             else { # just returns a scalar
1756 0         0 my $descendants = -1; # to offset $self being counted
1757             $start->traverse(
1758             [ # pre-order sub only
1759             sub {
1760 0     0   0 ++$descendants;
1761 0         0 return 1;
1762             },
1763             undef # no post
1764 0         0 ],
1765             1, # ignore text
1766             );
1767 0         0 return $descendants;
1768             }
1769             }
1770              
1771 167     167 0 4007 sub find { shift->find_by_tag_name(@_) }
1772              
1773             # yup, a handy alias
1774              
1775             sub find_by_tag_name {
1776 167     167 0 253 my (@pile) = shift(@_); # start out the to-do stack for the traverser
1777 167 50       316 Carp::croak "find_by_tag_name can be called only as an object method"
1778             unless ref $pile[0];
1779 167 50       231 return () unless @_;
1780 167         253 my (@tags) = $pile[0]->_fold_case(@_);
1781 167         149 my ( @matching, $this, $this_tag );
1782 167         264 while (@pile) {
1783 1345         1419 $this_tag = ( $this = shift @pile )->{'_tag'};
1784 1345         1202 foreach my $t (@tags) {
1785 1429 100       1929 if ( $t eq $this_tag ) {
1786 274 100       293 if (wantarray) {
1787 235         177 push @matching, $this;
1788 235         208 last;
1789             }
1790             else {
1791 39         177 return $this;
1792             }
1793             }
1794             }
1795 1306 100       809 unshift @pile, grep ref($_), @{ $this->{'_content'} || next };
  1306         2969  
1796             }
1797 128 100       497 return @matching if wantarray;
1798 30         68 return;
1799             }
1800              
1801             sub find_by_attribute {
1802              
1803             # We could limit this to non-internal attributes, but hey.
1804 0     0 0 0 my ( $self, $attribute, $value ) = @_;
1805 0 0       0 Carp::croak "Attribute must be a defined value!"
1806             unless defined $attribute;
1807 0         0 $attribute = $self->_fold_case($attribute);
1808              
1809 0         0 my @matching;
1810 0         0 my $wantarray = wantarray;
1811 0         0 my $quit;
1812             $self->traverse(
1813             [ # pre-order only
1814             sub {
1815 0 0 0 0   0 if ( exists $_[0]{$attribute}
1816             and $_[0]{$attribute} eq $value )
1817             {
1818 0         0 push @matching, $_[0];
1819 0 0       0 return HTML::DOM::_Element::ABORT
1820             unless $wantarray; # only take the first
1821             }
1822 0         0 1; # keep traversing
1823             },
1824             undef # no post
1825 0         0 ],
1826             1, # yes, ignore text nodes.
1827             );
1828              
1829 0 0       0 if ($wantarray) {
1830 0         0 return @matching;
1831             }
1832             else {
1833 0 0       0 return unless @matching;
1834 0         0 return $matching[0];
1835             }
1836             }
1837              
1838             #--------------------------------------------------------------------------
1839              
1840             sub look_down {
1841 190 50   190 0 360 ref( $_[0] ) or Carp::croak "look_down works only as an object method";
1842              
1843 190         147 my @criteria;
1844 190         370 for ( my $i = 1; $i < @_; ) {
1845 347 50       455 Carp::croak "Can't use undef as an attribute name"
1846             unless defined $_[$i];
1847 347 100       607 if ( ref $_[$i] ) {
1848 18 50       28 Carp::croak "A " . ref( $_[$i] ) . " value is not a criterion"
1849             unless ref $_[$i] eq 'CODE';
1850 18         42 push @criteria, $_[ $i++ ];
1851             }
1852             else {
1853 329 50       471 Carp::croak "param list to look_down ends in a key!" if $i == $#_;
1854 329 100       454 push @criteria, [
    50          
1855             scalar( $_[0]->_fold_case( $_[$i] ) ),
1856             defined( $_[ $i + 1 ] )
1857             ? ( ( ref $_[ $i + 1 ] ? $_[ $i + 1 ] : lc( $_[ $i + 1 ] ) ),
1858             ref( $_[ $i + 1 ] )
1859             )
1860              
1861             # yes, leave that LC!
1862             : undef
1863             ];
1864 329         573 $i += 2;
1865             }
1866             }
1867 190 50       298 Carp::croak "No criteria?" unless @criteria;
1868              
1869 190         233 my (@pile) = ( $_[0] );
1870 190         134 my ( @matching, $val, $this );
1871             Node:
1872 190         320 while ( defined( $this = shift @pile ) ) {
1873              
1874             # Yet another traverser implemented with merely iterative code.
1875 1573         1478 foreach my $c (@criteria) {
1876 1585 100       1674 if ( ref($c) eq 'CODE' ) {
1877 177 100       229 next Node unless $c->($this); # jump to the continue block
1878             }
1879             else { # it's an attr-value pair
1880             next Node # jump to the continue block
1881             if # two values are unequal if:
1882 1408 100 33     5749 ( defined( $val = $this->{ $c->[0] } ) )
    100          
1883             ? ( !defined $c->[ 1
1884             ] # actual is def, critval is undef => fail
1885             # allow regex matching
1886             # allow regex matching
1887             or (
1888             $c->[2] eq 'Regexp'
1889             ? $val !~ $c->[1]
1890             : ( ref $val ne $c->[2]
1891              
1892             # have unequal ref values => fail
1893             or lc($val) ne lc( $c->[1] )
1894              
1895             # have unequal lc string values => fail
1896             )
1897             )
1898             )
1899             : ( defined $c->[1]
1900             ) # actual is undef, critval is def => fail
1901             }
1902             }
1903              
1904             # We make it this far only if all the criteria passed.
1905 77 100       133 return $this unless wantarray;
1906 67         66 push @matching, $this;
1907             }
1908             continue {
1909 1563 100       1184 unshift @pile, grep ref($_), @{ $this->{'_content'} || $nillio };
  1563         4609  
1910             }
1911 180 100       400 return @matching if wantarray;
1912 147         420 return;
1913             }
1914              
1915             sub look_up {
1916 168 50   168 0 261 ref( $_[0] ) or Carp::croak "look_up works only as an object method";
1917              
1918 168         135 my @criteria;
1919 168         311 for ( my $i = 1; $i < @_; ) {
1920 168 50       260 Carp::croak "Can't use undef as an attribute name"
1921             unless defined $_[$i];
1922 168 50       202 if ( ref $_[$i] ) {
1923 0 0       0 Carp::croak "A " . ref( $_[$i] ) . " value is not a criterion"
1924             unless ref $_[$i] eq 'CODE';
1925 0         0 push @criteria, $_[ $i++ ];
1926             }
1927             else {
1928 168 50       257 Carp::croak "param list to look_up ends in a key!" if $i == $#_;
1929 168 50       302 push @criteria, [
    50          
1930             scalar( $_[0]->_fold_case( $_[$i] ) ),
1931             defined( $_[ $i + 1 ] )
1932             ? ( ( ref $_[ $i + 1 ] ? $_[ $i + 1 ] : lc( $_[ $i + 1 ] ) ),
1933             ref( $_[ $i + 1 ] )
1934             )
1935             : undef # Yes, leave that LC!
1936             ];
1937 168         340 $i += 2;
1938             }
1939             }
1940 168 50       237 Carp::croak "No criteria?" unless @criteria;
1941              
1942 168         123 my ( @matching, $val );
1943 168         139 my $this = $_[0];
1944             Node:
1945 168         129 while (1) {
1946              
1947             # You'll notice that the code here is almost the same as for look_down.
1948 465         426 foreach my $c (@criteria) {
1949 465 50       549 if ( ref($c) eq 'CODE' ) {
1950 0 0       0 next Node unless $c->($this); # jump to the continue block
1951             }
1952             else { # it's an attr-value pair
1953             next Node # jump to the continue block
1954             if # two values are unequal if:
1955 465 50 33     2741 ( defined( $val = $this->{ $c->[0] } ) )
    100          
1956             ? ( !defined $c->[ 1
1957             ] # actual is def, critval is undef => fail
1958             or (
1959             $c->[2] eq 'Regexp'
1960             ? $val !~ $c->[1]
1961             : ( ref $val ne $c->[2]
1962              
1963             # have unequal ref values => fail
1964             or lc($val) ne $c->[1]
1965              
1966             # have unequal lc string values => fail
1967             )
1968             )
1969             )
1970             : ( defined $c->[1]
1971             ) # actual is undef, critval is def => fail
1972             }
1973             }
1974              
1975             # We make it this far only if all the criteria passed.
1976 134 100       423 return $this unless wantarray;
1977 29         31 push @matching, $this;
1978             }
1979             continue {
1980 360 100 66     1065 last unless defined( $this = $this->{'_parent'} ) and ref $this;
1981             }
1982              
1983 63 100       308 return @matching if wantarray;
1984 1         3 return;
1985             }
1986              
1987             #--------------------------------------------------------------------------
1988              
1989             sub attr_get_i {
1990 0 0   0 0 0 if ( @_ > 2 ) {
1991 0         0 my $self = shift;
1992 0 0       0 Carp::croak "No attribute names can be undef!"
1993             if grep !defined($_), @_;
1994 0         0 my @attributes = $self->_fold_case(@_);
1995 0 0       0 if (wantarray) {
1996 0         0 my @out;
1997 0         0 foreach my $x ( $self, $self->lineage ) {
1998             push @out,
1999 0 0       0 map { exists( $x->{$_} ) ? $x->{$_} : () } @attributes;
  0         0  
2000             }
2001 0         0 return @out;
2002             }
2003             else {
2004 0         0 foreach my $x ( $self, $self->lineage ) {
2005 0         0 foreach my $attribute (@attributes) {
2006             return $x->{$attribute}
2007 0 0       0 if exists $x->{$attribute}; # found
2008             }
2009             }
2010 0         0 return; # never found
2011             }
2012             }
2013             else {
2014              
2015             # Single-attribute search. Simpler, most common, so optimize
2016             # for the most common case
2017 0 0       0 Carp::croak "Attribute name must be a defined value!"
2018             unless defined $_[1];
2019 0         0 my $self = $_[0];
2020 0         0 my $attribute = $self->_fold_case( $_[1] );
2021 0 0       0 if (wantarray) { # list context
2022             return
2023 0 0       0 map { exists( $_->{$attribute} ) ? $_->{$attribute} : () }
  0         0  
2024             $self, $self->lineage;
2025             }
2026             else { # scalar context
2027 0         0 foreach my $x ( $self, $self->lineage ) {
2028 0 0       0 return $x->{$attribute} if exists $x->{$attribute}; # found
2029             }
2030 0         0 return; # never found
2031             }
2032             }
2033             }
2034              
2035             sub tagname_map {
2036 0     0 0 0 my (@pile) = $_[0]; # start out the to-do stack for the traverser
2037 0 0       0 Carp::croak "find_by_tag_name can be called only as an object method"
2038             unless ref $pile[0];
2039 0         0 my ( %map, $this_tag, $this );
2040 0         0 while (@pile) {
2041             $this_tag = ''
2042 0 0       0 unless defined( $this_tag = ( $this = shift @pile )->{'_tag'} )
2043             ; # dance around the strange case of having an undef tagname.
2044 0   0     0 push @{ $map{$this_tag} ||= [] }, $this; # add to map
  0         0  
2045             unshift @pile, grep ref($_),
2046 0 0       0 @{ $this->{'_content'} || next }; # traverse
  0         0  
2047             }
2048 0         0 return \%map;
2049             }
2050              
2051             sub extract_links {
2052 0     0 0 0 my $start = shift;
2053              
2054 0         0 my %wantType;
2055 0         0 @wantType{ $start->_fold_case(@_) } = (1) x @_; # if there were any
2056 0         0 my $wantType = scalar(@_);
2057              
2058 0         0 my @links;
2059              
2060             # TODO: add xml:link?
2061              
2062 0         0 my ( $link_attrs, $tag, $self, $val ); # scratch for each iteration
2063             $start->traverse(
2064             [ sub { # pre-order call only
2065 0     0   0 $self = $_[0];
2066              
2067 0         0 $tag = $self->{'_tag'};
2068             return 1
2069 0 0 0     0 if $wantType && !$wantType{$tag}; # if we're selective
2070              
2071 0 0       0 if (defined(
2072             $link_attrs = $HTML::DOM::_Element::linkElements{$tag}
2073             )
2074             )
2075             {
2076              
2077             # If this is a tag that has any link attributes,
2078             # look over possibly present link attributes,
2079             # saving the value, if found.
2080 0 0       0 for ( ref($link_attrs) ? @$link_attrs : $link_attrs ) {
2081 0 0       0 if ( defined( $val = $self->attr($_) ) ) {
2082 0         0 push( @links, [ $val, $self, $_, $tag ] );
2083             }
2084             }
2085             }
2086 0         0 1; # return true, so we keep recursing
2087             },
2088             undef
2089 0         0 ],
2090             1, # ignore text nodes
2091             );
2092 0         0 \@links;
2093             }
2094              
2095             sub simplify_pres {
2096 0     0 0 0 my $pre = 0;
2097              
2098 0         0 my $sub;
2099             my $line;
2100             $sub = sub {
2101 0 0   0   0 ++$pre if $_[0]->{'_tag'} eq 'pre';
2102 0 0       0 foreach my $it ( @{ $_[0]->{'_content'} || return } ) {
  0         0  
2103 0 0       0 if ( ref $it ) {
    0          
2104 0         0 $sub->($it); # recurse!
2105             }
2106             elsif ($pre) {
2107              
2108             #$it =~ s/(?:(?:\cm\cj*)|(?:\cj))/\n/g;
2109              
2110             $it = join "\n", map {
2111 0         0 ;
2112 0         0 $line = $_;
2113 0         0 while (
2114             $line
2115 0         0 =~ s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
2116              
2117             # Sort of adapted from Text::Tabs -- yes, it's hardwired-in that
2118             # tabs are at every EIGHTH column.
2119             )
2120             {
2121             }
2122 0         0 $line;
2123             }
2124             split /(?:(?:\cm\cj*)|(?:\cj))/, $it, -1;
2125             }
2126             }
2127 0 0       0 --$pre if $_[0]->{'_tag'} eq 'pre';
2128 0         0 return;
2129 0         0 };
2130 0         0 $sub->( $_[0] );
2131              
2132 0         0 undef $sub;
2133 0         0 return;
2134              
2135             }
2136              
2137             sub same_as {
2138 0 0   0 0 0 die 'same_as() takes only one argument: $h->same_as($i)' unless @_ == 2;
2139 0         0 my ( $h, $i ) = @_[ 0, 1 ];
2140 0 0       0 die "same_as() can be called only as an object method" unless ref $h;
2141              
2142 0 0 0     0 return 0 unless defined $i and ref $i;
2143              
2144             # An element can't be same_as anything but another element!
2145             # They needn't be of the same class, tho.
2146              
2147 0 0       0 return 1 if $h eq $i;
2148              
2149             # special (if rare) case: anything is the same as... itself!
2150              
2151             # assumes that no content lists in/under $h or $i contain subsequent
2152             # text segments, like: ['foo', ' bar']
2153              
2154             # compare attributes now.
2155             #print "Comparing tags of $h and $i...\n";
2156              
2157 0 0       0 return 0 unless $h->{'_tag'} eq $i->{'_tag'};
2158              
2159             # only significant attribute whose name starts with "_"
2160              
2161             #print "Comparing attributes of $h and $i...\n";
2162             # Compare attributes, but only the real ones.
2163             {
2164              
2165             # Bear in mind that the average element has very few attributes,
2166             # and that element names are rather short.
2167             # (Values are a different story.)
2168              
2169             # XXX I would think that /^[^_]/ would be faster, at least easier to read.
2170 0         0 my @keys_h
2171 0 0       0 = sort grep { length $_ and substr( $_, 0, 1 ) ne '_' } keys %$h;
  0         0  
2172             my @keys_i
2173 0 0       0 = sort grep { length $_ and substr( $_, 0, 1 ) ne '_' } keys %$i;
  0         0  
2174              
2175 0 0       0 return 0 unless @keys_h == @keys_i;
2176              
2177             # different number of real attributes? they're different.
2178 0         0 for ( my $x = 0; $x < @keys_h; ++$x ) {
2179             return 0
2180             unless $keys_h[$x] eq $keys_i[$x] and # same key name
2181 0 0 0     0 $h->{ $keys_h[$x] } eq $i->{ $keys_h[$x] }; # same value
2182             # Should this test for definedness on values?
2183             # People shouldn't be putting undef in attribute values, I think.
2184             }
2185             }
2186              
2187             #print "Comparing children of $h and $i...\n";
2188 0   0     0 my $hcl = $h->{'_content'} || [];
2189 0   0     0 my $icl = $i->{'_content'} || [];
2190              
2191 0 0       0 return 0 unless @$hcl == @$icl;
2192              
2193             # different numbers of children? they're different.
2194              
2195 0 0       0 if (@$hcl) {
2196              
2197             # compare each of the children:
2198 0         0 for ( my $x = 0; $x < @$hcl; ++$x ) {
2199 0 0       0 if ( ref $hcl->[$x] ) {
2200 0 0       0 return 0 unless ref( $icl->[$x] );
2201              
2202             # an element can't be the same as a text segment
2203             # Both elements:
2204 0 0       0 return 0 unless $hcl->[$x]->same_as( $icl->[$x] ); # RECURSE!
2205             }
2206             else {
2207 0 0       0 return 0 if ref( $icl->[$x] );
2208              
2209             # a text segment can't be the same as an element
2210             # Both text segments:
2211 0 0       0 return 0 unless $hcl->[$x] eq $icl->[$x];
2212             }
2213             }
2214             }
2215              
2216 0         0 return 1; # passed all the tests!
2217             }
2218              
2219             sub new_from_lol {
2220 0     0 0 0 my $class = shift;
2221 0   0     0 $class = ref($class) || $class;
2222              
2223             # calling as an object method is just the same as ref($h)->new_from_lol(...)
2224 0         0 my $lol = $_[1];
2225              
2226 0         0 my @ancestor_lols;
2227              
2228             # So we can make sure there's no cyclicities in this lol.
2229             # That would be perverse, but one never knows.
2230 0         0 my ( $sub, $k, $v, $node ); # last three are scratch values
2231             $sub = sub {
2232              
2233             #print "Building for $_[0]\n";
2234 0     0   0 my $lol = $_[0];
2235 0 0       0 return unless @$lol;
2236 0         0 my ( @attributes, @children );
2237 0 0       0 Carp::croak "Cyclicity detected in source LOL tree, around $lol?!?"
2238             if grep( $_ eq $lol, @ancestor_lols );
2239 0         0 push @ancestor_lols, $lol;
2240              
2241 0         0 my $tag_name = 'null';
2242              
2243             # Recursion in in here:
2244 0         0 for ( my $i = 0; $i < @$lol; ++$i ) { # Iterate over children
2245 0 0       0 if ( ref( $lol->[$i] ) eq 'ARRAY' )
    0          
    0          
    0          
2246             { # subtree: most common thing in loltree
2247 0         0 push @children, $sub->( $lol->[$i] );
2248             }
2249             elsif ( !ref( $lol->[$i] ) ) {
2250 0 0       0 if ( $i == 0 ) { # name
2251 0         0 $tag_name = $lol->[$i];
2252 0 0       0 Carp::croak "\"$tag_name\" isn't a good tag name!"
2253             if $tag_name =~ m/[<>\/\x00-\x20]/
2254             ; # minimal sanity, certainly!
2255             }
2256             else { # text segment child
2257 0         0 push @children, $lol->[$i];
2258             }
2259             }
2260             elsif ( ref( $lol->[$i] ) eq 'HASH' ) { # attribute hashref
2261 0         0 keys %{ $lol->[$i] }; # reset the each-counter, just in case
  0         0  
2262 0         0 while ( ( $k, $v ) = each %{ $lol->[$i] } ) {
  0         0  
2263 0 0 0     0 push @attributes, $class->_fold_case($k), $v
      0        
      0        
2264             if defined $v
2265             and $k ne '_name'
2266             and $k ne '_content'
2267             and $k ne '_parent';
2268              
2269             # enforce /some/ sanity!
2270             }
2271             }
2272             elsif ( UNIVERSAL::isa( $lol->[$i], __PACKAGE__ ) ) {
2273 0 0       0 if ( $lol->[$i]->{'_parent'} ) { # if claimed
2274             #print "About to clone ", $lol->[$i], "\n";
2275 0         0 push @children, $lol->[$i]->clone();
2276             }
2277             else {
2278 0         0 push @children, $lol->[$i]; # if unclaimed...
2279             #print "Claiming ", $lol->[$i], "\n";
2280 0         0 $lol->[$i]->{'_parent'} = 1; # claim it NOW
2281             # This WILL be replaced by the correct value once we actually
2282             # construct the parent, just after the end of this loop...
2283             }
2284             }
2285             else {
2286 0         0 Carp::croak "new_from_lol doesn't handle references of type "
2287             . ref( $lol->[$i] );
2288             }
2289             }
2290              
2291 0         0 pop @ancestor_lols;
2292 0         0 $node = $class->new($tag_name);
2293              
2294             #print "Children: @children\n";
2295              
2296 0 0       0 if ( $class eq __PACKAGE__ ) { # Special-case it, for speed:
2297 0 0       0 %$node = ( %$node, @attributes ) if @attributes;
2298              
2299             #print join(' ', $node, ' ' , map("<$_>", %$node), "\n");
2300 0 0       0 if (@children) {
2301 0         0 $node->{'_content'} = \@children;
2302 0         0 foreach my $c (@children) {
2303 0 0       0 $c->{'_parent'} = $node
2304             if ref $c;
2305             }
2306             }
2307             }
2308             else { # Do it the clean way...
2309             #print "Done neatly\n";
2310 0         0 while (@attributes) { $node->attr( splice @attributes, 0, 2 ) }
  0         0  
2311 0 0       0 $node->push_content( map { $_->{'_parent'} = $node if ref $_; $_ }
  0 0       0  
  0         0  
2312             @children )
2313             if @children;
2314             }
2315              
2316 0         0 return $node;
2317 0         0 };
2318              
2319             # End of sub definition.
2320              
2321 0 0       0 if (wantarray) {
2322 0 0       0 my (@nodes) = map { ; ( ref($_) eq 'ARRAY' ) ? $sub->($_) : $_ } @_;
  0         0  
2323              
2324             # Let text bits pass thru, I guess. This makes this act more like
2325             # unshift_content et al. Undocumented.
2326 0         0 undef $sub;
2327              
2328             # so it won't be in its own frame, so its refcount can hit 0
2329 0         0 return @nodes;
2330             }
2331             else {
2332 0 0       0 Carp::croak "new_from_lol in scalar context needs exactly one lol"
2333             unless @_ == 1;
2334 0 0       0 return $_[0] unless ref( $_[0] ) eq 'ARRAY';
2335              
2336             # used to be a fatal error. still undocumented tho.
2337 0         0 $node = $sub->( $_[0] );
2338 0         0 undef $sub;
2339              
2340             # so it won't be in its own frame, so its refcount can hit 0
2341 0         0 return $node;
2342             }
2343             }
2344              
2345             sub objectify_text {
2346 0     0 0 0 my (@stack) = ( $_[0] );
2347              
2348 0         0 my ($this);
2349 0         0 while (@stack) {
2350 0         0 foreach my $c ( @{ ( $this = shift @stack )->{'_content'} } ) {
  0         0  
2351 0 0       0 if ( ref($c) ) {
2352 0         0 unshift @stack, $c; # visit it later.
2353             }
2354             else {
2355 0         0 $c = $this->element_class->new(
2356             '~text',
2357             'text' => $c,
2358             '_parent' => $this
2359             );
2360             }
2361             }
2362             }
2363 0         0 return;
2364             }
2365              
2366             sub deobjectify_text {
2367 68     68 0 97 my (@stack) = ( $_[0] );
2368 68         92 my ($old_node);
2369              
2370 68 50       129 if ( $_[0]{'_tag'} eq '~text' ) { # special case
2371             # Puts the $old_node variable to a different purpose
2372 0 0       0 if ( $_[0]{'_parent'} ) {
2373 0         0 $_[0]->replace_with( $old_node = delete $_[0]{'text'} )->delete;
2374             }
2375             else { # well, that's that, then!
2376 0         0 $old_node = delete $_[0]{'text'};
2377             }
2378              
2379 0 0       0 if ( ref( $_[0] ) eq __PACKAGE__ ) { # common case
2380 0         0 %{ $_[0] } = (); # poof!
  0         0  
2381             }
2382             else {
2383              
2384             # play nice:
2385 0         0 delete $_[0]{'_parent'};
2386 0         0 $_[0]->delete;
2387             }
2388 0 0       0 return '' unless defined $old_node; # sanity!
2389 0         0 return $old_node;
2390             }
2391              
2392 68         101 while (@stack) {
2393 203         130 foreach my $c ( @{ ( shift @stack )->{'_content'} } ) {
  203         326  
2394 241 50       327 if ( ref($c) ) {
2395 241 100       308 if ( $c->{'_tag'} eq '~text' ) {
2396 106         114 $c = ( $old_node = $c )->{'text'};
2397 106 50       159 if ( ref($old_node) eq __PACKAGE__ ) { # common case
2398 0         0 %$old_node = (); # poof!
2399             }
2400             else {
2401              
2402             # play nice:
2403 106         100 delete $old_node->{'_parent'};
2404 106         137 $old_node->delete;
2405             }
2406             }
2407             else {
2408 135         207 unshift @stack, $c; # visit it later.
2409             }
2410             }
2411             }
2412             }
2413              
2414 68         125 return;
2415             }
2416              
2417             {
2418              
2419             # The next three subs are basically copied from Number::Latin,
2420             # based on a one-liner by Abigail. Yes, I could simply require that
2421             # module, and a Roman numeral module too, but really, HTML-Tree already
2422             # has enough dependecies as it is; and anyhow, I don't need the functions
2423             # that do latin2int or roman2int.
2424 28     28   157 no integer;
  28         33  
  28         99  
2425              
2426             sub _int2latin {
2427 0 0   0     return unless defined $_[0];
2428 0 0 0       return '0' if $_[0] < 1 and $_[0] > -1;
2429 0 0         return '-' . _i2l( abs int $_[0] )
2430             if $_[0] <= -1; # tolerate negatives
2431 0           return _i2l( int $_[0] );
2432             }
2433              
2434             sub _int2LATIN {
2435              
2436             # just the above plus uc
2437 0 0   0     return unless defined $_[0];
2438 0 0 0       return '0' if $_[0] < 1 and $_[0] > -1;
2439 0 0         return '-' . uc( _i2l( abs int $_[0] ) )
2440             if $_[0] <= -1; # tolerate negs
2441 0           return uc( _i2l( int $_[0] ) );
2442             }
2443              
2444             my @alpha = ( 'a' .. 'z' );
2445              
2446             sub _i2l { # the real work
2447 0   0 0     my $int = $_[0] || return "";
2448 0           _i2l( int( ( $int - 1 ) / 26 ) )
2449             . $alpha[ $int % 26 - 1 ]; # yes, recursive
2450             # Yes, 26 => is (26 % 26 - 1), which is -1 => Z!
2451             }
2452             }
2453              
2454             {
2455              
2456             # And now, some much less impressive Roman numerals code:
2457              
2458             my (@i) = ( '', qw(I II III IV V VI VII VIII IX) );
2459             my (@x) = ( '', qw(X XX XXX XL L LX LXX LXXX XC) );
2460             my (@c) = ( '', qw(C CC CCC CD D DC DCC DCCC CM) );
2461             my (@m) = ( '', qw(M MM MMM) );
2462              
2463             sub _int2ROMAN {
2464 0     0     my ( $i, $pref );
2465 0 0 0       return '0'
2466             if 0 == ( $i = int( $_[0] || 0 ) ); # zero is a special case
2467 0 0 0       return $i + 0 if $i <= -4000 or $i >= 4000;
2468              
2469             # Because over 3999 would require non-ASCII chars, like D-with-)-inside
2470 0 0         if ( $i < 0 ) { # grumble grumble tolerate negatives grumble
2471 0           $pref = '-';
2472 0           $i = abs($i);
2473             }
2474             else {
2475 0           $pref = ''; # normal case
2476             }
2477              
2478 0           my ( $x, $c, $m ) = ( 0, 0, 0 );
2479 0 0         if ( $i >= 10 ) {
2480 0           $x = $i / 10;
2481 0           $i %= 10;
2482 0 0         if ( $x >= 10 ) {
2483 0           $c = $x / 10;
2484 0           $x %= 10;
2485 0 0         if ( $c >= 10 ) { $m = $c / 10; $c %= 10; }
  0            
  0            
2486             }
2487             }
2488              
2489             #print "m$m c$c x$x i$i\n";
2490              
2491 0           return join( '', $pref, $m[$m], $c[$c], $x[$x], $i[$i] );
2492             }
2493              
2494 0     0     sub _int2roman { lc( _int2ROMAN( $_[0] ) ) }
2495             }
2496              
2497 0     0     sub _int2int { $_[0] } # dummy
2498              
2499             %list_type_to_sub = (
2500             'I' => \&_int2ROMAN,
2501             'i' => \&_int2roman,
2502             'A' => \&_int2LATIN,
2503             'a' => \&_int2latin,
2504             '1' => \&_int2int,
2505             );
2506              
2507             sub number_lists {
2508 0     0 0   my (@stack) = ( $_[0] );
2509 0           my ( $this, $tag, $counter, $numberer ); # scratch
2510 0           while (@stack) { # yup, pre-order-traverser idiom
2511 0 0 0       if ( ( $tag = ( $this = shift @stack )->{'_tag'} ) eq 'ol' ) {
    0 0        
2512              
2513             # Prep some things:
2514             $counter
2515 0 0 0       = ( ( $this->{'start'} || '' ) =~ m<^\s*(\d{1,7})\s*$>s )
2516             ? $1
2517             : 1;
2518             $numberer = $list_type_to_sub{ $this->{'type'} || '' }
2519 0   0       || $list_type_to_sub{'1'};
2520              
2521             # Immeditately iterate over all children
2522 0 0         foreach my $c ( @{ $this->{'_content'} || next } ) {
  0            
2523 0 0         next unless ref $c;
2524 0           unshift @stack, $c;
2525 0 0         if ( $c->{'_tag'} eq 'li' ) {
2526             $counter = $1
2527             if (
2528 0 0 0       ( $c->{'value'} || '' ) =~ m<^\s*(\d{1,7})\s*$>s );
2529 0           $c->{'_bullet'} = $numberer->($counter) . '.';
2530 0           ++$counter;
2531             }
2532             }
2533              
2534             }
2535             elsif ( $tag eq 'ul' or $tag eq 'dir' or $tag eq 'menu' ) {
2536              
2537             # Immeditately iterate over all children
2538 0 0         foreach my $c ( @{ $this->{'_content'} || next } ) {
  0            
2539 0 0         next unless ref $c;
2540 0           unshift @stack, $c;
2541 0 0         $c->{'_bullet'} = '*' if $c->{'_tag'} eq 'li';
2542             }
2543              
2544             }
2545             else {
2546 0 0         foreach my $c ( @{ $this->{'_content'} || next } ) {
  0            
2547 0 0         unshift @stack, $c if ref $c;
2548             }
2549             }
2550             }
2551 0           return;
2552             }
2553              
2554             sub has_insane_linkage {
2555 0     0 0   my @pile = ( $_[0] );
2556 0           my ( $c, $i, $p, $this ); # scratch
2557              
2558             # Another iterative traverser; this time much simpler because
2559             # only in pre-order:
2560 0           my %parent_of = ( $_[0], 'TOP-OF-SCAN' );
2561 0           while (@pile) {
2562 0           $this = shift @pile;
2563 0   0       $c = $this->{'_content'} || next;
2564 0 0         return ( $this, "_content attribute is true but nonref." )
2565             unless ref($c) eq 'ARRAY';
2566 0 0         next unless @$c;
2567 0           for ( $i = 0; $i < @$c; ++$i ) {
2568 0 0         return ( $this, "Child $i is undef" )
2569             unless defined $c->[$i];
2570 0 0         if ( ref( $c->[$i] ) ) {
2571 0 0         return ( $c->[$i], "appears in its own content list" )
2572             if $c->[$i] eq $this;
2573             return ( $c->[$i],
2574             "appears twice in the tree: once under $this, once under $parent_of{$c->[$i]}"
2575 0 0         ) if exists $parent_of{ $c->[$i] };
2576 0           $parent_of{ $c->[$i] } = '' . $this;
2577              
2578             # might as well just use the stringification of it.
2579              
2580             return ( $c->[$i],
2581             "_parent attribute is wrong (not defined)" )
2582 0 0         unless defined( $p = $c->[$i]{'_parent'} );
2583 0 0         return ( $c->[$i], "_parent attribute is wrong (nonref)" )
2584             unless ref($p);
2585 0 0         return ( $c->[$i],
2586             "_parent attribute is wrong (is $p; should be $this)" )
2587             unless $p eq $this;
2588             }
2589             }
2590 0           unshift @pile, grep ref($_), @$c;
2591              
2592             # queue up more things on the pile stack
2593             }
2594 0           return; #okay
2595             }
2596              
2597             sub _asserts_fail { # to be run on trusted documents only
2598 0     0     my (@pile) = ( $_[0] );
2599 0           my ( @errors, $this, $id, $assert, $parent, $rv );
2600 0           while (@pile) {
2601 0           $this = shift @pile;
2602 0 0         if ( defined( $assert = $this->{'assert'} ) ) {
2603 0   0       $id = ( $this->{'id'} ||= $this->address )
2604             ; # don't use '0' as an ID, okay?
2605 0 0         unless ( ref($assert) ) {
2606              
2607             package main;
2608             ## no critic
2609 0 0         $assert = $this->{'assert'} = (
2610             $assert =~ m/\bsub\b/
2611             ? eval($assert)
2612             : eval("sub { $assert\n}")
2613             );
2614             ## use critic
2615 0 0         if ($@) {
2616 0           push @errors,
2617             [ $this, "assertion at $id broke in eval: $@" ];
2618 0     0     $assert = $this->{'assert'} = sub { };
2619             }
2620             }
2621 0           $parent = $this->{'_parent'};
2622 0           $rv = undef;
2623 0           eval {
2624             $rv = $assert->(
2625             $this, $this->{'_tag'}, $this->{'_id'}, # 0,1,2
2626             $parent
2627 0 0         ? ( $parent, $parent->{'_tag'}, $parent->{'id'} )
2628             : () # 3,4,5
2629             );
2630             };
2631 0 0         if ($@) {
    0          
2632 0           push @errors, [ $this, "assertion at $id died: $@" ];
2633             }
2634             elsif ( !$rv ) {
2635 0           push @errors, [ $this, "assertion at $id failed" ];
2636             }
2637              
2638             # else OK
2639             }
2640 0 0         push @pile, grep ref($_), @{ $this->{'_content'} || next };
  0            
2641             }
2642 0           return @errors;
2643             }
2644              
2645             ## _valid_name
2646             # validate XML style attribute names
2647             # http://www.w3.org/TR/2006/REC-xml11-20060816/#NT-Name
2648              
2649             sub _valid_name {
2650 0     0     my $self = shift;
2651 0 0         my $attr = shift
2652             or Carp::croak("sub valid_name requires an attribute name");
2653              
2654 0 0         return (0) unless ( $attr =~ /^$START_CHAR$NAME_CHAR+$/ );
2655              
2656 0           return (1);
2657             }
2658              
2659             sub element_class {
2660 0 0   0 0   $_[0]->{_element_class} || __PACKAGE__;
2661             }
2662              
2663             1;
2664              
2665             1;