ef03c78f0f9cb83b292bc907c4f25c64cf2b5091
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
::data_map
{
42 my ($container, @rest) = @_;
45 my %p = validate
(@rest, {
48 excluding
=> { type
=> ARRAYREF
, default => [] }
52 my @same_as = $container->look_down('_attr' => $p{with_attr
});
54 for my $same_as (@same_as) {
55 next if first
{ $same_as eq $_ } @
{$p{excluding
}} ;
56 $same_as->replace_content( $p{href
}->{ $same_as->attr( $p{with_attr
} ) } ) ;
62 sub HTML
::Element
::passover
{
63 my ($tree, $child_id) = @_;
65 warn "ARGS: my ($tree, $child_id)" if $DEBUG;
66 warn $tree->as_HTML(undef, ' ') if $DEBUG;
68 my $exodus = $tree->look_down(id
=> $child_id);
70 warn "E: $exodus" if $DEBUG;
72 my @s = HTML
::Element
::siblings
($exodus);
76 if ($s->attr('id') eq $child_id) {
83 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
87 sub HTML
::Element
::sibdex
{
90 firstidx
{ $_ eq $element } $element->siblings
94 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
96 sub HTML
::Element
::replace_content
{
98 $elem->delete_content;
99 $elem->push_content(@_);
102 sub HTML
::Element
::wrap_content
{
103 my($self, $wrap) = @_;
104 my $content = $self->content;
106 $wrap->push_content(@
$content);
110 $self->push_content($wrap);
115 sub HTML
::Element
::Library
::super_literal
{
118 HTML
::Element
->new('~literal', text
=> $text);
122 sub HTML
::Element
::position
{
123 # Report coordinates by chasing addr's up the
124 # HTML::ElementSuper tree. We know we've reached
125 # the top when a) there is no parent, or b) the
126 # parent is some HTML::Element unable to report
132 unshift(@pos, $a) if defined $a;
139 sub HTML
::Element
::content_handler
{
140 my ($tree, %content_hash) = @_;
142 for my $k (keys %content_hash) {
143 $tree->set_child_content(id
=> $k, $content_hash{$k});
158 sub HTML
::Element
::iter
{
159 my ($tree, $p, @data) = @_;
161 # warn 'P: ' , $p->attr('id') ;
162 # warn 'H: ' , $p->as_HTML;
164 # my $id_incr = make_counter;
166 my $new_item = clone
$p;
167 $new_item->replace_content($_);
168 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
172 $p->replace_with(@item);
177 sub HTML
::Element
::iter2
{
181 #warn "INPUT TO TABLE2: ", Dumper \@_;
185 wrapper_ld
=> { default => ['_tag' => 'dl'] },
187 wrapper_proc
=> { default => undef },
188 item_ld
=> { default => sub {
191 $tree->look_down('_tag' => 'dt'),
192 $tree->look_down('_tag' => 'dd')
196 item_data
=> { default => sub { my ($wrapper_data) = @_;
197 shift(@
{$wrapper_data}) ;
201 my ($item_elems, $item_data, $row_count) = @_;
202 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
205 splice => { default => sub {
206 my ($container, @item_elems) = @_;
207 $container->splice_content(0, 2, @item_elems);
210 debug
=> {default => 0}
214 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
216 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
217 warn "container: " . $container if $p{debug
} ;
218 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug
} ;
219 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
220 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug
} ;
222 my $_item_elems = $p{item_ld
}->($container);
229 my $item_data = $p{item_data
}->($p{wrapper_data
});
230 last unless defined $item_data;
232 warn Dumper
("item_data", $item_data);
235 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
238 for (@
{$item_elems}) {
239 warn "ITEM_ELEMS ", $_->as_HTML;
243 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
246 for (@
{$new_item_elems}) {
247 warn "NEWITEM_ELEMS ", $_->as_HTML;
252 push @item_elem, @
{$new_item_elems} ;
257 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
259 $p{splice}->($container, @item_elem);
263 sub HTML
::Element
::dual_iter
{
264 my ($parent, $data) = @_;
266 my ($prototype_a, $prototype_b) = $parent->content_list;
268 # my $id_incr = make_counter;
273 confess
'dataset does not contain an even number of members';
275 my @iterable_data = ngroup
2 => @
$data;
278 my ($new_a, $new_b) = map { clone
$_ } ($prototype_a, $prototype_b) ;
279 $new_a->splice_content(0,1, $_->[0]);
280 $new_b->splice_content(0,1, $_->[1]);
281 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
285 $parent->splice_content(0, 2, @item);
290 sub HTML
::Element
::set_child_content
{
295 my $content_tag = $tree->look_down(@look_down);
297 unless ($content_tag) {
298 warn "criteria [@look_down] not found";
302 $content_tag->replace_content($content);
306 sub HTML
::Element
::highlander
{
307 my ($tree, $local_root_id, $aref, @arg) = @_;
309 ref $aref eq 'ARRAY' or confess
310 "must supply array reference";
313 @aref % 2 == 0 or confess
314 "supplied array ref must have an even number of entries";
316 warn __PACKAGE__
if $DEBUG;
319 while (my ($id, $test) = splice @aref, 0, 2) {
328 my @id_survivor = (id
=> $survivor);
329 my $survivor_node = $tree->look_down(@id_survivor);
331 # warn $local_root_id;
334 warn "survivor: $survivor" if $DEBUG;
335 warn "tree: " . $tree->as_HTML if $DEBUG;
337 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
339 my $survivor_node_parent = $survivor_node->parent;
340 $survivor_node = $survivor_node->clone;
341 $survivor_node_parent->replace_content($survivor_node);
343 warn "new tree: " . $tree->as_HTML if $DEBUG;
349 sub HTML
::Element
::highlander2
{
352 my %p = validate
(@_, {
353 cond
=> { type
=> ARRAYREF
},
354 cond_arg
=> { type
=> ARRAYREF
,
357 debug
=> { default => 0 }
362 my @cond = @
{$p{cond
}};
363 @cond % 2 == 0 or confess
364 "supplied array ref must have an even number of entries";
366 warn __PACKAGE__
if $p{debug
};
368 my @cond_arg = @
{$p{cond_arg
}};
370 my $survivor; my $then;
371 while (my ($id, $if_then) = splice @cond, 0, 2) {
373 warn $id if $p{debug
};
376 if (ref $if_then eq 'ARRAY') {
377 ($if, $_then) = @
$if_then;
379 ($if, $_then) = ($if_then, sub {});
382 if ($if->(@cond_arg)) {
390 my @ld = (ref $survivor eq 'ARRAY')
395 warn "survivor: ", $survivor if $p{debug
};
396 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
399 my $survivor_node = $tree->look_down(@ld);
401 $survivor_node or confess
402 "search for @ld failed in tree($tree): " . $tree->as_HTML;
404 my $survivor_node_parent = $survivor_node->parent;
405 $survivor_node = $survivor_node->clone;
406 $survivor_node_parent->replace_content($survivor_node);
409 # **************** NEW FUNCTIONALITY *******************
411 # apply transforms on survivor node
414 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug
};
415 $then->($survivor_node, @cond_arg);
416 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug
};
418 # **************** NEW FUNCTIONALITY *******************
427 sub overwrite_action
{
428 my ($mute_node, %X) = @_;
430 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
434 sub HTML
::Element
::overwrite_attr
{
437 $tree->mute_elem(@_, \
&overwrite_action
);
442 sub HTML
::Element
::mute_elem
{
443 my ($tree, $mute_attr, $closures, $post_hook) = @_;
445 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
446 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
448 for my $mute_node (@mute_node) {
449 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
450 my $local_attr_value_current = $mute_node->attr($local_attr);
451 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
458 current
=> $local_attr_value_current,
459 new
=> $local_attr_value_new
468 sub HTML
::Element
::table
{
470 my ($s, %table) = @_;
474 # use Data::Dumper; warn Dumper \%table;
476 # ++$DEBUG if $table{debug} ;
479 # Get the table element
480 $table->{table_node
} = $s->look_down(id
=> $table{gi_table
});
481 $table->{table_node
} or confess
482 "table tag not found via (id => $table{gi_table}";
484 # Get the prototype tr element(s)
485 my @table_gi_tr = listify
$table{gi_tr
} ;
488 my $tr = $table->{table_node
}->look_down(id
=> $_);
489 $tr or confess
"tr with id => $_ not found";
493 warn "found " . @iter_node . " iter nodes " if $DEBUG;
494 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
495 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
498 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
500 # $table->{content} = $table{content};
501 #$table->{parent} = $table->{table_node}->parent;
504 # $table->{table_node}->detach;
505 # $_->detach for @iter_node;
510 my $row = $table{tr_data
}->($table, $table{table_data
});
511 last unless defined $row;
513 # get a sample table row and clone it.
514 my $I = $iter_node->next;
515 warn "I: $I" if $DEBUG;
516 my $new_iter_node = $I->clone;
519 $table{td_data
}->($new_iter_node, $row);
520 push @table_rows, $new_iter_node;
527 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
529 $s->look_down(id
=> $_)->detach;
532 $replace_with_elem->replace_with(@table_rows);
540 my ($tree, $slot) = @_;
542 if (ref($slot) eq 'CODE') {
545 $tree->look_down(@
$slot);
551 sub HTML
::Element
::table2
{
559 table_ld
=> { default => ['_tag' => 'table'] },
561 table_proc
=> { default => undef },
563 tr_ld
=> { default => ['_tag' => 'tr'] },
564 tr_data
=> { default => sub { my ($self, $data) = @_;
567 tr_base_id
=> { default => undef },
568 tr_proc
=> { default => sub {} },
570 debug
=> {default => 0}
574 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
576 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
580 # use Data::Dumper; warn Dumper \%table;
582 # ++$DEBUG if $table{debug} ;
584 # Get the table element
586 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
588 $table->{table_node
} or confess
589 "table tag not found via " . Dumper
($p{table_ld
}) ;
591 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
594 # Get the prototype tr element(s)
595 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
597 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
599 @proto_tr or return ;
602 warn $_->as_HTML for @proto_tr;
604 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
606 my $tr_parent = $proto_tr[0]->parent;
607 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
614 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
615 warn "data row: " . Dumper
$row if $p{debug
};
616 last unless defined $row;
618 # wont work: my $new_iter_node = $table->{iter_node}->clone;
619 my $new_tr_node = $proto_tr->next->clone;
620 warn "new_tr_node: $new_tr_node" if $p{debug
};
622 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
623 if defined $p{tr_proc
};
625 warn "data row redux: " . Dumper
$row if $p{debug
};
628 $p{td_proc
}->($new_tr_node, $row);
629 push @table_rows, $new_tr_node;
636 $_->detach for @proto_tr;
638 $tr_parent->push_content(@table_rows) if (@table_rows) ;
643 sub HTML
::Element
::unroll_select
{
645 my ($s, %select) = @_;
649 my $select_node = $s->look_down(id
=> $select{select_label
});
651 my $option = $select_node->look_down('_tag' => 'option');
658 while (my $row = $select{data_iter
}->($select{data
}))
661 my $o = $option->clone;
662 $o->attr('value', $select{option_value
}->($row));
663 $o->attr('SELECTED', 1) if ($select{option_selected
}->($row)) ;
665 $o->replace_content($select{option_content
}->($row));
666 $select_node->push_content($o);
674 sub HTML
::Element
::set_sibling_content
{
675 my ($elt, $content) = @_;
677 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
681 sub HTML
::TreeBuilder
::parse_string
{
682 my ($package, $string) = @_;
684 my $h = HTML
::TreeBuilder
->new;
685 HTML
::TreeBuilder
->parse($string);
693 # Below is stub documentation for your module. You'd better edit it!
697 HTML::Element::Library - HTML::Element convenience functions
701 use HTML::Element::Library;
702 use HTML::TreeBuilder;
706 This method provides API calls for common actions on trees when using
711 The test suite contains examples of each of these methods in a
714 =head2 Positional Querying Methods
716 =head3 $elem->siblings
718 Return a list of all nodes under the same parent.
722 Return the index of C<$elem> into the array of siblings of which it is
723 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
724 that is a descriptive name. And such naming is deceptively close to the
725 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
726 backwards compatibility, both methods are available.
732 =head3 $elem->position()
734 Returns the coordinates of this element in the tree it inhabits.
735 This is accomplished by succesively calling addr() on ancestor
736 elements until either a) an element that does not support these
737 methods is found, or b) there are no more parents. The resulting
738 list is the n-dimensional coordinates of the element in the tree.
740 =head2 Element Decoration Methods
742 =head3 HTML::Element::Library::super_literal($text)
744 In L<HTML::Element>, Sean Burke discusses super-literals. They are
745 text which does not get escaped. Great for includng Javascript in
746 HTML. Also great for including foreign language into a document.
748 So, you basically toss C<super_literal> your text and back comes
749 your text wrapped in a C<~literal> element.
751 One of these days, I'll around to writing a nice C<EXPORT> section.
753 =head2 Tree Rewriting Methods
755 =head3 $elem->replace_content(@new_elem)
757 Replaces all of C<$elem>'s content with C<@new_elem>.
759 =head3 $elem->wrap_content($wrapper_element)
761 Wraps the existing content in the provided element. If the provided element
762 happens to be a non-element, a push_content is performed instead.
764 =head3 $elem->set_child_content(@look_down, $content)
766 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
768 After finding the node, it detaches the node's content and pushes $content as the node's content.
770 =head3 $tree->content_handler(%id_content)
772 This is a convenience method. Because the look_down criteria will often simply be:
778 <a id=fixme href=http://www.somesite.org>replace_content</a>
780 You can call this method to shorten your typing a bit. You can simply type
782 $elem->content_handler( fixme => 'new text' )
786 $elem->set_child_content(sid => 'fixme', 'new text')
788 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:
790 my %id_content = (name => "Terrence Brannon",
791 email => 'tbrannon@in.com',
793 content => $main_content);
795 $tree->content_handler(%id_content);
797 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
799 This allows for "if-then-else" style processing. Highlander was a movie in
800 which only one would survive. Well, in terms of a tree when looking at a
801 structure that you want to process in C<if-then-else> style, only one child
802 will survive. For example, given this HTML template:
804 <span klass="highlander" id="age_dialog">
806 Hello, does your mother know you're
807 using her AOL account?
810 Sorry, you're not old enough to enter
811 (and too dumb to lie about your age)
818 We only want one child of the C<span> tag with id C<age_dialog> to remain
819 based on the age of the person visiting the page.
821 So, let's setup a call that will prune the subtree as a function of age:
825 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
830 under10 => sub { $_[0] < 10} ,
831 under18 => sub { $_[0] < 18} ,
837 And there we have it. If the age is less than 10, then the node with
838 id C<under10> remains. For age less than 18, the node with id C<under18>
840 Otherwise our "else" condition fires and the child with id C<welcome> remains.
842 =head3 $tree->passover($id_of_element)
844 In some cases, you know exactly which element should survive. In this case,
845 you can simply call C<passover> to remove it's siblings. For the HTML
846 above, you could delete C<under10> and C<welcome> by simply calling:
848 $tree->passover('under18');
850 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
852 Right around the same time that C<table2()> came into being, Seamstress
853 began to tackle tougher and tougher processing problems. It became clear that
854 a more powerful highlander was needed... one that not only snipped the tree
855 of the nodes that should not survive, but one that allows for
856 post-processing of the survivor node. And one that was more flexible with
857 how to find the nodes to snip.
859 Thus (drum roll) C<highlander2()>.
861 So let's look at our HTML which requires post-selection processing:
863 <span klass="highlander" id="age_dialog">
865 Hello, little <span id=age>AGE</span>-year old,
866 does your mother know you're using her AOL account?
869 Sorry, you're only <span id=age>AGE</span>
870 (and too dumb to lie about your age)
873 Welcome, isn't it good to be <span id=age>AGE</span> years old?
877 In this case, a branch survives, but it has dummy data in it. We must take
878 the surviving segment of HTML and rewrite the age C<span> with the age.
879 Here is how we use C<highlander2()> to do so:
884 $branch->look_down(id => 'age')->replace_content($age);
887 my $if_then = $tree->look_down(id => 'age_dialog');
889 $if_then->highlander2(
907 We pass it the tree (C<$if_then>), an arrayref of conditions
908 (C<cond>) and an arrayref of arguments which are passed to the
909 C<cond>s and to the replacement subs.
911 The C<under10>, C<under18> and C<welcome> are id attributes in the
912 tree of the siblings of which only one will survive. However,
913 should you need to do
914 more complex look-downs to find the survivor,
915 then supply an array ref instead of a simple
919 $if_then->highlander2(
921 [class => 'r12'] => [
925 [class => 'z22'] => [
929 [class => 'w88'] => [
938 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
940 This method is designed for taking a tree and reworking a set of nodes in
941 a stereotyped fashion. For instance let's say you have 3 remote image
942 archives, but you don't want to put long URLs in your img src
943 tags for reasons of abstraction, re-use and brevity. So instead you do this:
945 <img src="/img/smiley-face.jpg" fixup="src lnc">
946 <img src="/img/hot-babe.jpg" fixup="src playboy">
947 <img src="/img/footer.jpg" fixup="src foobar">
949 and then when the tree of HTML is being processed, you make this call:
952 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
953 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
954 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
957 $tree->overwrite_attr(fixup => \%closures) ;
959 and the tags come out modified like so:
961 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
962 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
963 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
965 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
967 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
968 assumes the return value of the
969 closure is supposed overwrite an attribute value and does it for you.
970 C<mute_elem> is a more general function which does nothing but
971 hand the closure the element and let it mutate it as it jolly well pleases :)
973 In fact, here is the implementation of C<overwrite_attr>
974 to give you a taste of how C<mute_attr> is used:
976 sub overwrite_action {
977 my ($mute_node, %X) = @_;
979 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
983 sub HTML::Element::overwrite_attr {
986 $tree->mute_elem(@_, \&overwrite_action);
992 =head2 Tree-Building Methods: Unrolling an array via a single sample element (<ul> container)
994 This is best described by example. Given this HTML:
996 <strong>Here are the things I need from the store:</strong>
998 <li class="store_items">Sample item</li>
1001 We can unroll it like so:
1003 my $li = $tree->look_down(class => 'store_items');
1005 my @items = qw(bread butter vodka);
1007 $tree->iter($li => @items);
1014 <body>Here are the things I need from the store:
1016 <li class="store_items">bread</li>
1017 <li class="store_items">butter</li>
1018 <li class="store_items">vodka</li>
1023 =head2 Tree-Building Methods: Unrolling an array via n sample elements (<dl> container)
1025 C<iter()> was fine for awhile, but some things
1026 (e.g. definition lists) need a more general function to make them easy to
1027 do. Hence C<iter2()>. This function will be explained by example of unrolling
1028 a simple definition list.
1030 So here's our mock-up HTML from the designer:
1032 <dl class="dual_iter" id="service_plan">
1037 A person who draws blood.
1044 A clone of Iggy Pop.
1051 A relative of Edgar Allan Poe.
1054 <dt class="adstyle">sample header</dt>
1055 <dd class="adstyle2">sample data</dd>
1060 And we want to unroll our data set:
1063 ['the pros' => 'never have to worry about service again'],
1064 ['the cons' => 'upfront extra charge on purchase'],
1065 ['our choice' => 'go with the extended service plan']
1069 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1070 Let's assume that we want only the last <dt> and it's accompanying <dd>
1071 (the one with "sample data") to be used as the sample data
1072 for unrolling with our data set. Let's further assume that we want them to
1073 remain in the final output.
1075 So now, the API to C<iter2()> will be discussed and we will explain how our
1076 goal of getting our data into HTML fits into the API.
1082 This is how to look down and find the container of all the elements we will
1083 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1086 If you pass an anonymous subroutine, then it is presumed that execution of
1087 this subroutine will return the HTML::Element representing the container tag.
1088 If you pass an array ref, then this will be dereferenced and passed to
1089 C<HTML::Element::look_down()>.
1091 default value: C<< ['_tag' => 'dl'] >>
1093 Based on the mock HTML above, this default is fine for finding our container
1094 tag. So let's move on.
1096 =item * wrapper_data
1098 This is an array reference of data that we will be putting into the container.
1099 You must supply this. C<@items> above is our C<wrapper_data>.
1101 =item * wrapper_proc
1103 After we find the container via C<wrapper_ld>, we may want to pre-process
1104 some aspect of this tree. In our case the first two sets of dt and dd need
1105 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1112 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1113 be cloned and populated with item data
1114 (item data is a "row" of C<wrapper_data>).
1116 default: returns an arrayref consisting of the dt and dd element inside the
1121 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1122 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1123 I hope that makes sense.
1125 default: shifts C<wrapper_data>.
1129 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1130 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1131 eventually be spliced into the container.
1133 Note that this subroutine MUST return the new items. This is done
1134 So that more items than were passed in can be returned. This is
1135 useful when, for example, you must return 2 dts for an input data item.
1136 And when would you do this? When a single term has multiple spellings
1139 default: expects C<item_data> to be an arrayref of two elements and
1140 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1141 content of the C<HTML::Element>s with the C<item_data>.
1145 After building up an array of C<@item_elems>, the subroutine passed as
1146 C<splice> will be given the parent container HTML::Element and the
1147 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1148 routine: it could put half of them in. It could unshift them or whatever.
1150 default: C<< $container->splice_content(0, 2, @item_elems) >>
1151 In other words, kill the 2 sample elements with the newly generated
1156 So now that we have documented the API, let's see the call we need:
1159 # default wrapper_ld ok.
1160 wrapper_data => \@items,
1161 wrapper_proc => sub {
1162 my ($container) = @_;
1164 # only keep the last 2 dts and dds
1165 my @content_list = $container->content_list;
1166 $container->splice_content(0, @content_list - 2);
1169 # default item_ld is fine.
1170 # default item_data is fine.
1171 # default item_proc is fine.
1173 my ($container, @item_elems) = @_;
1174 $container->unshift_content(@item_elems);
1180 =head2 Tree-Building Methods: Select Unrolling
1182 The C<unroll_select> method has this API:
1184 $tree->unroll_select(
1185 select_label => $id_label,
1186 option_value => $closure, # how to get option value from data row
1187 option_content => $closure, # how to get option content from data row
1188 option_selected => $closure, # boolean to decide if SELECTED
1189 data => $data # the data to be put into the SELECT
1190 data_iter => $closure # the thing that will get a row of data
1195 $tree->unroll_select(
1196 select_label => 'clan_list',
1197 option_value => sub { my $row = shift; $row->clan_id },
1198 option_content => sub { my $row = shift; $row->clan_name },
1199 option_selected => sub { my $row = shift; $row->selected },
1200 data => \@query_results,
1201 data_iter => sub { my $data = shift; $data->next }
1206 =head2 Tree-Building Methods: Table Generation
1208 Matthew Sisk has a much more intuitive (imperative)
1209 way to generate tables via his module
1210 L<HTML::ElementTable|HTML::ElementTable>.
1211 However, for those with callback fever, the following
1212 method is available. First, we look at a nuts and bolts way to build a table
1213 using only standard L<HTML::Tree> API calls. Then the C<table> method
1214 available here is discussed.
1218 package Simple::Class;
1222 my @name = qw(bob bill brian babette bobo bix);
1223 my @age = qw(99 12 44 52 12 43);
1224 my @weight = qw(99 52 80 124 120 230);
1229 bless {}, ref($this) || $this;
1237 age => $age[rand $#age] + int rand 20,
1238 name => shift @name,
1239 weight => $weight[rand $#weight] + int rand 40
1243 Set::Array->new(@data);
1250 =head4 Sample Usage:
1252 my $data = Simple::Class->load_data;
1253 ++$_->{age} for @$data
1255 =head3 Inline Code to Unroll a Table
1261 <table id="load_data">
1263 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1267 <td id="name"> NATURE BOY RIC FLAIR </td>
1268 <td id="age"> 35 </td>
1269 <td id="weight"> 220 </td>
1278 =head4 The manual way (*NOT* recommended)
1280 require 'simple-class.pl';
1281 use HTML::Seamstress;
1284 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1287 my $o = Simple::Class->new;
1288 my $data = $o->load_data;
1290 # find the <table> and <tr>
1291 my $table_node = $seamstress->look_down('id', 'load_data');
1292 my $iter_node = $table_node->look_down('id', 'iterate');
1293 my $table_parent = $table_node->parent;
1296 # drop the sample <table> and <tr> from the HTML
1297 # only add them in if there is data in the model
1298 # this is achieved via the $add_table flag
1300 $table_node->detach;
1304 # Get a row of model data
1305 while (my $row = shift @$data) {
1307 # We got row data. Set the flag indicating ok to hook the table into the HTML
1310 # clone the sample <tr>
1311 my $new_iter_node = $iter_node->clone;
1313 # find the tags labeled name age and weight and
1314 # set their content to the row data
1315 $new_iter_node->content_handler($_ => $row->{$_})
1316 for qw(name age weight);
1318 $table_node->push_content($new_iter_node);
1322 # reattach the table to the HTML tree if we loaded data into some table rows
1324 $table_parent->push_content($table_node) if $add_table;
1326 print $seamstress->as_HTML;
1330 =head3 $tree->table() : API call to Unroll a Table
1332 require 'simple-class.pl';
1333 use HTML::Seamstress;
1336 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1338 my $o = Simple::Class->new;
1342 # tell seamstress where to find the table, via the method call
1343 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1344 # HTML tree automatically if no table rows can be built
1346 gi_table => 'load_data',
1348 # tell seamstress where to find the tr. This is a bit useless as
1349 # the <tr> usually can be found as the first child of the parent
1353 # the model data to be pushed into the table
1355 table_data => $o->load_data,
1357 # the way to take the model data and obtain one row
1358 # if the table data were a hashref, we would do:
1359 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1361 tr_data => sub { my ($self, $data) = @_;
1365 # the way to take a row of data and fill the <td> tags
1367 td_data => sub { my ($tr_node, $tr_data) = @_;
1368 $tr_node->content_handler($_ => $tr_data->{$_})
1369 for qw(name age weight) }
1374 print $seamstress->as_HTML;
1378 =head4 Looping over Multiple Sample Rows
1384 <table id="load_data" CELLPADDING=8 BORDER=2>
1386 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1388 <tr id="iterate1" BGCOLOR="white" >
1390 <td id="name"> NATURE BOY RIC FLAIR </td>
1391 <td id="age"> 35 </td>
1392 <td id="weight"> 220 </td>
1395 <tr id="iterate2" BGCOLOR="#CCCC99">
1397 <td id="name"> NATURE BOY RIC FLAIR </td>
1398 <td id="age"> 35 </td>
1399 <td id="weight"> 220 </td>
1408 * Only one change to last API call.
1416 gi_tr => ['iterate1', 'iterate2']
1418 =head3 $tree->table2() : New API Call to Unroll a Table
1420 After 2 or 3 years with C<table()>, I began to develop
1421 production websites with it and decided it needed a cleaner
1422 interface, particularly in the area of handling the fact that
1423 C<id> tags will be the same after cloning a table row.
1425 First, I will give a dry listing of the function's argument parameters.
1426 This will not be educational most likely. A better way to understand how
1427 to use the function is to read through the incremental unrolling of the
1428 function's interface given in conversational style after the dry listing.
1429 But take your pick. It's the same information given in two different
1432 =head4 Dry/technical parameter documentation
1434 C<< $tree->table2(%param) >> takes the following arguments:
1438 =item * C<< table_ld => $look_down >> : optional
1440 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1441 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1442 passing it C<$tree>.
1444 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1446 =item * C<< table_data => $tabular_data >> : required
1448 The data to fill the table with. I<Must> be passed in.
1450 =item * C<< table_proc => $code_ref >> : not implemented
1452 A subroutine to do something to the table once it is found.
1453 Not currently implemented. Not obviously necessary. Just
1454 created because there is a C<tr_proc> and C<td_proc>.
1456 =item * C<< tr_ld => $look_down >> : optional
1458 Same as C<table_ld> but for finding the table row elements. Please note
1459 that the C<tr_ld> is done on the table node that was found I<instead>
1460 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1461 below the table that was just found.
1463 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1465 =item * C<< tr_data => $code_ref >> : optional
1467 How to take the C<table_data> and return a row. Defaults to:
1469 sub { my ($self, $data) = @_;
1473 =item * C<< tr_proc => $code_ref >> : optional
1475 Something to do to the table row we are about to add to the
1476 table we are making. Defaults to a routine which makes the C<id>
1480 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1481 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1484 =item * C<< td_proc => $code_ref >> : required
1486 This coderef will take the row of data and operate on the C<td> cells that
1487 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1489 Here's a sample one:
1492 my ($tr, $data) = @_;
1493 my @td = $tr->look_down('_tag' => 'td');
1494 for my $i (0..$#td) {
1495 $td[$i]->splice_content(0, 1, $data->[$i]);
1501 =head4 Conversational parameter documentation
1503 The first thing you need is a table. So we need a look down for that. If you
1504 don't give one, it defaults to
1508 What good is a table to display in without data to display?!
1509 So you must supply a scalar representing your tabular
1510 data source. This scalar might be an array reference, a C<next>able iterator,
1511 a DBI statement handle. Whatever it is, it can be iterated through to build
1512 up rows of table data.
1513 These two required fields (the way to find the table and the data to
1514 display in the table) are C<table_ld> and C<table_data>
1515 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1517 of the code ref is presumed to return the C<HTML::Element>
1518 representing the table in the HTML tree.
1520 Next, we get the row or rows which serve as sample C<tr> elements by doing
1521 a C<look_down> from the C<table_elem>. While normally one sample row
1522 is enough to unroll a table, consider when you have alternating
1523 table rows. This API call would need one of each row so that it can
1525 sample rows as it loops through the data.
1526 Alternatively, you could always just use one row and
1527 make the necessary changes to the single C<tr> row by
1528 mutating the element in C<tr_proc>,
1529 discussed below. The default C<tr_ld> is
1530 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1531 it with a subroutine, then it is expected that the subroutine will return
1532 the C<HTML::Element>(s)
1533 which are C<tr> element(s).
1534 The reason a subroutine might be preferred is in the case
1535 that the HTML designers gave you 8 sample C<tr> rows but only one
1536 prototype row is needed.
1537 So you can write a subroutine, to splice out the 7 rows you don't need
1538 and leave the one sample
1539 row remaining so that this API call can clone it and supply it to
1540 the C<tr_proc> and C<td_proc> calls.
1542 Now, as we move through the table rows with table data,
1543 we need to do two different things on
1548 =item * get one row of data from the C<table_data> via C<tr_data>
1550 The default procedure assumes the C<table_data> is an array reference and
1551 shifts a row off of it:
1553 sub { my ($self, $data) = @_;
1557 Your function MUST return undef when there is no more rows to lay out.
1559 =item * take the C<tr> element and mutate it via C<tr_proc>
1561 The default procedure simply makes the id of the table row unique:
1563 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1564 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1569 Now that we have our row of data, we call C<td_proc> so that it can
1570 take the data and the C<td> cells in this C<tr> and process them.
1571 This function I<must> be supplied.
1574 =head3 Whither a Table with No Rows
1576 Often when a table has no rows, we want to display a message
1577 indicating this to the view. Use conditional processing to decide what
1581 <table><tr><td>No Data is Good Data</td></tr></table>
1586 <table id="load_data">
1588 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1592 <td id="name"> NATURE BOY RIC FLAIR </td>
1593 <td id="age"> 35 </td>
1594 <td id="weight"> 220 </td>
1611 =item * L<HTML::Tree>
1613 A perl package for creating and manipulating HTML trees
1615 =item * L<HTML::ElementTable>
1617 An L<HTML::Tree> - based module which allows for manipulation of HTML
1618 trees using cartesian coordinations.
1620 =item * L<HTML::Seamstress>
1622 An L<HTML::Tree> - based module inspired by
1623 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1624 HTML generation via tree rewriting.
1632 currently the API expects the subtrees to survive or be pruned to be
1635 $if_then->highlander2([
1636 under10 => sub { $_[0] < 10} ,
1637 under18 => sub { $_[0] < 18} ,
1642 $branch->look_down(id => 'age')->replace_content($age);
1649 but, it should be more flexible. the C<under10>, and C<under18> are
1650 expected to be ids in the tree... but it is not hard to have a check to
1651 see if this field is an array reference and if it, then to do a look
1654 $if_then->highlander2([
1655 [class => 'under10'] => sub { $_[0] < 10} ,
1656 [class => 'under18'] => sub { $_[0] < 18} ,
1657 [class => 'welcome'] => [
1661 $branch->look_down(id => 'age')->replace_content($age);
1678 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1680 Many thanks to BARBIE for his RT bug report.
1682 =head1 COPYRIGHT AND LICENSE
1684 Copyright (C) 2004 by Terrence Brannon
1686 This library is free software; you can redistribute it and/or modify
1687 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1688 at your option, any later version of Perl 5 you may have available.
This page took 0.099823 seconds and 3 git commands to generate.