99abc3d39f7c534ce6eff10ac7cbba1cbedcbbeb
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_id)";
44 my $exodus = $tree->look_down(id
=> $child_id);
46 my @s = HTML
::Element
::siblings
($exodus);
50 if ($s->attr('id') eq $child_id) {
57 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
61 sub HTML
::Element
::sibdex
{
64 firstidx
{ $_ eq $element } $element->siblings
68 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
70 sub HTML
::Element
::replace_content
{
72 $elem->delete_content;
73 $elem->push_content(@_);
76 sub HTML
::Element
::wrap_content
{
77 my($self, $wrap) = @_;
78 my $content = $self->content;
80 $wrap->push_content(@
$content);
84 $self->push_content($wrap);
89 sub HTML
::Element
::Library
::super_literal
{
92 HTML
::Element
->new('~literal', text
=> $text);
96 sub HTML
::Element
::position
{
97 # Report coordinates by chasing addr's up the
98 # HTML::ElementSuper tree. We know we've reached
99 # the top when a) there is no parent, or b) the
100 # parent is some HTML::Element unable to report
106 unshift(@pos, $a) if defined $a;
113 sub HTML
::Element
::content_handler
{
114 my ($tree, %content_hash) = @_;
116 for my $k (keys %content_hash) {
117 $tree->set_child_content(id
=> $k, $content_hash{$k});
132 sub HTML
::Element
::iter
{
133 my ($tree, $p, @data) = @_;
135 # warn 'P: ' , $p->attr('id') ;
136 # warn 'H: ' , $p->as_HTML;
138 # my $id_incr = make_counter;
140 my $new_item = clone
$p;
141 $new_item->replace_content($_);
142 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
146 $p->replace_with(@item);
151 sub HTML
::Element
::iter2
{
155 #warn "INPUT TO TABLE2: ", Dumper \@_;
159 wrapper_ld
=> { default => ['_tag' => 'dl'] },
161 wrapper_proc
=> { default => undef },
162 item_ld
=> { default => sub {
165 $tree->look_down('_tag' => 'dt'),
166 $tree->look_down('_tag' => 'dd')
170 item_data
=> { default => sub { my ($wrapper_data) = @_;
171 shift(@
{$wrapper_data}) ;
175 my ($item_elems, $item_data, $row_count) = @_;
176 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
179 splice => { default => sub {
180 my ($container, @item_elems) = @_;
181 $container->splice_content(0, 2, @item_elems);
184 debug
=> {default => 0}
188 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
190 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
191 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug
} ;
192 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
193 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug
} ;
195 my $_item_elems = $p{item_ld
}->($container);
202 my $item_data = $p{item_data
}->($p{wrapper_data
});
203 last unless defined $item_data;
205 warn Dumper
("item_data", $item_data);
208 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
211 for (@
{$item_elems}) {
212 warn "ITEM_ELEMS ", $_->as_HTML;
216 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
219 for (@
{$new_item_elems}) {
220 warn "NEWITEM_ELEMS ", $_->as_HTML;
225 push @item_elem, @
{$new_item_elems} ;
230 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
232 $p{splice}->($container, @item_elem);
236 sub HTML
::Element
::dual_iter
{
237 my ($parent, $data) = @_;
239 my ($prototype_a, $prototype_b) = $parent->content_list;
241 # my $id_incr = make_counter;
246 confess
'dataset does not contain an even number of members';
248 my @iterable_data = ngroup
2 => @
$data;
251 my ($new_a, $new_b) = map { clone
$_ } ($prototype_a, $prototype_b) ;
252 $new_a->splice_content(0,1, $_->[0]);
253 $new_b->splice_content(0,1, $_->[1]);
254 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
258 $parent->splice_content(0, 2, @item);
263 sub HTML
::Element
::set_child_content
{
268 my $content_tag = $tree->look_down(@look_down);
270 unless ($content_tag) {
271 warn "criteria [@look_down] not found";
275 $content_tag->replace_content($content);
279 sub HTML
::Element
::highlander
{
280 my ($tree, $local_root_id, $aref, @arg) = @_;
282 ref $aref eq 'ARRAY' or confess
283 "must supply array reference";
286 @aref % 2 == 0 or confess
287 "supplied array ref must have an even number of entries";
289 warn __PACKAGE__
if $DEBUG;
292 while (my ($id, $test) = splice @aref, 0, 2) {
301 my @id_survivor = (id
=> $survivor);
302 my $survivor_node = $tree->look_down(@id_survivor);
304 # warn $local_root_id;
307 warn "survivor: $survivor" if $DEBUG;
308 warn "tree: " . $tree->as_HTML if $DEBUG;
310 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
312 my $survivor_node_parent = $survivor_node->parent;
313 $survivor_node = $survivor_node->clone;
314 $survivor_node_parent->replace_content($survivor_node);
316 warn "new tree: " . $tree->as_HTML if $DEBUG;
322 sub HTML
::Element
::highlander2
{
325 my %p = validate
(@_, {
326 cond
=> { type
=> ARRAYREF
},
327 cond_arg
=> { type
=> ARRAYREF
,
330 debug
=> { default => 0 }
335 my @cond = @
{$p{cond
}};
336 @cond % 2 == 0 or confess
337 "supplied array ref must have an even number of entries";
339 warn __PACKAGE__
if $p{debug
};
341 my @cond_arg = @
{$p{cond_arg
}};
343 my $survivor; my $then;
344 while (my ($id, $if_then) = splice @cond, 0, 2) {
346 warn $id if $p{debug
};
349 if (ref $if_then eq 'ARRAY') {
350 ($if, $_then) = @
$if_then;
352 ($if, $_then) = ($if_then, sub {});
355 if ($if->(@cond_arg)) {
363 my @ld = (ref $survivor eq 'ARRAY')
368 warn "survivor: ", $survivor if $p{debug
};
369 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
372 my $survivor_node = $tree->look_down(@ld);
374 $survivor_node or confess
375 "search for @ld failed in tree($tree): " . $tree->as_HTML;
377 my $survivor_node_parent = $survivor_node->parent;
378 $survivor_node = $survivor_node->clone;
379 $survivor_node_parent->replace_content($survivor_node);
382 # **************** NEW FUNCTIONALITY *******************
384 # apply transforms on survivor node
387 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug
};
388 $then->($survivor_node, @cond_arg);
389 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug
};
391 # **************** NEW FUNCTIONALITY *******************
400 sub overwrite_action
{
401 my ($mute_node, %X) = @_;
403 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
407 sub HTML
::Element
::overwrite_attr
{
410 $tree->mute_elem(@_, \
&overwrite_action
);
415 sub HTML
::Element
::mute_elem
{
416 my ($tree, $mute_attr, $closures, $post_hook) = @_;
418 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
419 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
421 for my $mute_node (@mute_node) {
422 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
423 my $local_attr_value_current = $mute_node->attr($local_attr);
424 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
431 current
=> $local_attr_value_current,
432 new
=> $local_attr_value_new
441 sub HTML
::Element
::table
{
443 my ($s, %table) = @_;
447 # use Data::Dumper; warn Dumper \%table;
449 # ++$DEBUG if $table{debug} ;
452 # Get the table element
453 $table->{table_node
} = $s->look_down(id
=> $table{gi_table
});
454 $table->{table_node
} or confess
455 "table tag not found via (id => $table{gi_table}";
457 # Get the prototype tr element(s)
458 my @table_gi_tr = listify
$table{gi_tr
} ;
461 my $tr = $table->{table_node
}->look_down(id
=> $_);
462 $tr or confess
"tr with id => $_ not found";
466 warn "found " . @iter_node . " iter nodes " if $DEBUG;
467 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
468 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
471 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
473 # $table->{content} = $table{content};
474 #$table->{parent} = $table->{table_node}->parent;
477 # $table->{table_node}->detach;
478 # $_->detach for @iter_node;
483 my $row = $table{tr_data
}->($table, $table{table_data
});
484 last unless defined $row;
486 # get a sample table row and clone it.
487 my $I = $iter_node->next;
488 warn "I: $I" if $DEBUG;
489 my $new_iter_node = $I->clone;
492 $table{td_data
}->($new_iter_node, $row);
493 push @table_rows, $new_iter_node;
500 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
502 $s->look_down(id
=> $_)->detach;
505 $replace_with_elem->replace_with(@table_rows);
513 my ($tree, $slot) = @_;
515 if (ref($slot) eq 'CODE') {
518 $tree->look_down(@
$slot);
524 sub HTML
::Element
::table2
{
532 table_ld
=> { default => ['_tag' => 'table'] },
534 table_proc
=> { default => undef },
536 tr_ld
=> { default => ['_tag' => 'tr'] },
537 tr_data
=> { default => sub { my ($self, $data) = @_;
540 tr_base_id
=> { default => undef },
541 tr_proc
=> { default => sub {} },
543 debug
=> {default => 0}
547 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
549 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
553 # use Data::Dumper; warn Dumper \%table;
555 # ++$DEBUG if $table{debug} ;
557 # Get the table element
559 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
561 $table->{table_node
} or confess
562 "table tag not found via " . Dumper
($p{table_ld
}) ;
564 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
567 # Get the prototype tr element(s)
568 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
570 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
572 @proto_tr or return ;
575 warn $_->as_HTML for @proto_tr;
577 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
579 my $tr_parent = $proto_tr[0]->parent;
580 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
587 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
588 warn "data row: " . Dumper
$row if $p{debug
};
589 last unless defined $row;
591 # wont work: my $new_iter_node = $table->{iter_node}->clone;
592 my $new_tr_node = $proto_tr->next->clone;
593 warn "new_tr_node: $new_tr_node" if $p{debug
};
595 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
596 if defined $p{tr_proc
};
598 warn "data row redux: " . Dumper
$row if $p{debug
};
601 $p{td_proc
}->($new_tr_node, $row);
602 push @table_rows, $new_tr_node;
609 $_->detach for @proto_tr;
611 $tr_parent->push_content(@table_rows) if (@table_rows) ;
616 sub HTML
::Element
::unroll_select
{
618 my ($s, %select) = @_;
622 my $select_node = $s->look_down(id
=> $select{select_label
});
624 my $option = $select_node->look_down('_tag' => 'option');
631 while (my $row = $select{data_iter
}->($select{data
}))
634 my $o = $option->clone;
635 $o->attr('value', $select{option_value
}->($row));
636 $o->attr('SELECTED', 1) if ($select{option_selected
}->($row)) ;
638 $o->replace_content($select{option_content
}->($row));
639 $select_node->push_content($o);
647 sub HTML
::Element
::set_sibling_content
{
648 my ($elt, $content) = @_;
650 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
654 sub HTML
::TreeBuilder
::parse_string
{
655 my ($package, $string) = @_;
657 my $h = HTML
::TreeBuilder
->new;
658 HTML
::TreeBuilder
->parse($string);
666 # Below is stub documentation for your module. You'd better edit it!
670 HTML::Element::Library - HTML::Element convenience functions
674 use HTML::Element::Library;
675 use HTML::TreeBuilder;
679 This method provides API calls for common actions on trees when using
684 The test suite contains examples of each of these methods in a
687 =head2 Positional Querying Methods
689 =head3 $elem->siblings
691 Return a list of all nodes under the same parent.
695 Return the index of C<$elem> into the array of siblings of which it is
696 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
697 that is a descriptive name. And such naming is deceptively close to the
698 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
699 backwards compatibility, both methods are available.
705 =head3 $elem->position()
707 Returns the coordinates of this element in the tree it inhabits.
708 This is accomplished by succesively calling addr() on ancestor
709 elements until either a) an element that does not support these
710 methods is found, or b) there are no more parents. The resulting
711 list is the n-dimensional coordinates of the element in the tree.
713 =head2 Element Decoration Methods
715 =head3 HTML::Element::Library::super_literal($text)
717 In L<HTML::Element>, Sean Burke discusses super-literals. They are
718 text which does not get escaped. Great for includng Javascript in
719 HTML. Also great for including foreign language into a document.
721 So, you basically toss C<super_literal> your text and back comes
722 your text wrapped in a C<~literal> element.
724 One of these days, I'll around to writing a nice C<EXPORT> section.
726 =head2 Tree Rewriting Methods
728 =head3 $elem->replace_content(@new_elem)
730 Replaces all of C<$elem>'s content with C<@new_elem>.
732 =head3 $elem->wrap_content($wrapper_element)
734 Wraps the existing content in the provided element. If the provided element
735 happens to be a non-element, a push_content is performed instead.
737 =head3 $elem->set_child_content(@look_down, $content)
739 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
741 After finding the node, it detaches the node's content and pushes $content as the node's content.
743 =head3 $tree->content_handler(%id_content)
745 This is a convenience method. Because the look_down criteria will often simply be:
751 <a id=fixme href=http://www.somesite.org>replace_content</a>
753 You can call this method to shorten your typing a bit. You can simply type
755 $elem->content_handler( fixme => 'new text' )
759 $elem->set_child_content(sid => 'fixme', 'new text')
761 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:
763 my %id_content = (name => "Terrence Brannon",
764 email => 'tbrannon@in.com',
766 content => $main_content);
768 $tree->content_handler(%id_content);
770 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
772 This allows for "if-then-else" style processing. Highlander was a movie in
773 which only one would survive. Well, in terms of a tree when looking at a
774 structure that you want to process in C<if-then-else> style, only one child
775 will survive. For example, given this HTML template:
777 <span klass="highlander" id="age_dialog">
779 Hello, does your mother know you're
780 using her AOL account?
783 Sorry, you're not old enough to enter
784 (and too dumb to lie about your age)
791 We only want one child of the C<span> tag with id C<age_dialog> to remain
792 based on the age of the person visiting the page.
794 So, let's setup a call that will prune the subtree as a function of age:
798 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
803 under10 => sub { $_[0] < 10} ,
804 under18 => sub { $_[0] < 18} ,
810 And there we have it. If the age is less than 10, then the node with
811 id C<under10> remains. For age less than 18, the node with id C<under18>
813 Otherwise our "else" condition fires and the child with id C<welcome> remains.
815 =head3 $tree->passover($id_of_element)
817 In some cases, you know exactly which element should survive. In this case,
818 you can simply call C<passover> to remove it's siblings. For the HTML
819 above, you could delete C<under10> and C<welcome> by simply calling:
821 $tree->passover('under18');
823 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
825 Right around the same time that C<table2()> came into being, Seamstress
826 began to tackle tougher and tougher processing problems. It became clear that
827 a more powerful highlander was needed... one that not only snipped the tree
828 of the nodes that should not survive, but one that allows for
829 post-processing of the survivor node. And one that was more flexible with
830 how to find the nodes to snip.
832 Thus (drum roll) C<highlander2()>.
834 So let's look at our HTML which requires post-selection processing:
836 <span klass="highlander" id="age_dialog">
838 Hello, little <span id=age>AGE</span>-year old,
839 does your mother know you're using her AOL account?
842 Sorry, you're only <span id=age>AGE</span>
843 (and too dumb to lie about your age)
846 Welcome, isn't it good to be <span id=age>AGE</span> years old?
850 In this case, a branch survives, but it has dummy data in it. We must take
851 the surviving segment of HTML and rewrite the age C<span> with the age.
852 Here is how we use C<highlander2()> to do so:
857 $branch->look_down(id => 'age')->replace_content($age);
860 my $if_then = $tree->look_down(id => 'age_dialog');
862 $if_then->highlander2(
880 We pass it the tree (C<$if_then>), an arrayref of conditions
881 (C<cond>) and an arrayref of arguments which are passed to the
882 C<cond>s and to the replacement subs.
884 The C<under10>, C<under18> and C<welcome> are id attributes in the
885 tree of the siblings of which only one will survive. However,
886 should you need to do
887 more complex look-downs to find the survivor,
888 then supply an array ref instead of a simple
892 $if_then->highlander2(
894 [class => 'r12'] => [
898 [class => 'z22'] => [
902 [class => 'w88'] => [
911 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
913 This method is designed for taking a tree and reworking a set of nodes in
914 a stereotyped fashion. For instance let's say you have 3 remote image
915 archives, but you don't want to put long URLs in your img src
916 tags for reasons of abstraction, re-use and brevity. So instead you do this:
918 <img src="/img/smiley-face.jpg" fixup="src lnc">
919 <img src="/img/hot-babe.jpg" fixup="src playboy">
920 <img src="/img/footer.jpg" fixup="src foobar">
922 and then when the tree of HTML is being processed, you make this call:
925 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
926 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
927 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
930 $tree->overwrite_attr(fixup => \%closures) ;
932 and the tags come out modified like so:
934 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
935 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
936 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
938 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
940 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
941 assumes the return value of the
942 closure is supposed overwrite an attribute value and does it for you.
943 C<mute_elem> is a more general function which does nothing but
944 hand the closure the element and let it mutate it as it jolly well pleases :)
946 In fact, here is the implementation of C<overwrite_attr>
947 to give you a taste of how C<mute_attr> is used:
949 sub overwrite_action {
950 my ($mute_node, %X) = @_;
952 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
956 sub HTML::Element::overwrite_attr {
959 $tree->mute_elem(@_, \&overwrite_action);
965 =head2 Tree-Building Methods: Unrolling an array via a single sample element (<ul> container)
967 This is best described by example. Given this HTML:
969 <strong>Here are the things I need from the store:</strong>
971 <li class="store_items">Sample item</li>
974 We can unroll it like so:
976 my $li = $tree->look_down(class => 'store_items');
978 my @items = qw(bread butter vodka);
980 $tree->iter($li => @items);
987 <body>Here are the things I need from the store:
989 <li class="store_items">bread</li>
990 <li class="store_items">butter</li>
991 <li class="store_items">vodka</li>
996 =head2 Tree-Building Methods: Unrolling an array via n sample elements (<dl> container)
998 C<iter()> was fine for awhile, but some things
999 (e.g. definition lists) need a more general function to make them easy to
1000 do. Hence C<iter2()>. This function will be explained by example of unrolling
1001 a simple definition list.
1003 So here's our mock-up HTML from the designer:
1005 <dl class="dual_iter" id="service_plan">
1010 A person who draws blood.
1017 A clone of Iggy Pop.
1024 A relative of Edgar Allan Poe.
1027 <dt class="adstyle">sample header</dt>
1028 <dd class="adstyle2">sample data</dd>
1033 And we want to unroll our data set:
1036 ['the pros' => 'never have to worry about service again'],
1037 ['the cons' => 'upfront extra charge on purchase'],
1038 ['our choice' => 'go with the extended service plan']
1042 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1043 Let's assume that we want only the last <dt> and it's accompanying <dd>
1044 (the one with "sample data") to be used as the sample data
1045 for unrolling with our data set. Let's further assume that we want them to
1046 remain in the final output.
1048 So now, the API to C<iter2()> will be discussed and we will explain how our
1049 goal of getting our data into HTML fits into the API.
1055 This is how to look down and find the container of all the elements we will
1056 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1059 If you pass an anonymous subroutine, then it is presumed that execution of
1060 this subroutine will return the HTML::Element representing the container tag.
1061 If you pass an array ref, then this will be dereferenced and passed to
1062 C<HTML::Element::look_down()>.
1064 default value: C<< ['_tag' => 'dl'] >>
1066 Based on the mock HTML above, this default is fine for finding our container
1067 tag. So let's move on.
1069 =item * wrapper_data
1071 This is an array reference of data that we will be putting into the container.
1072 You must supply this. C<@items> above is our C<wrapper_data>.
1074 =item * wrapper_proc
1076 After we find the container via C<wrapper_ld>, we may want to pre-process
1077 some aspect of this tree. In our case the first two sets of dt and dd need
1078 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1085 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1086 be cloned and populated with item data
1087 (item data is a "row" of C<wrapper_data>).
1089 default: returns an arrayref consisting of the dt and dd element inside the
1094 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1095 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1096 I hope that makes sense.
1098 default: shifts C<wrapper_data>.
1102 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1103 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1104 eventually be spliced into the container.
1106 Note that this subroutine MUST return the new items. This is done
1107 So that more items than were passed in can be returned. This is
1108 useful when, for example, you must return 2 dts for an input data item.
1109 And when would you do this? When a single term has multiple spellings
1112 default: expects C<item_data> to be an arrayref of two elements and
1113 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1114 content of the C<HTML::Element>s with the C<item_data>.
1118 After building up an array of C<@item_elems>, the subroutine passed as
1119 C<splice> will be given the parent container HTML::Element and the
1120 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1121 routine: it could put half of them in. It could unshift them or whatever.
1123 default: C<< $container->splice_content(0, 2, @item_elems) >>
1124 In other words, kill the 2 sample elements with the newly generated
1129 So now that we have documented the API, let's see the call we need:
1132 # default wrapper_ld ok.
1133 wrapper_data => \@items,
1134 wrapper_proc => sub {
1135 my ($container) = @_;
1137 # only keep the last 2 dts and dds
1138 my @content_list = $container->content_list;
1139 $container->splice_content(0, @content_list - 2);
1142 # default item_ld is fine.
1143 # default item_data is fine.
1144 # default item_proc is fine.
1146 my ($container, @item_elems) = @_;
1147 $container->unshift_content(@item_elems);
1153 =head2 Tree-Building Methods: Select Unrolling
1155 The C<unroll_select> method has this API:
1157 $tree->unroll_select(
1158 select_label => $id_label,
1159 option_value => $closure, # how to get option value from data row
1160 option_content => $closure, # how to get option content from data row
1161 option_selected => $closure, # boolean to decide if SELECTED
1162 data => $data # the data to be put into the SELECT
1163 data_iter => $closure # the thing that will get a row of data
1168 $tree->unroll_select(
1169 select_label => 'clan_list',
1170 option_value => sub { my $row = shift; $row->clan_id },
1171 option_content => sub { my $row = shift; $row->clan_name },
1172 option_selected => sub { my $row = shift; $row->selected },
1173 data => \@query_results,
1174 data_iter => sub { my $data = shift; $data->next }
1179 =head2 Tree-Building Methods: Table Generation
1181 Matthew Sisk has a much more intuitive (imperative)
1182 way to generate tables via his module
1183 L<HTML::ElementTable|HTML::ElementTable>.
1184 However, for those with callback fever, the following
1185 method is available. First, we look at a nuts and bolts way to build a table
1186 using only standard L<HTML::Tree> API calls. Then the C<table> method
1187 available here is discussed.
1191 package Simple::Class;
1195 my @name = qw(bob bill brian babette bobo bix);
1196 my @age = qw(99 12 44 52 12 43);
1197 my @weight = qw(99 52 80 124 120 230);
1202 bless {}, ref($this) || $this;
1210 age => $age[rand $#age] + int rand 20,
1211 name => shift @name,
1212 weight => $weight[rand $#weight] + int rand 40
1216 Set::Array->new(@data);
1223 =head4 Sample Usage:
1225 my $data = Simple::Class->load_data;
1226 ++$_->{age} for @$data
1228 =head3 Inline Code to Unroll a Table
1234 <table id="load_data">
1236 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1240 <td id="name"> NATURE BOY RIC FLAIR </td>
1241 <td id="age"> 35 </td>
1242 <td id="weight"> 220 </td>
1251 =head4 The manual way (*NOT* recommended)
1253 require 'simple-class.pl';
1254 use HTML::Seamstress;
1257 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1260 my $o = Simple::Class->new;
1261 my $data = $o->load_data;
1263 # find the <table> and <tr>
1264 my $table_node = $seamstress->look_down('id', 'load_data');
1265 my $iter_node = $table_node->look_down('id', 'iterate');
1266 my $table_parent = $table_node->parent;
1269 # drop the sample <table> and <tr> from the HTML
1270 # only add them in if there is data in the model
1271 # this is achieved via the $add_table flag
1273 $table_node->detach;
1277 # Get a row of model data
1278 while (my $row = shift @$data) {
1280 # We got row data. Set the flag indicating ok to hook the table into the HTML
1283 # clone the sample <tr>
1284 my $new_iter_node = $iter_node->clone;
1286 # find the tags labeled name age and weight and
1287 # set their content to the row data
1288 $new_iter_node->content_handler($_ => $row->{$_})
1289 for qw(name age weight);
1291 $table_node->push_content($new_iter_node);
1295 # reattach the table to the HTML tree if we loaded data into some table rows
1297 $table_parent->push_content($table_node) if $add_table;
1299 print $seamstress->as_HTML;
1303 =head3 $tree->table() : API call to Unroll a Table
1305 require 'simple-class.pl';
1306 use HTML::Seamstress;
1309 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1311 my $o = Simple::Class->new;
1315 # tell seamstress where to find the table, via the method call
1316 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1317 # HTML tree automatically if no table rows can be built
1319 gi_table => 'load_data',
1321 # tell seamstress where to find the tr. This is a bit useless as
1322 # the <tr> usually can be found as the first child of the parent
1326 # the model data to be pushed into the table
1328 table_data => $o->load_data,
1330 # the way to take the model data and obtain one row
1331 # if the table data were a hashref, we would do:
1332 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1334 tr_data => sub { my ($self, $data) = @_;
1338 # the way to take a row of data and fill the <td> tags
1340 td_data => sub { my ($tr_node, $tr_data) = @_;
1341 $tr_node->content_handler($_ => $tr_data->{$_})
1342 for qw(name age weight) }
1347 print $seamstress->as_HTML;
1351 =head4 Looping over Multiple Sample Rows
1357 <table id="load_data" CELLPADDING=8 BORDER=2>
1359 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1361 <tr id="iterate1" BGCOLOR="white" >
1363 <td id="name"> NATURE BOY RIC FLAIR </td>
1364 <td id="age"> 35 </td>
1365 <td id="weight"> 220 </td>
1368 <tr id="iterate2" BGCOLOR="#CCCC99">
1370 <td id="name"> NATURE BOY RIC FLAIR </td>
1371 <td id="age"> 35 </td>
1372 <td id="weight"> 220 </td>
1381 * Only one change to last API call.
1389 gi_tr => ['iterate1', 'iterate2']
1391 =head3 $tree->table2() : New API Call to Unroll a Table
1393 After 2 or 3 years with C<table()>, I began to develop
1394 production websites with it and decided it needed a cleaner
1395 interface, particularly in the area of handling the fact that
1396 C<id> tags will be the same after cloning a table row.
1398 First, I will give a dry listing of the function's argument parameters.
1399 This will not be educational most likely. A better way to understand how
1400 to use the function is to read through the incremental unrolling of the
1401 function's interface given in conversational style after the dry listing.
1402 But take your pick. It's the same information given in two different
1405 =head4 Dry/technical parameter documentation
1407 C<< $tree->table2(%param) >> takes the following arguments:
1411 =item * C<< table_ld => $look_down >> : optional
1413 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1414 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1415 passing it C<$tree>.
1417 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1419 =item * C<< table_data => $tabular_data >> : required
1421 The data to fill the table with. I<Must> be passed in.
1423 =item * C<< table_proc => $code_ref >> : not implemented
1425 A subroutine to do something to the table once it is found.
1426 Not currently implemented. Not obviously necessary. Just
1427 created because there is a C<tr_proc> and C<td_proc>.
1429 =item * C<< tr_ld => $look_down >> : optional
1431 Same as C<table_ld> but for finding the table row elements. Please note
1432 that the C<tr_ld> is done on the table node that was found I<instead>
1433 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1434 below the table that was just found.
1436 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1438 =item * C<< tr_data => $code_ref >> : optional
1440 How to take the C<table_data> and return a row. Defaults to:
1442 sub { my ($self, $data) = @_;
1446 =item * C<< tr_proc => $code_ref >> : optional
1448 Something to do to the table row we are about to add to the
1449 table we are making. Defaults to a routine which makes the C<id>
1453 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1454 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1457 =item * C<< td_proc => $code_ref >> : required
1459 This coderef will take the row of data and operate on the C<td> cells that
1460 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1462 Here's a sample one:
1465 my ($tr, $data) = @_;
1466 my @td = $tr->look_down('_tag' => 'td');
1467 for my $i (0..$#td) {
1468 $td[$i]->splice_content(0, 1, $data->[$i]);
1474 =head4 Conversational parameter documentation
1476 The first thing you need is a table. So we need a look down for that. If you
1477 don't give one, it defaults to
1481 What good is a table to display in without data to display?!
1482 So you must supply a scalar representing your tabular
1483 data source. This scalar might be an array reference, a C<next>able iterator,
1484 a DBI statement handle. Whatever it is, it can be iterated through to build
1485 up rows of table data.
1486 These two required fields (the way to find the table and the data to
1487 display in the table) are C<table_ld> and C<table_data>
1488 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1490 of the code ref is presumed to return the C<HTML::Element>
1491 representing the table in the HTML tree.
1493 Next, we get the row or rows which serve as sample C<tr> elements by doing
1494 a C<look_down> from the C<table_elem>. While normally one sample row
1495 is enough to unroll a table, consider when you have alternating
1496 table rows. This API call would need one of each row so that it can
1498 sample rows as it loops through the data.
1499 Alternatively, you could always just use one row and
1500 make the necessary changes to the single C<tr> row by
1501 mutating the element in C<tr_proc>,
1502 discussed below. The default C<tr_ld> is
1503 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1504 it with a subroutine, then it is expected that the subroutine will return
1505 the C<HTML::Element>(s)
1506 which are C<tr> element(s).
1507 The reason a subroutine might be preferred is in the case
1508 that the HTML designers gave you 8 sample C<tr> rows but only one
1509 prototype row is needed.
1510 So you can write a subroutine, to splice out the 7 rows you don't need
1511 and leave the one sample
1512 row remaining so that this API call can clone it and supply it to
1513 the C<tr_proc> and C<td_proc> calls.
1515 Now, as we move through the table rows with table data,
1516 we need to do two different things on
1521 =item * get one row of data from the C<table_data> via C<tr_data>
1523 The default procedure assumes the C<table_data> is an array reference and
1524 shifts a row off of it:
1526 sub { my ($self, $data) = @_;
1530 Your function MUST return undef when there is no more rows to lay out.
1532 =item * take the C<tr> element and mutate it via C<tr_proc>
1534 The default procedure simply makes the id of the table row unique:
1536 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1537 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1542 Now that we have our row of data, we call C<td_proc> so that it can
1543 take the data and the C<td> cells in this C<tr> and process them.
1544 This function I<must> be supplied.
1547 =head3 Whither a Table with No Rows
1549 Often when a table has no rows, we want to display a message
1550 indicating this to the view. Use conditional processing to decide what
1554 <table><tr><td>No Data is Good Data</td></tr></table>
1559 <table id="load_data">
1561 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1565 <td id="name"> NATURE BOY RIC FLAIR </td>
1566 <td id="age"> 35 </td>
1567 <td id="weight"> 220 </td>
1584 =item * L<HTML::Tree>
1586 A perl package for creating and manipulating HTML trees
1588 =item * L<HTML::ElementTable>
1590 An L<HTML::Tree> - based module which allows for manipulation of HTML
1591 trees using cartesian coordinations.
1593 =item * L<HTML::Seamstress>
1595 An L<HTML::Tree> - based module inspired by
1596 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1597 HTML generation via tree rewriting.
1605 currently the API expects the subtrees to survive or be pruned to be
1608 $if_then->highlander2([
1609 under10 => sub { $_[0] < 10} ,
1610 under18 => sub { $_[0] < 18} ,
1615 $branch->look_down(id => 'age')->replace_content($age);
1622 but, it should be more flexible. the C<under10>, and C<under18> are
1623 expected to be ids in the tree... but it is not hard to have a check to
1624 see if this field is an array reference and if it, then to do a look
1627 $if_then->highlander2([
1628 [class => 'under10'] => sub { $_[0] < 10} ,
1629 [class => 'under18'] => sub { $_[0] < 18} ,
1630 [class => 'welcome'] => [
1634 $branch->look_down(id => 'age')->replace_content($age);
1651 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1653 Many thanks to BARBIE for his RT bug report.
1655 =head1 COPYRIGHT AND LICENSE
1657 Copyright (C) 2004 by Terrence Brannon
1659 This library is free software; you can redistribute it and/or modify
1660 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1661 at your option, any later version of Perl 5 you may have available.
This page took 0.095824 seconds and 3 git commands to generate.