1 package HTML
::Element
::Library
;
11 use Array
::Group
qw(:all);
15 use List
::MoreUtils qw
/:all/;
16 use Params
::Validate
qw(:all);
19 use List
::Rotation
::Cycle
;
21 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
22 our @EXPORT_OK = ( @
{ $EXPORT_TAGS{'all'} } );
27 our $VERSION = '3.53';
30 # Preloaded methods go here.
32 sub HTML
::Element
::siblings
{
34 my $p = $element->parent;
39 sub HTML
::Element
::passover
{
40 my ($tree, $child_id) = @_;
42 #warn "ARGS: my ($tree, $child)";
44 my $exodus = $tree->look_down(id
=> $child_id);
46 my @s = HTML
::Element
::siblings
($exodus);
48 warn "sibling count", scalar @s;
49 warn "siblings", join ':', @s;
53 warn "ref sib", ref $s;
55 if ($s->attr('id') eq $child_id) {
62 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
66 sub HTML
::Element
::sibdex
{
69 firstidx
{ $_ eq $element } $element->siblings
73 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
75 sub HTML
::Element
::replace_content
{
77 $elem->delete_content;
78 $elem->push_content(@_);
81 sub HTML
::Element
::wrap_content
{
82 my($self, $wrap) = @_;
83 my $content = $self->content;
85 $wrap->push_content(@
$content);
89 $self->push_content($wrap);
94 sub HTML
::Element
::Library
::super_literal
{
97 HTML
::Element
->new('~literal', text
=> $text);
101 sub HTML
::Element
::position
{
102 # Report coordinates by chasing addr's up the
103 # HTML::ElementSuper tree. We know we've reached
104 # the top when a) there is no parent, or b) the
105 # parent is some HTML::Element unable to report
111 unshift(@pos, $a) if defined $a;
118 sub HTML
::Element
::content_handler
{
119 my ($tree, $id_name, $content) = @_;
121 $tree->set_child_content(id
=> $id_name, $content);
134 sub HTML
::Element
::iter
{
135 my ($tree, $p, @data) = @_;
137 # warn 'P: ' , $p->attr('id') ;
138 # warn 'H: ' , $p->as_HTML;
140 # my $id_incr = make_counter;
142 my $new_item = clone
$p;
143 $new_item->replace_content($_);
144 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
148 $p->replace_with(@item);
153 sub HTML
::Element
::iter2
{
157 #warn "INPUT TO TABLE2: ", Dumper \@_;
161 wrapper_ld
=> { default => ['_tag' => 'dl'] },
163 wrapper_proc
=> { default => undef },
164 item_ld
=> { default => sub {
167 $tree->look_down('_tag' => 'dt'),
168 $tree->look_down('_tag' => 'dd')
172 item_data
=> { default => sub { my ($wrapper_data) = @_;
173 shift(@
{$wrapper_data}) ;
177 my ($item_elems, $item_data, $row_count) = @_;
178 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
181 splice => { default => sub {
182 my ($container, @item_elems) = @_;
183 $container->splice_content(0, 2, @item_elems);
186 debug
=> {default => 0}
190 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
192 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
193 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug
} ;
194 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
195 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug
} ;
197 my $_item_elems = $p{item_ld
}->($container);
204 my $item_data = $p{item_data
}->($p{wrapper_data
});
205 last unless defined $item_data;
207 warn Dumper
("item_data", $item_data);
210 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
213 for (@
{$item_elems}) {
214 warn "ITEM_ELEMS ", $_->as_HTML;
218 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
221 for (@
{$new_item_elems}) {
222 warn "NEWITEM_ELEMS ", $_->as_HTML;
227 push @item_elem, @
{$new_item_elems} ;
232 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
234 $p{splice}->($container, @item_elem);
238 sub HTML
::Element
::dual_iter
{
239 my ($parent, $data) = @_;
241 my ($prototype_a, $prototype_b) = $parent->content_list;
243 # my $id_incr = make_counter;
248 confess
'dataset does not contain an even number of members';
250 my @iterable_data = ngroup
2 => @
$data;
253 my ($new_a, $new_b) = map { clone
$_ } ($prototype_a, $prototype_b) ;
254 $new_a->splice_content(0,1, $_->[0]);
255 $new_b->splice_content(0,1, $_->[1]);
256 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
260 $parent->splice_content(0, 2, @item);
265 sub HTML
::Element
::set_child_content
{
270 my $content_tag = $tree->look_down(@look_down);
272 unless ($content_tag) {
273 warn "criteria [@look_down] not found";
277 $content_tag->replace_content($content);
281 sub HTML
::Element
::highlander
{
282 my ($tree, $local_root_id, $aref, @arg) = @_;
284 ref $aref eq 'ARRAY' or confess
285 "must supply array reference";
288 @aref % 2 == 0 or confess
289 "supplied array ref must have an even number of entries";
291 warn __PACKAGE__
if $DEBUG;
294 while (my ($id, $test) = splice @aref, 0, 2) {
303 my @id_survivor = (id
=> $survivor);
304 my $survivor_node = $tree->look_down(@id_survivor);
306 # warn $local_root_id;
309 warn "survivor: $survivor" if $DEBUG;
310 warn "tree: " . $tree->as_HTML if $DEBUG;
312 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
314 my $survivor_node_parent = $survivor_node->parent;
315 $survivor_node = $survivor_node->clone;
316 $survivor_node_parent->replace_content($survivor_node);
318 warn "new tree: " . $tree->as_HTML if $DEBUG;
324 sub HTML
::Element
::highlander2
{
327 my %p = validate
(@_, {
328 cond
=> { type
=> ARRAYREF
},
329 cond_arg
=> { type
=> ARRAYREF
,
332 debug
=> { default => 0 }
337 my @cond = @
{$p{cond
}};
338 @cond % 2 == 0 or confess
339 "supplied array ref must have an even number of entries";
341 warn __PACKAGE__
if $p{debug
};
343 my @cond_arg = @
{$p{cond_arg
}};
345 my $survivor; my $then;
346 while (my ($id, $if_then) = splice @cond, 0, 2) {
348 warn $id if $p{debug
};
351 if (ref $if_then eq 'ARRAY') {
352 ($if, $_then) = @
$if_then;
354 ($if, $_then) = ($if_then, sub {});
357 if ($if->(@cond_arg)) {
365 my @ld = (ref $survivor eq 'ARRAY')
370 warn "survivor: ", $survivor if $p{debug
};
371 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
374 my $survivor_node = $tree->look_down(@ld);
376 $survivor_node or confess
377 "search for @ld failed in tree($tree): " . $tree->as_HTML;
379 my $survivor_node_parent = $survivor_node->parent;
380 $survivor_node = $survivor_node->clone;
381 $survivor_node_parent->replace_content($survivor_node);
384 # **************** NEW FUNCTIONALITY *******************
386 # apply transforms on survivor node
389 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug
};
390 $then->($survivor_node, @cond_arg);
391 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug
};
393 # **************** NEW FUNCTIONALITY *******************
402 sub overwrite_action
{
403 my ($mute_node, %X) = @_;
405 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
409 sub HTML
::Element
::overwrite_attr
{
412 $tree->mute_elem(@_, \
&overwrite_action
);
417 sub HTML
::Element
::mute_elem
{
418 my ($tree, $mute_attr, $closures, $post_hook) = @_;
420 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
421 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
423 for my $mute_node (@mute_node) {
424 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
425 my $local_attr_value_current = $mute_node->attr($local_attr);
426 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
433 current
=> $local_attr_value_current,
434 new
=> $local_attr_value_new
443 sub HTML
::Element
::table
{
445 my ($s, %table) = @_;
449 # use Data::Dumper; warn Dumper \%table;
451 # ++$DEBUG if $table{debug} ;
454 # Get the table element
455 $table->{table_node
} = $s->look_down(id
=> $table{gi_table
});
456 $table->{table_node
} or confess
457 "table tag not found via (id => $table{gi_table}";
459 # Get the prototype tr element(s)
460 my @table_gi_tr = listify
$table{gi_tr
} ;
463 my $tr = $table->{table_node
}->look_down(id
=> $_);
464 $tr or confess
"tr with id => $_ not found";
468 warn "found " . @iter_node . " iter nodes " if $DEBUG;
469 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
470 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
473 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
475 # $table->{content} = $table{content};
476 #$table->{parent} = $table->{table_node}->parent;
479 # $table->{table_node}->detach;
480 # $_->detach for @iter_node;
485 my $row = $table{tr_data
}->($table, $table{table_data
});
486 last unless defined $row;
488 # get a sample table row and clone it.
489 my $I = $iter_node->next;
490 warn "I: $I" if $DEBUG;
491 my $new_iter_node = $I->clone;
494 $table{td_data
}->($new_iter_node, $row);
495 push @table_rows, $new_iter_node;
502 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
504 $s->look_down(id
=> $_)->detach;
507 $replace_with_elem->replace_with(@table_rows);
515 my ($tree, $slot) = @_;
517 if (ref($slot) eq 'CODE') {
520 $tree->look_down(@
$slot);
526 sub HTML
::Element
::table2
{
534 table_ld
=> { default => ['_tag' => 'table'] },
536 table_proc
=> { default => undef },
538 tr_ld
=> { default => ['_tag' => 'tr'] },
539 tr_data
=> { default => sub { my ($self, $data) = @_;
542 tr_base_id
=> { default => undef },
543 tr_proc
=> { default => sub {} },
545 debug
=> {default => 0}
549 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
551 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
555 # use Data::Dumper; warn Dumper \%table;
557 # ++$DEBUG if $table{debug} ;
559 # Get the table element
561 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
563 $table->{table_node
} or confess
564 "table tag not found via " . Dumper
($p{table_ld
}) ;
566 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
569 # Get the prototype tr element(s)
570 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
572 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
574 @proto_tr or return ;
577 warn $_->as_HTML for @proto_tr;
579 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
581 my $tr_parent = $proto_tr[0]->parent;
582 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
589 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
590 warn "data row: " . Dumper
$row if $p{debug
};
591 last unless defined $row;
593 # wont work: my $new_iter_node = $table->{iter_node}->clone;
594 my $new_tr_node = $proto_tr->next->clone;
595 warn "new_tr_node: $new_tr_node" if $p{debug
};
597 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
598 if defined $p{tr_proc
};
600 warn "data row redux: " . Dumper
$row if $p{debug
};
603 $p{td_proc
}->($new_tr_node, $row);
604 push @table_rows, $new_tr_node;
611 $_->detach for @proto_tr;
613 $tr_parent->push_content(@table_rows) if (@table_rows) ;
618 sub HTML
::Element
::unroll_select
{
620 my ($s, %select) = @_;
624 my $select_node = $s->look_down(id
=> $select{select_label
});
626 my $option = $select_node->look_down('_tag' => 'option');
633 while (my $row = $select{data_iter
}->($select{data
}))
636 my $o = $option->clone;
637 $o->attr('value', $select{option_value
}->($row));
638 $o->attr('SELECTED', 1) if ($select{option_selected
}->($row)) ;
640 $o->replace_content($select{option_content
}->($row));
641 $select_node->push_content($o);
649 sub HTML
::Element
::set_sibling_content
{
650 my ($elt, $content) = @_;
652 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
656 sub HTML
::TreeBuilder
::parse_string
{
657 my ($package, $string) = @_;
659 my $h = HTML
::TreeBuilder
->new;
660 HTML
::TreeBuilder
->parse($string);
668 # Below is stub documentation for your module. You'd better edit it!
672 HTML::Element::Library - HTML::Element convenience functions
676 use HTML::Element::Library;
677 use HTML::TreeBuilder;
681 This method provides API calls for common actions on trees when using
686 The test suite contains examples of each of these methods in a
689 =head2 Positional Querying Methods
691 =head3 $elem->siblings
693 Return a list of all nodes under the same parent.
697 Return the index of C<$elem> into the array of siblings of which it is
698 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
699 that is a descriptive name. And such naming is deceptively close to the
700 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
701 backwards compatibility, both methods are available.
707 =head3 $elem->position()
709 Returns the coordinates of this element in the tree it inhabits.
710 This is accomplished by succesively calling addr() on ancestor
711 elements until either a) an element that does not support these
712 methods is found, or b) there are no more parents. The resulting
713 list is the n-dimensional coordinates of the element in the tree.
715 =head2 Element Decoration Methods
717 =head3 HTML::Element::Library::super_literal($text)
719 In L<HTML::Element>, Sean Burke discusses super-literals. They are
720 text which does not get escaped. Great for includng Javascript in
721 HTML. Also great for including foreign language into a document.
723 So, you basically toss C<super_literal> your text and back comes
724 your text wrapped in a C<~literal> element.
726 One of these days, I'll around to writing a nice C<EXPORT> section.
728 =head2 Tree Rewriting Methods
730 =head3 $elem->replace_content(@new_elem)
732 Replaces all of C<$elem>'s content with C<@new_elem>.
734 =head3 $elem->wrap_content($wrapper_element)
736 Wraps the existing content in the provided element. If the provided element
737 happens to be a non-element, a push_content is performed instead.
739 =head3 $elem->set_child_content(@look_down, $content)
741 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
743 After finding the node, it detaches the node's content and pushes $content as the node's content.
745 =head3 $tree->content_handler($sid_value , $content)
747 This is a convenience method. Because the look_down criteria will often simply be:
753 <a id=fixme href=http://www.somesite.org>replace_content</a>
755 You can call this method to shorten your typing a bit. You can simply type
757 $elem->content_handler( fixme => 'new text' )
761 $elem->set_child_content(sid => 'fixme', 'new text')
763 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
765 This allows for "if-then-else" style processing. Highlander was a movie in
766 which only one would survive. Well, in terms of a tree when looking at a
767 structure that you want to process in C<if-then-else> style, only one child
768 will survive. For example, given this HTML template:
770 <span klass="highlander" id="age_dialog">
772 Hello, does your mother know you're
773 using her AOL account?
776 Sorry, you're not old enough to enter
777 (and too dumb to lie about your age)
784 We only want one child of the C<span> tag with id C<age_dialog> to remain
785 based on the age of the person visiting the page.
787 So, let's setup a call that will prune the subtree as a function of age:
791 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
796 under10 => sub { $_[0] < 10} ,
797 under18 => sub { $_[0] < 18} ,
803 And there we have it. If the age is less than 10, then the node with
804 id C<under10> remains. For age less than 18, the node with id C<under18>
806 Otherwise our "else" condition fires and the child with id C<welcome> remains.
808 =head3 $tree->passover($id_of_element)
810 In some cases, you know exactly which element should survive. In this case,
811 you can simply call C<passover> to remove it's siblings. For the HTML
812 above, you could delete C<under10> and C<welcome> by simply calling:
814 $tree->passover('under18');
816 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
818 Right around the same time that C<table2()> came into being, Seamstress
819 began to tackle tougher and tougher processing problems. It became clear that
820 a more powerful highlander was needed... one that not only snipped the tree
821 of the nodes that should not survive, but one that allows for
822 post-processing of the survivor node. And one that was more flexible with
823 how to find the nodes to snip.
825 Thus (drum roll) C<highlander2()>.
827 So let's look at our HTML which requires post-selection processing:
829 <span klass="highlander" id="age_dialog">
831 Hello, little <span id=age>AGE</span>-year old,
832 does your mother know you're using her AOL account?
835 Sorry, you're only <span id=age>AGE</span>
836 (and too dumb to lie about your age)
839 Welcome, isn't it good to be <span id=age>AGE</span> years old?
843 In this case, a branch survives, but it has dummy data in it. We must take
844 the surviving segment of HTML and rewrite the age C<span> with the age.
845 Here is how we use C<highlander2()> to do so:
850 $branch->look_down(id => 'age')->replace_content($age);
853 my $if_then = $tree->look_down(id => 'age_dialog');
855 $if_then->highlander2(
873 We pass it the tree (C<$if_then>), an arrayref of conditions
874 (C<cond>) and an arrayref of arguments which are passed to the
875 C<cond>s and to the replacement subs.
877 The C<under10>, C<under18> and C<welcome> are id attributes in the
878 tree of the siblings of which only one will survive. However,
879 should you need to do
880 more complex look-downs to find the survivor,
881 then supply an array ref instead of a simple
885 $if_then->highlander2(
887 [class => 'r12'] => [
891 [class => 'z22'] => [
895 [class => 'w88'] => [
904 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
906 This method is designed for taking a tree and reworking a set of nodes in
907 a stereotyped fashion. For instance let's say you have 3 remote image
908 archives, but you don't want to put long URLs in your img src
909 tags for reasons of abstraction, re-use and brevity. So instead you do this:
911 <img src="/img/smiley-face.jpg" fixup="src lnc">
912 <img src="/img/hot-babe.jpg" fixup="src playboy">
913 <img src="/img/footer.jpg" fixup="src foobar">
915 and then when the tree of HTML is being processed, you make this call:
918 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
919 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
920 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
923 $tree->overwrite_attr(fixup => \%closures) ;
925 and the tags come out modified like so:
927 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
928 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
929 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
931 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
933 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
934 assumes the return value of the
935 closure is supposed overwrite an attribute value and does it for you.
936 C<mute_elem> is a more general function which does nothing but
937 hand the closure the element and let it mutate it as it jolly well pleases :)
939 In fact, here is the implementation of C<overwrite_attr>
940 to give you a taste of how C<mute_attr> is used:
942 sub overwrite_action {
943 my ($mute_node, %X) = @_;
945 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
949 sub HTML::Element::overwrite_attr {
952 $tree->mute_elem(@_, \&overwrite_action);
958 =head2 Tree-Building Methods: Unrolling an array via a single sample element (<ul> container)
960 This is best described by example. Given this HTML:
962 <strong>Here are the things I need from the store:</strong>
964 <li class="store_items">Sample item</li>
967 We can unroll it like so:
969 my $li = $tree->look_down(class => 'store_items');
971 my @items = qw(bread butter vodka);
973 $tree->iter($li => @items);
980 <body>Here are the things I need from the store:
982 <li class="store_items">bread</li>
983 <li class="store_items">butter</li>
984 <li class="store_items">vodka</li>
989 =head2 Tree-Building Methods: Unrolling an array via n sample elements (<dl> container)
991 C<iter()> was fine for awhile, but some things
992 (e.g. definition lists) need a more general function to make them easy to
993 do. Hence C<iter2()>. This function will be explained by example of unrolling
994 a simple definition list.
996 So here's our mock-up HTML from the designer:
998 <dl class="dual_iter" id="service_plan">
1003 A person who draws blood.
1010 A clone of Iggy Pop.
1017 A relative of Edgar Allan Poe.
1020 <dt class="adstyle">sample header</dt>
1021 <dd class="adstyle2">sample data</dd>
1026 And we want to unroll our data set:
1029 ['the pros' => 'never have to worry about service again'],
1030 ['the cons' => 'upfront extra charge on purchase'],
1031 ['our choice' => 'go with the extended service plan']
1035 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1036 Let's assume that we want only the last <dt> and it's accompanying <dd>
1037 (the one with "sample data") to be used as the sample data
1038 for unrolling with our data set. Let's further assume that we want them to
1039 remain in the final output.
1041 So now, the API to C<iter2()> will be discussed and we will explain how our
1042 goal of getting our data into HTML fits into the API.
1048 This is how to look down and find the container of all the elements we will
1049 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1052 If you pass an anonymous subroutine, then it is presumed that execution of
1053 this subroutine will return the HTML::Element representing the container tag.
1054 If you pass an array ref, then this will be dereferenced and passed to
1055 C<HTML::Element::look_down()>.
1057 default value: C<< ['_tag' => 'dl'] >>
1059 Based on the mock HTML above, this default is fine for finding our container
1060 tag. So let's move on.
1062 =item * wrapper_data
1064 This is an array reference of data that we will be putting into the container.
1065 You must supply this. C<@items> above is our C<wrapper_data>.
1067 =item * wrapper_proc
1069 After we find the container via C<wrapper_ld>, we may want to pre-process
1070 some aspect of this tree. In our case the first two sets of dt and dd need
1071 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1078 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1079 be cloned and populated with item data
1080 (item data is a "row" of C<wrapper_data>).
1082 default: returns an arrayref consisting of the dt and dd element inside the
1087 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1088 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1089 I hope that makes sense.
1091 default: shifts C<wrapper_data>.
1095 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1096 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1097 eventually be spliced into the container.
1099 Note that this subroutine MUST return the new items. This is done
1100 So that more items than were passed in can be returned. This is
1101 useful when, for example, you must return 2 dts for an input data item.
1102 And when would you do this? When a single term has multiple spellings
1105 default: expects C<item_data> to be an arrayref of two elements and
1106 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1107 content of the C<HTML::Element>s with the C<item_data>.
1111 After building up an array of C<@item_elems>, the subroutine passed as
1112 C<splice> will be given the parent container HTML::Element and the
1113 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1114 routine: it could put half of them in. It could unshift them or whatever.
1116 default: C<< $container->splice_content(0, 2, @item_elems) >>
1117 In other words, kill the 2 sample elements with the newly generated
1122 So now that we have documented the API, let's see the call we need:
1125 # default wrapper_ld ok.
1126 wrapper_data => \@items,
1127 wrapper_proc => sub {
1128 my ($container) = @_;
1130 # only keep the last 2 dts and dds
1131 my @content_list = $container->content_list;
1132 $container->splice_content(0, @content_list - 2);
1135 # default item_ld is fine.
1136 # default item_data is fine.
1137 # default item_proc is fine.
1139 my ($container, @item_elems) = @_;
1140 $container->unshift_content(@item_elems);
1146 =head2 Tree-Building Methods: Select Unrolling
1148 The C<unroll_select> method has this API:
1150 $tree->unroll_select(
1151 select_label => $id_label,
1152 option_value => $closure, # how to get option value from data row
1153 option_content => $closure, # how to get option content from data row
1154 option_selected => $closure, # boolean to decide if SELECTED
1155 data => $data # the data to be put into the SELECT
1156 data_iter => $closure # the thing that will get a row of data
1161 $tree->unroll_select(
1162 select_label => 'clan_list',
1163 option_value => sub { my $row = shift; $row->clan_id },
1164 option_content => sub { my $row = shift; $row->clan_name },
1165 option_selected => sub { my $row = shift; $row->selected },
1166 data => \@query_results,
1167 data_iter => sub { my $data = shift; $data->next }
1172 =head2 Tree-Building Methods: Table Generation
1174 Matthew Sisk has a much more intuitive (imperative)
1175 way to generate tables via his module
1176 L<HTML::ElementTable|HTML::ElementTable>.
1177 However, for those with callback fever, the following
1178 method is available. First, we look at a nuts and bolts way to build a table
1179 using only standard L<HTML::Tree> API calls. Then the C<table> method
1180 available here is discussed.
1184 package Simple::Class;
1188 my @name = qw(bob bill brian babette bobo bix);
1189 my @age = qw(99 12 44 52 12 43);
1190 my @weight = qw(99 52 80 124 120 230);
1195 bless {}, ref($this) || $this;
1203 age => $age[rand $#age] + int rand 20,
1204 name => shift @name,
1205 weight => $weight[rand $#weight] + int rand 40
1209 Set::Array->new(@data);
1216 =head4 Sample Usage:
1218 my $data = Simple::Class->load_data;
1219 ++$_->{age} for @$data
1221 =head3 Inline Code to Unroll a Table
1227 <table id="load_data">
1229 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1233 <td id="name"> NATURE BOY RIC FLAIR </td>
1234 <td id="age"> 35 </td>
1235 <td id="weight"> 220 </td>
1244 =head4 The manual way (*NOT* recommended)
1246 require 'simple-class.pl';
1247 use HTML::Seamstress;
1250 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1253 my $o = Simple::Class->new;
1254 my $data = $o->load_data;
1256 # find the <table> and <tr>
1257 my $table_node = $seamstress->look_down('id', 'load_data');
1258 my $iter_node = $table_node->look_down('id', 'iterate');
1259 my $table_parent = $table_node->parent;
1262 # drop the sample <table> and <tr> from the HTML
1263 # only add them in if there is data in the model
1264 # this is achieved via the $add_table flag
1266 $table_node->detach;
1270 # Get a row of model data
1271 while (my $row = shift @$data) {
1273 # We got row data. Set the flag indicating ok to hook the table into the HTML
1276 # clone the sample <tr>
1277 my $new_iter_node = $iter_node->clone;
1279 # find the tags labeled name age and weight and
1280 # set their content to the row data
1281 $new_iter_node->content_handler($_ => $row->{$_})
1282 for qw(name age weight);
1284 $table_node->push_content($new_iter_node);
1288 # reattach the table to the HTML tree if we loaded data into some table rows
1290 $table_parent->push_content($table_node) if $add_table;
1292 print $seamstress->as_HTML;
1296 =head3 $tree->table() : API call to Unroll a Table
1298 require 'simple-class.pl';
1299 use HTML::Seamstress;
1302 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1304 my $o = Simple::Class->new;
1308 # tell seamstress where to find the table, via the method call
1309 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1310 # HTML tree automatically if no table rows can be built
1312 gi_table => 'load_data',
1314 # tell seamstress where to find the tr. This is a bit useless as
1315 # the <tr> usually can be found as the first child of the parent
1319 # the model data to be pushed into the table
1321 table_data => $o->load_data,
1323 # the way to take the model data and obtain one row
1324 # if the table data were a hashref, we would do:
1325 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1327 tr_data => sub { my ($self, $data) = @_;
1331 # the way to take a row of data and fill the <td> tags
1333 td_data => sub { my ($tr_node, $tr_data) = @_;
1334 $tr_node->content_handler($_ => $tr_data->{$_})
1335 for qw(name age weight) }
1340 print $seamstress->as_HTML;
1344 =head4 Looping over Multiple Sample Rows
1350 <table id="load_data" CELLPADDING=8 BORDER=2>
1352 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1354 <tr id="iterate1" BGCOLOR="white" >
1356 <td id="name"> NATURE BOY RIC FLAIR </td>
1357 <td id="age"> 35 </td>
1358 <td id="weight"> 220 </td>
1361 <tr id="iterate2" BGCOLOR="#CCCC99">
1363 <td id="name"> NATURE BOY RIC FLAIR </td>
1364 <td id="age"> 35 </td>
1365 <td id="weight"> 220 </td>
1374 * Only one change to last API call.
1382 gi_tr => ['iterate1', 'iterate2']
1384 =head3 $tree->table2() : New API Call to Unroll a Table
1386 After 2 or 3 years with C<table()>, I began to develop
1387 production websites with it and decided it needed a cleaner
1388 interface, particularly in the area of handling the fact that
1389 C<id> tags will be the same after cloning a table row.
1391 First, I will give a dry listing of the function's argument parameters.
1392 This will not be educational most likely. A better way to understand how
1393 to use the function is to read through the incremental unrolling of the
1394 function's interface given in conversational style after the dry listing.
1395 But take your pick. It's the same information given in two different
1398 =head4 Dry/technical parameter documentation
1400 C<< $tree->table2(%param) >> takes the following arguments:
1404 =item * C<< table_ld => $look_down >> : optional
1406 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1407 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1408 passing it C<$tree>.
1410 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1412 =item * C<< table_data => $tabular_data >> : required
1414 The data to fill the table with. I<Must> be passed in.
1416 =item * C<< table_proc => $code_ref >> : not implemented
1418 A subroutine to do something to the table once it is found.
1419 Not currently implemented. Not obviously necessary. Just
1420 created because there is a C<tr_proc> and C<td_proc>.
1422 =item * C<< tr_ld => $look_down >> : optional
1424 Same as C<table_ld> but for finding the table row elements. Please note
1425 that the C<tr_ld> is done on the table node that was found I<instead>
1426 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1427 below the table that was just found.
1429 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1431 =item * C<< tr_data => $code_ref >> : optional
1433 How to take the C<table_data> and return a row. Defaults to:
1435 sub { my ($self, $data) = @_;
1439 =item * C<< tr_proc => $code_ref >> : optional
1441 Something to do to the table row we are about to add to the
1442 table we are making. Defaults to a routine which makes the C<id>
1446 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1447 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1450 =item * C<< td_proc => $code_ref >> : required
1452 This coderef will take the row of data and operate on the C<td> cells that
1453 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1455 Here's a sample one:
1458 my ($tr, $data) = @_;
1459 my @td = $tr->look_down('_tag' => 'td');
1460 for my $i (0..$#td) {
1461 $td[$i]->splice_content(0, 1, $data->[$i]);
1467 =head4 Conversational parameter documentation
1469 The first thing you need is a table. So we need a look down for that. If you
1470 don't give one, it defaults to
1474 What good is a table to display in without data to display?!
1475 So you must supply a scalar representing your tabular
1476 data source. This scalar might be an array reference, a C<next>able iterator,
1477 a DBI statement handle. Whatever it is, it can be iterated through to build
1478 up rows of table data.
1479 These two required fields (the way to find the table and the data to
1480 display in the table) are C<table_ld> and C<table_data>
1481 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1483 of the code ref is presumed to return the C<HTML::Element>
1484 representing the table in the HTML tree.
1486 Next, we get the row or rows which serve as sample C<tr> elements by doing
1487 a C<look_down> from the C<table_elem>. While normally one sample row
1488 is enough to unroll a table, consider when you have alternating
1489 table rows. This API call would need one of each row so that it can
1491 sample rows as it loops through the data.
1492 Alternatively, you could always just use one row and
1493 make the necessary changes to the single C<tr> row by
1494 mutating the element in C<tr_proc>,
1495 discussed below. The default C<tr_ld> is
1496 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1497 it with a subroutine, then it is expected that the subroutine will return
1498 the C<HTML::Element>(s)
1499 which are C<tr> element(s).
1500 The reason a subroutine might be preferred is in the case
1501 that the HTML designers gave you 8 sample C<tr> rows but only one
1502 prototype row is needed.
1503 So you can write a subroutine, to splice out the 7 rows you don't need
1504 and leave the one sample
1505 row remaining so that this API call can clone it and supply it to
1506 the C<tr_proc> and C<td_proc> calls.
1508 Now, as we move through the table rows with table data,
1509 we need to do two different things on
1514 =item * get one row of data from the C<table_data> via C<tr_data>
1516 The default procedure assumes the C<table_data> is an array reference and
1517 shifts a row off of it:
1519 sub { my ($self, $data) = @_;
1523 Your function MUST return undef when there is no more rows to lay out.
1525 =item * take the C<tr> element and mutate it via C<tr_proc>
1527 The default procedure simply makes the id of the table row unique:
1529 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1530 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1535 Now that we have our row of data, we call C<td_proc> so that it can
1536 take the data and the C<td> cells in this C<tr> and process them.
1537 This function I<must> be supplied.
1540 =head3 Whither a Table with No Rows
1542 Often when a table has no rows, we want to display a message
1543 indicating this to the view. Use conditional processing to decide what
1547 <table><tr><td>No Data is Good Data</td></tr></table>
1552 <table id="load_data">
1554 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1558 <td id="name"> NATURE BOY RIC FLAIR </td>
1559 <td id="age"> 35 </td>
1560 <td id="weight"> 220 </td>
1577 =item * L<HTML::Tree>
1579 A perl package for creating and manipulating HTML trees
1581 =item * L<HTML::ElementTable>
1583 An L<HTML::Tree> - based module which allows for manipulation of HTML
1584 trees using cartesian coordinations.
1586 =item * L<HTML::Seamstress>
1588 An L<HTML::Tree> - based module inspired by
1589 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1590 HTML generation via tree rewriting.
1598 currently the API expects the subtrees to survive or be pruned to be
1601 $if_then->highlander2([
1602 under10 => sub { $_[0] < 10} ,
1603 under18 => sub { $_[0] < 18} ,
1608 $branch->look_down(id => 'age')->replace_content($age);
1615 but, it should be more flexible. the C<under10>, and C<under18> are
1616 expected to be ids in the tree... but it is not hard to have a check to
1617 see if this field is an array reference and if it, then to do a look
1620 $if_then->highlander2([
1621 [class => 'under10'] => sub { $_[0] < 10} ,
1622 [class => 'under18'] => sub { $_[0] < 18} ,
1623 [class => 'welcome'] => [
1627 $branch->look_down(id => 'age')->replace_content($age);
1644 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1646 Many thanks to BARBIE for his RT bug report.
1648 =head1 COPYRIGHT AND LICENSE
1650 Copyright (C) 2004 by Terrence Brannon
1652 This library is free software; you can redistribute it and/or modify
1653 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1654 at your option, any later version of Perl 5 you may have available.
This page took 0.094675 seconds and 4 git commands to generate.