936840ba8a71ab11f4516cdcc1987f82ad96cd97
1 package HTML
::Element
::Library
;
11 use Array
::Group
qw(:all);
15 use List
::Util
qw(first);
16 use List
::MoreUtils qw
/:all/;
17 use Params
::Validate
qw(:all);
20 use List
::Rotation
::Cycle
;
22 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
23 our @EXPORT_OK = ( @
{ $EXPORT_TAGS{'all'} } );
28 our $VERSION = '3.53';
31 # Preloaded methods go here.
33 sub HTML
::Element
::siblings
{
35 my $p = $element->parent;
40 sub HTML
::Element
::hash_map
{
41 my $container = shift;
43 my %p = validate
(@_, {
44 hash
=> { type
=> HASHREF
},
46 excluding
=> { type
=> ARRAYREF
, default => [] },
47 debug
=> { default => 0 },
50 warn 'The container tag is ', $container->tag if $p{debug
} ;
51 warn 'hash' . Dumper
($p{hash
}) if $p{debug
} ;
52 warn 'at_under' . Dumper
(\
@_);
54 my @same_as = $container->look_down( $p{to_attr
} => qr/.+/ ) ;
56 warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug
} ;
59 for my $same_as (@same_as) {
60 my $attr_val = $same_as->attr($p{to_attr
}) ;
61 if (first
{ $attr_val eq $_ } @
{$p{excluding
}}) {
62 warn "excluding $attr_val" if $p{debug
} ;
65 warn "processing $attr_val" if $p{debug
} ;
66 $same_as->replace_content( $p{hash
}->{$attr_val} ) ;
72 sub HTML
::Element
::passover
{
73 my ($tree, $child_id) = @_;
75 warn "ARGS: my ($tree, $child_id)" if $DEBUG;
76 warn $tree->as_HTML(undef, ' ') if $DEBUG;
78 my $exodus = $tree->look_down(id
=> $child_id);
80 warn "E: $exodus" if $DEBUG;
82 my @s = HTML
::Element
::siblings
($exodus);
86 if ($s->attr('id') eq $child_id) {
93 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
97 sub HTML
::Element
::sibdex
{
100 firstidx
{ $_ eq $element } $element->siblings
104 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
106 sub HTML
::Element
::replace_content
{
108 $elem->delete_content;
109 $elem->push_content(@_);
112 sub HTML
::Element
::wrap_content
{
113 my($self, $wrap) = @_;
114 my $content = $self->content;
116 $wrap->push_content(@
$content);
120 $self->push_content($wrap);
125 sub HTML
::Element
::Library
::super_literal
{
128 HTML
::Element
->new('~literal', text
=> $text);
132 sub HTML
::Element
::position
{
133 # Report coordinates by chasing addr's up the
134 # HTML::ElementSuper tree. We know we've reached
135 # the top when a) there is no parent, or b) the
136 # parent is some HTML::Element unable to report
142 unshift(@pos, $a) if defined $a;
149 sub HTML
::Element
::content_handler
{
150 my ($tree, %content_hash) = @_;
152 for my $k (keys %content_hash) {
153 $tree->set_child_content(id
=> $k, $content_hash{$k});
168 sub HTML
::Element
::iter
{
169 my ($tree, $p, @data) = @_;
171 # warn 'P: ' , $p->attr('id') ;
172 # warn 'H: ' , $p->as_HTML;
174 # my $id_incr = make_counter;
176 my $new_item = clone
$p;
177 $new_item->replace_content($_);
178 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
182 $p->replace_with(@item);
187 sub HTML
::Element
::iter2
{
191 #warn "INPUT TO TABLE2: ", Dumper \@_;
195 wrapper_ld
=> { default => ['_tag' => 'dl'] },
197 wrapper_proc
=> { default => undef },
198 item_ld
=> { default => sub {
201 $tree->look_down('_tag' => 'dt'),
202 $tree->look_down('_tag' => 'dd')
206 item_data
=> { default => sub { my ($wrapper_data) = @_;
207 shift(@
{$wrapper_data}) ;
211 my ($item_elems, $item_data, $row_count) = @_;
212 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
215 splice => { default => sub {
216 my ($container, @item_elems) = @_;
217 $container->splice_content(0, 2, @item_elems);
220 debug
=> {default => 0}
224 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
226 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
227 warn "container: " . $container if $p{debug
} ;
228 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug
} ;
229 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
230 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug
} ;
232 my $_item_elems = $p{item_ld
}->($container);
239 my $item_data = $p{item_data
}->($p{wrapper_data
});
240 last unless defined $item_data;
242 warn Dumper
("item_data", $item_data);
245 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
248 for (@
{$item_elems}) {
249 warn "ITEM_ELEMS ", $_->as_HTML;
253 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
256 for (@
{$new_item_elems}) {
257 warn "NEWITEM_ELEMS ", $_->as_HTML;
262 push @item_elem, @
{$new_item_elems} ;
267 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
269 $p{splice}->($container, @item_elem);
273 sub HTML
::Element
::dual_iter
{
274 my ($parent, $data) = @_;
276 my ($prototype_a, $prototype_b) = $parent->content_list;
278 # my $id_incr = make_counter;
283 confess
'dataset does not contain an even number of members';
285 my @iterable_data = ngroup
2 => @
$data;
288 my ($new_a, $new_b) = map { clone
$_ } ($prototype_a, $prototype_b) ;
289 $new_a->splice_content(0,1, $_->[0]);
290 $new_b->splice_content(0,1, $_->[1]);
291 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
295 $parent->splice_content(0, 2, @item);
300 sub HTML
::Element
::set_child_content
{
305 my $content_tag = $tree->look_down(@look_down);
307 unless ($content_tag) {
308 warn "criteria [@look_down] not found";
312 $content_tag->replace_content($content);
316 sub HTML
::Element
::highlander
{
317 my ($tree, $local_root_id, $aref, @arg) = @_;
319 ref $aref eq 'ARRAY' or confess
320 "must supply array reference";
323 @aref % 2 == 0 or confess
324 "supplied array ref must have an even number of entries";
326 warn __PACKAGE__
if $DEBUG;
329 while (my ($id, $test) = splice @aref, 0, 2) {
338 my @id_survivor = (id
=> $survivor);
339 my $survivor_node = $tree->look_down(@id_survivor);
341 # warn $local_root_id;
344 warn "survivor: $survivor" if $DEBUG;
345 warn "tree: " . $tree->as_HTML if $DEBUG;
347 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
349 my $survivor_node_parent = $survivor_node->parent;
350 $survivor_node = $survivor_node->clone;
351 $survivor_node_parent->replace_content($survivor_node);
353 warn "new tree: " . $tree->as_HTML if $DEBUG;
359 sub HTML
::Element
::highlander2
{
362 my %p = validate
(@_, {
363 cond
=> { type
=> ARRAYREF
},
364 cond_arg
=> { type
=> ARRAYREF
,
367 debug
=> { default => 0 }
372 my @cond = @
{$p{cond
}};
373 @cond % 2 == 0 or confess
374 "supplied array ref must have an even number of entries";
376 warn __PACKAGE__
if $p{debug
};
378 my @cond_arg = @
{$p{cond_arg
}};
380 my $survivor; my $then;
381 while (my ($id, $if_then) = splice @cond, 0, 2) {
383 warn $id if $p{debug
};
386 if (ref $if_then eq 'ARRAY') {
387 ($if, $_then) = @
$if_then;
389 ($if, $_then) = ($if_then, sub {});
392 if ($if->(@cond_arg)) {
400 my @ld = (ref $survivor eq 'ARRAY')
405 warn "survivor: ", $survivor if $p{debug
};
406 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
409 my $survivor_node = $tree->look_down(@ld);
411 $survivor_node or confess
412 "search for @ld failed in tree($tree): " . $tree->as_HTML;
414 my $survivor_node_parent = $survivor_node->parent;
415 $survivor_node = $survivor_node->clone;
416 $survivor_node_parent->replace_content($survivor_node);
419 # **************** NEW FUNCTIONALITY *******************
421 # apply transforms on survivor node
424 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug
};
425 $then->($survivor_node, @cond_arg);
426 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug
};
428 # **************** NEW FUNCTIONALITY *******************
437 sub overwrite_action
{
438 my ($mute_node, %X) = @_;
440 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
444 sub HTML
::Element
::overwrite_attr
{
447 $tree->mute_elem(@_, \
&overwrite_action
);
452 sub HTML
::Element
::mute_elem
{
453 my ($tree, $mute_attr, $closures, $post_hook) = @_;
455 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
456 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
458 for my $mute_node (@mute_node) {
459 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
460 my $local_attr_value_current = $mute_node->attr($local_attr);
461 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
468 current
=> $local_attr_value_current,
469 new
=> $local_attr_value_new
478 sub HTML
::Element
::table
{
480 my ($s, %table) = @_;
484 # use Data::Dumper; warn Dumper \%table;
486 # ++$DEBUG if $table{debug} ;
489 # Get the table element
490 $table->{table_node
} = $s->look_down(id
=> $table{gi_table
});
491 $table->{table_node
} or confess
492 "table tag not found via (id => $table{gi_table}";
494 # Get the prototype tr element(s)
495 my @table_gi_tr = listify
$table{gi_tr
} ;
498 my $tr = $table->{table_node
}->look_down(id
=> $_);
499 $tr or confess
"tr with id => $_ not found";
503 warn "found " . @iter_node . " iter nodes " if $DEBUG;
504 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
505 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
508 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
510 # $table->{content} = $table{content};
511 #$table->{parent} = $table->{table_node}->parent;
514 # $table->{table_node}->detach;
515 # $_->detach for @iter_node;
520 my $row = $table{tr_data
}->($table, $table{table_data
});
521 last unless defined $row;
523 # get a sample table row and clone it.
524 my $I = $iter_node->next;
525 warn "I: $I" if $DEBUG;
526 my $new_iter_node = $I->clone;
529 $table{td_data
}->($new_iter_node, $row);
530 push @table_rows, $new_iter_node;
537 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
539 $s->look_down(id
=> $_)->detach;
542 $replace_with_elem->replace_with(@table_rows);
550 my ($tree, $slot) = @_;
552 if (ref($slot) eq 'CODE') {
555 $tree->look_down(@
$slot);
561 sub HTML
::Element
::table2
{
569 table_ld
=> { default => ['_tag' => 'table'] },
571 table_proc
=> { default => undef },
573 tr_ld
=> { default => ['_tag' => 'tr'] },
574 tr_data
=> { default => sub { my ($self, $data) = @_;
577 tr_base_id
=> { default => undef },
578 tr_proc
=> { default => sub {} },
580 debug
=> {default => 0}
584 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
586 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
590 # use Data::Dumper; warn Dumper \%table;
592 # ++$DEBUG if $table{debug} ;
594 # Get the table element
596 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
598 $table->{table_node
} or confess
599 "table tag not found via " . Dumper
($p{table_ld
}) ;
601 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
604 # Get the prototype tr element(s)
605 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
607 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
609 @proto_tr or return ;
612 warn $_->as_HTML for @proto_tr;
614 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
616 my $tr_parent = $proto_tr[0]->parent;
617 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
624 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
625 warn "data row: " . Dumper
$row if $p{debug
};
626 last unless defined $row;
628 # wont work: my $new_iter_node = $table->{iter_node}->clone;
629 my $new_tr_node = $proto_tr->next->clone;
630 warn "new_tr_node: $new_tr_node" if $p{debug
};
632 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
633 if defined $p{tr_proc
};
635 warn "data row redux: " . Dumper
$row if $p{debug
};
638 $p{td_proc
}->($new_tr_node, $row);
639 push @table_rows, $new_tr_node;
646 $_->detach for @proto_tr;
648 $tr_parent->push_content(@table_rows) if (@table_rows) ;
653 sub HTML
::Element
::unroll_select
{
655 my ($s, %select) = @_;
659 my $select_node = $s->look_down(id
=> $select{select_label
});
660 warn "Select Node: " . $select_node if $select{debug
};
662 unless ($select{append
}) {
663 for my $option ($select_node->look_down('_tag' => 'option')) {
669 my $option = HTML
::Element
->new('option');
670 warn "Option Node: " . $option if $select{debug
};
674 while (my $row = $select{data_iter
}->($select{data
}))
676 warn "Data Row:" . Dumper
($row) if $select{debug
};
677 my $o = $option->clone;
678 $o->attr('value', $select{option_value
}->($row));
679 $o->attr('SELECTED', 1) if (exists $select{option_selected
} and $select{option_selected
}->($row)) ;
681 $o->replace_content($select{option_content
}->($row));
682 $select_node->push_content($o);
683 warn $o->as_HTML if $select{debug
};
691 sub HTML
::Element
::set_sibling_content
{
692 my ($elt, $content) = @_;
694 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
698 sub HTML
::TreeBuilder
::parse_string
{
699 my ($package, $string) = @_;
701 my $h = HTML
::TreeBuilder
->new;
702 HTML
::TreeBuilder
->parse($string);
710 # Below is stub documentation for your module. You'd better edit it!
714 HTML::Element::Library - HTML::Element convenience functions
718 use HTML::Element::Library;
719 use HTML::TreeBuilder;
723 This method provides API calls for common actions on trees when using
728 The test suite contains examples of each of these methods in a
731 =head2 Positional Querying Methods
733 =head3 $elem->siblings
735 Return a list of all nodes under the same parent.
739 Return the index of C<$elem> into the array of siblings of which it is
740 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
741 that is a descriptive name. And such naming is deceptively close to the
742 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
743 backwards compatibility, both methods are available.
749 =head3 $elem->position()
751 Returns the coordinates of this element in the tree it inhabits.
752 This is accomplished by succesively calling addr() on ancestor
753 elements until either a) an element that does not support these
754 methods is found, or b) there are no more parents. The resulting
755 list is the n-dimensional coordinates of the element in the tree.
757 =head2 Element Decoration Methods
759 =head3 HTML::Element::Library::super_literal($text)
761 In L<HTML::Element>, Sean Burke discusses super-literals. They are
762 text which does not get escaped. Great for includng Javascript in
763 HTML. Also great for including foreign language into a document.
765 So, you basically toss C<super_literal> your text and back comes
766 your text wrapped in a C<~literal> element.
768 One of these days, I'll around to writing a nice C<EXPORT> section.
770 =head2 Tree Rewriting Methods
772 =head3 $elem->hash_map(hash => \%h, to_attr => $attr, excluding => \@excluded)
774 This method is designed to take a hashref and populate a series of elements. For example:
778 <tr sclass="tr" class="alt" align="left" valign="top">
779 <td smap="people_id">1</td>
780 <td smap="phone">(877) 255-3239</td>
781 <td smap="password">*********</td>
785 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
787 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
789 Then a single API call allows us to populate the HTML while excluding those ones we dont:
791 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
793 Of course, the other way to prevent rendering some of the hash mapping is to not give that element the attr
794 you plan to use for hash mapping.
797 =head3 $elem->replace_content(@new_elem)
799 Replaces all of C<$elem>'s content with C<@new_elem>.
801 =head3 $elem->wrap_content($wrapper_element)
803 Wraps the existing content in the provided element. If the provided element
804 happens to be a non-element, a push_content is performed instead.
806 =head3 $elem->set_child_content(@look_down, $content)
808 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
810 After finding the node, it detaches the node's content and pushes $content as the node's content.
812 =head3 $tree->content_handler(%id_content)
814 This is a convenience method. Because the look_down criteria will often simply be:
820 <a id=fixme href=http://www.somesite.org>replace_content</a>
822 You can call this method to shorten your typing a bit. You can simply type
824 $elem->content_handler( fixme => 'new text' )
828 $elem->set_child_content(sid => 'fixme', 'new text')
830 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:
832 my %id_content = (name => "Terrence Brannon",
833 email => 'tbrannon@in.com',
835 content => $main_content);
837 $tree->content_handler(%id_content);
839 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
841 This allows for "if-then-else" style processing. Highlander was a movie in
842 which only one would survive. Well, in terms of a tree when looking at a
843 structure that you want to process in C<if-then-else> style, only one child
844 will survive. For example, given this HTML template:
846 <span klass="highlander" id="age_dialog">
848 Hello, does your mother know you're
849 using her AOL account?
852 Sorry, you're not old enough to enter
853 (and too dumb to lie about your age)
860 We only want one child of the C<span> tag with id C<age_dialog> to remain
861 based on the age of the person visiting the page.
863 So, let's setup a call that will prune the subtree as a function of age:
867 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
872 under10 => sub { $_[0] < 10} ,
873 under18 => sub { $_[0] < 18} ,
879 And there we have it. If the age is less than 10, then the node with
880 id C<under10> remains. For age less than 18, the node with id C<under18>
882 Otherwise our "else" condition fires and the child with id C<welcome> remains.
884 =head3 $tree->passover($id_of_element)
886 In some cases, you know exactly which element should survive. In this case,
887 you can simply call C<passover> to remove it's siblings. For the HTML
888 above, you could delete C<under10> and C<welcome> by simply calling:
890 $tree->passover('under18');
892 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
894 Right around the same time that C<table2()> came into being, Seamstress
895 began to tackle tougher and tougher processing problems. It became clear that
896 a more powerful highlander was needed... one that not only snipped the tree
897 of the nodes that should not survive, but one that allows for
898 post-processing of the survivor node. And one that was more flexible with
899 how to find the nodes to snip.
901 Thus (drum roll) C<highlander2()>.
903 So let's look at our HTML which requires post-selection processing:
905 <span klass="highlander" id="age_dialog">
907 Hello, little <span id=age>AGE</span>-year old,
908 does your mother know you're using her AOL account?
911 Sorry, you're only <span id=age>AGE</span>
912 (and too dumb to lie about your age)
915 Welcome, isn't it good to be <span id=age>AGE</span> years old?
919 In this case, a branch survives, but it has dummy data in it. We must take
920 the surviving segment of HTML and rewrite the age C<span> with the age.
921 Here is how we use C<highlander2()> to do so:
926 $branch->look_down(id => 'age')->replace_content($age);
929 my $if_then = $tree->look_down(id => 'age_dialog');
931 $if_then->highlander2(
949 We pass it the tree (C<$if_then>), an arrayref of conditions
950 (C<cond>) and an arrayref of arguments which are passed to the
951 C<cond>s and to the replacement subs.
953 The C<under10>, C<under18> and C<welcome> are id attributes in the
954 tree of the siblings of which only one will survive. However,
955 should you need to do
956 more complex look-downs to find the survivor,
957 then supply an array ref instead of a simple
961 $if_then->highlander2(
963 [class => 'r12'] => [
967 [class => 'z22'] => [
971 [class => 'w88'] => [
980 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
982 This method is designed for taking a tree and reworking a set of nodes in
983 a stereotyped fashion. For instance let's say you have 3 remote image
984 archives, but you don't want to put long URLs in your img src
985 tags for reasons of abstraction, re-use and brevity. So instead you do this:
987 <img src="/img/smiley-face.jpg" fixup="src lnc">
988 <img src="/img/hot-babe.jpg" fixup="src playboy">
989 <img src="/img/footer.jpg" fixup="src foobar">
991 and then when the tree of HTML is being processed, you make this call:
994 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
995 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
996 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
999 $tree->overwrite_attr(fixup => \%closures) ;
1001 and the tags come out modified like so:
1003 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1004 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1005 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1007 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1009 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1010 assumes the return value of the
1011 closure is supposed overwrite an attribute value and does it for you.
1012 C<mute_elem> is a more general function which does nothing but
1013 hand the closure the element and let it mutate it as it jolly well pleases :)
1015 In fact, here is the implementation of C<overwrite_attr>
1016 to give you a taste of how C<mute_attr> is used:
1018 sub overwrite_action {
1019 my ($mute_node, %X) = @_;
1021 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1025 sub HTML::Element::overwrite_attr {
1028 $tree->mute_elem(@_, \&overwrite_action);
1034 =head2 Tree-Building Methods
1038 =head3 Unrolling an array via a single sample element (<ul> container)
1040 This is best described by example. Given this HTML:
1042 <strong>Here are the things I need from the store:</strong>
1044 <li class="store_items">Sample item</li>
1047 We can unroll it like so:
1049 my $li = $tree->look_down(class => 'store_items');
1051 my @items = qw(bread butter vodka);
1053 $tree->iter($li => @items);
1060 <body>Here are the things I need from the store:
1062 <li class="store_items">bread</li>
1063 <li class="store_items">butter</li>
1064 <li class="store_items">vodka</li>
1069 =head3 Unrolling an array via n sample elements (<dl> container)
1071 C<iter()> was fine for awhile, but some things
1072 (e.g. definition lists) need a more general function to make them easy to
1073 do. Hence C<iter2()>. This function will be explained by example of unrolling
1074 a simple definition list.
1076 So here's our mock-up HTML from the designer:
1078 <dl class="dual_iter" id="service_plan">
1083 A person who draws blood.
1090 A clone of Iggy Pop.
1097 A relative of Edgar Allan Poe.
1100 <dt class="adstyle">sample header</dt>
1101 <dd class="adstyle2">sample data</dd>
1106 And we want to unroll our data set:
1109 ['the pros' => 'never have to worry about service again'],
1110 ['the cons' => 'upfront extra charge on purchase'],
1111 ['our choice' => 'go with the extended service plan']
1115 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1116 Let's assume that we want only the last <dt> and it's accompanying <dd>
1117 (the one with "sample data") to be used as the sample data
1118 for unrolling with our data set. Let's further assume that we want them to
1119 remain in the final output.
1121 So now, the API to C<iter2()> will be discussed and we will explain how our
1122 goal of getting our data into HTML fits into the API.
1128 This is how to look down and find the container of all the elements we will
1129 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1132 If you pass an anonymous subroutine, then it is presumed that execution of
1133 this subroutine will return the HTML::Element representing the container tag.
1134 If you pass an array ref, then this will be dereferenced and passed to
1135 C<HTML::Element::look_down()>.
1137 default value: C<< ['_tag' => 'dl'] >>
1139 Based on the mock HTML above, this default is fine for finding our container
1140 tag. So let's move on.
1142 =item * wrapper_data
1144 This is an array reference of data that we will be putting into the container.
1145 You must supply this. C<@items> above is our C<wrapper_data>.
1147 =item * wrapper_proc
1149 After we find the container via C<wrapper_ld>, we may want to pre-process
1150 some aspect of this tree. In our case the first two sets of dt and dd need
1151 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1158 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1159 be cloned and populated with item data
1160 (item data is a "row" of C<wrapper_data>).
1162 default: returns an arrayref consisting of the dt and dd element inside the
1167 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1168 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1169 I hope that makes sense.
1171 default: shifts C<wrapper_data>.
1175 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1176 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1177 eventually be spliced into the container.
1179 Note that this subroutine MUST return the new items. This is done
1180 So that more items than were passed in can be returned. This is
1181 useful when, for example, you must return 2 dts for an input data item.
1182 And when would you do this? When a single term has multiple spellings
1185 default: expects C<item_data> to be an arrayref of two elements and
1186 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1187 content of the C<HTML::Element>s with the C<item_data>.
1191 After building up an array of C<@item_elems>, the subroutine passed as
1192 C<splice> will be given the parent container HTML::Element and the
1193 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1194 routine: it could put half of them in. It could unshift them or whatever.
1196 default: C<< $container->splice_content(0, 2, @item_elems) >>
1197 In other words, kill the 2 sample elements with the newly generated
1202 So now that we have documented the API, let's see the call we need:
1205 # default wrapper_ld ok.
1206 wrapper_data => \@items,
1207 wrapper_proc => sub {
1208 my ($container) = @_;
1210 # only keep the last 2 dts and dds
1211 my @content_list = $container->content_list;
1212 $container->splice_content(0, @content_list - 2);
1215 # default item_ld is fine.
1216 # default item_data is fine.
1217 # default item_proc is fine.
1219 my ($container, @item_elems) = @_;
1220 $container->unshift_content(@item_elems);
1228 =head3 Select Unrolling
1230 The C<unroll_select> method has this API:
1232 $tree->unroll_select(
1233 select_label => $id_label,
1234 option_value => $closure, # how to get option value from data row
1235 option_content => $closure, # how to get option content from data row
1236 option_selected => $closure, # boolean to decide if SELECTED
1237 data => $data # the data to be put into the SELECT
1238 data_iter => $closure # the thing that will get a row of data
1240 append => $boolean, # remove the sample <OPTION> data or append?
1245 $tree->unroll_select(
1246 select_label => 'clan_list',
1247 option_value => sub { my $row = shift; $row->clan_id },
1248 option_content => sub { my $row = shift; $row->clan_name },
1249 option_selected => sub { my $row = shift; $row->selected },
1250 data => \@query_results,
1251 data_iter => sub { my $data = shift; $data->next },
1258 =head2 Tree-Building Methods: Table Generation
1260 Matthew Sisk has a much more intuitive (imperative)
1261 way to generate tables via his module
1262 L<HTML::ElementTable|HTML::ElementTable>.
1263 However, for those with callback fever, the following
1264 method is available. First, we look at a nuts and bolts way to build a table
1265 using only standard L<HTML::Tree> API calls. Then the C<table> method
1266 available here is discussed.
1270 package Simple::Class;
1274 my @name = qw(bob bill brian babette bobo bix);
1275 my @age = qw(99 12 44 52 12 43);
1276 my @weight = qw(99 52 80 124 120 230);
1281 bless {}, ref($this) || $this;
1289 age => $age[rand $#age] + int rand 20,
1290 name => shift @name,
1291 weight => $weight[rand $#weight] + int rand 40
1295 Set::Array->new(@data);
1302 =head4 Sample Usage:
1304 my $data = Simple::Class->load_data;
1305 ++$_->{age} for @$data
1307 =head3 Inline Code to Unroll a Table
1313 <table id="load_data">
1315 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1319 <td id="name"> NATURE BOY RIC FLAIR </td>
1320 <td id="age"> 35 </td>
1321 <td id="weight"> 220 </td>
1330 =head4 The manual way (*NOT* recommended)
1332 require 'simple-class.pl';
1333 use HTML::Seamstress;
1336 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1339 my $o = Simple::Class->new;
1340 my $data = $o->load_data;
1342 # find the <table> and <tr>
1343 my $table_node = $seamstress->look_down('id', 'load_data');
1344 my $iter_node = $table_node->look_down('id', 'iterate');
1345 my $table_parent = $table_node->parent;
1348 # drop the sample <table> and <tr> from the HTML
1349 # only add them in if there is data in the model
1350 # this is achieved via the $add_table flag
1352 $table_node->detach;
1356 # Get a row of model data
1357 while (my $row = shift @$data) {
1359 # We got row data. Set the flag indicating ok to hook the table into the HTML
1362 # clone the sample <tr>
1363 my $new_iter_node = $iter_node->clone;
1365 # find the tags labeled name age and weight and
1366 # set their content to the row data
1367 $new_iter_node->content_handler($_ => $row->{$_})
1368 for qw(name age weight);
1370 $table_node->push_content($new_iter_node);
1374 # reattach the table to the HTML tree if we loaded data into some table rows
1376 $table_parent->push_content($table_node) if $add_table;
1378 print $seamstress->as_HTML;
1382 =head3 $tree->table() : API call to Unroll a Table
1384 require 'simple-class.pl';
1385 use HTML::Seamstress;
1388 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1390 my $o = Simple::Class->new;
1394 # tell seamstress where to find the table, via the method call
1395 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1396 # HTML tree automatically if no table rows can be built
1398 gi_table => 'load_data',
1400 # tell seamstress where to find the tr. This is a bit useless as
1401 # the <tr> usually can be found as the first child of the parent
1405 # the model data to be pushed into the table
1407 table_data => $o->load_data,
1409 # the way to take the model data and obtain one row
1410 # if the table data were a hashref, we would do:
1411 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1413 tr_data => sub { my ($self, $data) = @_;
1417 # the way to take a row of data and fill the <td> tags
1419 td_data => sub { my ($tr_node, $tr_data) = @_;
1420 $tr_node->content_handler($_ => $tr_data->{$_})
1421 for qw(name age weight) }
1426 print $seamstress->as_HTML;
1430 =head4 Looping over Multiple Sample Rows
1436 <table id="load_data" CELLPADDING=8 BORDER=2>
1438 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1440 <tr id="iterate1" BGCOLOR="white" >
1442 <td id="name"> NATURE BOY RIC FLAIR </td>
1443 <td id="age"> 35 </td>
1444 <td id="weight"> 220 </td>
1447 <tr id="iterate2" BGCOLOR="#CCCC99">
1449 <td id="name"> NATURE BOY RIC FLAIR </td>
1450 <td id="age"> 35 </td>
1451 <td id="weight"> 220 </td>
1460 * Only one change to last API call.
1468 gi_tr => ['iterate1', 'iterate2']
1470 =head3 $tree->table2() : New API Call to Unroll a Table
1472 After 2 or 3 years with C<table()>, I began to develop
1473 production websites with it and decided it needed a cleaner
1474 interface, particularly in the area of handling the fact that
1475 C<id> tags will be the same after cloning a table row.
1477 First, I will give a dry listing of the function's argument parameters.
1478 This will not be educational most likely. A better way to understand how
1479 to use the function is to read through the incremental unrolling of the
1480 function's interface given in conversational style after the dry listing.
1481 But take your pick. It's the same information given in two different
1484 =head4 Dry/technical parameter documentation
1486 C<< $tree->table2(%param) >> takes the following arguments:
1490 =item * C<< table_ld => $look_down >> : optional
1492 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1493 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1494 passing it C<$tree>.
1496 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1498 =item * C<< table_data => $tabular_data >> : required
1500 The data to fill the table with. I<Must> be passed in.
1502 =item * C<< table_proc => $code_ref >> : not implemented
1504 A subroutine to do something to the table once it is found.
1505 Not currently implemented. Not obviously necessary. Just
1506 created because there is a C<tr_proc> and C<td_proc>.
1508 =item * C<< tr_ld => $look_down >> : optional
1510 Same as C<table_ld> but for finding the table row elements. Please note
1511 that the C<tr_ld> is done on the table node that was found I<instead>
1512 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1513 below the table that was just found.
1515 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1517 =item * C<< tr_data => $code_ref >> : optional
1519 How to take the C<table_data> and return a row. Defaults to:
1521 sub { my ($self, $data) = @_;
1525 =item * C<< tr_proc => $code_ref >> : optional
1527 Something to do to the table row we are about to add to the
1528 table we are making. Defaults to a routine which makes the C<id>
1532 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1533 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1536 =item * C<< td_proc => $code_ref >> : required
1538 This coderef will take the row of data and operate on the C<td> cells that
1539 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1541 Here's a sample one:
1544 my ($tr, $data) = @_;
1545 my @td = $tr->look_down('_tag' => 'td');
1546 for my $i (0..$#td) {
1547 $td[$i]->splice_content(0, 1, $data->[$i]);
1553 =head4 Conversational parameter documentation
1555 The first thing you need is a table. So we need a look down for that. If you
1556 don't give one, it defaults to
1560 What good is a table to display in without data to display?!
1561 So you must supply a scalar representing your tabular
1562 data source. This scalar might be an array reference, a C<next>able iterator,
1563 a DBI statement handle. Whatever it is, it can be iterated through to build
1564 up rows of table data.
1565 These two required fields (the way to find the table and the data to
1566 display in the table) are C<table_ld> and C<table_data>
1567 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1569 of the code ref is presumed to return the C<HTML::Element>
1570 representing the table in the HTML tree.
1572 Next, we get the row or rows which serve as sample C<tr> elements by doing
1573 a C<look_down> from the C<table_elem>. While normally one sample row
1574 is enough to unroll a table, consider when you have alternating
1575 table rows. This API call would need one of each row so that it can
1577 sample rows as it loops through the data.
1578 Alternatively, you could always just use one row and
1579 make the necessary changes to the single C<tr> row by
1580 mutating the element in C<tr_proc>,
1581 discussed below. The default C<tr_ld> is
1582 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1583 it with a subroutine, then it is expected that the subroutine will return
1584 the C<HTML::Element>(s)
1585 which are C<tr> element(s).
1586 The reason a subroutine might be preferred is in the case
1587 that the HTML designers gave you 8 sample C<tr> rows but only one
1588 prototype row is needed.
1589 So you can write a subroutine, to splice out the 7 rows you don't need
1590 and leave the one sample
1591 row remaining so that this API call can clone it and supply it to
1592 the C<tr_proc> and C<td_proc> calls.
1594 Now, as we move through the table rows with table data,
1595 we need to do two different things on
1600 =item * get one row of data from the C<table_data> via C<tr_data>
1602 The default procedure assumes the C<table_data> is an array reference and
1603 shifts a row off of it:
1605 sub { my ($self, $data) = @_;
1609 Your function MUST return undef when there is no more rows to lay out.
1611 =item * take the C<tr> element and mutate it via C<tr_proc>
1613 The default procedure simply makes the id of the table row unique:
1615 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1616 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1621 Now that we have our row of data, we call C<td_proc> so that it can
1622 take the data and the C<td> cells in this C<tr> and process them.
1623 This function I<must> be supplied.
1626 =head3 Whither a Table with No Rows
1628 Often when a table has no rows, we want to display a message
1629 indicating this to the view. Use conditional processing to decide what
1633 <table><tr><td>No Data is Good Data</td></tr></table>
1638 <table id="load_data">
1640 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1644 <td id="name"> NATURE BOY RIC FLAIR </td>
1645 <td id="age"> 35 </td>
1646 <td id="weight"> 220 </td>
1663 =item * L<HTML::Tree>
1665 A perl package for creating and manipulating HTML trees
1667 =item * L<HTML::ElementTable>
1669 An L<HTML::Tree> - based module which allows for manipulation of HTML
1670 trees using cartesian coordinations.
1672 =item * L<HTML::Seamstress>
1674 An L<HTML::Tree> - based module inspired by
1675 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1676 HTML generation via tree rewriting.
1684 currently the API expects the subtrees to survive or be pruned to be
1687 $if_then->highlander2([
1688 under10 => sub { $_[0] < 10} ,
1689 under18 => sub { $_[0] < 18} ,
1694 $branch->look_down(id => 'age')->replace_content($age);
1701 but, it should be more flexible. the C<under10>, and C<under18> are
1702 expected to be ids in the tree... but it is not hard to have a check to
1703 see if this field is an array reference and if it, then to do a look
1706 $if_then->highlander2([
1707 [class => 'under10'] => sub { $_[0] < 10} ,
1708 [class => 'under18'] => sub { $_[0] < 18} ,
1709 [class => 'welcome'] => [
1713 $branch->look_down(id => 'age')->replace_content($age);
1730 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1732 Many thanks to BARBIE for his RT bug report.
1734 =head1 COPYRIGHT AND LICENSE
1736 Copyright (C) 2004 by Terrence Brannon
1738 This library is free software; you can redistribute it and/or modify
1739 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1740 at your option, any later version of Perl 5 you may have available.
This page took 0.099734 seconds and 3 git commands to generate.