package HTML::Element::Library;
-# ABSTRACT: Convenience methods for HTML::TreeBuilder and HTML::Element
-
use strict;
use warnings;
-
+our $VERSION = '5.120100';
our $DEBUG = 0;
-#our $DEBUG = 1;
-use Array::Group qw(:all);
-use Carp qw(confess);
+use Array::Group ':all';
+use Carp 'confess';
use Data::Dumper;
+use Data::Rmap 'rmap_array';
use HTML::Element;
-use List::Util qw(first);
-use List::MoreUtils qw/:all/;
-use Params::Validate qw(:all);
-use Scalar::Listify;
-#use Tie::Cycle;
+use HTML::FillInForm;
+use List::MoreUtils ':all';
use List::Rotation::Cycle;
-
-our %EXPORT_TAGS = ( 'all' => [ qw() ] );
-our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
-our @EXPORT = qw();
-
-
-
-
-
-
-
-# Preloaded methods go here.
+use List::Util 'first';
+use Params::Validate ':all';
+use Scalar::Listify;
# https://rt.cpan.org/Ticket/Display.html?id=44105
sub HTML::Element::fillinform {
+ my ($tree, $hashref, $return_tree, $guts) = @_;
+ (ref $hashref) eq 'HASH' or confess 'hashref not supplied as argument' ;
- my ($tree, $hashref, $return_tree, $guts)=@_;
-
- (ref $hashref) eq 'HASH' or die 'hashref not supplied as argument' ;
-
- use HTML::FillInForm;
- my $html = $tree->as_HTML;
- my $new_html = HTML::FillInForm->fill(\$html, $hashref);
-
- if ($return_tree) {
- my $tree = HTML::TreeBuilder->new_from_content($new_html);
- $tree = $guts ? $tree->guts : $tree ;
- } else {
- $new_html;
- }
+ my $html = $tree->as_HTML;
+ my $new_html = HTML::FillInForm->fill(\$html, $hashref);
+ if ($return_tree) {
+ my $tree = HTML::TreeBuilder->new_from_content($new_html);
+ $tree = $guts ? $tree->guts : $tree ;
+ } else {
+ $new_html;
+ }
}
sub HTML::Element::siblings {
- my $element = shift;
- my $p = $element->parent;
- return () unless $p;
- $p->content_list;
+ my $element = shift;
+ my $p = $element->parent;
+ return () unless $p;
+ $p->content_list;
}
sub HTML::Element::defmap {
- my($tree,$attr,$hashref,$debug)=@_;
-
- while (my ($k, $v) = (each %$hashref)) {
- warn "defmap looks for ($attr => $k)" if $debug;
- my $found = $tree->look_down($attr => $k);
- if ($found) {
- warn "($attr => $k) was found.. replacing with '$v'" if $debug;
- $found->replace_content( $v );
+ my($tree, $attr, $hashref, $debug) = @_;
+
+ while (my ($k, $v) = (each %$hashref)) {
+ warn "defmap looks for ($attr => $k)" if $debug;
+ my $found = $tree->look_down($attr => $k);
+ if ($found) {
+ warn "($attr => $k) was found.. replacing with '$v'" if $debug;
+ $found->replace_content( $v );
+ }
}
- }
-
}
sub HTML::Element::_only_empty_content {
- my ($self)=@_;
- my @c = $self->content_list;
- my $length = scalar @c;
+ my ($self) = @_;
+ my @c = $self->content_list;
+ my $length = scalar @c;
- #use Data::Dumper;
- #warn sprintf 'Testing %s (%s)' , $self->starttag, Dumper(\@c);
- #warn sprintf "\t\tlength of content: %d ", $length;
-
- scalar @c == 1 and not length($c[0]);
+ scalar @c == 1 and not length $c[0];
}
sub HTML::Element::prune {
- my ($self)=@_;
+ my ($self) = @_;
- for my $c ($self->content_list) {
- next unless ref $c;
- #warn "C: " . Dumper($c);
- $c->prune;
- }
+ for my $c ($self->content_list) {
+ next unless ref $c;
+ $c->prune;
+ }
- # post-order:
- $self->delete if ($self->is_empty or $self->_only_empty_content);
- $self;
+ # post-order:
+ $self->delete if ($self->is_empty or $self->_only_empty_content);
+ $self;
}
sub HTML::Element::newchild {
- my ($lol, $parent_label, @newchild)=@_;
-
- use Data::Rmap qw(rmap_array);
-
- my ($mapresult) = rmap_array {
-
-
- if ($_->[0] eq $parent_label) {
- $_ = [ $parent_label => @newchild ];
- Data::Rmap::cut($_);
- } else {
- $_;
- }
-
- } $lol;
-
- $mapresult;
-
+ my ($lol, $parent_label, @newchild) = @_;
+ rmap_array {
+ if ($_->[0] eq $parent_label) {
+ $_ = [ $parent_label => @newchild ];
+ Data::Rmap::cut($_);
+ } else {
+ $_;
+ }
+ } $lol;
}
sub HTML::Element::crunch {
- my $container = shift;
+ my $container = shift;
+
+ my %p = validate(@_, {
+ look_down => { type => ARRAYREF },
+ leave => { default => 1 },
+ });
- my %p = validate(@_, {
- look_down => { type => ARRAYREF },
- leave => { default => 1 },
- });
+ my @look_down = @{$p{look_down}} ;
+ my @elem = $container->look_down(@look_down) ;
- my @look_down = @{$p{look_down}} ;
- my @elem = $container->look_down( @look_down ) ;
-
- my $left;
-
- for my $elem (@elem) {
- $elem->detach if $left++ >= $p{leave} ;
- }
+ my $left;
+ for my $elem (@elem) {
+ $elem->detach if $left++ >= $p{leave};
+ }
}
sub HTML::Element::hash_map {
- my $container = shift;
-
- my %p = validate(@_, {
- hash => { type => HASHREF },
- to_attr => 1,
- excluding => { type => ARRAYREF , default => [] },
- debug => { default => 0 },
- });
-
- warn 'The container tag is ', $container->tag if $p{debug} ;
- warn 'hash' . Dumper($p{hash}) if $p{debug} ;
- #warn 'at_under' . Dumper(\@_) if $p{debug} ;
-
- my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ;
-
- warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ;
-
-
- for my $same_as (@same_as) {
- my $attr_val = $same_as->attr($p{to_attr}) ;
- if (first { $attr_val eq $_ } @{$p{excluding}}) {
- warn "excluding $attr_val" if $p{debug} ;
- next;
+ my $container = shift;
+
+ my %p = validate(@_, {
+ hash => { type => HASHREF },
+ to_attr => 1,
+ excluding => { type => ARRAYREF , default => [] },
+ debug => { default => 0 },
+ });
+
+ warn 'The container tag is ', $container->tag if $p{debug} ;
+ warn 'hash' . Dumper($p{hash}) if $p{debug} ;
+ #warn 'at_under' . Dumper(\@_) if $p{debug} ;
+
+ my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ;
+
+ warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ;
+
+ for my $same_as (@same_as) {
+ my $attr_val = $same_as->attr($p{to_attr}) ;
+ if (first { $attr_val eq $_ } @{$p{excluding}}) {
+ warn "excluding $attr_val" if $p{debug} ;
+ next;
+ }
+ warn "processing $attr_val" if $p{debug} ;
+ $same_as->replace_content($p{hash}->{$attr_val});
}
- warn "processing $attr_val" if $p{debug} ;
- $same_as->replace_content( $p{hash}->{$attr_val} ) ;
- }
-
}
sub HTML::Element::hashmap {
- my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
-
- $excluding ||= [] ;
+ my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
- $container->hash_map(hash => $hashref,
- to_attr => $attr_name,
- excluding => $excluding,
- debug => $debug);
+ $excluding ||= [] ;
+ $container->hash_map(hash => $hashref,
+ to_attr => $attr_name,
+ excluding => $excluding,
+ debug => $debug);
}
sub HTML::Element::passover {
- my ($tree, @to_preserve) = @_;
-
- warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
- warn $tree->as_HTML(undef, ' ') if $DEBUG;
+ my ($tree, @to_preserve) = @_;
- my $exodus = $tree->look_down(id => $to_preserve[0]);
+ warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
+ warn $tree->as_HTML(undef, ' ') if $DEBUG;
- warn "E: $exodus" if $DEBUG;
+ my $exodus = $tree->look_down(id => $to_preserve[0]);
- my @s = HTML::Element::siblings($exodus);
+ warn "E: $exodus" if $DEBUG;
- for my $s (@s) {
- next unless ref $s;
- if (first { $s->attr('id') eq $_ } @to_preserve) {
- ;
- } else {
- $s->delete;
- }
- }
+ my @s = HTML::Element::siblings($exodus);
- return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
+ for my $s (@s) {
+ next unless ref $s;
+ $s->delete unless first { $s->attr('id') eq $_ } @to_preserve;
+ }
+ return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
}
sub HTML::Element::sibdex {
-
- my $element = shift;
- firstidx { $_ eq $element } $element->siblings
-
+ my $element = shift;
+ firstidx { $_ eq $element } $element->siblings
}
sub HTML::Element::addr { goto &HTML::Element::sibdex }
sub HTML::Element::replace_content {
- my $elem = shift;
- $elem->delete_content;
- $elem->push_content(@_);
+ my $elem = shift;
+ $elem->delete_content;
+ $elem->push_content(@_);
}
sub HTML::Element::wrap_content {
- my($self, $wrap) = @_;
- my $content = $self->content;
- if (ref $content) {
- $wrap->push_content(@$content);
- @$content = ($wrap);
- }
- else {
- $self->push_content($wrap);
- }
- $wrap;
+ my($self, $wrap) = @_;
+ my $content = $self->content;
+ if (ref $content) {
+ $wrap->push_content(@$content);
+ @$content = ($wrap);
+ }
+ else {
+ $self->push_content($wrap);
+ }
+ $wrap;
}
sub HTML::Element::Library::super_literal {
- my($text) = @_;
-
- HTML::Element->new('~literal', text => $text);
+ my($text) = @_;
+ HTML::Element->new('~literal', text => $text);
}
-
sub HTML::Element::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;
+ # 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 HTML::Element::content_handler {
- my ($tree, %content_hash) = @_;
-
- for my $k (keys %content_hash) {
- $tree->set_child_content(id => $k, $content_hash{$k});
- }
+ my ($tree, %content_hash) = @_;
-
-}
-
-sub HTML::Element::assign {
- goto &HTML::Element::content_handler;
+ for my $k (keys %content_hash) {
+ $tree->set_child_content(id => $k, $content_hash{$k});
+ }
}
+sub HTML::Element::assign { goto &HTML::Element::content_handler }
sub make_counter {
- my $i = 1;
- sub {
- shift() . ':' . $i++
- }
+ my $i = 1;
+ sub {
+ shift() . ':' . $i++
+ }
}
-
sub HTML::Element::iter {
- my ($tree, $p, @data) = @_;
-
- # warn 'P: ' , $p->attr('id') ;
- # warn 'H: ' , $p->as_HTML;
+ my ($tree, $p, @data) = @_;
- # my $id_incr = make_counter;
- my @item = map {
- my $new_item = clone $p;
- $new_item->replace_content($_);
- $new_item;
- } @data;
+ # warn 'P: ' , $p->attr('id') ;
+ # warn 'H: ' , $p->as_HTML;
- $p->replace_with(@item);
+ # my $id_incr = make_counter;
+ my @item = map {
+ my $new_item = clone $p;
+ $new_item->replace_content($_);
+ $new_item;
+ } @data;
+ $p->replace_with(@item);
}
-
sub HTML::Element::iter2 {
-
- my $tree = shift;
-
- #warn "INPUT TO TABLE2: ", Dumper \@_;
-
- my %p = validate(
- @_, {
- wrapper_ld => { default => ['_tag' => 'dl'] },
- wrapper_data => 1,
- wrapper_proc => { default => undef },
- item_ld => { default => sub {
- my $tree = shift;
- [
- $tree->look_down('_tag' => 'dt'),
- $tree->look_down('_tag' => 'dd')
- ];
- }
+ my $tree = shift;
+
+ #warn "INPUT TO TABLE2: ", Dumper \@_;
+
+ my %p = validate(
+ @_, {
+ wrapper_ld => { default => ['_tag' => 'dl'] },
+ wrapper_data => 1,
+ wrapper_proc => { default => undef },
+ item_ld => {
+ default => sub {
+ my $tree = shift;
+ [
+ $tree->look_down('_tag' => 'dt'),
+ $tree->look_down('_tag' => 'dd')
+ ];
+ }},
+ item_data => {
+ default => sub {
+ my ($wrapper_data) = @_;
+ shift(@{$wrapper_data}) ;
+ }},
+ item_proc => {
+ default => sub {
+ my ($item_elems, $item_data, $row_count) = @_;
+ $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
+ $item_elems;
+ }},
+ splice => {
+ default => sub {
+ my ($container, @item_elems) = @_;
+ $container->splice_content(0, 2, @item_elems);
+ }
},
- item_data => { default => sub { my ($wrapper_data) = @_;
- shift(@{$wrapper_data}) ;
- }},
- item_proc => {
- default => sub {
- my ($item_elems, $item_data, $row_count) = @_;
- $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
- $item_elems;
- }},
- splice => { default => sub {
- my ($container, @item_elems) = @_;
- $container->splice_content(0, 2, @item_elems);
- }
- },
- debug => {default => 0}
- }
- );
-
- warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ;
+ debug => {default => 0}
+ }
+ );
- my $container = ref_or_ld($tree, $p{wrapper_ld});
- warn "container: " . $container if $p{debug} ;
- warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ;
- $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ;
- warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ;
+ warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ;
- my $_item_elems = $p{item_ld}->($container);
-
+ my $container = ref_or_ld($tree, $p{wrapper_ld});
+ warn "container: " . $container if $p{debug} ;
+ warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ;
+ $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ;
+ warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ;
+ my $_item_elems = $p{item_ld}->($container);
- my $row_count;
- my @item_elem;
- {
- my $item_data = $p{item_data}->($p{wrapper_data});
- last unless defined $item_data;
+ my $row_count;
+ my @item_elem;
+ while(1){
+ my $item_data = $p{item_data}->($p{wrapper_data});
+ last unless defined $item_data;
- warn Dumper("item_data", $item_data);
+ warn Dumper("item_data", $item_data);
+ my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
- my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
+ if ($p{debug}) {
+ for (@{$item_elems}) {
+ warn "ITEM_ELEMS ", $_->as_HTML;
+ }
+ }
- if ($p{debug}) {
- for (@{$item_elems}) {
- warn "ITEM_ELEMS ", $_->as_HTML;
- }
- }
+ my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);
- my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);
+ if ($p{debug}) {
+ for (@{$new_item_elems}) {
+ warn "NEWITEM_ELEMS ", $_->as_HTML;
+ }
+ }
- if ($p{debug}) {
- for (@{$new_item_elems}) {
- warn "NEWITEM_ELEMS ", $_->as_HTML;
- }
- }
-
-
- push @item_elem, @{$new_item_elems} ;
-
- redo;
- }
-
- warn "pushing " . @item_elem . " elems " if $p{debug} ;
+ push @item_elem, @{$new_item_elems} ;
+ }
- $p{splice}->($container, @item_elem);
+ warn "pushing " . @item_elem . " elems " if $p{debug} ;
+ $p{splice}->($container, @item_elem);
}
sub HTML::Element::dual_iter {
- my ($parent, $data) = @_;
+ my ($parent, $data) = @_;
- my ($prototype_a, $prototype_b) = $parent->content_list;
+ my ($prototype_a, $prototype_b) = $parent->content_list;
- # my $id_incr = make_counter;
+ # my $id_incr = make_counter;
- my $i;
+ my $i;
- @$data %2 == 0 or
- confess 'dataset does not contain an even number of members';
+ @$data %2 == 0 or confess 'dataset does not contain an even number of members';
- my @iterable_data = ngroup 2 => @$data;
+ my @iterable_data = ngroup 2 => @$data;
- my @item = map {
- my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ;
- $new_a->splice_content(0,1, $_->[0]);
- $new_b->splice_content(0,1, $_->[1]);
- #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
- ($new_a, $new_b)
- } @iterable_data;
-
- $parent->splice_content(0, 2, @item);
+ my @item = map {
+ my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ;
+ $new_a->splice_content(0,1, $_->[0]);
+ $new_b->splice_content(0,1, $_->[1]);
+ #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
+ ($new_a, $new_b)
+ } @iterable_data;
+ $parent->splice_content(0, 2, @item);
}
-
sub HTML::Element::set_child_content {
- my $tree = shift;
- my $content = pop;
- my @look_down = @_;
+ my $tree = shift;
+ my $content = pop;
+ my @look_down = @_;
- my $content_tag = $tree->look_down(@look_down);
+ my $content_tag = $tree->look_down(@look_down);
- unless ($content_tag) {
- warn "criteria [@look_down] not found";
- return;
- }
-
- $content_tag->replace_content($content);
+ unless ($content_tag) {
+ warn "criteria [@look_down] not found";
+ return;
+ }
+ $content_tag->replace_content($content);
}
sub HTML::Element::highlander {
- my ($tree, $local_root_id, $aref, @arg) = @_;
+ my ($tree, $local_root_id, $aref, @arg) = @_;
- ref $aref eq 'ARRAY' or confess
- "must supply array reference";
-
- my @aref = @$aref;
- @aref % 2 == 0 or confess
- "supplied array ref must have an even number of entries";
+ ref $aref eq 'ARRAY' or confess "must supply array reference";
- warn __PACKAGE__ if $DEBUG;
+ my @aref = @$aref;
+ @aref % 2 == 0 or confess "supplied array ref must have an even number of entries";
- my $survivor;
- while (my ($id, $test) = splice @aref, 0, 2) {
- warn $id if $DEBUG;
- if ($test->(@arg)) {
- $survivor = $id;
- last;
- }
- }
+ warn __PACKAGE__ if $DEBUG;
+ my $survivor;
+ while (my ($id, $test) = splice @aref, 0, 2) {
+ warn $id if $DEBUG;
+ if ($test->(@arg)) {
+ $survivor = $id;
+ last;
+ }
+ }
- my @id_survivor = (id => $survivor);
- my $survivor_node = $tree->look_down(@id_survivor);
-# warn $survivor;
-# warn $local_root_id;
-# warn $node;
+ my @id_survivor = (id => $survivor);
+ my $survivor_node = $tree->look_down(@id_survivor);
+ # warn $survivor;
+ # warn $local_root_id;
+ # warn $node;
- warn "survivor: $survivor" if $DEBUG;
- warn "tree: " . $tree->as_HTML if $DEBUG;
+ warn "survivor: $survivor" if $DEBUG;
+ warn "tree: " . $tree->as_HTML if $DEBUG;
- $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
+ $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
- my $survivor_node_parent = $survivor_node->parent;
- $survivor_node = $survivor_node->clone;
- $survivor_node_parent->replace_content($survivor_node);
+ my $survivor_node_parent = $survivor_node->parent;
+ $survivor_node = $survivor_node->clone;
+ $survivor_node_parent->replace_content($survivor_node);
- warn "new tree: " . $tree->as_HTML if $DEBUG;
+ warn "new tree: " . $tree->as_HTML if $DEBUG;
- $survivor_node;
+ $survivor_node;
}
-
sub HTML::Element::highlander2 {
- my $tree = shift;
-
- my %p = validate(@_, {
- cond => { type => ARRAYREF },
- cond_arg => { type => ARRAYREF,
- default => []
- },
- debug => { default => 0 }
- }
- );
-
-
- my @cond = @{$p{cond}};
- @cond % 2 == 0 or confess
- "supplied array ref must have an even number of entries";
-
- warn __PACKAGE__ if $p{debug};
-
- my @cond_arg = @{$p{cond_arg}};
-
- my $survivor; my $then;
- while (my ($id, $if_then) = splice @cond, 0, 2) {
-
- warn $id if $p{debug};
- my ($if, $_then);
-
- if (ref $if_then eq 'ARRAY') {
- ($if, $_then) = @$if_then;
- } else {
- ($if, $_then) = ($if_then, sub {});
- }
-
- if ($if->(@cond_arg)) {
- $survivor = $id;
- $then = $_then;
- last;
- }
-
- }
-
- my @ld = (ref $survivor eq 'ARRAY')
- ? @$survivor
- : (id => $survivor)
- ;
-
- warn "survivor: ", $survivor if $p{debug};
- warn "survivor_ld: ", Dumper \@ld if $p{debug};
-
-
- my $survivor_node = $tree->look_down(@ld);
-
- $survivor_node or confess
- "search for @ld failed in tree($tree): " . $tree->as_HTML;
-
- my $survivor_node_parent = $survivor_node->parent;
- $survivor_node = $survivor_node->clone;
- $survivor_node_parent->replace_content($survivor_node);
-
-
- # **************** NEW FUNCTIONALITY *******************
+ my $tree = shift;
+
+ my %p = validate(@_, {
+ cond => { type => ARRAYREF },
+ cond_arg => {
+ type => ARRAYREF,
+ default => []
+ },
+ debug => { default => 0 }
+ });
+
+ my @cond = @{$p{cond}};
+ @cond % 2 == 0 or confess "supplied array ref must have an even number of entries";
+
+ warn __PACKAGE__ if $p{debug};
+
+ my @cond_arg = @{$p{cond_arg}};
+
+ my $survivor; my $then;
+ while (my ($id, $if_then) = splice @cond, 0, 2) {
+ warn $id if $p{debug};
+ my ($if, $_then);
+
+ if (ref $if_then eq 'ARRAY') {
+ ($if, $_then) = @$if_then;
+ } else {
+ ($if, $_then) = ($if_then, sub {});
+ }
+
+ if ($if->(@cond_arg)) {
+ $survivor = $id;
+ $then = $_then;
+ last;
+ }
+ }
- # apply transforms on survivor node
+ my @ld = (ref $survivor eq 'ARRAY') ? @$survivor : (id => $survivor);
+ warn "survivor: ", $survivor if $p{debug};
+ warn "survivor_ld: ", Dumper \@ld if $p{debug};
- warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug};
- $then->($survivor_node, @cond_arg);
- warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug};
+ my $survivor_node = $tree->look_down(@ld);
- # **************** NEW FUNCTIONALITY *******************
+ $survivor_node or confess "search for @ld failed in tree($tree): " . $tree->as_HTML;
+ my $survivor_node_parent = $survivor_node->parent;
+ $survivor_node = $survivor_node->clone;
+ $survivor_node_parent->replace_content($survivor_node);
+ # **************** NEW FUNCTIONALITY *******************
+ # apply transforms on survivor node
+ warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug};
+ $then->($survivor_node, @cond_arg);
+ warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug};
+ # **************** NEW FUNCTIONALITY *******************
- $survivor_node;
+ $survivor_node;
}
-
sub overwrite_action {
- my ($mute_node, %X) = @_;
+ my ($mute_node, %X) = @_;
- $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
+ $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
}
-
sub HTML::Element::overwrite_attr {
- my $tree = shift;
-
- $tree->mute_elem(@_, \&overwrite_action);
-}
-
+ my $tree = shift;
+ $tree->mute_elem(@_, \&overwrite_action);
+}
sub HTML::Element::mute_elem {
- my ($tree, $mute_attr, $closures, $post_hook) = @_;
-
- warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
- my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
-
- for my $mute_node (@mute_node) {
- my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
- my $local_attr_value_current = $mute_node->attr($local_attr);
- my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
- $post_hook->(
- $mute_node,
- tree => $tree,
- local_attr => {
- name => $local_attr,
- value => {
- current => $local_attr_value_current,
- new => $local_attr_value_new
- }
- }
- ) if ($post_hook) ;
- }
+ my ($tree, $mute_attr, $closures, $post_hook) = @_;
+
+ warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
+ my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
+
+ for my $mute_node (@mute_node) {
+ my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
+ my $local_attr_value_current = $mute_node->attr($local_attr);
+ my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
+ $post_hook->(
+ $mute_node,
+ tree => $tree,
+ local_attr => {
+ name => $local_attr,
+ value => {
+ current => $local_attr_value_current,
+ new => $local_attr_value_new
+ }
+ }
+ ) if ($post_hook) ;
+ }
}
sub HTML::Element::table {
+ my ($s, %table) = @_;
+ my $table = {};
- my ($s, %table) = @_;
-
- my $table = {};
-
- # use Data::Dumper; warn Dumper \%table;
-
- # ++$DEBUG if $table{debug} ;
-
-
- # Get the table element
- $table->{table_node} = $s->look_down(id => $table{gi_table});
- $table->{table_node} or confess
- "table tag not found via (id => $table{gi_table}";
-
- # Get the prototype tr element(s)
- my @table_gi_tr = listify $table{gi_tr} ;
- my @iter_node = map
- {
- my $tr = $table->{table_node}->look_down(id => $_);
- $tr or confess "tr with id => $_ not found";
- $tr;
- } @table_gi_tr;
-
- warn "found " . @iter_node . " iter nodes " if $DEBUG;
- # tie my $iter_node, 'Tie::Cycle', \@iter_node;
- my $iter_node = List::Rotation::Cycle->new(@iter_node);
-
- # warn $iter_node;
- warn Dumper ($iter_node, \@iter_node) if $DEBUG;
+ # Get the table element
+ $table->{table_node} = $s->look_down(id => $table{gi_table});
+ $table->{table_node} or confess "table tag not found via (id => $table{gi_table}";
- # $table->{content} = $table{content};
- #$table->{parent} = $table->{table_node}->parent;
+ # Get the prototype tr element(s)
+ my @table_gi_tr = listify $table{gi_tr} ;
+ my @iter_node = map {
+ my $tr = $table->{table_node}->look_down(id => $_);
+ $tr or confess "tr with id => $_ not found";
+ $tr;
+ } @table_gi_tr;
+ warn "found " . @iter_node . " iter nodes " if $DEBUG;
+ my $iter_node = List::Rotation::Cycle->new(@iter_node);
- # $table->{table_node}->detach;
- # $_->detach for @iter_node;
+ # warn $iter_node;
+ warn Dumper ($iter_node, \@iter_node) if $DEBUG;
- my @table_rows;
+ # $table->{content} = $table{content};
+ # $table->{parent} = $table->{table_node}->parent;
- {
- my $row = $table{tr_data}->($table, $table{table_data});
- last unless defined $row;
+ # $table->{table_node}->detach;
+ # $_->detach for @iter_node;
- # get a sample table row and clone it.
- my $I = $iter_node->next;
- warn "I: $I" if $DEBUG;
- my $new_iter_node = $I->clone;
+ my @table_rows;
+ while (1) {
+ my $row = $table{tr_data}->($table, $table{table_data});
+ last unless defined $row;
- $table{td_data}->($new_iter_node, $row);
- push @table_rows, $new_iter_node;
+ # get a sample table row and clone it.
+ my $I = $iter_node->next;
+ warn "I: $I" if $DEBUG;
+ my $new_iter_node = $I->clone;
- redo;
- }
-
- if (@table_rows) {
-
- my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ;
- for (@table_gi_tr) {
- $s->look_down(id => $_)->detach;
- }
-
- $replace_with_elem->replace_with(@table_rows);
-
- }
+ $table{td_data}->($new_iter_node, $row);
+ push @table_rows, $new_iter_node;
+ }
+ if (@table_rows) {
+ my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ;
+ $s->look_down(id => $_)->detach for @table_gi_tr;
+ $replace_with_elem->replace_with(@table_rows);
+ }
}
sub ref_or_ld {
+ my ($tree, $slot) = @_;
- my ($tree, $slot) = @_;
-
- if (ref($slot) eq 'CODE') {
- $slot->($tree);
- } else {
- $tree->look_down(@$slot);
- }
+ if (ref($slot) eq 'CODE') {
+ $slot->($tree);
+ } else {
+ $tree->look_down(@$slot);
+ }
}
-
-
sub HTML::Element::table2 {
+ my $tree = shift;
+
+ my %p = validate(
+ @_, {
+ table_ld => { default => ['_tag' => 'table'] },
+ table_data => 1,
+ table_proc => { default => undef },
+ tr_ld => { default => ['_tag' => 'tr'] },
+ tr_data => {
+ default => sub {
+ my ($self, $data) = @_;
+ shift(@{$data}) ;
+ }},
+ tr_base_id => { default => undef },
+ tr_proc => { default => sub {} },
+ td_proc => 1,
+ debug => {default => 0}
+ }
+ );
+
+ warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug};
+ warn "table_data: " . Dumper $p{table_data} if $p{debug} ;
+
+ my $table = {};
+
+ # Get the table element
+ $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ;
+ $table->{table_node} or confess "table tag not found via " . Dumper($p{table_ld}) ;
+
+ warn "table: " . $table->{table_node}->as_HTML if $p{debug};
+
+ # Get the prototype tr element(s)
+ my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ;
+
+ warn "found " . @proto_tr . " iter nodes " if $p{debug};
+
+ return unless @proto_tr;
+
+ if ($p{debug}) {
+ warn $_->as_HTML for @proto_tr;
+ }
+ my $proto_tr = List::Rotation::Cycle->new(@proto_tr);
- my $tree = shift;
-
-
-
- my %p = validate(
- @_, {
- table_ld => { default => ['_tag' => 'table'] },
- table_data => 1,
- table_proc => { default => undef },
-
- tr_ld => { default => ['_tag' => 'tr'] },
- tr_data => { default => sub { my ($self, $data) = @_;
- shift(@{$data}) ;
- }},
- tr_base_id => { default => undef },
- tr_proc => { default => sub {} },
- td_proc => 1,
- debug => {default => 0}
- }
- );
-
- warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug};
-
- warn "table_data: " . Dumper $p{table_data} if $p{debug} ;
-
- my $table = {};
-
- # use Data::Dumper; warn Dumper \%table;
-
- # ++$DEBUG if $table{debug} ;
-
- # Get the table element
- #warn 1;
- $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ;
- #warn 2;
- $table->{table_node} or confess
- "table tag not found via " . Dumper($p{table_ld}) ;
-
- warn "table: " . $table->{table_node}->as_HTML if $p{debug};
-
-
- # Get the prototype tr element(s)
- my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ;
-
- warn "found " . @proto_tr . " iter nodes " if $p{debug};
-
- @proto_tr or return ;
-
- if ($p{debug}) {
- warn $_->as_HTML for @proto_tr;
- }
- my $proto_tr = List::Rotation::Cycle->new(@proto_tr);
-
- my $tr_parent = $proto_tr[0]->parent;
- warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug};
-
- my $row_count;
-
- my @table_rows;
-
- {
- my $row = $p{tr_data}->($table, $p{table_data}, $row_count);
- warn "data row: " . Dumper $row if $p{debug};
- last unless defined $row;
+ my $tr_parent = $proto_tr[0]->parent;
+ warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug};
- # wont work: my $new_iter_node = $table->{iter_node}->clone;
- my $new_tr_node = $proto_tr->next->clone;
- warn "new_tr_node: $new_tr_node" if $p{debug};
+ my $row_count;
- $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count)
- if defined $p{tr_proc};
+ my @table_rows;
- warn "data row redux: " . Dumper $row if $p{debug};
- #warn 3.3;
+ while(1) {
+ my $row = $p{tr_data}->($table, $p{table_data}, $row_count);
+ warn "data row: " . Dumper $row if $p{debug};
+ last unless defined $row;
- $p{td_proc}->($new_tr_node, $row);
- push @table_rows, $new_tr_node;
+ # wont work: my $new_iter_node = $table->{iter_node}->clone;
+ my $new_tr_node = $proto_tr->next->clone;
+ warn "new_tr_node: $new_tr_node" if $p{debug};
- #warn 4.4;
+ $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count) if defined $p{tr_proc};
- redo;
- }
+ warn "data row redux: " . Dumper $row if $p{debug};
- $_->detach for @proto_tr;
+ $p{td_proc}->($new_tr_node, $row);
+ push @table_rows, $new_tr_node;
+ }
- $tr_parent->push_content(@table_rows) if (@table_rows) ;
+ $_->detach for @proto_tr;
+ $tr_parent->push_content(@table_rows) if (@table_rows) ;
}
-
sub HTML::Element::unroll_select {
+ my ($s, %select) = @_;
- my ($s, %select) = @_;
-
- my $select = {};
-
- warn "Select Hash: " . Dumper(\%select) if $select{debug};
-
- my $select_node = $s->look_down(id => $select{select_label});
- warn "Select Node: " . $select_node if $select{debug};
-
- unless ($select{append}) {
- for my $option ($select_node->look_down('_tag' => 'option')) {
- $option->delete;
- }
- }
+ my $select = {};
+ warn "Select Hash: " . Dumper(\%select) if $select{debug};
+ my $select_node = $s->look_down(id => $select{select_label});
+ warn "Select Node: " . $select_node if $select{debug};
- my $option = HTML::Element->new('option');
- warn "Option Node: " . $option if $select{debug};
-
- $option->detach;
+ unless ($select{append}) {
+ for my $option ($select_node->look_down('_tag' => 'option')) {
+ $option->delete;
+ }
+ }
- while (my $row = $select{data_iter}->($select{data}))
- {
- warn "Data Row:" . Dumper($row) if $select{debug};
- my $o = $option->clone;
- $o->attr('value', $select{option_value}->($row));
- $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)) ;
+ my $option = HTML::Element->new('option');
+ warn "Option Node: " . $option if $select{debug};
- $o->replace_content($select{option_content}->($row));
- $select_node->push_content($o);
- warn $o->as_HTML if $select{debug};
- }
+ $option->detach;
+ while (my $row = $select{data_iter}->($select{data})) {
+ warn "Data Row:" . Dumper($row) if $select{debug};
+ my $o = $option->clone;
+ $o->attr('value', $select{option_value}->($row));
+ $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row));
+ $o->replace_content($select{option_content}->($row));
+ $select_node->push_content($o);
+ warn $o->as_HTML if $select{debug};
+ }
}
-
-
sub HTML::Element::set_sibling_content {
- my ($elt, $content) = @_;
-
- $elt->parent->splice_content($elt->pindex + 1, 1, $content);
+ my ($elt, $content) = @_;
+ $elt->parent->splice_content($elt->pindex + 1, 1, $content);
}
sub HTML::TreeBuilder::parse_string {
- my ($package, $string) = @_;
-
- my $h = HTML::TreeBuilder->new;
- HTML::TreeBuilder->parse($string);
+ my ($package, $string) = @_;
+ my $h = HTML::TreeBuilder->new;
+ HTML::TreeBuilder->parse($string);
}
-
-
1;
__END__
projects / html-element-library.git / commitdiff