File Coverage

blib/lib/HTML/ElementSuper.pm

Criterion	Covered	Total	%
statement	27	238	11.3
branch	0	104	0.0
condition	0	24	0.0
subroutine	9	49	18.3
pod	14	19	73.6
total	50	434	11.5

package HTML::ElementSuper;

# Extend the HTML::Element class to allow the following:
#    positional reporting
#    content replacement
#    masking (i.e., in the structure but invisible to traverse)
#    content wrapping
#    cloning of self and arbitrary elements

use strict;
use vars qw($VERSION @ISA $AUTOLOAD);
use Carp;
use Data::Dumper;

# Make sure we have access to the new methods. These were added sometime
# in early 2000 but we'll just anchor off of the new numbering system.
use HTML::Element 3.01;

@ISA = qw(HTML::Element);

$VERSION = '1.18';

### attr extension ###

sub push_attr {
  my $self = shift;
  my($attr, @new) = @_;
  my(%seen, @vals);
  if (defined(my $spec = $self->attr($attr))) {
    for my $v (split(/\s+/, $spec)) {
      next if $seen{$v};
      push(@vals, $seen{$v} = $v);
    }
  }
  for my $v (grep { defined $_ } @new) {
    next if $seen{$v};
    push(@vals, $seen{$v} = $v);
  }
  $self->SUPER::attr($attr, join(' ', @vals));
}

### positional extension ###

sub addr {
  my $self = shift;
  my $p = $self->parent;
  return undef unless $p;
  my @sibs = $p->content_list;
  foreach my $i (0..$#sibs) {
    return $i if defined $sibs[$i] && $sibs[$i] eq $self;
  }
  Carp::confess "major oops, no addr found for $self\n";
}

sub position {
  # Report coordinates by chasing addr's up the HTML::ElementSuper tree.
  # We know we've reached the top when a) there is no parent, or b) the
  # parent is some HTML::Element unable to report it's position.
  my $p = shift;
  my @pos;
  while ($p) {
    my $pp = $p->parent;
    last unless ref $pp && $pp->isa(__PACKAGE__);
    my $a = $p->addr;
    unshift(@pos, $a) if defined $a;
    $p = $pp;
  }
  @pos;
}

sub depth {
  my $self = shift;
  my $depth = 0;
  my $p = $self;
  while ($p = $p->parent) {
    ++$depth;
  }
  $depth;
}

# Handy debugging tools

sub push_position {
  # Push positional coordinates into own content
  my $self = shift;
  $self->push_content(' (' . join(',', $self->position) . ')');
}

sub push_depth {
  # Push HTML tree depth into own content
  my $self = shift;
  $self->push_content('(' . $self->depth . ')');
}

### cloner extension ###

sub clone {
  # Clone HTML::Element style trees.
  # Clone self unless told otherwise.
  # Cloning comes in handy when distributing methods such as
  # push_content - you don't want the same HTML::Element tree across
  # multiple nodes, just a copy of it - since HTML::Element nodes only
  # recognize one parent.
  #
  # Note: The new cloning functionality of HTML::Element is insufficent
  #       for our purposes. Syntax aside, the native clone() does not
  #       clone the element globs associated with a table...the globs
  #       continue to affect the original element structure.
  my $self = shift;
  my @args = @_;

  @args || push(@args, $self);
  my($clone, $node, @clones);
  my($VAR1, $VAR2, $VAR3);
  $Data::Dumper::Purity = 1;
  foreach $node (@args) {
    _cloning($node, 1);
    eval(Dumper($node));
    carp("$@ $node") if $@;
    _cloning($node, 0);
    _cloning($VAR1, 0);
    # Retie the watchdogs
    $VAR1->traverse(sub {
                      my($node, $startflag) = @_;
                      return unless $startflag;
                      if ($node->can('watchdog')) {
                        $node->watchdog(1);
                        $node->watchdog->mask(1) if $node->mask;
                      }
                      1;
                    }, 'ignore_text') if ref $VAR1;
    push(@clones, $VAR1);
  }
  $#clones ? @clones : $clones[0];
}

sub _cloning {
  # Ugh. We need to do this when we clone and happen to be masked,
  # otherwise masked content will not make it into the clone.
  my $node = shift;
  return unless ref $node;
  if (@_) {
    if ($_[0]) {
      $node->traverse(sub {
                        my($node, $startflag) = @_;
                        return unless $startflag;
                        $node->_clone_state(1) if $node->can('_clone_state');
                        1;
                      }, 'ignore_text');
    }
    else {
      $node->traverse(sub {
                        my($node, $startflag) = @_;
                        return unless $startflag;
                        $node->_clone_state(0) if $node->can('_clone_state');
                        1;
                      }, 'ignore_text');
    }
  }
  $node->can('watchdog') && $node->watchdog ? $node->watchdog->cloning : 0;
}

sub _clone_state {
  my($self, $state) = @_;
  return 0 unless $self->watchdog;
  if (defined $state) {
    if ($state) {
      $self->watchdog->cloning(1);
    }
    else {
      $self->watchdog->cloning(0);
    }
  }
  $self->watchdog->cloning;
}


### maskable extension ###

sub mask {
  my($self, $mode) = @_;
  if (defined $mode) {
    # We count modes since masking can come from overlapping influences,
    # theoretically.
    if ($mode) {
      if (! $self->{_mask}) {
        # deactivate (mask) content
        $self->watchdog(1) unless $self->watchdog;
        $self->watchdog->mask(1);
      }
      ++$self->{_mask};
    }
    else {
      --$self->{_mask} unless $self->{_mask} <= 0;
      if (! $self->{_mask}) {
        # activate (unmask) content
        if ($self->watchdog_listref) {
          $self->watchdog->mask(0);
        }
        else {
          $self->watchdog(0);
        }
      }
    }
  }
  $self->{_mask};
}

sub starttag {
  my $self = shift;
  return '' if $self->mask;
  $self->SUPER::starttag(@_);
}

sub endtag {
  my $self = shift;
  return '' if $self->mask;
  $self->SUPER::endtag(@_);
}

sub starttag_XML {
  my $self = shift;
  return '' if $self->mask;
  $self->SUPER::starttag_XML(@_);
}

sub endtag_XML {
  my $self = shift;
  return '' if $self->mask;
  $self->SUPER::endtag_XML(@_);
}

# Oh, the horror! This used to be all that was necessary to implement
# masking -- overriding traverse. But the new HTML::Element does NOT
# call traverse on a per-element basis, so now when we're masked we have
# to play dead -- no tags, no content. To make matters worse, we can't
# just override the content method because the new traverse()
# implentation is playing directly wiht the data structures rather than
# calling content().
#
# See below for the current solution: HTML::ElementSuper::TiedContent
#
# For the time being, I've kept the old code and commentary here:
#
## Routines that use traverse, such as as_HTML, are not called
## on a per-element basis.  as_HTML always belongs to the top level
## element that initiated the call.  A maskable element should not
## be seen, though.  Overriding as_HTML will not do the trick since
## we cannot guarantee that the top level element is a maskable-aware
## element with the overridden method.  Therefore, for maskable
## elements, we override traverse itself, which does get called on a
## per-element basis. If this element is masked, simply return from
## traverse, making this element truly invisible to parents.  This
## means that traverse is no longer guranteed to actually visit all
## elements in the tree. For that, you must rely on the actual
## contents of each element.
#sub traverse {
#  my $self = shift;
#  return if $self->mask;
#  $self->SUPER::traverse(@_);
#}
#
#sub super_traverse {
#  # Saftey net for catching wayward masked elements.
#  my $self = shift;
#  $self->SUPER::traverse(@_);
#}

### replacer extension ###

sub replace_content {
  my $self = shift;
  $self->delete_content;
  $self->push_content(@_);
}

### wrapper extension ###

sub wrap_content {
  my($self, $wrap) = @_;
  my $content = $self->content;
  if (ref $content) {
    $wrap->push_content(@$content);
    @$content = ($wrap);
  }
  else {
    $self->push_content($wrap);
  }
  $wrap;
}

### watchdog extension ###

sub watchdog_listref {
  my $self = shift;
  @_ ? $self->{_wa} = shift : $self->{_wa};
}

sub watchdog {
  my $self = shift;
  if (@_) {
    if ($_[0]) {
      # Install the watchdog hash
      my $wa = shift;
      if (ref $wa eq 'ARRAY') {
        $self->watchdog_listref($wa);
      }
      else {
        $wa = $self->watchdog_listref;
      }
      my $cr = $self->content;
      my @content = @$cr;
      @$cr = ();
      $self->{_wd} = tie @$cr, 'HTML::ElementSuper::ContentWatchdog';
      @$cr = @content;
      $self->{_wd}->watchdog($wa) if ref $wa eq 'ARRAY';
    }
    else {
      # Release the watchdog
      my @content = $self->{_wd}->fetchall; # in case it's masked
      my $cr = $self->content;
      # Delete obj ref before untie in order to hush -w
      delete $self->{_wd};
      untie @$cr;
      @$cr = @content;
    }
  }
  $self->{_wd};
}

###

sub new {
  my $that = shift;
  my $class = ref($that) || $that;
  my $self = $class->SUPER::new(@_);
  # force init of content with array ref
  $self->content_array_ref;
  bless $self,$class;
  $self;
}

### deprecated ###

sub delete_attr {
  # Deprecated by new HTML::Element functionality. Should now use
  # attr($attr, undef) for attribute deletions. Still returning the old
  # value here for backwards compatability.
  my($self, $attr) = @_;
  $attr = lc $attr;
  my $old = $self->attr($attr);
  $self->attr($attr, undef);
  $old;
}

### temporary Overrides (until bugs fixed in HTML::Element) ###

sub replace_with {
  my $self = shift;
  my $p = $self->parent;
  $self->SUPER::replace_with(@_);
  grep { $_->parent($p) } @_;
  $self;
}

### bag o kludgy tricks ###

{
  package HTML::ElementSuper::ContentWatchdog;

  use strict;
  use Carp;
  use vars qw( @ISA );
  use Tie::Array;
  @ISA = qw( Tie::Array );

  # I got tired of jumping through hoops dealing with the new
  # HTML::Element semantics. Since I could no longer override traverse()
  # I was having to go through all sorts of contortions to "hide"
  # elements in the tree when masked. In a cohesive tree like
  # HTML::ElementTable, this was still insufficient because globbed
  # access to the masked elements still needed to be retained.
  #
  # The hoops in question involved either a) breaking containment all
  # over the place, or b) overriding *all* content methods, or c)
  # swapping in a doppleganger element for the masked element, which
  # then involved overriding just about everything since the positional
  # methods needed to look at the doppleganger, but everything else
  # needed to look at the original.
  #
  # So here I provide a class for tying the content array and doing the
  # right thing when masked. Note that starttag() and endtag() still
  # need to be overridden, but this tied class should take care of
  # traverse rifling through masked content.
  #
  # Note that all content manipulation works as expected, except for
  # FETCH. This is intentional.
  #
  # Technically, this is not breaking containment since the content()
  # method returns the content array reference. Even though this is a
  # read-only method, we can still tie() over the array pointed to by
  # the reference!
  #
  # See mask() for implementation.
  #
  # I'll probably go to programmer hell for this, but what the hey.
  #
  # UPDATE: Since I was already doing this for masking, I decided to to
  # general content policing with the same mechanism, but only when
  # requested via the watchdog parameter, passed as a code reference.
  # Alas, this meant a full implmentation rather than just subclassing
  # Tie::StdArray and overriding FETCH().

  # Object methods

  sub fetchall { @{shift->{_array}} }

  sub watchdog {
    my($self, $classes_ref) = @_;
    if ($classes_ref) {
      $self->{watchdog} = {};
      foreach (@$classes_ref) {
        ++$self->{watchdog}{$_};
      }
    }
    $self->{watchdog};
  }

  sub permit {
    my($self, @objects) = @_;
    return 1 unless $self->{watchdog};
    foreach (@objects) {
      my $type = ref($_) || $_;
      croak "Adoption of type $type, which is not of type " .
        join(', ', sort keys %{$self->{watchdog}}) . "\n"
          unless $self->{watchdog}{$type};
    }
    1;
  }

  sub mask {
    my $self = shift;
    @_ ? $self->{mask} = shift : $self->{mask};
  }

  sub cloning {
    my $self = shift;
    @_ ? $self->{cloning} = shift : $self->{cloning};
  }

  # Tied array methods

  sub TIEARRAY {
    my $that = shift;
    my $class = (ref $that) || $that;
    my $self = {};
    bless $self, $class;
    %$self = @_;
    $self->{_array} = [];
    $self;
  }

  sub FETCH {
    my($self, $k) = @_;
    return if $self->{mask} && !$self->{cloning};
    $self->{_array}[$k];
  }

  sub STORE {
    my($self, $k, $v) = @_;
    my $vc = ref $v;
    $self->permit($v) if $self->{watchdog};
    $self->{_array}[$k] = $v;
  }

  sub PUSH {
    my $self = shift;
    $self->permit(@_) if $self->{watchdog};
    push(@{$self->{_array}}, @_);
  }

  sub UNSHIFT {
    my $self = shift;
    $self->permit(@_) if $self->{watchdog};
    unshift(@{$self->{_array}}, @_);
  }

  sub SPLICE {
    my($self, $offset, $length, @list) = @_;
    if (@list && $self->{watchdog}) {
      $self->permit(@list);
    }
    splice(@{$self->{_array}}, @_);
  }

  #### The rest of these are just native ops on the inner array.

  sub FETCHSIZE { scalar @{shift->{_array}} }
  sub STORESIZE {
    my($self, $size) = @_;
    $#{$self->{_array}} = $size - 1;
  }
  sub CLEAR {       @{shift->{_array}} = () }
  sub POP   {   pop(@{shift->{_array}})     }
  sub SHIFT { shift(@{shift->{_array}})     }

} ### End HTML::ElementSuper::ContentWatchdog

1;
__END__