1 package HTML
::Element
::Library
;
11 use Array
::Group
qw(:all);
15 use List
::Util
qw(first);
16 use List
::MoreUtils qw
/:all/;
17 use Params
::Validate
qw(:all);
20 use List
::Rotation
::Cycle
;
22 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
23 our @EXPORT_OK = ( @
{ $EXPORT_TAGS{'all'} } );
28 our $VERSION = '3.53';
31 # Preloaded methods go here.
33 sub HTML
::Element
::siblings
{
35 my $p = $element->parent;
40 sub HTML
::Element
::hash_map
{
41 my $container = shift;
43 my %p = validate
(@_, {
44 hash
=> { type
=> HASHREF
},
46 excluding
=> { type
=> ARRAYREF
},
47 debug
=> { default => 0 },
50 my @same_as = $container->look_down('_attr' => $p{to_attr
});
52 for my $same_as (@same_as) {
53 next if first
{ $same_as->attr($p{to_attr
}) eq $_ } @
{$p{excluding
}} ;
54 my $hash_key = $same_as->attr($p{to_attr
}) ;
55 $same_as->replace_content( $p{hash
}->{$hash_key} ) ;
61 sub HTML
::Element
::passover
{
62 my ($tree, $child_id) = @_;
64 warn "ARGS: my ($tree, $child_id)" if $DEBUG;
65 warn $tree->as_HTML(undef, ' ') if $DEBUG;
67 my $exodus = $tree->look_down(id
=> $child_id);
69 warn "E: $exodus" if $DEBUG;
71 my @s = HTML
::Element
::siblings
($exodus);
75 if ($s->attr('id') eq $child_id) {
82 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
86 sub HTML
::Element
::sibdex
{
89 firstidx
{ $_ eq $element } $element->siblings
93 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
95 sub HTML
::Element
::replace_content
{
97 $elem->delete_content;
98 $elem->push_content(@_);
101 sub HTML
::Element
::wrap_content
{
102 my($self, $wrap) = @_;
103 my $content = $self->content;
105 $wrap->push_content(@
$content);
109 $self->push_content($wrap);
114 sub HTML
::Element
::Library
::super_literal
{
117 HTML
::Element
->new('~literal', text
=> $text);
121 sub HTML
::Element
::position
{
122 # Report coordinates by chasing addr's up the
123 # HTML::ElementSuper tree. We know we've reached
124 # the top when a) there is no parent, or b) the
125 # parent is some HTML::Element unable to report
131 unshift(@pos, $a) if defined $a;
138 sub HTML
::Element
::content_handler
{
139 my ($tree, %content_hash) = @_;
141 for my $k (keys %content_hash) {
142 $tree->set_child_content(id
=> $k, $content_hash{$k});
157 sub HTML
::Element
::iter
{
158 my ($tree, $p, @data) = @_;
160 # warn 'P: ' , $p->attr('id') ;
161 # warn 'H: ' , $p->as_HTML;
163 # my $id_incr = make_counter;
165 my $new_item = clone
$p;
166 $new_item->replace_content($_);
167 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
171 $p->replace_with(@item);
176 sub HTML
::Element
::iter2
{
180 #warn "INPUT TO TABLE2: ", Dumper \@_;
184 wrapper_ld
=> { default => ['_tag' => 'dl'] },
186 wrapper_proc
=> { default => undef },
187 item_ld
=> { default => sub {
190 $tree->look_down('_tag' => 'dt'),
191 $tree->look_down('_tag' => 'dd')
195 item_data
=> { default => sub { my ($wrapper_data) = @_;
196 shift(@
{$wrapper_data}) ;
200 my ($item_elems, $item_data, $row_count) = @_;
201 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
204 splice => { default => sub {
205 my ($container, @item_elems) = @_;
206 $container->splice_content(0, 2, @item_elems);
209 debug
=> {default => 0}
213 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
215 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
216 warn "container: " . $container if $p{debug
} ;
217 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug
} ;
218 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
219 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug
} ;
221 my $_item_elems = $p{item_ld
}->($container);
228 my $item_data = $p{item_data
}->($p{wrapper_data
});
229 last unless defined $item_data;
231 warn Dumper
("item_data", $item_data);
234 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
237 for (@
{$item_elems}) {
238 warn "ITEM_ELEMS ", $_->as_HTML;
242 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
245 for (@
{$new_item_elems}) {
246 warn "NEWITEM_ELEMS ", $_->as_HTML;
251 push @item_elem, @
{$new_item_elems} ;
256 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
258 $p{splice}->($container, @item_elem);
262 sub HTML
::Element
::dual_iter
{
263 my ($parent, $data) = @_;
265 my ($prototype_a, $prototype_b) = $parent->content_list;
267 # my $id_incr = make_counter;
272 confess
'dataset does not contain an even number of members';
274 my @iterable_data = ngroup
2 => @
$data;
277 my ($new_a, $new_b) = map { clone
$_ } ($prototype_a, $prototype_b) ;
278 $new_a->splice_content(0,1, $_->[0]);
279 $new_b->splice_content(0,1, $_->[1]);
280 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
284 $parent->splice_content(0, 2, @item);
289 sub HTML
::Element
::set_child_content
{
294 my $content_tag = $tree->look_down(@look_down);
296 unless ($content_tag) {
297 warn "criteria [@look_down] not found";
301 $content_tag->replace_content($content);
305 sub HTML
::Element
::highlander
{
306 my ($tree, $local_root_id, $aref, @arg) = @_;
308 ref $aref eq 'ARRAY' or confess
309 "must supply array reference";
312 @aref % 2 == 0 or confess
313 "supplied array ref must have an even number of entries";
315 warn __PACKAGE__
if $DEBUG;
318 while (my ($id, $test) = splice @aref, 0, 2) {
327 my @id_survivor = (id
=> $survivor);
328 my $survivor_node = $tree->look_down(@id_survivor);
330 # warn $local_root_id;
333 warn "survivor: $survivor" if $DEBUG;
334 warn "tree: " . $tree->as_HTML if $DEBUG;
336 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
338 my $survivor_node_parent = $survivor_node->parent;
339 $survivor_node = $survivor_node->clone;
340 $survivor_node_parent->replace_content($survivor_node);
342 warn "new tree: " . $tree->as_HTML if $DEBUG;
348 sub HTML
::Element
::highlander2
{
351 my %p = validate
(@_, {
352 cond
=> { type
=> ARRAYREF
},
353 cond_arg
=> { type
=> ARRAYREF
,
356 debug
=> { default => 0 }
361 my @cond = @
{$p{cond
}};
362 @cond % 2 == 0 or confess
363 "supplied array ref must have an even number of entries";
365 warn __PACKAGE__
if $p{debug
};
367 my @cond_arg = @
{$p{cond_arg
}};
369 my $survivor; my $then;
370 while (my ($id, $if_then) = splice @cond, 0, 2) {
372 warn $id if $p{debug
};
375 if (ref $if_then eq 'ARRAY') {
376 ($if, $_then) = @
$if_then;
378 ($if, $_then) = ($if_then, sub {});
381 if ($if->(@cond_arg)) {
389 my @ld = (ref $survivor eq 'ARRAY')
394 warn "survivor: ", $survivor if $p{debug
};
395 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
398 my $survivor_node = $tree->look_down(@ld);
400 $survivor_node or confess
401 "search for @ld failed in tree($tree): " . $tree->as_HTML;
403 my $survivor_node_parent = $survivor_node->parent;
404 $survivor_node = $survivor_node->clone;
405 $survivor_node_parent->replace_content($survivor_node);
408 # **************** NEW FUNCTIONALITY *******************
410 # apply transforms on survivor node
413 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug
};
414 $then->($survivor_node, @cond_arg);
415 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug
};
417 # **************** NEW FUNCTIONALITY *******************
426 sub overwrite_action
{
427 my ($mute_node, %X) = @_;
429 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
433 sub HTML
::Element
::overwrite_attr
{
436 $tree->mute_elem(@_, \
&overwrite_action
);
441 sub HTML
::Element
::mute_elem
{
442 my ($tree, $mute_attr, $closures, $post_hook) = @_;
444 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
445 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
447 for my $mute_node (@mute_node) {
448 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
449 my $local_attr_value_current = $mute_node->attr($local_attr);
450 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
457 current
=> $local_attr_value_current,
458 new
=> $local_attr_value_new
467 sub HTML
::Element
::table
{
469 my ($s, %table) = @_;
473 # use Data::Dumper; warn Dumper \%table;
475 # ++$DEBUG if $table{debug} ;
478 # Get the table element
479 $table->{table_node
} = $s->look_down(id
=> $table{gi_table
});
480 $table->{table_node
} or confess
481 "table tag not found via (id => $table{gi_table}";
483 # Get the prototype tr element(s)
484 my @table_gi_tr = listify
$table{gi_tr
} ;
487 my $tr = $table->{table_node
}->look_down(id
=> $_);
488 $tr or confess
"tr with id => $_ not found";
492 warn "found " . @iter_node . " iter nodes " if $DEBUG;
493 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
494 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
497 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
499 # $table->{content} = $table{content};
500 #$table->{parent} = $table->{table_node}->parent;
503 # $table->{table_node}->detach;
504 # $_->detach for @iter_node;
509 my $row = $table{tr_data
}->($table, $table{table_data
});
510 last unless defined $row;
512 # get a sample table row and clone it.
513 my $I = $iter_node->next;
514 warn "I: $I" if $DEBUG;
515 my $new_iter_node = $I->clone;
518 $table{td_data
}->($new_iter_node, $row);
519 push @table_rows, $new_iter_node;
526 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
528 $s->look_down(id
=> $_)->detach;
531 $replace_with_elem->replace_with(@table_rows);
539 my ($tree, $slot) = @_;
541 if (ref($slot) eq 'CODE') {
544 $tree->look_down(@
$slot);
550 sub HTML
::Element
::table2
{
558 table_ld
=> { default => ['_tag' => 'table'] },
560 table_proc
=> { default => undef },
562 tr_ld
=> { default => ['_tag' => 'tr'] },
563 tr_data
=> { default => sub { my ($self, $data) = @_;
566 tr_base_id
=> { default => undef },
567 tr_proc
=> { default => sub {} },
569 debug
=> {default => 0}
573 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
575 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
579 # use Data::Dumper; warn Dumper \%table;
581 # ++$DEBUG if $table{debug} ;
583 # Get the table element
585 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
587 $table->{table_node
} or confess
588 "table tag not found via " . Dumper
($p{table_ld
}) ;
590 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
593 # Get the prototype tr element(s)
594 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
596 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
598 @proto_tr or return ;
601 warn $_->as_HTML for @proto_tr;
603 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
605 my $tr_parent = $proto_tr[0]->parent;
606 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
613 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
614 warn "data row: " . Dumper
$row if $p{debug
};
615 last unless defined $row;
617 # wont work: my $new_iter_node = $table->{iter_node}->clone;
618 my $new_tr_node = $proto_tr->next->clone;
619 warn "new_tr_node: $new_tr_node" if $p{debug
};
621 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
622 if defined $p{tr_proc
};
624 warn "data row redux: " . Dumper
$row if $p{debug
};
627 $p{td_proc
}->($new_tr_node, $row);
628 push @table_rows, $new_tr_node;
635 $_->detach for @proto_tr;
637 $tr_parent->push_content(@table_rows) if (@table_rows) ;
642 sub HTML
::Element
::unroll_select
{
644 my ($s, %select) = @_;
648 my $select_node = $s->look_down(id
=> $select{select_label
});
650 my $option = $select_node->look_down('_tag' => 'option');
657 while (my $row = $select{data_iter
}->($select{data
}))
660 my $o = $option->clone;
661 $o->attr('value', $select{option_value
}->($row));
662 $o->attr('SELECTED', 1) if ($select{option_selected
}->($row)) ;
664 $o->replace_content($select{option_content
}->($row));
665 $select_node->push_content($o);
673 sub HTML
::Element
::set_sibling_content
{
674 my ($elt, $content) = @_;
676 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
680 sub HTML
::TreeBuilder
::parse_string
{
681 my ($package, $string) = @_;
683 my $h = HTML
::TreeBuilder
->new;
684 HTML
::TreeBuilder
->parse($string);
692 # Below is stub documentation for your module. You'd better edit it!
696 HTML::Element::Library - HTML::Element convenience functions
700 use HTML::Element::Library;
701 use HTML::TreeBuilder;
705 This method provides API calls for common actions on trees when using
710 The test suite contains examples of each of these methods in a
713 =head2 Positional Querying Methods
715 =head3 $elem->siblings
717 Return a list of all nodes under the same parent.
721 Return the index of C<$elem> into the array of siblings of which it is
722 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
723 that is a descriptive name. And such naming is deceptively close to the
724 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
725 backwards compatibility, both methods are available.
731 =head3 $elem->position()
733 Returns the coordinates of this element in the tree it inhabits.
734 This is accomplished by succesively calling addr() on ancestor
735 elements until either a) an element that does not support these
736 methods is found, or b) there are no more parents. The resulting
737 list is the n-dimensional coordinates of the element in the tree.
739 =head2 Element Decoration Methods
741 =head3 HTML::Element::Library::super_literal($text)
743 In L<HTML::Element>, Sean Burke discusses super-literals. They are
744 text which does not get escaped. Great for includng Javascript in
745 HTML. Also great for including foreign language into a document.
747 So, you basically toss C<super_literal> your text and back comes
748 your text wrapped in a C<~literal> element.
750 One of these days, I'll around to writing a nice C<EXPORT> section.
752 =head2 Tree Rewriting Methods
754 =head3 $elem->hash_map(hash => \%h, to_attr => $attr, excluding => \@excluded)
756 This method is designed to take a hashref and populate a series of elements. For example:
760 <tr sclass="tr" class="alt" align="left" valign="top">
761 <td sid="people_id">1</td>
762 <td sid="phone">(877) 255-3239</td>
763 <td sid="password">*********</td>
767 In the table above, there are several attributes named C<sid>. If we have a hashref whose keys are the same:
769 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
771 Then a single API call allows us to populate the HTML while excluding those ones we dont:
773 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
775 Of course, the other way to prevent rendering some of the hash mapping is to not give that element the attr
776 you plan to use for hash mapping.
779 =head3 $elem->replace_content(@new_elem)
781 Replaces all of C<$elem>'s content with C<@new_elem>.
783 =head3 $elem->wrap_content($wrapper_element)
785 Wraps the existing content in the provided element. If the provided element
786 happens to be a non-element, a push_content is performed instead.
788 =head3 $elem->set_child_content(@look_down, $content)
790 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
792 After finding the node, it detaches the node's content and pushes $content as the node's content.
794 =head3 $tree->content_handler(%id_content)
796 This is a convenience method. Because the look_down criteria will often simply be:
802 <a id=fixme href=http://www.somesite.org>replace_content</a>
804 You can call this method to shorten your typing a bit. You can simply type
806 $elem->content_handler( fixme => 'new text' )
810 $elem->set_child_content(sid => 'fixme', 'new text')
812 PLEASE 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:
814 my %id_content = (name => "Terrence Brannon",
815 email => 'tbrannon@in.com',
817 content => $main_content);
819 $tree->content_handler(%id_content);
821 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
823 This allows for "if-then-else" style processing. Highlander was a movie in
824 which only one would survive. Well, in terms of a tree when looking at a
825 structure that you want to process in C<if-then-else> style, only one child
826 will survive. For example, given this HTML template:
828 <span klass="highlander" id="age_dialog">
830 Hello, does your mother know you're
831 using her AOL account?
834 Sorry, you're not old enough to enter
835 (and too dumb to lie about your age)
842 We only want one child of the C<span> tag with id C<age_dialog> to remain
843 based on the age of the person visiting the page.
845 So, let's setup a call that will prune the subtree as a function of age:
849 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
854 under10 => sub { $_[0] < 10} ,
855 under18 => sub { $_[0] < 18} ,
861 And there we have it. If the age is less than 10, then the node with
862 id C<under10> remains. For age less than 18, the node with id C<under18>
864 Otherwise our "else" condition fires and the child with id C<welcome> remains.
866 =head3 $tree->passover($id_of_element)
868 In some cases, you know exactly which element should survive. In this case,
869 you can simply call C<passover> to remove it's siblings. For the HTML
870 above, you could delete C<under10> and C<welcome> by simply calling:
872 $tree->passover('under18');
874 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
876 Right around the same time that C<table2()> came into being, Seamstress
877 began to tackle tougher and tougher processing problems. It became clear that
878 a more powerful highlander was needed... one that not only snipped the tree
879 of the nodes that should not survive, but one that allows for
880 post-processing of the survivor node. And one that was more flexible with
881 how to find the nodes to snip.
883 Thus (drum roll) C<highlander2()>.
885 So let's look at our HTML which requires post-selection processing:
887 <span klass="highlander" id="age_dialog">
889 Hello, little <span id=age>AGE</span>-year old,
890 does your mother know you're using her AOL account?
893 Sorry, you're only <span id=age>AGE</span>
894 (and too dumb to lie about your age)
897 Welcome, isn't it good to be <span id=age>AGE</span> years old?
901 In this case, a branch survives, but it has dummy data in it. We must take
902 the surviving segment of HTML and rewrite the age C<span> with the age.
903 Here is how we use C<highlander2()> to do so:
908 $branch->look_down(id => 'age')->replace_content($age);
911 my $if_then = $tree->look_down(id => 'age_dialog');
913 $if_then->highlander2(
931 We pass it the tree (C<$if_then>), an arrayref of conditions
932 (C<cond>) and an arrayref of arguments which are passed to the
933 C<cond>s and to the replacement subs.
935 The C<under10>, C<under18> and C<welcome> are id attributes in the
936 tree of the siblings of which only one will survive. However,
937 should you need to do
938 more complex look-downs to find the survivor,
939 then supply an array ref instead of a simple
943 $if_then->highlander2(
945 [class => 'r12'] => [
949 [class => 'z22'] => [
953 [class => 'w88'] => [
962 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
964 This method is designed for taking a tree and reworking a set of nodes in
965 a stereotyped fashion. For instance let's say you have 3 remote image
966 archives, but you don't want to put long URLs in your img src
967 tags for reasons of abstraction, re-use and brevity. So instead you do this:
969 <img src="/img/smiley-face.jpg" fixup="src lnc">
970 <img src="/img/hot-babe.jpg" fixup="src playboy">
971 <img src="/img/footer.jpg" fixup="src foobar">
973 and then when the tree of HTML is being processed, you make this call:
976 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
977 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
978 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
981 $tree->overwrite_attr(fixup => \%closures) ;
983 and the tags come out modified like so:
985 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
986 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
987 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
989 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
991 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
992 assumes the return value of the
993 closure is supposed overwrite an attribute value and does it for you.
994 C<mute_elem> is a more general function which does nothing but
995 hand the closure the element and let it mutate it as it jolly well pleases :)
997 In fact, here is the implementation of C<overwrite_attr>
998 to give you a taste of how C<mute_attr> is used:
1000 sub overwrite_action {
1001 my ($mute_node, %X) = @_;
1003 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1007 sub HTML::Element::overwrite_attr {
1010 $tree->mute_elem(@_, \&overwrite_action);
1016 =head2 Tree-Building Methods
1020 =head3 Unrolling an array via a single sample element (<ul> container)
1022 This is best described by example. Given this HTML:
1024 <strong>Here are the things I need from the store:</strong>
1026 <li class="store_items">Sample item</li>
1029 We can unroll it like so:
1031 my $li = $tree->look_down(class => 'store_items');
1033 my @items = qw(bread butter vodka);
1035 $tree->iter($li => @items);
1042 <body>Here are the things I need from the store:
1044 <li class="store_items">bread</li>
1045 <li class="store_items">butter</li>
1046 <li class="store_items">vodka</li>
1051 =head3 Unrolling an array via n sample elements (<dl> container)
1053 C<iter()> was fine for awhile, but some things
1054 (e.g. definition lists) need a more general function to make them easy to
1055 do. Hence C<iter2()>. This function will be explained by example of unrolling
1056 a simple definition list.
1058 So here's our mock-up HTML from the designer:
1060 <dl class="dual_iter" id="service_plan">
1065 A person who draws blood.
1072 A clone of Iggy Pop.
1079 A relative of Edgar Allan Poe.
1082 <dt class="adstyle">sample header</dt>
1083 <dd class="adstyle2">sample data</dd>
1088 And we want to unroll our data set:
1091 ['the pros' => 'never have to worry about service again'],
1092 ['the cons' => 'upfront extra charge on purchase'],
1093 ['our choice' => 'go with the extended service plan']
1097 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1098 Let's assume that we want only the last <dt> and it's accompanying <dd>
1099 (the one with "sample data") to be used as the sample data
1100 for unrolling with our data set. Let's further assume that we want them to
1101 remain in the final output.
1103 So now, the API to C<iter2()> will be discussed and we will explain how our
1104 goal of getting our data into HTML fits into the API.
1110 This is how to look down and find the container of all the elements we will
1111 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1114 If you pass an anonymous subroutine, then it is presumed that execution of
1115 this subroutine will return the HTML::Element representing the container tag.
1116 If you pass an array ref, then this will be dereferenced and passed to
1117 C<HTML::Element::look_down()>.
1119 default value: C<< ['_tag' => 'dl'] >>
1121 Based on the mock HTML above, this default is fine for finding our container
1122 tag. So let's move on.
1124 =item * wrapper_data
1126 This is an array reference of data that we will be putting into the container.
1127 You must supply this. C<@items> above is our C<wrapper_data>.
1129 =item * wrapper_proc
1131 After we find the container via C<wrapper_ld>, we may want to pre-process
1132 some aspect of this tree. In our case the first two sets of dt and dd need
1133 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1140 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1141 be cloned and populated with item data
1142 (item data is a "row" of C<wrapper_data>).
1144 default: returns an arrayref consisting of the dt and dd element inside the
1149 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1150 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1151 I hope that makes sense.
1153 default: shifts C<wrapper_data>.
1157 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1158 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1159 eventually be spliced into the container.
1161 Note that this subroutine MUST return the new items. This is done
1162 So that more items than were passed in can be returned. This is
1163 useful when, for example, you must return 2 dts for an input data item.
1164 And when would you do this? When a single term has multiple spellings
1167 default: expects C<item_data> to be an arrayref of two elements and
1168 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1169 content of the C<HTML::Element>s with the C<item_data>.
1173 After building up an array of C<@item_elems>, the subroutine passed as
1174 C<splice> will be given the parent container HTML::Element and the
1175 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1176 routine: it could put half of them in. It could unshift them or whatever.
1178 default: C<< $container->splice_content(0, 2, @item_elems) >>
1179 In other words, kill the 2 sample elements with the newly generated
1184 So now that we have documented the API, let's see the call we need:
1187 # default wrapper_ld ok.
1188 wrapper_data => \@items,
1189 wrapper_proc => sub {
1190 my ($container) = @_;
1192 # only keep the last 2 dts and dds
1193 my @content_list = $container->content_list;
1194 $container->splice_content(0, @content_list - 2);
1197 # default item_ld is fine.
1198 # default item_data is fine.
1199 # default item_proc is fine.
1201 my ($container, @item_elems) = @_;
1202 $container->unshift_content(@item_elems);
1210 =head3 Select Unrolling
1212 The C<unroll_select> method has this API:
1214 $tree->unroll_select(
1215 select_label => $id_label,
1216 option_value => $closure, # how to get option value from data row
1217 option_content => $closure, # how to get option content from data row
1218 option_selected => $closure, # boolean to decide if SELECTED
1219 data => $data # the data to be put into the SELECT
1220 data_iter => $closure # the thing that will get a row of data
1225 $tree->unroll_select(
1226 select_label => 'clan_list',
1227 option_value => sub { my $row = shift; $row->clan_id },
1228 option_content => sub { my $row = shift; $row->clan_name },
1229 option_selected => sub { my $row = shift; $row->selected },
1230 data => \@query_results,
1231 data_iter => sub { my $data = shift; $data->next }
1236 =head2 Tree-Building Methods: Table Generation
1238 Matthew Sisk has a much more intuitive (imperative)
1239 way to generate tables via his module
1240 L<HTML::ElementTable|HTML::ElementTable>.
1241 However, for those with callback fever, the following
1242 method is available. First, we look at a nuts and bolts way to build a table
1243 using only standard L<HTML::Tree> API calls. Then the C<table> method
1244 available here is discussed.
1248 package Simple::Class;
1252 my @name = qw(bob bill brian babette bobo bix);
1253 my @age = qw(99 12 44 52 12 43);
1254 my @weight = qw(99 52 80 124 120 230);
1259 bless {}, ref($this) || $this;
1267 age => $age[rand $#age] + int rand 20,
1268 name => shift @name,
1269 weight => $weight[rand $#weight] + int rand 40
1273 Set::Array->new(@data);
1280 =head4 Sample Usage:
1282 my $data = Simple::Class->load_data;
1283 ++$_->{age} for @$data
1285 =head3 Inline Code to Unroll a Table
1291 <table id="load_data">
1293 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1297 <td id="name"> NATURE BOY RIC FLAIR </td>
1298 <td id="age"> 35 </td>
1299 <td id="weight"> 220 </td>
1308 =head4 The manual way (*NOT* recommended)
1310 require 'simple-class.pl';
1311 use HTML::Seamstress;
1314 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1317 my $o = Simple::Class->new;
1318 my $data = $o->load_data;
1320 # find the <table> and <tr>
1321 my $table_node = $seamstress->look_down('id', 'load_data');
1322 my $iter_node = $table_node->look_down('id', 'iterate');
1323 my $table_parent = $table_node->parent;
1326 # drop the sample <table> and <tr> from the HTML
1327 # only add them in if there is data in the model
1328 # this is achieved via the $add_table flag
1330 $table_node->detach;
1334 # Get a row of model data
1335 while (my $row = shift @$data) {
1337 # We got row data. Set the flag indicating ok to hook the table into the HTML
1340 # clone the sample <tr>
1341 my $new_iter_node = $iter_node->clone;
1343 # find the tags labeled name age and weight and
1344 # set their content to the row data
1345 $new_iter_node->content_handler($_ => $row->{$_})
1346 for qw(name age weight);
1348 $table_node->push_content($new_iter_node);
1352 # reattach the table to the HTML tree if we loaded data into some table rows
1354 $table_parent->push_content($table_node) if $add_table;
1356 print $seamstress->as_HTML;
1360 =head3 $tree->table() : API call to Unroll a Table
1362 require 'simple-class.pl';
1363 use HTML::Seamstress;
1366 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1368 my $o = Simple::Class->new;
1372 # tell seamstress where to find the table, via the method call
1373 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1374 # HTML tree automatically if no table rows can be built
1376 gi_table => 'load_data',
1378 # tell seamstress where to find the tr. This is a bit useless as
1379 # the <tr> usually can be found as the first child of the parent
1383 # the model data to be pushed into the table
1385 table_data => $o->load_data,
1387 # the way to take the model data and obtain one row
1388 # if the table data were a hashref, we would do:
1389 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1391 tr_data => sub { my ($self, $data) = @_;
1395 # the way to take a row of data and fill the <td> tags
1397 td_data => sub { my ($tr_node, $tr_data) = @_;
1398 $tr_node->content_handler($_ => $tr_data->{$_})
1399 for qw(name age weight) }
1404 print $seamstress->as_HTML;
1408 =head4 Looping over Multiple Sample Rows
1414 <table id="load_data" CELLPADDING=8 BORDER=2>
1416 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1418 <tr id="iterate1" BGCOLOR="white" >
1420 <td id="name"> NATURE BOY RIC FLAIR </td>
1421 <td id="age"> 35 </td>
1422 <td id="weight"> 220 </td>
1425 <tr id="iterate2" BGCOLOR="#CCCC99">
1427 <td id="name"> NATURE BOY RIC FLAIR </td>
1428 <td id="age"> 35 </td>
1429 <td id="weight"> 220 </td>
1438 * Only one change to last API call.
1446 gi_tr => ['iterate1', 'iterate2']
1448 =head3 $tree->table2() : New API Call to Unroll a Table
1450 After 2 or 3 years with C<table()>, I began to develop
1451 production websites with it and decided it needed a cleaner
1452 interface, particularly in the area of handling the fact that
1453 C<id> tags will be the same after cloning a table row.
1455 First, I will give a dry listing of the function's argument parameters.
1456 This will not be educational most likely. A better way to understand how
1457 to use the function is to read through the incremental unrolling of the
1458 function's interface given in conversational style after the dry listing.
1459 But take your pick. It's the same information given in two different
1462 =head4 Dry/technical parameter documentation
1464 C<< $tree->table2(%param) >> takes the following arguments:
1468 =item * C<< table_ld => $look_down >> : optional
1470 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1471 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1472 passing it C<$tree>.
1474 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1476 =item * C<< table_data => $tabular_data >> : required
1478 The data to fill the table with. I<Must> be passed in.
1480 =item * C<< table_proc => $code_ref >> : not implemented
1482 A subroutine to do something to the table once it is found.
1483 Not currently implemented. Not obviously necessary. Just
1484 created because there is a C<tr_proc> and C<td_proc>.
1486 =item * C<< tr_ld => $look_down >> : optional
1488 Same as C<table_ld> but for finding the table row elements. Please note
1489 that the C<tr_ld> is done on the table node that was found I<instead>
1490 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1491 below the table that was just found.
1493 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1495 =item * C<< tr_data => $code_ref >> : optional
1497 How to take the C<table_data> and return a row. Defaults to:
1499 sub { my ($self, $data) = @_;
1503 =item * C<< tr_proc => $code_ref >> : optional
1505 Something to do to the table row we are about to add to the
1506 table we are making. Defaults to a routine which makes the C<id>
1510 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1511 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1514 =item * C<< td_proc => $code_ref >> : required
1516 This coderef will take the row of data and operate on the C<td> cells that
1517 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1519 Here's a sample one:
1522 my ($tr, $data) = @_;
1523 my @td = $tr->look_down('_tag' => 'td');
1524 for my $i (0..$#td) {
1525 $td[$i]->splice_content(0, 1, $data->[$i]);
1531 =head4 Conversational parameter documentation
1533 The first thing you need is a table. So we need a look down for that. If you
1534 don't give one, it defaults to
1538 What good is a table to display in without data to display?!
1539 So you must supply a scalar representing your tabular
1540 data source. This scalar might be an array reference, a C<next>able iterator,
1541 a DBI statement handle. Whatever it is, it can be iterated through to build
1542 up rows of table data.
1543 These two required fields (the way to find the table and the data to
1544 display in the table) are C<table_ld> and C<table_data>
1545 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1547 of the code ref is presumed to return the C<HTML::Element>
1548 representing the table in the HTML tree.
1550 Next, we get the row or rows which serve as sample C<tr> elements by doing
1551 a C<look_down> from the C<table_elem>. While normally one sample row
1552 is enough to unroll a table, consider when you have alternating
1553 table rows. This API call would need one of each row so that it can
1555 sample rows as it loops through the data.
1556 Alternatively, you could always just use one row and
1557 make the necessary changes to the single C<tr> row by
1558 mutating the element in C<tr_proc>,
1559 discussed below. The default C<tr_ld> is
1560 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1561 it with a subroutine, then it is expected that the subroutine will return
1562 the C<HTML::Element>(s)
1563 which are C<tr> element(s).
1564 The reason a subroutine might be preferred is in the case
1565 that the HTML designers gave you 8 sample C<tr> rows but only one
1566 prototype row is needed.
1567 So you can write a subroutine, to splice out the 7 rows you don't need
1568 and leave the one sample
1569 row remaining so that this API call can clone it and supply it to
1570 the C<tr_proc> and C<td_proc> calls.
1572 Now, as we move through the table rows with table data,
1573 we need to do two different things on
1578 =item * get one row of data from the C<table_data> via C<tr_data>
1580 The default procedure assumes the C<table_data> is an array reference and
1581 shifts a row off of it:
1583 sub { my ($self, $data) = @_;
1587 Your function MUST return undef when there is no more rows to lay out.
1589 =item * take the C<tr> element and mutate it via C<tr_proc>
1591 The default procedure simply makes the id of the table row unique:
1593 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1594 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1599 Now that we have our row of data, we call C<td_proc> so that it can
1600 take the data and the C<td> cells in this C<tr> and process them.
1601 This function I<must> be supplied.
1604 =head3 Whither a Table with No Rows
1606 Often when a table has no rows, we want to display a message
1607 indicating this to the view. Use conditional processing to decide what
1611 <table><tr><td>No Data is Good Data</td></tr></table>
1616 <table id="load_data">
1618 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1622 <td id="name"> NATURE BOY RIC FLAIR </td>
1623 <td id="age"> 35 </td>
1624 <td id="weight"> 220 </td>
1641 =item * L<HTML::Tree>
1643 A perl package for creating and manipulating HTML trees
1645 =item * L<HTML::ElementTable>
1647 An L<HTML::Tree> - based module which allows for manipulation of HTML
1648 trees using cartesian coordinations.
1650 =item * L<HTML::Seamstress>
1652 An L<HTML::Tree> - based module inspired by
1653 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1654 HTML generation via tree rewriting.
1662 currently the API expects the subtrees to survive or be pruned to be
1665 $if_then->highlander2([
1666 under10 => sub { $_[0] < 10} ,
1667 under18 => sub { $_[0] < 18} ,
1672 $branch->look_down(id => 'age')->replace_content($age);
1679 but, it should be more flexible. the C<under10>, and C<under18> are
1680 expected to be ids in the tree... but it is not hard to have a check to
1681 see if this field is an array reference and if it, then to do a look
1684 $if_then->highlander2([
1685 [class => 'under10'] => sub { $_[0] < 10} ,
1686 [class => 'under18'] => sub { $_[0] < 18} ,
1687 [class => 'welcome'] => [
1691 $branch->look_down(id => 'age')->replace_content($age);
1708 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1710 Many thanks to BARBIE for his RT bug report.
1712 =head1 COPYRIGHT AND LICENSE
1714 Copyright (C) 2004 by Terrence Brannon
1716 This library is free software; you can redistribute it and/or modify
1717 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1718 at your option, any later version of Perl 5 you may have available.
This page took 0.101044 seconds and 4 git commands to generate.