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.11';

### Begin Positional extension ###

sub addr {
  my $self = shift;
  my $p = $self->parent;
  return undef unless $p;
  my @sibs = $p->content_list;
  # For unknown reasons, at least on Solaris, a simple 'return $_'
  # does not work from within the foreach loop. I have no idea why,
  # but here's the clunky workaround.
  my $a;
  foreach (0..$#sibs) {
    if (defined $sibs[$_] && $sibs[$_] eq $self) {
      $a = $_;
      last;
    }
  }
  $a;
}

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 $a = $p->addr;
    unshift(@pos, $a) if defined $a;
    $p = $p->parent;
  }
  @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 . ')');
}

### End Positional extension ###


### Begin 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;
}


### End Cloner extension ###

### Begin 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(@_);
}

# 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(@_);
#}

### End Maskable extension ###

### Begin Replacer extension ###

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

### End Replacer extension ###

### Begin 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;
}

### End Wrapper extension ###


### Begin 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};
}

### End Watchdog extension ###

sub new {
  my $that = shift;
  my $class = ref($that) || $that;
  my $self = $class->SUPER::new(@_);
  # Grrr. content() is read only, and for various
  # reasons I need to initialize this to an array ref.
  $self->{_content} = [];
  bless $self,$class;
  $self;
}

### Deprecated methods ###

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 requrested 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__

=head1 NAME

HTML::ElementSuper - Perl extension for HTML::Element(3)

=head1 SYNOPSIS

  use HTML::ElementSuper;

  ### Positional extension
  $e = new HTML::ElementSuper 'font';
  $sibling_number = $e->addr();
  $e2 = new HTML::ElementSuper 'p';
  $e2->push_content($e);
  # 
  @coords = $e->position();
  $depth_in_pos_tree = $e->depth();

  ### Replacer extension
  $er = new HTML::ElementSuper 'font';
  # Tree beneath $er, if present, is dropped.
  $er->replace_content(new HTML::Element 'p');

  ### Wrapper extension
  $ew = new HTML::ElementSuper;
  $ew->push_content("Tickle me, baby");
  $ew->wrap_content(new HTML::Element 'font', color => 'pink');
  print $ew->as_HTML();

  ### Maskable extension
  $em = new HTML::ElementSuper 'td';
  $em->mask(1);
  print $em->as_HTML; # nada
  $em->mask(0);
  print $em->as_HTML; # $e and its children are visible

  ### Cloning of own tree or another element's tree
  ### (is this the correct clomenature?  :-)
  $a = new HTML::ElementSuper 'font', size => 2;
  $b = new HTML::ElementSuper 'font', color => 'red';
  $a_clone  = $a->clone;
  $b_clone = $a->clone($b);
  # Multiple elements can be cloned
  @clone_clones = $a_clone->clone($a_clone, $b_clone);


=head1 DESCRIPTION

HTML::ElementSuper is an extension for HTML::Element(3) that provides
several new methods to assist in element manipulation.  An HTML::ElementSuper
has the following additional properties:

   * report is coordinate position in a tree of its peers
   * replace its contents
   * wrap its contents in a new element
   * mask itself so that it and its descendants are invisible
     to traverse()
   * clone itself and other HTML::Element based object trees

Note that these extensions were originally developed to assist in
implementing the HTML::ElementTable(3) class, but were thought to be
of general enough utility to warrant their own package.

=head1 METHODS

=over

=item new('tag', attr => 'value', ...)

Return a new HTML::ElementSuper object.  Exactly like the constructor
for HTML::Element(3), takes a tag type and optional attributes.

=item addr()

Returns the position of this element in relation to its siblings
based on the content of the parent, starting with 0.  Returns
undef if this element has no parent. In other words, this returns
the index of this element in the content array of the parent.

=item position()

Returns the coordinates of this element in the tree it inhabits.
This is accomplished by succesively calling addr() on ancestor
elements until either a) an element that does not support these
methods is found, or b) there are no more parents.  The resulting
list is the n-dimensional coordinates of the element in the tree.

=item replace_content(@new_content)

Simple shortcut method that deletes the current contents of the
element before adding the new.

=item wrap_content($wrapper_element)

Wraps the existing content in the provided element.  If the
provided element happens to be a non-element, a push_content
is performed instead.

=item mask

=item mask(mode)

Toggles whether or not this element is visible to parental
methods that visit the element tree using traverse(), such as
as_HTML().  Valid arguments for mask() are 0 and 1.  Returns
the current setting without an argument.

This might seem like a strange method to have, but it helps
in managing dynamic tree structures.  For example, in HTML::ElementTable(3),
when you expand a table cell you simply mask what it covers
rather than destroy it.  Shrinking the table cell reveals that
content to as_HTML() once again.

=item clone

=item clone(@elements)

Returns a clone of elements and all of their descendants.  Without
arguments, the element clones itself, otherwise it clones the
elements provided as arguments. Any element can be cloned as long
as it is HTML::Element(3) based.  This method is very handy for
duplicating tree structures since an HTML::Element cannot have
more than one parent at any given time...hence "tree".

=back

=head1 REQUIRES

HTML::Element(3), Data::Dumper(3)

=head1 AUTHOR

Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt>

=head1 COPYRIGHT

Copyright (c) 1998-2002 Matthew P. Sisk.
All rights reserved. All wrongs revenged. This program is free
software; you can redistribute it and/or modify it under the
same terms as Perl itself.

=head1 SEE ALSO

HTML::Element(3), HTML::ElementGlob(3), HTML::ElementRaw(3), HTML::ElementTable(3), perl(1).
