]>
iEval git - html-element-library.git/blob - lib/HTML/Element/Library.pm
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
});
661 my $option = $select_node -> look_down ( '_tag' => 'option' );
668 while ( my $row = $select { data_iter
}->( $select { data
}))
671 my $o = $option -> clone ;
672 $o -> attr ( 'value' , $select { option_value
}->( $row ));
673 $o -> attr ( 'SELECTED' , 1 ) if ( $select { option_selected
}->( $row )) ;
675 $o -> replace_content ( $select { option_content
}->( $row ));
676 $select_node -> push_content ( $o );
684 sub HTML
:: Element
:: set_sibling_content
{
685 my ( $elt , $content ) = @_ ;
687 $elt -> parent -> splice_content ( $elt -> pindex + 1 , 1 , $content );
691 sub HTML
:: TreeBuilder
:: parse_string
{
692 my ( $package , $string ) = @_ ;
694 my $h = HTML
:: TreeBuilder
-> new ;
695 HTML
:: TreeBuilder
-> parse ( $string );
703 # Below is stub documentation for your module. You'd better edit it!
707 HTML::Element::Library - HTML::Element convenience functions
711 use HTML::Element::Library;
712 use HTML::TreeBuilder;
716 This method provides API calls for common actions on trees when using
721 The test suite contains examples of each of these methods in a
724 =head2 Positional Querying Methods
726 =head3 $elem->siblings
728 Return a list of all nodes under the same parent.
732 Return the index of C<$elem> into the array of siblings of which it is
733 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
734 that is a descriptive name. And such naming is deceptively close to the
735 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
736 backwards compatibility, both methods are available.
742 =head3 $elem->position()
744 Returns the coordinates of this element in the tree it inhabits.
745 This is accomplished by succesively calling addr() on ancestor
746 elements until either a) an element that does not support these
747 methods is found, or b) there are no more parents. The resulting
748 list is the n-dimensional coordinates of the element in the tree.
750 =head2 Element Decoration Methods
752 =head3 HTML::Element::Library::super_literal($text)
754 In L<HTML::Element>, Sean Burke discusses super-literals. They are
755 text which does not get escaped. Great for includng Javascript in
756 HTML. Also great for including foreign language into a document.
758 So, you basically toss C<super_literal> your text and back comes
759 your text wrapped in a C<~literal> element.
761 One of these days, I'll around to writing a nice C<EXPORT> section.
763 =head2 Tree Rewriting Methods
765 =head3 $elem->hash_map(hash => \%h, to_attr => $attr, excluding => \@excluded)
767 This method is designed to take a hashref and populate a series of elements. For example:
771 <tr sclass="tr" class="alt" align="left" valign="top">
772 <td sid="people_id">1</td>
773 <td sid="phone">(877) 255-3239</td>
774 <td sid="password">*********</td>
778 In the table above, there are several attributes named C<sid>. If we have a hashref whose keys are the same:
780 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
782 Then a single API call allows us to populate the HTML while excluding those ones we dont:
784 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
786 Of course, the other way to prevent rendering some of the hash mapping is to not give that element the attr
787 you plan to use for hash mapping.
790 =head3 $elem->replace_content(@new_elem)
792 Replaces all of C<$elem>'s content with C<@new_elem>.
794 =head3 $elem->wrap_content($wrapper_element)
796 Wraps the existing content in the provided element. If the provided element
797 happens to be a non-element, a push_content is performed instead.
799 =head3 $elem->set_child_content(@look_down, $content)
801 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
803 After finding the node, it detaches the node's content and pushes $content as the node's content.
805 =head3 $tree->content_handler(%id_content)
807 This is a convenience method. Because the look_down criteria will often simply be:
813 <a id=fixme href=http://www.somesite.org>replace_content</a>
815 You can call this method to shorten your typing a bit. You can simply type
817 $elem->content_handler( fixme => 'new text' )
821 $elem->set_child_content(sid => 'fixme', 'new text')
823 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:
825 my %id_content = (name => "Terrence Brannon",
826 email => 'tbrannon@in.com',
828 content => $main_content);
830 $tree->content_handler(%id_content);
832 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
834 This allows for "if-then-else" style processing. Highlander was a movie in
835 which only one would survive. Well, in terms of a tree when looking at a
836 structure that you want to process in C<if-then-else> style, only one child
837 will survive. For example, given this HTML template:
839 <span klass="highlander" id="age_dialog">
841 Hello, does your mother know you're
842 using her AOL account?
845 Sorry, you're not old enough to enter
846 (and too dumb to lie about your age)
853 We only want one child of the C<span> tag with id C<age_dialog> to remain
854 based on the age of the person visiting the page.
856 So, let's setup a call that will prune the subtree as a function of age:
860 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
865 under10 => sub { $_[0] < 10} ,
866 under18 => sub { $_[0] < 18} ,
872 And there we have it. If the age is less than 10, then the node with
873 id C<under10> remains. For age less than 18, the node with id C<under18>
875 Otherwise our "else" condition fires and the child with id C<welcome> remains.
877 =head3 $tree->passover($id_of_element)
879 In some cases, you know exactly which element should survive. In this case,
880 you can simply call C<passover> to remove it's siblings. For the HTML
881 above, you could delete C<under10> and C<welcome> by simply calling:
883 $tree->passover('under18');
885 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
887 Right around the same time that C<table2()> came into being, Seamstress
888 began to tackle tougher and tougher processing problems. It became clear that
889 a more powerful highlander was needed... one that not only snipped the tree
890 of the nodes that should not survive, but one that allows for
891 post-processing of the survivor node. And one that was more flexible with
892 how to find the nodes to snip.
894 Thus (drum roll) C<highlander2()>.
896 So let's look at our HTML which requires post-selection processing:
898 <span klass="highlander" id="age_dialog">
900 Hello, little <span id=age>AGE</span>-year old,
901 does your mother know you're using her AOL account?
904 Sorry, you're only <span id=age>AGE</span>
905 (and too dumb to lie about your age)
908 Welcome, isn't it good to be <span id=age>AGE</span> years old?
912 In this case, a branch survives, but it has dummy data in it. We must take
913 the surviving segment of HTML and rewrite the age C<span> with the age.
914 Here is how we use C<highlander2()> to do so:
919 $branch->look_down(id => 'age')->replace_content($age);
922 my $if_then = $tree->look_down(id => 'age_dialog');
924 $if_then->highlander2(
942 We pass it the tree (C<$if_then>), an arrayref of conditions
943 (C<cond>) and an arrayref of arguments which are passed to the
944 C<cond>s and to the replacement subs.
946 The C<under10>, C<under18> and C<welcome> are id attributes in the
947 tree of the siblings of which only one will survive. However,
948 should you need to do
949 more complex look-downs to find the survivor,
950 then supply an array ref instead of a simple
954 $if_then->highlander2(
956 [class => 'r12'] => [
960 [class => 'z22'] => [
964 [class => 'w88'] => [
973 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
975 This method is designed for taking a tree and reworking a set of nodes in
976 a stereotyped fashion. For instance let's say you have 3 remote image
977 archives, but you don't want to put long URLs in your img src
978 tags for reasons of abstraction, re-use and brevity. So instead you do this:
980 <img src="/img/smiley-face.jpg" fixup="src lnc">
981 <img src="/img/hot-babe.jpg" fixup="src playboy">
982 <img src="/img/footer.jpg" fixup="src foobar">
984 and then when the tree of HTML is being processed, you make this call:
987 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
988 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
989 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
992 $tree->overwrite_attr(fixup => \%closures) ;
994 and the tags come out modified like so:
996 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
997 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
998 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1000 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1002 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1003 assumes the return value of the
1004 closure is supposed overwrite an attribute value and does it for you.
1005 C<mute_elem> is a more general function which does nothing but
1006 hand the closure the element and let it mutate it as it jolly well pleases :)
1008 In fact, here is the implementation of C<overwrite_attr>
1009 to give you a taste of how C<mute_attr> is used:
1011 sub overwrite_action {
1012 my ($mute_node, %X) = @_;
1014 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1018 sub HTML::Element::overwrite_attr {
1021 $tree->mute_elem(@_, \&overwrite_action);
1027 =head2 Tree-Building Methods
1031 =head3 Unrolling an array via a single sample element (<ul> container)
1033 This is best described by example. Given this HTML:
1035 <strong>Here are the things I need from the store:</strong>
1037 <li class="store_items">Sample item</li>
1040 We can unroll it like so:
1042 my $li = $tree->look_down(class => 'store_items');
1044 my @items = qw(bread butter vodka);
1046 $tree->iter($li => @items);
1053 <body>Here are the things I need from the store:
1055 <li class="store_items">bread</li>
1056 <li class="store_items">butter</li>
1057 <li class="store_items">vodka</li>
1062 =head3 Unrolling an array via n sample elements (<dl> container)
1064 C<iter()> was fine for awhile, but some things
1065 (e.g. definition lists) need a more general function to make them easy to
1066 do. Hence C<iter2()>. This function will be explained by example of unrolling
1067 a simple definition list.
1069 So here's our mock-up HTML from the designer:
1071 <dl class="dual_iter" id="service_plan">
1076 A person who draws blood.
1083 A clone of Iggy Pop.
1090 A relative of Edgar Allan Poe.
1093 <dt class="adstyle">sample header</dt>
1094 <dd class="adstyle2">sample data</dd>
1099 And we want to unroll our data set:
1102 ['the pros' => 'never have to worry about service again'],
1103 ['the cons' => 'upfront extra charge on purchase'],
1104 ['our choice' => 'go with the extended service plan']
1108 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1109 Let's assume that we want only the last <dt> and it's accompanying <dd>
1110 (the one with "sample data") to be used as the sample data
1111 for unrolling with our data set. Let's further assume that we want them to
1112 remain in the final output.
1114 So now, the API to C<iter2()> will be discussed and we will explain how our
1115 goal of getting our data into HTML fits into the API.
1121 This is how to look down and find the container of all the elements we will
1122 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1125 If you pass an anonymous subroutine, then it is presumed that execution of
1126 this subroutine will return the HTML::Element representing the container tag.
1127 If you pass an array ref, then this will be dereferenced and passed to
1128 C<HTML::Element::look_down()>.
1130 default value: C<< ['_tag' => 'dl'] >>
1132 Based on the mock HTML above, this default is fine for finding our container
1133 tag. So let's move on.
1135 =item * wrapper_data
1137 This is an array reference of data that we will be putting into the container.
1138 You must supply this. C<@items> above is our C<wrapper_data>.
1140 =item * wrapper_proc
1142 After we find the container via C<wrapper_ld>, we may want to pre-process
1143 some aspect of this tree. In our case the first two sets of dt and dd need
1144 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1151 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1152 be cloned and populated with item data
1153 (item data is a "row" of C<wrapper_data>).
1155 default: returns an arrayref consisting of the dt and dd element inside the
1160 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1161 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1162 I hope that makes sense.
1164 default: shifts C<wrapper_data>.
1168 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1169 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1170 eventually be spliced into the container.
1172 Note that this subroutine MUST return the new items. This is done
1173 So that more items than were passed in can be returned. This is
1174 useful when, for example, you must return 2 dts for an input data item.
1175 And when would you do this? When a single term has multiple spellings
1178 default: expects C<item_data> to be an arrayref of two elements and
1179 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1180 content of the C<HTML::Element>s with the C<item_data>.
1184 After building up an array of C<@item_elems>, the subroutine passed as
1185 C<splice> will be given the parent container HTML::Element and the
1186 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1187 routine: it could put half of them in. It could unshift them or whatever.
1189 default: C<< $container->splice_content(0, 2, @item_elems) >>
1190 In other words, kill the 2 sample elements with the newly generated
1195 So now that we have documented the API, let's see the call we need:
1198 # default wrapper_ld ok.
1199 wrapper_data => \@items,
1200 wrapper_proc => sub {
1201 my ($container) = @_;
1203 # only keep the last 2 dts and dds
1204 my @content_list = $container->content_list;
1205 $container->splice_content(0, @content_list - 2);
1208 # default item_ld is fine.
1209 # default item_data is fine.
1210 # default item_proc is fine.
1212 my ($container, @item_elems) = @_;
1213 $container->unshift_content(@item_elems);
1221 =head3 Select Unrolling
1223 The C<unroll_select> method has this API:
1225 $tree->unroll_select(
1226 select_label => $id_label,
1227 option_value => $closure, # how to get option value from data row
1228 option_content => $closure, # how to get option content from data row
1229 option_selected => $closure, # boolean to decide if SELECTED
1230 data => $data # the data to be put into the SELECT
1231 data_iter => $closure # the thing that will get a row of data
1236 $tree->unroll_select(
1237 select_label => 'clan_list',
1238 option_value => sub { my $row = shift; $row->clan_id },
1239 option_content => sub { my $row = shift; $row->clan_name },
1240 option_selected => sub { my $row = shift; $row->selected },
1241 data => \@query_results,
1242 data_iter => sub { my $data = shift; $data->next }
1247 =head2 Tree-Building Methods: Table Generation
1249 Matthew Sisk has a much more intuitive (imperative)
1250 way to generate tables via his module
1251 L<HTML::ElementTable|HTML::ElementTable>.
1252 However, for those with callback fever, the following
1253 method is available. First, we look at a nuts and bolts way to build a table
1254 using only standard L<HTML::Tree> API calls. Then the C<table> method
1255 available here is discussed.
1259 package Simple::Class;
1263 my @name = qw(bob bill brian babette bobo bix);
1264 my @age = qw(99 12 44 52 12 43);
1265 my @weight = qw(99 52 80 124 120 230);
1270 bless {}, ref($this) || $this;
1278 age => $age[rand $#age] + int rand 20,
1279 name => shift @name,
1280 weight => $weight[rand $#weight] + int rand 40
1284 Set::Array->new(@data);
1291 =head4 Sample Usage:
1293 my $data = Simple::Class->load_data;
1294 ++$_->{age} for @$data
1296 =head3 Inline Code to Unroll a Table
1302 <table id="load_data">
1304 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1308 <td id="name"> NATURE BOY RIC FLAIR </td>
1309 <td id="age"> 35 </td>
1310 <td id="weight"> 220 </td>
1319 =head4 The manual way (*NOT* recommended)
1321 require 'simple-class.pl';
1322 use HTML::Seamstress;
1325 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1328 my $o = Simple::Class->new;
1329 my $data = $o->load_data;
1331 # find the <table> and <tr>
1332 my $table_node = $seamstress->look_down('id', 'load_data');
1333 my $iter_node = $table_node->look_down('id', 'iterate');
1334 my $table_parent = $table_node->parent;
1337 # drop the sample <table> and <tr> from the HTML
1338 # only add them in if there is data in the model
1339 # this is achieved via the $add_table flag
1341 $table_node->detach;
1345 # Get a row of model data
1346 while (my $row = shift @$data) {
1348 # We got row data. Set the flag indicating ok to hook the table into the HTML
1351 # clone the sample <tr>
1352 my $new_iter_node = $iter_node->clone;
1354 # find the tags labeled name age and weight and
1355 # set their content to the row data
1356 $new_iter_node->content_handler($_ => $row->{$_})
1357 for qw(name age weight);
1359 $table_node->push_content($new_iter_node);
1363 # reattach the table to the HTML tree if we loaded data into some table rows
1365 $table_parent->push_content($table_node) if $add_table;
1367 print $seamstress->as_HTML;
1371 =head3 $tree->table() : API call to Unroll a Table
1373 require 'simple-class.pl';
1374 use HTML::Seamstress;
1377 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1379 my $o = Simple::Class->new;
1383 # tell seamstress where to find the table, via the method call
1384 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1385 # HTML tree automatically if no table rows can be built
1387 gi_table => 'load_data',
1389 # tell seamstress where to find the tr. This is a bit useless as
1390 # the <tr> usually can be found as the first child of the parent
1394 # the model data to be pushed into the table
1396 table_data => $o->load_data,
1398 # the way to take the model data and obtain one row
1399 # if the table data were a hashref, we would do:
1400 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1402 tr_data => sub { my ($self, $data) = @_;
1406 # the way to take a row of data and fill the <td> tags
1408 td_data => sub { my ($tr_node, $tr_data) = @_;
1409 $tr_node->content_handler($_ => $tr_data->{$_})
1410 for qw(name age weight) }
1415 print $seamstress->as_HTML;
1419 =head4 Looping over Multiple Sample Rows
1425 <table id="load_data" CELLPADDING=8 BORDER=2>
1427 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1429 <tr id="iterate1" BGCOLOR="white" >
1431 <td id="name"> NATURE BOY RIC FLAIR </td>
1432 <td id="age"> 35 </td>
1433 <td id="weight"> 220 </td>
1436 <tr id="iterate2" BGCOLOR="#CCCC99">
1438 <td id="name"> NATURE BOY RIC FLAIR </td>
1439 <td id="age"> 35 </td>
1440 <td id="weight"> 220 </td>
1449 * Only one change to last API call.
1457 gi_tr => ['iterate1', 'iterate2']
1459 =head3 $tree->table2() : New API Call to Unroll a Table
1461 After 2 or 3 years with C<table()>, I began to develop
1462 production websites with it and decided it needed a cleaner
1463 interface, particularly in the area of handling the fact that
1464 C<id> tags will be the same after cloning a table row.
1466 First, I will give a dry listing of the function's argument parameters.
1467 This will not be educational most likely. A better way to understand how
1468 to use the function is to read through the incremental unrolling of the
1469 function's interface given in conversational style after the dry listing.
1470 But take your pick. It's the same information given in two different
1473 =head4 Dry/technical parameter documentation
1475 C<< $tree->table2(%param) >> takes the following arguments:
1479 =item * C<< table_ld => $look_down >> : optional
1481 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1482 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1483 passing it C<$tree>.
1485 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1487 =item * C<< table_data => $tabular_data >> : required
1489 The data to fill the table with. I<Must> be passed in.
1491 =item * C<< table_proc => $code_ref >> : not implemented
1493 A subroutine to do something to the table once it is found.
1494 Not currently implemented. Not obviously necessary. Just
1495 created because there is a C<tr_proc> and C<td_proc>.
1497 =item * C<< tr_ld => $look_down >> : optional
1499 Same as C<table_ld> but for finding the table row elements. Please note
1500 that the C<tr_ld> is done on the table node that was found I<instead>
1501 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1502 below the table that was just found.
1504 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1506 =item * C<< tr_data => $code_ref >> : optional
1508 How to take the C<table_data> and return a row. Defaults to:
1510 sub { my ($self, $data) = @_;
1514 =item * C<< tr_proc => $code_ref >> : optional
1516 Something to do to the table row we are about to add to the
1517 table we are making. Defaults to a routine which makes the C<id>
1521 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1522 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1525 =item * C<< td_proc => $code_ref >> : required
1527 This coderef will take the row of data and operate on the C<td> cells that
1528 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1530 Here's a sample one:
1533 my ($tr, $data) = @_;
1534 my @td = $tr->look_down('_tag' => 'td');
1535 for my $i (0..$#td) {
1536 $td[$i]->splice_content(0, 1, $data->[$i]);
1542 =head4 Conversational parameter documentation
1544 The first thing you need is a table. So we need a look down for that. If you
1545 don't give one, it defaults to
1549 What good is a table to display in without data to display?!
1550 So you must supply a scalar representing your tabular
1551 data source. This scalar might be an array reference, a C<next>able iterator,
1552 a DBI statement handle. Whatever it is, it can be iterated through to build
1553 up rows of table data.
1554 These two required fields (the way to find the table and the data to
1555 display in the table) are C<table_ld> and C<table_data>
1556 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1558 of the code ref is presumed to return the C<HTML::Element>
1559 representing the table in the HTML tree.
1561 Next, we get the row or rows which serve as sample C<tr> elements by doing
1562 a C<look_down> from the C<table_elem>. While normally one sample row
1563 is enough to unroll a table, consider when you have alternating
1564 table rows. This API call would need one of each row so that it can
1566 sample rows as it loops through the data.
1567 Alternatively, you could always just use one row and
1568 make the necessary changes to the single C<tr> row by
1569 mutating the element in C<tr_proc>,
1570 discussed below. The default C<tr_ld> is
1571 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1572 it with a subroutine, then it is expected that the subroutine will return
1573 the C<HTML::Element>(s)
1574 which are C<tr> element(s).
1575 The reason a subroutine might be preferred is in the case
1576 that the HTML designers gave you 8 sample C<tr> rows but only one
1577 prototype row is needed.
1578 So you can write a subroutine, to splice out the 7 rows you don't need
1579 and leave the one sample
1580 row remaining so that this API call can clone it and supply it to
1581 the C<tr_proc> and C<td_proc> calls.
1583 Now, as we move through the table rows with table data,
1584 we need to do two different things on
1589 =item * get one row of data from the C<table_data> via C<tr_data>
1591 The default procedure assumes the C<table_data> is an array reference and
1592 shifts a row off of it:
1594 sub { my ($self, $data) = @_;
1598 Your function MUST return undef when there is no more rows to lay out.
1600 =item * take the C<tr> element and mutate it via C<tr_proc>
1602 The default procedure simply makes the id of the table row unique:
1604 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1605 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1610 Now that we have our row of data, we call C<td_proc> so that it can
1611 take the data and the C<td> cells in this C<tr> and process them.
1612 This function I<must> be supplied.
1615 =head3 Whither a Table with No Rows
1617 Often when a table has no rows, we want to display a message
1618 indicating this to the view. Use conditional processing to decide what
1622 <table><tr><td>No Data is Good Data</td></tr></table>
1627 <table id="load_data">
1629 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1633 <td id="name"> NATURE BOY RIC FLAIR </td>
1634 <td id="age"> 35 </td>
1635 <td id="weight"> 220 </td>
1652 =item * L<HTML::Tree>
1654 A perl package for creating and manipulating HTML trees
1656 =item * L<HTML::ElementTable>
1658 An L<HTML::Tree> - based module which allows for manipulation of HTML
1659 trees using cartesian coordinations.
1661 =item * L<HTML::Seamstress>
1663 An L<HTML::Tree> - based module inspired by
1664 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1665 HTML generation via tree rewriting.
1673 currently the API expects the subtrees to survive or be pruned to be
1676 $if_then->highlander2([
1677 under10 => sub { $_[0] < 10} ,
1678 under18 => sub { $_[0] < 18} ,
1683 $branch->look_down(id => 'age')->replace_content($age);
1690 but, it should be more flexible. the C<under10>, and C<under18> are
1691 expected to be ids in the tree... but it is not hard to have a check to
1692 see if this field is an array reference and if it, then to do a look
1695 $if_then->highlander2([
1696 [class => 'under10'] => sub { $_[0] < 10} ,
1697 [class => 'under18'] => sub { $_[0] < 18} ,
1698 [class => 'welcome'] => [
1702 $branch->look_down(id => 'age')->replace_content($age);
1719 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1721 Many thanks to BARBIE for his RT bug report.
1723 =head1 COPYRIGHT AND LICENSE
1725 Copyright (C) 2004 by Terrence Brannon
1727 This library is free software; you can redistribute it and/or modify
1728 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1729 at your option, any later version of Perl 5 you may have available.
This page took 0.173954 seconds and 4 git commands to generate.