package HTML::Element::Library;
-
-use 5.006001;
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();
-
-
-
-our $VERSION = '3.53';
-
-
-
-# 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)=@_;
-
- use HTML::FillInForm;
- my $html = $tree->as_HTML;
- my $new_html = HTML::FillInForm->fill(\$html, $hashref);
+ my $html = $tree->as_HTML;
+ my $new_html = HTML::FillInForm->fill(\$html, $hashref);
+ if ($return_tree) {
+ $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;
+
+ scalar @c == 1 and not length $c[0];
}
+sub HTML::Element::prune {
+ my ($self) = @_;
+
+ for my $c ($self->content_list) {
+ next unless ref $c;
+ $c->prune;
+ }
-sub HTML::Element::hash_map {
- my $container = shift;
+ # post-order:
+ $self->delete if ($self->is_empty or $self->_only_empty_content);
+ $self;
+}
- my %p = validate(@_, {
- hash => { type => HASHREF },
- to_attr => 1,
- excluding => { type => ARRAYREF , default => [] },
- debug => { default => 0 },
- });
+sub HTML::Element::newchild {
+ my ($lol, $parent_label, @newchild) = @_;
+ rmap_array {
+ if ($_->[0] eq $parent_label) {
+ $_ = [ $parent_label => @newchild ];
+ Data::Rmap::cut($_);
+ } else {
+ $_;
+ }
+ } $lol;
+}
- 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} ;
+sub HTML::Element::crunch { ## no critic (RequireArgUnpacking)
+ my $container = shift;
- my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ;
+ my %p = validate(@_, {
+ look_down => { type => ARRAYREF },
+ leave => { default => 1 },
+ });
- warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ;
+ my @look_down = @{$p{look_down}} ;
+ my @elem = $container->look_down(@look_down) ;
+ my $detached;
- 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;
+ for my $elem (@elem) {
+ $elem->detach if $detached++ >= $p{leave};
}
- warn "processing $attr_val" if $p{debug} ;
- $same_as->replace_content( $p{hash}->{$attr_val} ) ;
- }
+}
+
+sub HTML::Element::hash_map { ## no critic (RequireArgUnpacking)
+ 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/.+/s ) ;
+
+ 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});
+ }
}
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) = @_;
+ 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) = @_;
+ my ($tree, $p, @data) = @_;
- # warn 'P: ' , $p->attr('id') ;
- # warn 'H: ' , $p->as_HTML;
+ # warn 'P: ' , $p->attr('id') ;
+ # warn 'H: ' , $p->as_HTML;
- # my $id_incr = make_counter;
- my @item = map {
- my $new_item = clone $p;
- $new_item->replace_content($_);
- $new_item;
- } @data;
-
- $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')
- ];
- }
- },
- 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);
- }
+sub HTML::Element::iter2 { ## no critic (RequireArgUnpacking)
+ 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 $tr = shift;
+ [
+ $tr->look_down('_tag' => 'dt'),
+ $tr->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);
+ }
},
- debug => {default => 0}
- }
- );
+ debug => {default => 0}
+ }
+ );
- warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ;
+ warn 'wrapper_data: ' . Dumper $p{wrapper_data} if $p{debug} ;
- 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 $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 $_item_elems = $p{item_ld}->($container);
+ my $row_count;
+ my @item_elem;
+ while(1){
+ my $item_data = $p{item_data}->($p{wrapper_data});
+ last unless defined $item_data;
- my $row_count;
- my @item_elem;
- {
- my $item_data = $p{item_data}->($p{wrapper_data});
- last unless defined $item_data;
+ warn Dumper('item_data', $item_data) if $p{debug};
- warn Dumper("item_data", $item_data);
+ my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
+ if ($p{debug}) {
+ for (@{$item_elems}) {
+ warn 'ITEM_ELEMS ', $_->as_HTML if $p{debug};
+ }
+ }
- my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
+ my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);
- if ($p{debug}) {
- for (@{$item_elems}) {
- warn "ITEM_ELEMS ", $_->as_HTML;
- }
- }
-
- 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;
- }
- }
-
-
- push @item_elem, @{$new_item_elems} ;
-
- redo;
- }
+ if ($p{debug}) {
+ for (@{$new_item_elems}) {
+ warn 'NEWITEM_ELEMS ', $_->as_HTML if $p{debug};
+ }
+ }
- 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 ($prototype_a, $prototype_b) = $parent->content_list;
+ my ($parent, $data) = @_;
- # my $id_incr = make_counter;
+ my ($prototype_a, $prototype_b) = $parent->content_list;
- my $i;
+ # my $id_incr = make_counter;
- @$data %2 == 0 or
- confess 'dataset does not contain an even number of members';
+ my $i;
- my @iterable_data = ngroup 2 => @$data;
+ @$data %2 == 0 or confess 'dataset does not contain an even number of members';
- 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;
+ my @iterable_data = ngroup 2 => @$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 { ## no critic (RequireArgUnpacking)
+ my $tree = shift;
+ my $content = pop;
+ my @look_down = @_;
-sub HTML::Element::set_child_content {
- 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) = @_;
-
- 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";
-
- 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 ($tree, $local_root_id, $aref, @arg) = @_;
+ ref $aref eq 'ARRAY' or confess 'must supply array reference';
- my @id_survivor = (id => $survivor);
- my $survivor_node = $tree->look_down(@id_survivor);
-# warn $survivor;
-# warn $local_root_id;
-# warn $node;
+ my @aref = @$aref;
+ @aref % 2 == 0 or confess 'supplied array ref must have an even number of entries';
- warn "survivor: $survivor" if $DEBUG;
- warn "tree: " . $tree->as_HTML if $DEBUG;
+ warn __PACKAGE__ if $DEBUG;
- $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);
-
- warn "new tree: " . $tree->as_HTML if $DEBUG;
-
- $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)
- ;
+ my $survivor;
+ while (my ($id, $test) = splice @aref, 0, 2) {
+ warn $id if $DEBUG;
+ if ($test->(@arg)) {
+ $survivor = $id;
+ last;
+ }
+ }
- warn "survivor: ", $survivor if $p{debug};
- warn "survivor_ld: ", Dumper \@ld if $p{debug};
+ 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;
- my $survivor_node = $tree->look_down(@ld);
+ $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
- $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);
- 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;
+ $survivor_node;
+}
- # **************** NEW FUNCTIONALITY *******************
+sub HTML::Element::highlander2 { ## no critic (RequireArgUnpacking)
+ 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) = @_;
+
+ my @mute_node = $tree->look_down($mute_attr => qr/.*/s) ;
+
+ for my $mute_node (@mute_node) {
+ my ($local_attr,$mute_key) = split /\s+/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;
+ # 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}";
- 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);
+ # 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 $iter_node;
- warn Dumper ($iter_node, \@iter_node) if $DEBUG;
+ warn 'found ' . @iter_node . ' iter nodes ' if $DEBUG;
+ my $iter_node = List::Rotation::Cycle->new(@iter_node);
- # $table->{content} = $table{content};
- #$table->{parent} = $table->{table_node}->parent;
+ # warn $iter_node;
+ warn Dumper ($iter_node, \@iter_node) if $DEBUG;
+ # $table->{content} = $table{content};
+ # $table->{parent} = $table->{table_node}->parent;
- # $table->{table_node}->detach;
- # $_->detach for @iter_node;
+ # $table->{table_node}->detach;
+ # $_->detach for @iter_node;
- my @table_rows;
+ my @table_rows;
- {
- my $row = $table{tr_data}->($table, $table{table_data});
- last unless defined $row;
+ while (1) {
+ my $row = $table{tr_data}->($table, $table{table_data});
+ last unless defined $row;
- # get a sample table row and clone it.
- my $I = $iter_node->next;
- warn "I: $I" if $DEBUG;
- my $new_iter_node = $I->clone;
+ # get a sample table row and clone it.
+ my $I = $iter_node->next;
+ warn "I: $I" if $DEBUG;
+ my $new_iter_node = $I->clone;
+ $table{td_data}->($new_iter_node, $row);
+ push @table_rows, $new_iter_node;
+ }
- $table{td_data}->($new_iter_node, $row);
- push @table_rows, $new_iter_node;
-
- 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);
-
- }
-
+ 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 { ## no critic (RequireArgUnpacking)
+ 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}
+ }
+ );
-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 'INPUT TO TABLE2: ', Dumper \@_ if $p{debug};
+ warn 'table_data: ' . Dumper $p{table_data} if $p{debug} ;
- warn "table_data: " . Dumper $p{table_data} if $p{debug} ;
+ my $table = {};
- 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}) ;
- # use Data::Dumper; warn Dumper \%table;
+ warn 'table: ' . $table->{table_node}->as_HTML if $p{debug};
- # ++$DEBUG if $table{debug} ;
+ # Get the prototype tr element(s)
+ my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ;
- # 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 'found ' . @proto_tr . ' iter nodes' if $p{debug};
- warn "table: " . $table->{table_node}->as_HTML 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);
- # 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__
-# Below is stub documentation for your module. You'd better edit it!
+
+=encoding utf-8
=head1 NAME
=head1 DESCRIPTION
-This method provides API calls for common actions on trees when using
-L<HTML::Tree>.
+HTML:::Element::Library provides extra methods for HTML::Element.
=head1 METHODS
-The test suite contains examples of each of these methods in a
-file C<t/$method.t>
-
=head2 Positional Querying Methods
=head3 $elem->siblings
=head3 $elem->sibdex
-Return the index of C<$elem> into the array of siblings of which it is
-a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
-that is a descriptive name. And such naming is deceptively close to the
-C<address> function of C<HTML::Element>. HOWEVER, in the interest of
-backwards compatibility, both methods are available.
+Return the index of C<$elem> into the array of siblings of which it is
+a part. L<HTML::ElementSuper> calls this method C<addr> but I don't
+think that is a descriptive name. And such naming is deceptively close
+to the C<address> function of C<HTML::Element>. HOWEVER, in the
+interest of backwards compatibility, both methods are available.
=head3 $elem->addr
=head3 $elem->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.
+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.
=head2 Element Decoration Methods
text which does not get escaped. Great for includng Javascript in
HTML. Also great for including foreign language into a document.
-So, you basically toss C<super_literal> your text and back comes
-your text wrapped in a C<~literal> element.
+So, you basically toss C<super_literal> your text and back comes your
+text wrapped in a C<~literal> element.
One of these days, I'll around to writing a nice C<EXPORT> section.
=head2 Tree Rewriting Methods
+=head3 "de-prepping" HTML
+
+Oftentimes, the HTML to be worked with will have multiple sample rows:
+
+ <OL>
+ <LI>bread
+ <LI>butter
+ <LI>beer
+ <LI>bacon
+ </OL>
+
+But, before you begin to rewrite the HTML with your model data, you
+typically only want 1 or 2 sample rows.
+
+Thus, you want to "crunch" the multiple sample rows to a specified
+amount. Hence the C<crunch> method:
+
+ $tree->crunch(look_down => [ '_tag' => 'li' ], leave => 2) ;
+
+The C<leave> argument defaults to 1 if not given. The call above would
+"crunch" the above 4 sample rows to:
+
+ <OL>
+ <LI>bread
+ <LI>butter
+ </OL>
+
=head3 Simplifying calls to HTML::FillInForm
-Since HTML::FillInForm gets and returns strings, using HTML::Element instances
-becomes tedious:
+Since HTML::FillInForm gets and returns strings, using HTML::Element
+instances becomes tedious:
1. Seamstress has an HTML tree that it wants the form filled in on
2. Seamstress converts this tree to a string
3. FillInForm parses the string into an HTML tree and then fills in the form
4. FillInForm converts the HTML tree to a string
- 5. Seamstress re-parses the HTML for additional processing
+ 5. Seamstress re-parses the HTML for additional processing
I've filed a bug about this:
L<https://rt.cpan.org/Ticket/Display.html?id=44105>
-This function, fillinform,
-allows you to pass a tree to fillinform (along with your data structure) and
-get back a tree:
+This function, fillinform, allows you to pass a tree to fillinform
+(along with your data structure) and get back a tree:
- my $new_tree = $html_tree->fillinform($data_structure);
-
+ my $new_tree = $html_tree->fillinform($data_structure);
=head3 Mapping a hashref to HTML elements
-It is very common to get a hashref of data from some external source - flat file, database, XML, etc.
-Therefore, it is important to have a convenient way of mapping this data to HTML.
+It is very common to get a hashref of data from some external source -
+flat file, database, XML, etc. Therefore, it is important to have a
+convenient way of mapping this data to HTML.
-As it turns out, there are 3 ways to do this in HTML::Element::Library.
-The most strict and structured way to do this is with
-C<content_handler>. Two other methods, C<hashmap> and C<datamap> require less manual mapping and may prove
-even more easy to use in certain cases.
+As it turns out, there are 3 ways to do this in
+HTML::Element::Library. The most strict and structured way to do this
+is with C<content_handler>. Two other methods, C<hashmap> and
+C<datamap> require less manual mapping and may prove even more easy to
+use in certain cases.
-As is usual with Perl, a practical example is always best. So let's take some sample HTML:
+As is usual with Perl, a practical example is always best. So let's
+take some sample HTML:
<h1>user data</h1>
<span id="name">?</span>
$tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ;
+In this case, you manually state the mapping between id tags and
+hashref keys and then C<content_handler> retrieves the hashref data
+and pops it in the specified place.
-In this case, you manually state the mapping between id tags and hashref keys and
-then C<content_handler> retrieves the hashref data and pops it in the specified place.
-
-Now let's look at the two (actually 2 and a half) other hash-mapping methods.
+Now let's look at the two (actually 2 and a half) other hash-mapping
+methods.
$tree->hashmap(id => $ref);
-Now, what this function does is super-destructive. It finds every element in the tree
-with an attribute named id (since 'id' is a parameter, it could find every element with
-some other attribute also) and replaces the content of those elements with the hashref
-value.
+Now, what this function does is super-destructive. It finds every
+element in the tree with an attribute named id (since 'id' is a
+parameter, it could find every element with some other attribute also)
+and replaces the content of those elements with the hashref value.
-So, in the case above, the
+So, in the case above, the
- <span id="name">?</span>
+ <span id="name">?</span>
would come out as
- <span id="name"></span>
+ <span id="name"></span>
-(it would be blank) - because there is nothing in the hash with that value, so it substituted
+(it would be blank) - because there is nothing in the hash with that
+value, so it substituted
- $ref->{name}
+ $ref->{name}
which was blank and emptied the contents.
-Now, let's assume we want to protect name from being auto-assigned. Here is what you do:
+Now, let's assume we want to protect name from being auto-assigned.
+Here is what you do:
$tree->hashmap(id => $ref, ['name']);
-That last array ref is an exclusion list.
+That last array ref is an exclusion list.
-But wouldnt it be nice if you could do a hashmap, but only assigned things which are defined
-in the hashref? C<< defmap() >> to the rescue:
+But wouldnt it be nice if you could do a hashmap, but only assigned
+things which are defined in the hashref? C<< defmap() >> to the
+rescue:
$tree->defmap(id => $ref);
-does just that, so
+does just that, so
- <span id="name">?</span>
+ <span id="name">?</span>
would be left alone.
-
=head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
-This method is designed to take a hashref and populate a series of elements. For example:
-
+This method is designed to take a hashref and populate a series of
+elements. For example:
<table>
<tr sclass="tr" class="alt" align="left" valign="top">
</tr>
</table>
-In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
+In the table above, there are several attributes named C<< smap >>. If
+we have a hashref whose keys are the same:
my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
-Then a single API call allows us to populate the HTML while excluding those ones we dont:
+Then a single API call allows us to populate the HTML while excluding
+those ones we dont:
$tree->hashmap(smap => \%data, ['password']);
+Note: the other way to prevent rendering some of the hash mapping is
+to not give that element the attr you plan to use for hash mapping.
-Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
-you plan to use for hash mapping.
-
-Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
-(which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
+Also note: the function C<< hashmap >> has a simple easy-to-type API.
+Interally, it calls C<< hash_map >> (which has a more verbose keyword
+calling API). Thus, the above call to C<hashmap()> results in this
+call:
$tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
C<defmap> was described above.
-
-=head4 $elem->content_handler(%hashref)
-
-C<content_handler> is described below.
-
-
=head3 $elem->replace_content(@new_elem)
-Replaces all of C<$elem>'s content with C<@new_elem>.
+Replaces all of C<$elem>'s content with C<@new_elem>.
=head3 $elem->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.
+Wraps the existing content in the provided element. If the provided
+element happens to be a non-element, a push_content is performed
+instead.
=head3 $elem->set_child_content(@look_down, $content)
- This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
+This method looks down $tree using the criteria specified in
+@look_down using the the HTML::Element look_down() method.
-After finding the node, it detaches the node's content and pushes $content as the node's content.
+After finding the node, it detaches the node's content and pushes
+$content as the node's content.
=head3 $tree->content_handler(%id_content)
-This is a convenience method. Because the look_down criteria will often simply be:
+This is a convenience method. Because the look_down criteria will
+often simply be:
- id => 'fixme'
+ id => 'fixme'
to find things like:
-
<a id=fixme href=http://www.somesite.org>replace_content</a>
+ <a id=fixme href=http://www.somesite.org>replace_content</a>
-You can call this method to shorten your typing a bit. You can simply type
+You can call this method to shorten your typing a bit. You can simply
+type
- $elem->content_handler( fixme => 'new text' )
+ $elem->content_handler( fixme => 'new text' )
Instead of typing:
- $elem->set_child_content(sid => 'fixme', 'new text')
+ $elem->set_child_content(sid => 'fixme', 'new text')
-ALSO NOTE: you can pass a hash whose keys are C<id>s and whose values are the content you want there and it will perform the replacement on each hash member:
+ALSO NOTE: you can pass a hash whose keys are C<id>s and whose values
+are the content you want there and it will perform the replacement on
+each hash member:
- my %id_content = (name => "Terrence Brannon",
+ my %id_content = (name => "Terrence Brannon",
email => 'tbrannon@in.com',
- balance => 666,
- content => $main_content);
-
- $tree->content_handler(%id_content);
+ balance => 666,
+ content => $main_content);
+ $tree->content_handler(%id_content);
=head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
-This allows for "if-then-else" style processing. Highlander was a movie in
-which only one would survive. Well, in terms of a tree when looking at a
-structure that you want to process in C<if-then-else> style, only one child
-will survive. For example, given this HTML template:
-
- <span klass="highlander" id="age_dialog">
- <span id="under10">
- Hello, does your mother know you're
- using her AOL account?
- </span>
- <span id="under18">
- Sorry, you're not old enough to enter
- (and too dumb to lie about your age)
- </span>
- <span id="welcome">
- Welcome
- </span>
- </span>
-
-We only want one child of the C<span> tag with id C<age_dialog> to remain
-based on the age of the person visiting the page.
-
-So, let's setup a call that will prune the subtree as a function of age:
+This allows for "if-then-else" style processing. Highlander was a
+movie in which only one would survive. Well, in terms of a tree when
+looking at a structure that you want to process in C<if-then-else>
+style, only one child will survive. For example, given this HTML
+template:
+
+ <span klass="highlander" id="age_dialog">
+ <span id="under10">
+ Hello, does your mother know you're
+ using her AOL account?
+ </span>
+ <span id="under18">
+ Sorry, you're not old enough to enter
+ (and too dumb to lie about your age)
+ </span>
+ <span id="welcome">
+ Welcome
+ </span>
+ </span>
+
+We only want one child of the C<span> tag with id C<age_dialog> to
+remain based on the age of the person visiting the page.
+
+So, let's setup a call that will prune the subtree as a function of
+age:
sub process_page {
my $age = shift;
$tree->highlander
(age_dialog =>
[
- under10 => sub { $_[0] < 10} ,
- under18 => sub { $_[0] < 18} ,
+ under10 => sub { $_[0] < 10},
+ under18 => sub { $_[0] < 18},
welcome => sub { 1 }
],
$age
);
-And there we have it. If the age is less than 10, then the node with
-id C<under10> remains. For age less than 18, the node with id C<under18>
-remains.
-Otherwise our "else" condition fires and the child with id C<welcome> remains.
+And there we have it. If the age is less than 10, then the node with
+id C<under10> remains. For age less than 18, the node with id
+C<under18> remains. Otherwise our "else" condition fires and the child
+with id C<welcome> remains.
=head3 $tree->passover(@id_of_element)
-In some cases, you know exactly which element(s) should survive. In this case,
-you can simply call C<passover> to remove it's (their) siblings. For the HTML
-above, you could delete C<under10> and C<welcome> by simply calling:
+In some cases, you know exactly which element(s) should survive. In
+this case, you can simply call C<passover> to remove it's (their)
+siblings. For the HTML above, you could delete C<under10> and
+C<welcome> by simply calling:
$tree->passover('under18');
-Because passover takes an array, you can specify several children to preserve.
+Because passover takes an array, you can specify several children to
+preserve.
=head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
-Right around the same time that C<table2()> came into being, Seamstress
-began to tackle tougher and tougher processing problems. It became clear that
-a more powerful highlander was needed... one that not only snipped the tree
-of the nodes that should not survive, but one that allows for
-post-processing of the survivor node. And one that was more flexible with
-how to find the nodes to snip.
+Right around the same time that C<table2()> came into being,
+Seamstress began to tackle tougher and tougher processing problems. It
+became clear that a more powerful highlander was needed... one that
+not only snipped the tree of the nodes that should not survive, but
+one that allows for post-processing of the survivor node. And one that
+was more flexible with how to find the nodes to snip.
Thus (drum roll) C<highlander2()>.
</span>
</span>
-In this case, a branch survives, but it has dummy data in it. We must take
-the surviving segment of HTML and rewrite the age C<span> with the age.
-Here is how we use C<highlander2()> to do so:
+In this case, a branch survives, but it has dummy data in it. We must
+take the surviving segment of HTML and rewrite the age C<span> with
+the age. Here is how we use C<highlander2()> to do so:
- sub replace_age {
- my $branch = shift;
- my $age = shift;
- $branch->look_down(id => 'age')->replace_content($age);
- }
+ sub replace_age {
+ my $branch = shift;
+ my $age = shift;
+ $branch->look_down(id => 'age')->replace_content($age);
+ }
- my $if_then = $tree->look_down(id => 'age_dialog');
+ my $if_then = $tree->look_down(id => 'age_dialog');
$if_then->highlander2(
cond => [
under10 => [
- sub { $_[0] < 10} ,
- \&replace_age
+ sub { $_[0] < 10} ,
+ \&replace_age
],
under18 => [
- sub { $_[0] < 18} ,
- \&replace_age
+ sub { $_[0] < 18} ,
+ \&replace_age
],
welcome => [
- sub { 1 },
- \&replace_age
+ sub { 1 },
+ \&replace_age
]
],
cond_arg => [ $age ]
- );
+ );
-We pass it the tree (C<$if_then>), an arrayref of conditions
-(C<cond>) and an arrayref of arguments which are passed to the
-C<cond>s and to the replacement subs.
+We pass it the tree (C<$if_then>), an arrayref of conditions (C<cond>)
+and an arrayref of arguments which are passed to the C<cond>s and to
+the replacement subs.
The C<under10>, C<under18> and C<welcome> are id attributes in the
-tree of the siblings of which only one will survive. However,
-should you need to do
-more complex look-downs to find the survivor,
-then supply an array ref instead of a simple
-scalar:
-
+tree of the siblings of which only one will survive. However, should
+you need to do more complex look-downs to find the survivor, then
+supply an array ref instead of a simple scalar:
$if_then->highlander2(
cond => [
[class => 'r12'] => [
- sub { $_[0] < 10} ,
- \&replace_age
+ sub { $_[0] < 10} ,
+ \&replace_age
],
[class => 'z22'] => [
- sub { $_[0] < 18} ,
- \&replace_age
+ sub { $_[0] < 18} ,
+ \&replace_age
],
[class => 'w88'] => [
- sub { 1 },
- \&replace_age
+ sub { 1 },
+ \&replace_age
]
],
cond_arg => [ $age ]
- );
-
+ );
=head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
-This method is designed for taking a tree and reworking a set of nodes in
-a stereotyped fashion. For instance let's say you have 3 remote image
-archives, but you don't want to put long URLs in your img src
-tags for reasons of abstraction, re-use and brevity. So instead you do this:
+This method is designed for taking a tree and reworking a set of nodes
+in a stereotyped fashion. For instance let's say you have 3 remote
+image archives, but you don't want to put long URLs in your img src
+tags for reasons of abstraction, re-use and brevity. So instead you do
+this:
<img src="/img/smiley-face.jpg" fixup="src lnc">
<img src="/img/hot-babe.jpg" fixup="src playboy">
=head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
-This is a generalization of C<overwrite_attr>. C<overwrite_attr>
-assumes the return value of the
-closure is supposed overwrite an attribute value and does it for you.
-C<mute_elem> is a more general function which does nothing but
-hand the closure the element and let it mutate it as it jolly well pleases :)
-
-In fact, here is the implementation of C<overwrite_attr>
-to give you a taste of how C<mute_attr> is used:
+This is a generalization of C<overwrite_attr>. C<overwrite_attr>
+assumes the return value of the closure is supposed overwrite an
+attribute value and does it for you. C<mute_elem> is a more general
+function which does nothing but hand the closure the element and let
+it mutate it as it jolly well pleases :)
- sub overwrite_action {
- my ($mute_node, %X) = @_;
+In fact, here is the implementation of C<overwrite_attr> to give you a
+taste of how C<mute_attr> is used:
- $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
- }
+ sub overwrite_action {
+ my ($mute_node, %X) = @_;
-
- sub HTML::Element::overwrite_attr {
- my $tree = shift;
-
- $tree->mute_elem(@_, \&overwrite_action);
- }
+ $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);
+ }
=head2 Tree-Building Methods
-
-
=head3 Unrolling an array via a single sample element (<ul> container)
This is best described by example. Given this HTML:
To produce this:
-
<html>
<head></head>
<body>Here are the things I need from the store:
</html>
Now, you might be wondering why the API call is:
-
+
$tree->iter($li => @items)
instead of:
$li->iter(@items)
-and there is no good answer. The latter would be more concise and it is what I
-should have done.
+and there is no good answer. The latter would be more concise and it
+is what I should have done.
=head3 Unrolling an array via n sample elements (<dl> container)
-C<iter()> was fine for awhile, but some things
-(e.g. definition lists) need a more general function to make them easy to
-do. Hence C<iter2()>. This function will be explained by example of unrolling
-a simple definition list.
+C<iter()> was fine for awhile, but some things (e.g. definition lists)
+need a more general function to make them easy to do. Hence
+C<iter2()>. This function will be explained by example of unrolling a
+simple definition list.
So here's our mock-up HTML from the designer:
- <dl class="dual_iter" id="service_plan">
- <dt>
- Artist
- </dt>
- <dd>
- A person who draws blood.
- </dd>
+ <dl class="dual_iter" id="service_plan">
+ <dt>Artist</dt>
+ <dd>A person who draws blood.</dd>
- <dt>
- Musician
- </dt>
- <dd>
- A clone of Iggy Pop.
- </dd>
+ <dt>Musician</dt>
+ <dd>A clone of Iggy Pop.</dd>
- <dt>
- Poet
- </dt>
- <dd>
- A relative of Edgar Allan Poe.
- </dd>
+ <dt>Poet</dt>
+ <dd>A relative of Edgar Allan Poe.</dd>
- <dt class="adstyle">sample header</dt>
- <dd class="adstyle2">sample data</dd>
-
- </dl>
+ <dt class="adstyle">sample header</dt>
+ <dd class="adstyle2">sample data</dd>
+</dl>
And we want to unroll our data set:
- my @items = (
- ['the pros' => 'never have to worry about service again'],
- ['the cons' => 'upfront extra charge on purchase'],
- ['our choice' => 'go with the extended service plan']
- );
+ my @items = (
+ ['the pros' => 'never have to worry about service again'],
+ ['the cons' => 'upfront extra charge on purchase'],
+ ['our choice' => 'go with the extended service plan']
+ );
-Now, let's make this problem a bit harder to show off the power of C<iter2()>.
-Let's assume that we want only the last <dt> and it's accompanying <dd>
-(the one with "sample data") to be used as the sample data
-for unrolling with our data set. Let's further assume that we want them to
-remain in the final output.
+Now, let's make this problem a bit harder to show off the power of
+C<iter2()>. Let's assume that we want only the last <dt> and it's
+accompanying <dd> (the one with "sample data") to be used as the
+sample data for unrolling with our data set. Let's further assume that
+we want them to remain in the final output.
-So now, the API to C<iter2()> will be discussed and we will explain how our
-goal of getting our data into HTML fits into the API.
+So now, the API to C<iter2()> will be discussed and we will explain
+how our goal of getting our data into HTML fits into the API.
=over 4
=item * wrapper_ld
-This is how to look down and find the container of all the elements we will
-be unrolling. The <dl> tag is the container for the dt and dd tags we will be
-unrolling.
+This is how to look down and find the container of all the elements we
+will be unrolling. The <dl> tag is the container for the dt and dd
+tags we will be unrolling.
-If you pass an anonymous subroutine, then it is presumed that execution of
-this subroutine will return the HTML::Element representing the container tag.
-If you pass an array ref, then this will be dereferenced and passed to
-C<HTML::Element::look_down()>.
+If you pass an anonymous subroutine, then it is presumed that
+execution of this subroutine will return the HTML::Element
+representing the container tag. If you pass an array ref, then this
+will be dereferenced and passed to C<HTML::Element::look_down()>.
default value: C<< ['_tag' => 'dl'] >>
-Based on the mock HTML above, this default is fine for finding our container
-tag. So let's move on.
+Based on the mock HTML above, this default is fine for finding our
+container tag. So let's move on.
=item * wrapper_data
-This is an array reference of data that we will be putting into the container.
-You must supply this. C<@items> above is our C<wrapper_data>.
+This is an array reference of data that we will be putting into the
+container. You must supply this. C<@items> above is our
+C<wrapper_data>.
=item * wrapper_proc
-After we find the container via C<wrapper_ld>, we may want to pre-process
-some aspect of this tree. In our case the first two sets of dt and dd need
-to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
-which will do this.
+After we find the container via C<wrapper_ld>, we may want to
+pre-process some aspect of this tree. In our case the first two sets
+of dt and dd need to be removed, leaving the last dt and dd. So, we
+supply a C<wrapper_proc> which will do this.
default: undef
=item * item_ld
-This anonymous subroutine returns an array ref of C<HTML::Element>s that will
-be cloned and populated with item data
-(item data is a "row" of C<wrapper_data>).
+This anonymous subroutine returns an array ref of C<HTML::Element>s
+that will be cloned and populated with item data (item data is a "row"
+of C<wrapper_data>).
-default: returns an arrayref consisting of the dt and dd element inside the
-container.
+default: returns an arrayref consisting of the dt and dd element
+inside the container.
=item * item_data
-This is a subroutine that takes C<wrapper_data> and retrieves one "row"
-to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
-I hope that makes sense.
+This is a subroutine that takes C<wrapper_data> and retrieves one
+"row" to be "pasted" into the array ref of C<HTML::Element>s found via
+C<item_ld>. I hope that makes sense.
default: shifts C<wrapper_data>.
=item * item_proc
-This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
-found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
-eventually be spliced into the container.
+This is a subroutine that takes the C<item_data> and the
+C<HTML::Element>s found via C<item_ld> and produces an arrayref of
+C<HTML::Element>s which will eventually be spliced into the container.
-Note that this subroutine MUST return the new items. This is done
-So that more items than were passed in can be returned. This is
-useful when, for example, you must return 2 dts for an input data item.
-And when would you do this? When a single term has multiple spellings
-for instance.
+Note that this subroutine MUST return the new items. This is done So
+that more items than were passed in can be returned. This is useful
+when, for example, you must return 2 dts for an input data item. And
+when would you do this? When a single term has multiple spellings for
+instance.
-default: expects C<item_data> to be an arrayref of two elements and
-C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
-content of the C<HTML::Element>s with the C<item_data>.
+default: expects C<item_data> to be an arrayref of two elements and
+C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces
+the content of the C<HTML::Element>s with the C<item_data>.
=item * splice
After building up an array of C<@item_elems>, the subroutine passed as
-C<splice> will be given the parent container HTML::Element and the
-C<@item_elems>. How the C<@item_elems> end up in the container is up to this
-routine: it could put half of them in. It could unshift them or whatever.
+C<splice> will be given the parent container HTML::Element and the
+C<@item_elems>. How the C<@item_elems> end up in the container is up
+to this routine: it could put half of them in. It could unshift them
+or whatever.
-default: C<< $container->splice_content(0, 2, @item_elems) >>
-In other words, kill the 2 sample elements with the newly generated
-@item_elems
+default: C<< $container->splice_content(0, 2, @item_elems) >> In other
+words, kill the 2 sample elements with the newly generated @item_elems
=back
So now that we have documented the API, let's see the call we need:
$tree->iter2(
- # default wrapper_ld ok.
+ # default wrapper_ld ok.
wrapper_data => \@items,
wrapper_proc => sub {
my ($container) = @_;
# only keep the last 2 dts and dds
my @content_list = $container->content_list;
- $container->splice_content(0, @content_list - 2);
+ $container->splice_content(0, @content_list - 2);
},
# default item_ld is fine.
# default item_data is fine.
- # default item_proc is fine.
+ # default item_proc is fine.
splice => sub {
my ($container, @item_elems) = @_;
$container->unshift_content(@item_elems);
debug => 1,
);
-
-
-
=head3 Select Unrolling
The C<unroll_select> method has this API:
option_value => $closure, # how to get option value from data row
option_content => $closure, # how to get option content from data row
option_selected => $closure, # boolean to decide if SELECTED
- data => $data # the data to be put into the SELECT
- data_iter => $closure # the thing that will get a row of data
- debug => $boolean,
- append => $boolean, # remove the sample <OPTION> data or append?
+ data => $data # the data to be put into the SELECT
+ data_iter => $closure # the thing that will get a row of data
+ debug => $boolean,
+ append => $boolean, # remove the sample <OPTION> data or append?
);
Here's an example:
- $tree->unroll_select(
- select_label => 'clan_list',
- option_value => sub { my $row = shift; $row->clan_id },
- option_content => sub { my $row = shift; $row->clan_name },
- option_selected => sub { my $row = shift; $row->selected },
- data => \@query_results,
- data_iter => sub { my $data = shift; $data->next },
- append => 0,
- debug => 0
- );
-
-
+ $tree->unroll_select(
+ select_label => 'clan_list',
+ option_value => sub { my $row = shift; $row->clan_id },
+ option_content => sub { my $row = shift; $row->clan_name },
+ option_selected => sub { my $row = shift; $row->selected },
+ data => \@query_results,
+ data_iter => sub { my $data = shift; $data->next },
+ append => 0,
+ debug => 0
+ );
=head2 Tree-Building Methods: Table Generation
-Matthew Sisk has a much more intuitive (imperative)
-way to generate tables via his module
-L<HTML::ElementTable|HTML::ElementTable>.
-However, for those with callback fever, the following
-method is available. First, we look at a nuts and bolts way to build a table
-using only standard L<HTML::Tree> API calls. Then the C<table> method
+Matthew Sisk has a much more intuitive (imperative) way to generate
+tables via his module L<HTML::ElementTable|HTML::ElementTable>.
+
+However, for those with callback fever, the following method is
+available. First, we look at a nuts and bolts way to build a table
+using only standard L<HTML::Tree> API calls. Then the C<table> method
available here is discussed.
=head3 Sample Model
- package Simple::Class;
-
- use Set::Array;
-
- my @name = qw(bob bill brian babette bobo bix);
- my @age = qw(99 12 44 52 12 43);
- my @weight = qw(99 52 80 124 120 230);
-
-
- sub new {
- my $this = shift;
- bless {}, ref($this) || $this;
- }
-
- sub load_data {
- my @data;
-
- for (0 .. 5) {
- push @data, {
- age => $age[rand $#age] + int rand 20,
- name => shift @name,
- weight => $weight[rand $#weight] + int rand 40
- }
- }
-
- Set::Array->new(@data);
- }
-
-
- 1;
+ package Simple::Class;
+
+ use Set::Array;
+
+ my @name = qw(bob bill brian babette bobo bix);
+ my @age = qw(99 12 44 52 12 43);
+ my @weight = qw(99 52 80 124 120 230);
+
+
+ sub new {
+ my $this = shift;
+ bless {}, ref($this) || $this;
+ }
+ sub load_data {
+ my @data;
+
+ for (0 .. 5) {
+ push @data, {
+ age => $age[rand $#age] + int rand 20,
+ name => shift @name,
+ weight => $weight[rand $#weight] + int rand 40
+ }
+ }
+
+ Set::Array->new(@data);
+ }
+
+ 1;
=head4 Sample Usage:
- my $data = Simple::Class->load_data;
- ++$_->{age} for @$data
+ my $data = Simple::Class->load_data;
+ ++$_->{age} for @$data
=head3 Inline Code to Unroll a Table
=head4 HTML
- <html>
-
- <table id="load_data">
-
- <tr> <th>name</th><th>age</th><th>weight</th> </tr>
-
- <tr id="iterate">
-
- <td id="name"> NATURE BOY RIC FLAIR </td>
- <td id="age"> 35 </td>
- <td id="weight"> 220 </td>
-
- </tr>
-
- </table>
-
- </html>
+ <html>
+ <table id="load_data">
+ <tr> <th>name</th><th>age</th><th>weight</th> </tr>
+ <tr id="iterate">
+ <td id="name"> NATURE BOY RIC FLAIR </td>
+ <td id="age"> 35 </td>
+ <td id="weight"> 220 </td>
+ </tr>
+ </table>
+ </html>
=head4 The manual way (*NOT* recommended)
- require 'simple-class.pl';
- use HTML::Seamstress;
-
- # load the view
- my $seamstress = HTML::Seamstress->new_from_file('simple.html');
-
- # load the model
- my $o = Simple::Class->new;
- my $data = $o->load_data;
-
- # find the <table> and <tr>
- my $table_node = $seamstress->look_down('id', 'load_data');
- my $iter_node = $table_node->look_down('id', 'iterate');
- my $table_parent = $table_node->parent;
-
-
- # drop the sample <table> and <tr> from the HTML
- # only add them in if there is data in the model
- # this is achieved via the $add_table flag
-
- $table_node->detach;
- $iter_node->detach;
- my $add_table;
-
- # Get a row of model data
- while (my $row = shift @$data) {
-
- # We got row data. Set the flag indicating ok to hook the table into the HTML
- ++$add_table;
-
- # clone the sample <tr>
- my $new_iter_node = $iter_node->clone;
-
- # find the tags labeled name age and weight and
- # set their content to the row data
- $new_iter_node->content_handler($_ => $row->{$_})
+ require 'simple-class.pl';
+ use HTML::Seamstress;
+
+ # load the view
+ my $seamstress = HTML::Seamstress->new_from_file('simple.html');
+
+ # load the model
+ my $o = Simple::Class->new;
+ my $data = $o->load_data;
+
+ # find the <table> and <tr>
+ my $table_node = $seamstress->look_down('id', 'load_data');
+ my $iter_node = $table_node->look_down('id', 'iterate');
+ my $table_parent = $table_node->parent;
+
+
+
# drop the sample <table> and <tr> from the HTML
+ # only add them in if there is data in the model
+ # this is achieved via the $add_table flag
+
+ $table_node->detach;
+ $iter_node->detach;
+ my $add_table;
+
+ # Get a row of model data
+ while (my $row = shift @$data) {
+
+ # We got row data. Set the flag indicating ok to hook the table into the HTML
+ ++$add_table;
+
+ # clone the sample <tr>
+ my $new_iter_node = $iter_node->clone;
+
+ # find the tags labeled name age and weight and
+ # set their content to the row data
+ $new_iter_node->content_handler($_ => $row->{$_})
for qw(name age weight);
-
- $table_node->push_content($new_iter_node);
-
- }
-
- # reattach the table to the HTML tree if we loaded data into some table rows
-
- $table_parent->push_content($table_node) if $add_table;
-
- print $seamstress->as_HTML;
-
+ $table_node->push_content($new_iter_node);
+
+ }
+
+ # reattach the table to the HTML tree if we loaded data into some table rows
+
+ $table_parent->push_content($table_node) if $add_table;
+
+ print $seamstress->as_HTML;
=head3 $tree->table() : API call to Unroll a Table
- require 'simple-class.pl';
- use HTML::Seamstress;
-
- # load the view
- my $seamstress = HTML::Seamstress->new_from_file('simple.html');
- # load the model
- my $o = Simple::Class->new;
-
- $seamstress->table
- (
- # tell seamstress where to find the table, via the method call
- # ->look_down('id', $gi_table). Seamstress detaches the table from the
- # HTML tree automatically if no table rows can be built
-
- gi_table => 'load_data',
-
- # tell seamstress where to find the tr. This is a bit useless as
- # the <tr> usually can be found as the first child of the parent
-
- gi_tr => 'iterate',
-
- # the model data to be pushed into the table
-
- table_data => $o->load_data,
-
- # the way to take the model data and obtain one row
- # if the table data were a hashref, we would do:
- # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
-
- tr_data => sub { my ($self, $data) = @_;
- shift(@{$data}) ;
- },
-
- # the way to take a row of data and fill the <td> tags
-
- td_data => sub { my ($tr_node, $tr_data) = @_;
- $tr_node->content_handler($_ => $tr_data->{$_})
- for qw(name age weight) }
-
- );
-
-
- print $seamstress->as_HTML;
+ require 'simple-class.pl';
+ use HTML::Seamstress;
+
+ # load the view
+ my $seamstress = HTML::Seamstress->new_from_file('simple.html');
+ # load the model
+ my $o = Simple::Class->new;
+
+ $seamstress->table
+ (
+ # tell seamstress where to find the table, via the method call
+ # ->look_down('id', $gi_table). Seamstress detaches the table from the
+ # HTML tree automatically if no table rows can be built
+
+ gi_table => 'load_data',
+
+ # tell seamstress where to find the tr. This is a bit useless as
+ # the <tr> usually can be found as the first child of the parent
+ gi_tr => 'iterate',
+ # the model data to be pushed into the table
+
+ table_data => $o->load_data,
+
+ # the way to take the model data and obtain one row
+ # if the table data were a hashref, we would do:
+ # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
+
+ tr_data => sub {
+ my ($self, $data) = @_;
+ shift @{$data} ;
+ },
+
+ # the way to take a row of data and fill the <td> tags
+
+ td_data => sub {
+ my ($tr_node, $tr_data) = @_;
+ $tr_node->content_handler($_ => $tr_data->{$_})
+ for qw(name age weight)
+ }
+ );
+
+ print $seamstress->as_HTML;
=head4 Looping over Multiple Sample Rows
* HTML
- <html>
-
- <table id="load_data" CELLPADDING=8 BORDER=2>
-
- <tr> <th>name</th><th>age</th><th>weight</th> </tr>
-
- <tr id="iterate1" BGCOLOR="white" >
-
- <td id="name"> NATURE BOY RIC FLAIR </td>
- <td id="age"> 35 </td>
- <td id="weight"> 220 </td>
-
- </tr>
- <tr id="iterate2" BGCOLOR="#CCCC99">
-
- <td id="name"> NATURE BOY RIC FLAIR </td>
- <td id="age"> 35 </td>
- <td id="weight"> 220 </td>
-
- </tr>
-
- </table>
-
- </html>
-
+ <html>
+ <table id="load_data" CELLPADDING=8 BORDER=2>
+ <tr> <th>name</th><th>age</th><th>weight</th> </tr>
+ <tr id="iterate1" BGCOLOR="white" >
+ <td id="name"> NATURE BOY RIC FLAIR </td>
+ <td id="age"> 35 </td>
+ <td id="weight"> 220 </td>
+ </tr>
+ <tr id="iterate2" BGCOLOR="#CCCC99">
+ <td id="name"> NATURE BOY RIC FLAIR </td>
+ <td id="age"> 35 </td>
+ <td id="weight"> 220 </td>
+ </tr>
+ </table>
+</html>
-* Only one change to last API call.
+* Only one change to last API call.
This:
- gi_tr => 'iterate',
+ gi_tr => 'iterate',
becomes this:
- gi_tr => ['iterate1', 'iterate2']
+ gi_tr => ['iterate1', 'iterate2']
=head3 $tree->table2() : New API Call to Unroll a Table
-After 2 or 3 years with C<table()>, I began to develop
-production websites with it and decided it needed a cleaner
-interface, particularly in the area of handling the fact that
-C<id> tags will be the same after cloning a table row.
+After 2 or 3 years with C<table()>, I began to develop production
+websites with it and decided it needed a cleaner interface,
+particularly in the area of handling the fact that C<id> tags will be
+the same after cloning a table row.
-First, I will give a dry listing of the function's argument parameters.
-This will not be educational most likely. A better way to understand how
-to use the function is to read through the incremental unrolling of the
-function's interface given in conversational style after the dry listing.
-But take your pick. It's the same information given in two different
-ways.
+First, I will give a dry listing of the function's argument
+parameters. This will not be educational most likely. A better way to
+understand how to use the function is to read through the incremental
+unrolling of the function's interface given in conversational style
+after the dry listing. But take your pick. It's the same information
+given in two different ways.
=head4 Dry/technical parameter documentation
=item * C<< table_ld => $look_down >> : optional
-How to find the C<table> element in C<$tree>. If C<$look_down> is an
+How to find the C<table> element in C<$tree>. If C<$look_down> is an
arrayref, then use C<look_down>. If it is a CODE ref, then call it,
passing it C<$tree>.
=item * C<< table_proc => $code_ref >> : not implemented
-A subroutine to do something to the table once it is found.
-Not currently implemented. Not obviously necessary. Just
-created because there is a C<tr_proc> and C<td_proc>.
+A subroutine to do something to the table once it is found. Not
+currently implemented. Not obviously necessary. Just created because
+there is a C<tr_proc> and C<td_proc>.
=item * C<< tr_ld => $look_down >> : optional
-Same as C<table_ld> but for finding the table row elements. Please note
-that the C<tr_ld> is done on the table node that was found I<instead>
-of the whole HTML tree. This makes sense. The C<tr>s that you want exist
-below the table that was just found.
+Same as C<table_ld> but for finding the table row elements. Please
+note that the C<tr_ld> is done on the table node that was found
+I<instead> of the whole HTML tree. This makes sense. The C<tr>s that
+you want exist below the table that was just found.
Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
How to take the C<table_data> and return a row. Defaults to:
- sub { my ($self, $data) = @_;
- shift(@{$data}) ;
- }
-
+ sub { my ($self, $data) = @_;
+ shift(@{$data}) ;
+ }
+
=item * C<< tr_proc => $code_ref >> : optional
-Something to do to the table row we are about to add to the
-table we are making. Defaults to a routine which makes the C<id>
-attribute unique:
+Something to do to the table row we are about to add to the table we
+are making. Defaults to a routine which makes the C<id> attribute
+unique:
- sub {
- my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
- $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
- }
+ sub {
+ my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
+ $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
+ }
=item * C<< td_proc => $code_ref >> : required
-This coderef will take the row of data and operate on the C<td> cells that
-are children of the C<tr>. See C<t/table2.t> for several usage examples.
+This coderef will take the row of data and operate on the C<td> cells
+that are children of the C<tr>. See C<t/table2.t> for several usage
+examples.
Here's a sample one:
- sub {
- my ($tr, $data) = @_;
- my @td = $tr->look_down('_tag' => 'td');
- for my $i (0..$#td) {
- $td[$i]->splice_content(0, 1, $data->[$i]);
- }
+ sub {
+ my ($tr, $data) = @_;
+ my @td = $tr->look_down('_tag' => 'td');
+ for my $i (0..$#td) {
+ $td[$i]->splice_content(0, 1, $data->[$i]);
}
+ }
-=cut
+=back
=head4 Conversational parameter documentation
-The first thing you need is a table. So we need a look down for that. If you
-don't give one, it defaults to
+The first thing you need is a table. So we need a look down for that.
+If you don't give one, it defaults to
['_tag' => 'table']
-What good is a table to display in without data to display?!
-So you must supply a scalar representing your tabular
-data source. This scalar might be an array reference, a C<next>able iterator,
-a DBI statement handle. Whatever it is, it can be iterated through to build
-up rows of table data.
-These two required fields (the way to find the table and the data to
-display in the table) are C<table_ld> and C<table_data>
-respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
-then execution
-of the code ref is presumed to return the C<HTML::Element>
-representing the table in the HTML tree.
-
-Next, we get the row or rows which serve as sample C<tr> elements by doing
-a C<look_down> from the C<table_elem>. While normally one sample row
-is enough to unroll a table, consider when you have alternating
-table rows. This API call would need one of each row so that it can
-cycle through the
-sample rows as it loops through the data.
-Alternatively, you could always just use one row and
-make the necessary changes to the single C<tr> row by
-mutating the element in C<tr_proc>,
-discussed below. The default C<tr_ld> is
-C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
-it with a subroutine, then it is expected that the subroutine will return
-the C<HTML::Element>(s)
-which are C<tr> element(s).
-The reason a subroutine might be preferred is in the case
-that the HTML designers gave you 8 sample C<tr> rows but only one
-prototype row is needed.
-So you can write a subroutine, to splice out the 7 rows you don't need
-and leave the one sample
-row remaining so that this API call can clone it and supply it to
-the C<tr_proc> and C<td_proc> calls.
-
-Now, as we move through the table rows with table data,
-we need to do two different things on
-each table row:
+What good is a table to display in without data to display?! So you
+must supply a scalar representing your tabular data source. This
+scalar might be an array reference, a C<next>able iterator, a DBI
+statement handle. Whatever it is, it can be iterated through to build
+up rows of table data. These two required fields (the way to find the
+table and the data to display in the table) are C<table_ld> and
+C<table_data> respectively. A little more on C<table_ld>. If this
+happens to be a CODE ref, then execution of the code ref is presumed
+to return the C<HTML::Element> representing the table in the HTML
+tree.
+
+Next, we get the row or rows which serve as sample C<tr> elements by
+doing a C<look_down> from the C<table_elem>. While normally one sample
+row is enough to unroll a table, consider when you have alternating
+table rows. This API call would need one of each row so that it can
+cycle through the sample rows as it loops through the data.
+Alternatively, you could always just use one row and make the
+necessary changes to the single C<tr> row by mutating the element in
+C<tr_proc>, discussed below. The default C<tr_ld> is C<< ['_tag' =>
+'tr'] >> but you can overwrite it. Note well, if you overwrite it with
+a subroutine, then it is expected that the subroutine will return the
+C<HTML::Element>(s) which are C<tr> element(s). The reason a
+subroutine might be preferred is in the case that the HTML designers
+gave you 8 sample C<tr> rows but only one prototype row is needed. So
+you can write a subroutine, to splice out the 7 rows you don't need
+and leave the one sample row remaining so that this API call can clone
+it and supply it to the C<tr_proc> and C<td_proc> calls.
+
+Now, as we move through the table rows with table data, we need to do
+two different things on each table row:
=over 4
=item * get one row of data from the C<table_data> via C<tr_data>
-The default procedure assumes the C<table_data> is an array reference and
-shifts a row off of it:
+The default procedure assumes the C<table_data> is an array reference
+and shifts a row off of it:
- sub { my ($self, $data) = @_;
- shift(@{$data}) ;
- }
+ sub {
+ my ($self, $data) = @_;
+ shift @{$data};
+ }
Your function MUST return undef when there is no more rows to lay out.
The default procedure simply makes the id of the table row unique:
- sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
- $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
- }
+ sub {
+ my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
+ $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
+ }
=back
Now that we have our row of data, we call C<td_proc> so that it can
-take the data and the C<td> cells in this C<tr> and process them.
-This function I<must> be supplied.
-
+take the data and the C<td> cells in this C<tr> and process them. This
+function I<must> be supplied.
=head3 Whither a Table with No Rows
indicating this to the view. Use conditional processing to decide what
to display:
- <span id=no_data>
- <table><tr><td>No Data is Good Data</td></tr></table>
- </span>
- <span id=load_data>
- <html>
-
- <table id="load_data">
-
- <tr> <th>name</th><th>age</th><th>weight</th> </tr>
-
- <tr id="iterate">
-
- <td id="name"> NATURE BOY RIC FLAIR </td>
- <td id="age"> 35 </td>
- <td id="weight"> 220 </td>
-
- </tr>
-
- </table>
-
- </html>
+ <span id=no_data>
+ <table><tr><td>No Data is Good Data</td></tr></table>
+ </span>
+ <span id=load_data>
+ <html>
+ <table id="load_data">
+ <tr> <th>name</th><th>age</th><th>weight</th> </tr>
+ <tr id="iterate">
+ <td id="name"> NATURE BOY RIC FLAIR </td>
+ <td id="age"> 35 </td>
+ <td id="weight"> 220 </td>
+ </tr>
+ </table>
+ </html>
+ </span>
- </span>
+=head2 Tree-Killing Methods
+=head3 $tree->prune
+This removes any nodes from the tree which consist of nothing or
+nothing but whitespace. See also delete_ignorable_whitespace in
+L<HTML::Element>.
+=head2 Loltree Functions
-=head1 SEE ALSO
+A loltree is an arrayref consisting of arrayrefs which is used by C<<
+new_from__lol >> in L<HTML::Element> to produce HTML trees. The CPAN
+distro L<XML::Element::Tolol> creates such XML trees by parsing XML
+files, analagous to L<XML::Toolkit>. The purpose of the functions in
+this section is to allow you manipulate a loltree programmatically.
-=over
+These could not be methods because if you bless a loltree, then
+HTML::Tree will barf.
+
+=head3 HTML::Element::newchild($lol, $parent_label, @newchild)
-=item * L<HTML::Tree>
+Given this initial loltree:
-A perl package for creating and manipulating HTML trees
+ my $initial_lol = [ note => [ shopping => [ item => 'sample' ] ] ];
-=item * L<HTML::ElementTable>
+This code:
+
+ sub shopping_items {
+ my @shopping_items = map { [ item => _ ] } qw(bread butter beans);
+ @shopping_items;
+ }
+
+ my $new_lol = HTML::Element::newnode($initial_lol, item => shopping_items());
+
+ will replace the single sample with a list of shopping items:
+
+ [
+ 'note',
+ [
+ 'shopping',
+ [
+ 'item',
+ 'bread'
+ ],
+ [
+ 'item',
+ 'butter'
+ ],
+ [
+ 'item',
+ 'beans'
+ ]
+
+ ]
+ ];
+
+Thanks to kcott and the other Perlmonks in this thread:
+http://www.perlmonks.org/?node_id=912416
+
+
+=head1 SEE ALSO
+
+=head2 L<HTML::Tree>
+
+A perl package for creating and manipulating HTML trees.
+
+=head2 L<HTML::ElementTable>
An L<HTML::Tree> - based module which allows for manipulation of HTML
-trees using cartesian coordinations.
+trees using cartesian coordinations.
+
+=head2 L<HTML::Seamstress>
+
+An L<HTML::Tree> - based module inspired by XMLC
+(L<http://xmlc.enhydra.org>), allowing for dynamic HTML generation via
+tree rewriting.
-=item * L<HTML::Seamstress>
+=head2 Push-style templating systems
-An L<HTML::Tree> - based module inspired by
-XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
-HTML generation via tree rewriting.
+A comprehensive cross-language
+L<list of push-style templating systems|http://perlmonks.org/?node_id=674225>.
=head1 TODO
identified by id:
$if_then->highlander2([
- under10 => sub { $_[0] < 10} ,
+ under10 => sub { $_[0] < 10} ,
under18 => sub { $_[0] < 18} ,
welcome => [
sub { 1 },
- sub {
- my $branch = shift;
- $branch->look_down(id => 'age')->replace_content($age);
+ sub {
+ my $branch = shift;
+ $branch->look_down(id => 'age')->replace_content($age);
}
]
- ],
- $age
- );
+ ], $age);
but, it should be more flexible. the C<under10>, and C<under18> are
-expected to be ids in the tree... but it is not hard to have a check to
-see if this field is an array reference and if it, then to do a look
-down instead:
+expected to be ids in the tree... but it is not hard to have a check
+to see if this field is an array reference and if it, then to do a
+look down instead:
$if_then->highlander2([
- [class => 'under10'] => sub { $_[0] < 10} ,
+ [class => 'under10'] => sub { $_[0] < 10} ,
[class => 'under18'] => sub { $_[0] < 18} ,
[class => 'welcome'] => [
sub { 1 },
- sub {
- my $branch = shift;
- $branch->look_down(id => 'age')->replace_content($age);
+ sub {
+ my $branch = shift;
+ $branch->look_down(id => 'age')->replace_content($age);
}
]
- ],
- $age
- );
-
-
+ ], $age);
-=cut
+=back
-=head1 SEE ALSO
+=head1 AUTHOR
-L<HTML::Seamstress>
+Original author Terrence Brannon, E<lt>tbone@cpan.orgE<gt>.
-=head1 AUTHOR / SOURCE
+Adopted by Marius Gavrilescu C<< <marius@ieval.ro> >>.
-Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
+I appreciate the feedback from M. David Moussa Leo Keita regarding
+some issues with the test suite, namely (1) CRLF leading to test
+breakage in F<t/crunch.t> and (2) using the wrong module in
+F<t/prune.t> thus not having the right functionality available.
Many thanks to BARBIE for his RT bug report.
-The source is at L<http://github.com/metaperl/html-element-library/tree/master>
+Many thanks to perlmonk kcott for his work on array rewriting:
+L<http://www.perlmonks.org/?node_id=912416>. It was crucial in the
+development of newchild.
=head1 COPYRIGHT AND LICENSE
-Copyright (C) 2004 by Terrence Brannon
+Coypright (C) 2014 by Marius Gavrilescu
+
+Copyright (C) 2004-2012 by Terrence Brannon
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
projects / html-element-library.git / blobdiff