1package HTML::ElementSuper; 2 3# Extend the HTML::Element class to allow the following: 4# positional reporting 5# content replacement 6# masking (i.e., in the structure but invisible to traverse) 7# content wrapping 8# cloning of self and arbitrary elements 9 10use strict; 11use vars qw($VERSION @ISA $AUTOLOAD); 12use Carp; 13use Data::Dumper; 14 15# Make sure we have access to the new methods. These were added sometime 16# in early 2000 but we'll just anchor off of the new numbering system. 17use HTML::Element 3.01; 18 19@ISA = qw(HTML::Element); 20 21$VERSION = '1.18'; 22 23### attr extension ### 24 25sub push_attr { 26 my $self = shift; 27 my($attr, @new) = @_; 28 my(%seen, @vals); 29 if (defined(my $spec = $self->attr($attr))) { 30 for my $v (split(/\s+/, $spec)) { 31 next if $seen{$v}; 32 push(@vals, $seen{$v} = $v); 33 } 34 } 35 for my $v (grep { defined $_ } @new) { 36 next if $seen{$v}; 37 push(@vals, $seen{$v} = $v); 38 } 39 $self->SUPER::attr($attr, join(' ', @vals)); 40} 41 42### positional extension ### 43 44sub addr { 45 my $self = shift; 46 my $p = $self->parent; 47 return undef unless $p; 48 my @sibs = $p->content_list; 49 foreach my $i (0..$#sibs) { 50 return $i if defined $sibs[$i] && $sibs[$i] eq $self; 51 } 52 Carp::confess "major oops, no addr found for $self\n"; 53} 54 55sub position { 56 # Report coordinates by chasing addr's up the HTML::ElementSuper tree. 57 # We know we've reached the top when a) there is no parent, or b) the 58 # parent is some HTML::Element unable to report it's position. 59 my $p = shift; 60 my @pos; 61 while ($p) { 62 my $pp = $p->parent; 63 last unless ref $pp && $pp->isa(__PACKAGE__); 64 my $a = $p->addr; 65 unshift(@pos, $a) if defined $a; 66 $p = $pp; 67 } 68 @pos; 69} 70 71sub depth { 72 my $self = shift; 73 my $depth = 0; 74 my $p = $self; 75 while ($p = $p->parent) { 76 ++$depth; 77 } 78 $depth; 79} 80 81# Handy debugging tools 82 83sub push_position { 84 # Push positional coordinates into own content 85 my $self = shift; 86 $self->push_content(' (' . join(',', $self->position) . ')'); 87} 88 89sub push_depth { 90 # Push HTML tree depth into own content 91 my $self = shift; 92 $self->push_content('(' . $self->depth . ')'); 93} 94 95### cloner extension ### 96 97sub clone { 98 # Clone HTML::Element style trees. 99 # Clone self unless told otherwise. 100 # Cloning comes in handy when distributing methods such as 101 # push_content - you don't want the same HTML::Element tree across 102 # multiple nodes, just a copy of it - since HTML::Element nodes only 103 # recognize one parent. 104 # 105 # Note: The new cloning functionality of HTML::Element is insufficent 106 # for our purposes. Syntax aside, the native clone() does not 107 # clone the element globs associated with a table...the globs 108 # continue to affect the original element structure. 109 my $self = shift; 110 my @args = @_; 111 112 @args || push(@args, $self); 113 my($clone, $node, @clones); 114 my($VAR1, $VAR2, $VAR3); 115 $Data::Dumper::Purity = 1; 116 foreach $node (@args) { 117 _cloning($node, 1); 118 eval(Dumper($node)); 119 carp("$@ $node") if $@; 120 _cloning($node, 0); 121 _cloning($VAR1, 0); 122 # Retie the watchdogs 123 $VAR1->traverse(sub { 124 my($node, $startflag) = @_; 125 return unless $startflag; 126 if ($node->can('watchdog')) { 127 $node->watchdog(1); 128 $node->watchdog->mask(1) if $node->mask; 129 } 130 1; 131 }, 'ignore_text') if ref $VAR1; 132 push(@clones, $VAR1); 133 } 134 $#clones ? @clones : $clones[0]; 135} 136 137sub _cloning { 138 # Ugh. We need to do this when we clone and happen to be masked, 139 # otherwise masked content will not make it into the clone. 140 my $node = shift; 141 return unless ref $node; 142 if (@_) { 143 if ($_[0]) { 144 $node->traverse(sub { 145 my($node, $startflag) = @_; 146 return unless $startflag; 147 $node->_clone_state(1) if $node->can('_clone_state'); 148 1; 149 }, 'ignore_text'); 150 } 151 else { 152 $node->traverse(sub { 153 my($node, $startflag) = @_; 154 return unless $startflag; 155 $node->_clone_state(0) if $node->can('_clone_state'); 156 1; 157 }, 'ignore_text'); 158 } 159 } 160 $node->can('watchdog') && $node->watchdog ? $node->watchdog->cloning : 0; 161} 162 163sub _clone_state { 164 my($self, $state) = @_; 165 return 0 unless $self->watchdog; 166 if (defined $state) { 167 if ($state) { 168 $self->watchdog->cloning(1); 169 } 170 else { 171 $self->watchdog->cloning(0); 172 } 173 } 174 $self->watchdog->cloning; 175} 176 177 178### maskable extension ### 179 180sub mask { 181 my($self, $mode) = @_; 182 if (defined $mode) { 183 # We count modes since masking can come from overlapping influences, 184 # theoretically. 185 if ($mode) { 186 if (! $self->{_mask}) { 187 # deactivate (mask) content 188 $self->watchdog(1) unless $self->watchdog; 189 $self->watchdog->mask(1); 190 } 191 ++$self->{_mask}; 192 } 193 else { 194 --$self->{_mask} unless $self->{_mask} <= 0; 195 if (! $self->{_mask}) { 196 # activate (unmask) content 197 if ($self->watchdog_listref) { 198 $self->watchdog->mask(0); 199 } 200 else { 201 $self->watchdog(0); 202 } 203 } 204 } 205 } 206 $self->{_mask}; 207} 208 209sub starttag { 210 my $self = shift; 211 return '' if $self->mask; 212 $self->SUPER::starttag(@_); 213} 214 215sub endtag { 216 my $self = shift; 217 return '' if $self->mask; 218 $self->SUPER::endtag(@_); 219} 220 221sub starttag_XML { 222 my $self = shift; 223 return '' if $self->mask; 224 $self->SUPER::starttag_XML(@_); 225} 226 227sub endtag_XML { 228 my $self = shift; 229 return '' if $self->mask; 230 $self->SUPER::endtag_XML(@_); 231} 232 233# Oh, the horror! This used to be all that was necessary to implement 234# masking -- overriding traverse. But the new HTML::Element does NOT 235# call traverse on a per-element basis, so now when we're masked we have 236# to play dead -- no tags, no content. To make matters worse, we can't 237# just override the content method because the new traverse() 238# implentation is playing directly wiht the data structures rather than 239# calling content(). 240# 241# See below for the current solution: HTML::ElementSuper::TiedContent 242# 243# For the time being, I've kept the old code and commentary here: 244# 245## Routines that use traverse, such as as_HTML, are not called 246## on a per-element basis. as_HTML always belongs to the top level 247## element that initiated the call. A maskable element should not 248## be seen, though. Overriding as_HTML will not do the trick since 249## we cannot guarantee that the top level element is a maskable-aware 250## element with the overridden method. Therefore, for maskable 251## elements, we override traverse itself, which does get called on a 252## per-element basis. If this element is masked, simply return from 253## traverse, making this element truly invisible to parents. This 254## means that traverse is no longer guranteed to actually visit all 255## elements in the tree. For that, you must rely on the actual 256## contents of each element. 257#sub traverse { 258# my $self = shift; 259# return if $self->mask; 260# $self->SUPER::traverse(@_); 261#} 262# 263#sub super_traverse { 264# # Saftey net for catching wayward masked elements. 265# my $self = shift; 266# $self->SUPER::traverse(@_); 267#} 268 269### replacer extension ### 270 271sub replace_content { 272 my $self = shift; 273 $self->delete_content; 274 $self->push_content(@_); 275} 276 277### wrapper extension ### 278 279sub wrap_content { 280 my($self, $wrap) = @_; 281 my $content = $self->content; 282 if (ref $content) { 283 $wrap->push_content(@$content); 284 @$content = ($wrap); 285 } 286 else { 287 $self->push_content($wrap); 288 } 289 $wrap; 290} 291 292### watchdog extension ### 293 294sub watchdog_listref { 295 my $self = shift; 296 @_ ? $self->{_wa} = shift : $self->{_wa}; 297} 298 299sub watchdog { 300 my $self = shift; 301 if (@_) { 302 if ($_[0]) { 303 # Install the watchdog hash 304 my $wa = shift; 305 if (ref $wa eq 'ARRAY') { 306 $self->watchdog_listref($wa); 307 } 308 else { 309 $wa = $self->watchdog_listref; 310 } 311 my $cr = $self->content; 312 my @content = @$cr; 313 @$cr = (); 314 $self->{_wd} = tie @$cr, 'HTML::ElementSuper::ContentWatchdog'; 315 @$cr = @content; 316 $self->{_wd}->watchdog($wa) if ref $wa eq 'ARRAY'; 317 } 318 else { 319 # Release the watchdog 320 my @content = $self->{_wd}->fetchall; # in case it's masked 321 my $cr = $self->content; 322 # Delete obj ref before untie in order to hush -w 323 delete $self->{_wd}; 324 untie @$cr; 325 @$cr = @content; 326 } 327 } 328 $self->{_wd}; 329} 330 331### 332 333sub new { 334 my $that = shift; 335 my $class = ref($that) || $that; 336 my $self = $class->SUPER::new(@_); 337 # force init of content with array ref 338 $self->content_array_ref; 339 bless $self,$class; 340 $self; 341} 342 343### deprecated ### 344 345sub delete_attr { 346 # Deprecated by new HTML::Element functionality. Should now use 347 # attr($attr, undef) for attribute deletions. Still returning the old 348 # value here for backwards compatability. 349 my($self, $attr) = @_; 350 $attr = lc $attr; 351 my $old = $self->attr($attr); 352 $self->attr($attr, undef); 353 $old; 354} 355 356### temporary Overrides (until bugs fixed in HTML::Element) ### 357 358sub replace_with { 359 my $self = shift; 360 my $p = $self->parent; 361 $self->SUPER::replace_with(@_); 362 grep { $_->parent($p) } @_; 363 $self; 364} 365 366### bag o kludgy tricks ### 367 368{ 369 package HTML::ElementSuper::ContentWatchdog; 370 371 use strict; 372 use Carp; 373 use vars qw( @ISA ); 374 use Tie::Array; 375 @ISA = qw( Tie::Array ); 376 377 # I got tired of jumping through hoops dealing with the new 378 # HTML::Element semantics. Since I could no longer override traverse() 379 # I was having to go through all sorts of contortions to "hide" 380 # elements in the tree when masked. In a cohesive tree like 381 # HTML::ElementTable, this was still insufficient because globbed 382 # access to the masked elements still needed to be retained. 383 # 384 # The hoops in question involved either a) breaking containment all 385 # over the place, or b) overriding *all* content methods, or c) 386 # swapping in a doppleganger element for the masked element, which 387 # then involved overriding just about everything since the positional 388 # methods needed to look at the doppleganger, but everything else 389 # needed to look at the original. 390 # 391 # So here I provide a class for tying the content array and doing the 392 # right thing when masked. Note that starttag() and endtag() still 393 # need to be overridden, but this tied class should take care of 394 # traverse rifling through masked content. 395 # 396 # Note that all content manipulation works as expected, except for 397 # FETCH. This is intentional. 398 # 399 # Technically, this is not breaking containment since the content() 400 # method returns the content array reference. Even though this is a 401 # read-only method, we can still tie() over the array pointed to by 402 # the reference! 403 # 404 # See mask() for implementation. 405 # 406 # I'll probably go to programmer hell for this, but what the hey. 407 # 408 # UPDATE: Since I was already doing this for masking, I decided to to 409 # general content policing with the same mechanism, but only when 410 # requested via the watchdog parameter, passed as a code reference. 411 # Alas, this meant a full implmentation rather than just subclassing 412 # Tie::StdArray and overriding FETCH(). 413 414 # Object methods 415 416 sub fetchall { @{shift->{_array}} } 417 418 sub watchdog { 419 my($self, $classes_ref) = @_; 420 if ($classes_ref) { 421 $self->{watchdog} = {}; 422 foreach (@$classes_ref) { 423 ++$self->{watchdog}{$_}; 424 } 425 } 426 $self->{watchdog}; 427 } 428 429 sub permit { 430 my($self, @objects) = @_; 431 return 1 unless $self->{watchdog}; 432 foreach (@objects) { 433 my $type = ref($_) || $_; 434 croak "Adoption of type $type, which is not of type " . 435 join(', ', sort keys %{$self->{watchdog}}) . "\n" 436 unless $self->{watchdog}{$type}; 437 } 438 1; 439 } 440 441 sub mask { 442 my $self = shift; 443 @_ ? $self->{mask} = shift : $self->{mask}; 444 } 445 446 sub cloning { 447 my $self = shift; 448 @_ ? $self->{cloning} = shift : $self->{cloning}; 449 } 450 451 # Tied array methods 452 453 sub TIEARRAY { 454 my $that = shift; 455 my $class = (ref $that) || $that; 456 my $self = {}; 457 bless $self, $class; 458 %$self = @_; 459 $self->{_array} = []; 460 $self; 461 } 462 463 sub FETCH { 464 my($self, $k) = @_; 465 return if $self->{mask} && !$self->{cloning}; 466 $self->{_array}[$k]; 467 } 468 469 sub STORE { 470 my($self, $k, $v) = @_; 471 my $vc = ref $v; 472 $self->permit($v) if $self->{watchdog}; 473 $self->{_array}[$k] = $v; 474 } 475 476 sub PUSH { 477 my $self = shift; 478 $self->permit(@_) if $self->{watchdog}; 479 push(@{$self->{_array}}, @_); 480 } 481 482 sub UNSHIFT { 483 my $self = shift; 484 $self->permit(@_) if $self->{watchdog}; 485 unshift(@{$self->{_array}}, @_); 486 } 487 488 sub SPLICE { 489 my($self, $offset, $length, @list) = @_; 490 if (@list && $self->{watchdog}) { 491 $self->permit(@list); 492 } 493 splice(@{$self->{_array}}, @_); 494 } 495 496 #### The rest of these are just native ops on the inner array. 497 498 sub FETCHSIZE { scalar @{shift->{_array}} } 499 sub STORESIZE { 500 my($self, $size) = @_; 501 $#{$self->{_array}} = $size - 1; 502 } 503 sub CLEAR { @{shift->{_array}} = () } 504 sub POP { pop(@{shift->{_array}}) } 505 sub SHIFT { shift(@{shift->{_array}}) } 506 507} ### End HTML::ElementSuper::ContentWatchdog 508 5091; 510__END__ 511 512=head1 NAME 513 514HTML::ElementSuper - Perl extension for HTML::Element(3) 515 516=head1 SYNOPSIS 517 518 use HTML::ElementSuper; 519 520 ### Positional extension 521 $e = new HTML::ElementSuper 'font'; 522 $sibling_number = $e->addr(); 523 $e2 = new HTML::ElementSuper 'p'; 524 $e2->push_content($e); 525 # 526 @coords = $e->position(); 527 $depth_in_pos_tree = $e->depth(); 528 529 ### Replacer extension 530 $er = new HTML::ElementSuper 'font'; 531 # Tree beneath $er, if present, is dropped. 532 $er->replace_content(new HTML::Element 'p'); 533 534 ### Wrapper extension 535 $ew = new HTML::ElementSuper; 536 $ew->push_content("Tickle me, baby"); 537 $ew->wrap_content(new HTML::Element 'font', color => 'pink'); 538 print $ew->as_HTML(); 539 540 ### Maskable extension 541 $em = new HTML::ElementSuper 'td'; 542 $em->mask(1); 543 print $em->as_HTML; # nada 544 $em->mask(0); 545 print $em->as_HTML; # $e and its children are visible 546 547 ### Cloning of own tree or another element's tree 548 ### (is this the correct clomenature? :-) 549 $a = new HTML::ElementSuper 'font', size => 2; 550 $b = new HTML::ElementSuper 'font', color => 'red'; 551 $a_clone = $a->clone; 552 $b_clone = $a->clone($b); 553 # Multiple elements can be cloned 554 @clone_clones = $a_clone->clone($a_clone, $b_clone); 555 556 557=head1 DESCRIPTION 558 559HTML::ElementSuper is an extension for HTML::Element(3) that provides 560several new methods to assist in element manipulation. An 561HTML::ElementSuper has the following additional properties: 562 563 * report is coordinate position in a tree of its peers 564 * replace its contents 565 * wrap its contents in a new element 566 * mask itself so that it and its descendants are invisible to 567 traverse() 568 * clone itself and other HTML::Element based object trees 569 * handle multiple values for attributes 570 571Note that these extensions were originally developed to assist in 572implementing the HTML::ElementTable(3) class, but were thought to be of 573general enough utility to warrant their own package. 574 575=head1 METHODS 576 577=over 578 579=item new('tag', attr => 'value', ...) 580 581Return a new HTML::ElementSuper object. Exactly like the constructor for 582HTML::Element(3), takes a tag type and optional attributes. 583 584=item push_attr(attr => @values) 585 586Extend the value string for a particular attribute. An example of this 587might be when you'd like to assign multiple CSS classes to a single 588element. The attribute value is extended using white space as a 589separator. 590 591=item addr() 592 593Returns the position of this element in relation to its siblings based 594on the content of the parent, starting with 0. Returns undef if this 595element has no parent. In other words, this returns the index of this 596element in the content array of the parent. 597 598=item position() 599 600Returns the coordinates of this element in the tree it inhabits. This is 601accomplished by succesively calling addr() on ancestor elements until 602either a) an element that does not support these methods is found, or b) 603there are no more parents. The resulting list is the n-dimensional 604coordinates of the element in the tree. 605 606=item replace_content(@new_content) 607 608Simple shortcut method that deletes the current contents of the element 609before adding the new. 610 611=item wrap_content($wrapper_element) 612 613Wraps the existing content in the provided element. If the 614provided element happens to be a non-element, a push_content is 615performed instead. 616 617=item mask 618 619=item mask(mode) 620 621Toggles whether or not this element is visible to parental methods that 622visit the element tree using traverse(), such as as_HTML(). Valid 623arguments for mask() are 0 and 1. Returns the current setting without 624an argument. 625 626This might seem like a strange method to have, but it helps in managing 627dynamic tree structures. For example, in HTML::ElementTable(3), when 628you expand a table cell you simply mask what it covers rather than 629destroy it. Shrinking the table cell reveals that content to as_HTML() 630once again. 631 632=item clone 633 634=item clone(@elements) 635 636Returns a clone of elements and all of their descendants. Without 637arguments, the element clones itself, otherwise it clones the elements 638provided as arguments. Any element can be cloned as long as it is 639HTML::Element(3) based. This method is very handy for duplicating tree 640structures since an HTML::Element cannot have more than one parent at 641any given time...hence "tree". 642 643=back 644 645=head1 REQUIRES 646 647HTML::Element(3), Data::Dumper(3) 648 649=head1 AUTHOR 650 651Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt> 652 653=head1 COPYRIGHT 654 655Copyright (c) 1998-2010 Matthew P. Sisk. All rights reserved. All wrongs 656revenged. This program is free software; you can redistribute it and/or 657modify it under the same terms as Perl itself. 658 659=head1 SEE ALSO 660 661HTML::Element(3), HTML::ElementGlob(3), HTML::ElementRaw(3), HTML::ElementTable(3), perl(1). 662