]>
iEval git - html-element-library.git/blob - lib/HTML/Element/Library.pm
7573cbd26fda9a57265570e6c1a0ab503df7f06f
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
:: defmap
{
41 my ( $tree , $attr , $hashref )= @_ ;
43 while ( my ( $k , $v ) = ( each % $hashref )) {
44 my $found = $tree -> look_down ( $attr => $k );
46 $found -> replace_content ( $v );
53 sub HTML
:: Element
:: hash_map
{
54 my $container = shift ;
56 my %p = validate
( @_ , {
57 hash
=> { type
=> HASHREF
},
59 excluding
=> { type
=> ARRAYREF
, default => [] },
60 debug
=> { default => 0 },
63 warn 'The container tag is ' , $container -> tag if $p { debug
} ;
64 warn 'hash' . Dumper
( $p { hash
}) if $p { debug
} ;
65 warn 'at_under' . Dumper
( \
@_ ) if $p { debug
} ;
67 my @same_as = $container -> look_down ( $p { to_attr
} => qr/.+/ ) ;
69 warn 'Found ' . scalar ( @same_as ) . ' nodes' if $p { debug
} ;
72 for my $same_as ( @same_as ) {
73 my $attr_val = $same_as -> attr ( $p { to_attr
}) ;
74 if ( first
{ $attr_val eq $_ } @
{ $p { excluding
}}) {
75 warn "excluding $attr_val " if $p { debug
} ;
78 warn "processing $attr_val " if $p { debug
} ;
79 $same_as -> replace_content ( $p { hash
}->{ $attr_val } ) ;
84 sub HTML
:: Element
:: hashmap
{
85 my ( $container , $attr_name , $hashref , $excluding , $debug ) = @_ ;
89 $container -> hash_map ( hash
=> $hashref ,
90 to_attr
=> $attr_name ,
91 excluding
=> $excluding ,
97 sub HTML
:: Element
:: passover
{
98 my ( $tree , $child_id ) = @_ ;
100 warn "ARGS: my ( $tree , $child_id )" if $DEBUG ;
101 warn $tree -> as_HTML ( undef , ' ' ) if $DEBUG ;
103 my $exodus = $tree -> look_down ( id
=> $child_id );
105 warn "E: $exodus " if $DEBUG ;
107 my @s = HTML
:: Element
:: siblings
( $exodus );
111 if ( $s -> attr ( 'id' ) eq $child_id ) {
118 return $exodus ; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
122 sub HTML
:: Element
:: sibdex
{
125 firstidx
{ $_ eq $element } $element -> siblings
129 sub HTML
:: Element
:: addr
{ goto & HTML
:: Element
:: sibdex
}
131 sub HTML
:: Element
:: replace_content
{
133 $elem -> delete_content ;
134 $elem -> push_content ( @_ );
137 sub HTML
:: Element
:: wrap_content
{
138 my ( $self , $wrap ) = @_ ;
139 my $content = $self -> content ;
141 $wrap -> push_content ( @
$content );
145 $self -> push_content ( $wrap );
150 sub HTML
:: Element
:: Library
:: super_literal
{
153 HTML
:: Element
-> new ( '~literal' , text
=> $text );
157 sub HTML
:: Element
:: position
{
158 # Report coordinates by chasing addr's up the
159 # HTML::ElementSuper tree. We know we've reached
160 # the top when a) there is no parent, or b) the
161 # parent is some HTML::Element unable to report
167 unshift ( @pos , $a ) if defined $a ;
174 sub HTML
:: Element
:: content_handler
{
175 my ( $tree , %content_hash ) = @_ ;
177 for my $k ( keys %content_hash ) {
178 $tree -> set_child_content ( id
=> $k , $content_hash { $k });
193 sub HTML
:: Element
:: iter
{
194 my ( $tree , $p , @data ) = @_ ;
196 # warn 'P: ' , $p->attr('id') ;
197 # warn 'H: ' , $p->as_HTML;
199 # my $id_incr = make_counter;
201 my $new_item = clone
$p ;
202 $new_item -> replace_content ( $_ );
203 # $new_item->attr('id', $id_incr->( $p->attr('id') ));
207 $p -> replace_with ( @item );
212 sub HTML
:: Element
:: iter2
{
216 #warn "INPUT TO TABLE2: ", Dumper \@_;
220 wrapper_ld
=> { default => [ '_tag' => 'dl' ] },
222 wrapper_proc
=> { default => undef },
223 item_ld
=> { default => sub {
226 $tree -> look_down ( '_tag' => 'dt' ),
227 $tree -> look_down ( '_tag' => 'dd' )
231 item_data
=> { default => sub { my ( $wrapper_data ) = @_ ;
232 shift ( @
{ $wrapper_data }) ;
236 my ( $item_elems , $item_data , $row_count ) = @_ ;
237 $item_elems ->[ $_ ]-> replace_content ( $item_data ->[ $_ ]) for ( 0 , 1 ) ;
240 splice => { default => sub {
241 my ( $container , @item_elems ) = @_ ;
242 $container -> splice_content ( 0 , 2 , @item_elems );
245 debug
=> { default => 0 }
249 warn "wrapper_data: " . Dumper
$p { wrapper_data
} if $p { debug
} ;
251 my $container = ref_or_ld
( $tree , $p { wrapper_ld
});
252 warn "container: " . $container if $p { debug
} ;
253 warn "wrapper_(preproc): " . $container -> as_HTML if $p { debug
} ;
254 $p { wrapper_proc
}->( $container ) if defined $p { wrapper_proc
} ;
255 warn "wrapper_(postproc): " . $container -> as_HTML if $p { debug
} ;
257 my $_item_elems = $p { item_ld
}->( $container );
264 my $item_data = $p { item_data
}->( $p { wrapper_data
});
265 last unless defined $item_data ;
267 warn Dumper
( "item_data" , $item_data );
270 my $item_elems = [ map { $_ -> clone } @
{ $_item_elems } ] ;
273 for ( @
{ $item_elems }) {
274 warn "ITEM_ELEMS " , $_ -> as_HTML ;
278 my $new_item_elems = $p { item_proc
}->( $item_elems , $item_data , ++ $row_count );
281 for ( @
{ $new_item_elems }) {
282 warn "NEWITEM_ELEMS " , $_ -> as_HTML ;
287 push @item_elem , @
{ $new_item_elems } ;
292 warn "pushing " . @item_elem . " elems " if $p { debug
} ;
294 $p { splice }->( $container , @item_elem );
298 sub HTML
:: Element
:: dual_iter
{
299 my ( $parent , $data ) = @_ ;
301 my ( $prototype_a , $prototype_b ) = $parent -> content_list ;
303 # my $id_incr = make_counter;
308 confess
'dataset does not contain an even number of members' ;
310 my @iterable_data = ngroup
2 => @
$data ;
313 my ( $new_a , $new_b ) = map { clone
$_ } ( $prototype_a , $prototype_b ) ;
314 $new_a -> splice_content ( 0 , 1 , $_ ->[ 0 ]);
315 $new_b -> splice_content ( 0 , 1 , $_ ->[ 1 ]);
316 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
320 $parent -> splice_content ( 0 , 2 , @item );
325 sub HTML
:: Element
:: set_child_content
{
330 my $content_tag = $tree -> look_down ( @look_down );
332 unless ( $content_tag ) {
333 warn "criteria [ @look_down ] not found" ;
337 $content_tag -> replace_content ( $content );
341 sub HTML
:: Element
:: highlander
{
342 my ( $tree , $local_root_id , $aref , @arg ) = @_ ;
344 ref $aref eq 'ARRAY' or confess
345 "must supply array reference" ;
348 @aref % 2 == 0 or confess
349 "supplied array ref must have an even number of entries" ;
351 warn __PACKAGE__
if $DEBUG ;
354 while ( my ( $id , $test ) = splice @aref , 0 , 2 ) {
363 my @id_survivor = ( id
=> $survivor );
364 my $survivor_node = $tree -> look_down ( @id_survivor );
366 # warn $local_root_id;
369 warn "survivor: $survivor " if $DEBUG ;
370 warn "tree: " . $tree -> as_HTML if $DEBUG ;
372 $survivor_node or die "search for @id_survivor failed in tree( $tree ): " . $tree -> as_HTML ;
374 my $survivor_node_parent = $survivor_node -> parent ;
375 $survivor_node = $survivor_node -> clone ;
376 $survivor_node_parent -> replace_content ( $survivor_node );
378 warn "new tree: " . $tree -> as_HTML if $DEBUG ;
384 sub HTML
:: Element
:: highlander2
{
387 my %p = validate
( @_ , {
388 cond
=> { type
=> ARRAYREF
},
389 cond_arg
=> { type
=> ARRAYREF
,
392 debug
=> { default => 0 }
397 my @cond = @
{ $p { cond
}};
398 @cond % 2 == 0 or confess
399 "supplied array ref must have an even number of entries" ;
401 warn __PACKAGE__
if $p { debug
};
403 my @cond_arg = @
{ $p { cond_arg
}};
405 my $survivor ; my $then ;
406 while ( my ( $id , $if_then ) = splice @cond , 0 , 2 ) {
408 warn $id if $p { debug
};
411 if ( ref $if_then eq 'ARRAY' ) {
412 ( $if , $_then ) = @
$if_then ;
414 ( $if , $_then ) = ( $if_then , sub {});
417 if ( $if ->( @cond_arg )) {
425 my @ld = ( ref $survivor eq 'ARRAY' )
430 warn "survivor: " , $survivor if $p { debug
};
431 warn "survivor_ld: " , Dumper \
@ld if $p { debug
};
434 my $survivor_node = $tree -> look_down ( @ld );
436 $survivor_node or confess
437 "search for @ld failed in tree( $tree ): " . $tree -> as_HTML ;
439 my $survivor_node_parent = $survivor_node -> parent ;
440 $survivor_node = $survivor_node -> clone ;
441 $survivor_node_parent -> replace_content ( $survivor_node );
444 # **************** NEW FUNCTIONALITY *******************
446 # apply transforms on survivor node
449 warn "SURV::pre_trans " . $survivor_node -> as_HTML if $p { debug
};
450 $then ->( $survivor_node , @cond_arg );
451 warn "SURV::post_trans " . $survivor_node -> as_HTML if $p { debug
};
453 # **************** NEW FUNCTIONALITY *******************
462 sub overwrite_action
{
463 my ( $mute_node , %X ) = @_ ;
465 $mute_node -> attr ( $X { local_attr
}{ name
} => $X { local_attr
}{ value
}{ new
});
469 sub HTML
:: Element
:: overwrite_attr
{
472 $tree -> mute_elem ( @_ , \
& overwrite_action
);
477 sub HTML
:: Element
:: mute_elem
{
478 my ( $tree , $mute_attr , $closures , $post_hook ) = @_ ;
480 warn "my mute_node = $tree ->look_down( $mute_attr => qr/.*/) ;" ;
481 my @mute_node = $tree -> look_down ( $mute_attr => qr/.*/ ) ;
483 for my $mute_node ( @mute_node ) {
484 my ( $local_attr , $mute_key ) = split /\s+/ , $mute_node -> attr ( $mute_attr );
485 my $local_attr_value_current = $mute_node -> attr ( $local_attr );
486 my $local_attr_value_new = $closures ->{ $mute_key }->( $tree , $mute_node , $local_attr_value_current );
493 current
=> $local_attr_value_current ,
494 new
=> $local_attr_value_new
503 sub HTML
:: Element
:: table
{
505 my ( $s , %table ) = @_ ;
509 # use Data::Dumper; warn Dumper \%table;
511 # ++$DEBUG if $table{debug} ;
514 # Get the table element
515 $table ->{ table_node
} = $s -> look_down ( id
=> $table { gi_table
});
516 $table ->{ table_node
} or confess
517 "table tag not found via (id => $table {gi_table}" ;
519 # Get the prototype tr element(s)
520 my @table_gi_tr = listify
$table { gi_tr
} ;
523 my $tr = $table ->{ table_node
}-> look_down ( id
=> $_ );
524 $tr or confess
"tr with id => $_ not found" ;
528 warn "found " . @iter_node . " iter nodes " if $DEBUG ;
529 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
530 my $iter_node = List
:: Rotation
:: Cycle
-> new ( @iter_node );
533 warn Dumper
( $iter_node , \
@iter_node ) if $DEBUG ;
535 # $table->{content} = $table{content};
536 #$table->{parent} = $table->{table_node}->parent;
539 # $table->{table_node}->detach;
540 # $_->detach for @iter_node;
545 my $row = $table { tr_data
}->( $table , $table { table_data
});
546 last unless defined $row ;
548 # get a sample table row and clone it.
549 my $I = $iter_node -> next ;
550 warn "I: $I " if $DEBUG ;
551 my $new_iter_node = $I -> clone ;
554 $table { td_data
}->( $new_iter_node , $row );
555 push @table_rows , $new_iter_node ;
562 my $replace_with_elem = $s -> look_down ( id
=> shift @table_gi_tr ) ;
564 $s -> look_down ( id
=> $_ )-> detach ;
567 $replace_with_elem -> replace_with ( @table_rows );
575 my ( $tree , $slot ) = @_ ;
577 if ( ref ( $slot ) eq 'CODE' ) {
580 $tree -> look_down ( @
$slot );
586 sub HTML
:: Element
:: table2
{
594 table_ld
=> { default => [ '_tag' => 'table' ] },
596 table_proc
=> { default => undef },
598 tr_ld
=> { default => [ '_tag' => 'tr' ] },
599 tr_data
=> { default => sub { my ( $self , $data ) = @_ ;
602 tr_base_id
=> { default => undef },
603 tr_proc
=> { default => sub {} },
605 debug
=> { default => 0 }
609 warn "INPUT TO TABLE2: " , Dumper \
@_ if $p { debug
};
611 warn "table_data: " . Dumper
$p { table_data
} if $p { debug
} ;
615 # use Data::Dumper; warn Dumper \%table;
617 # ++$DEBUG if $table{debug} ;
619 # Get the table element
621 $table ->{ table_node
} = ref_or_ld
( $tree , $p { table_ld
} ) ;
623 $table ->{ table_node
} or confess
624 "table tag not found via " . Dumper
( $p { table_ld
}) ;
626 warn "table: " . $table ->{ table_node
}-> as_HTML if $p { debug
};
629 # Get the prototype tr element(s)
630 my @proto_tr = ref_or_ld
( $table ->{ table_node
}, $p { tr_ld
} ) ;
632 warn "found " . @proto_tr . " iter nodes " if $p { debug
};
634 @proto_tr or return ;
637 warn $_ -> as_HTML for @proto_tr ;
639 my $proto_tr = List
:: Rotation
:: Cycle
-> new ( @proto_tr );
641 my $tr_parent = $proto_tr [ 0 ]-> parent ;
642 warn "parent element of trs: " . $tr_parent -> as_HTML if $p { debug
};
649 my $row = $p { tr_data
}->( $table , $p { table_data
}, $row_count );
650 warn "data row: " . Dumper
$row if $p { debug
};
651 last unless defined $row ;
653 # wont work: my $new_iter_node = $table->{iter_node}->clone;
654 my $new_tr_node = $proto_tr -> next -> clone ;
655 warn "new_tr_node: $new_tr_node " if $p { debug
};
657 $p { tr_proc
}->( $tree , $new_tr_node , $row , $p { tr_base_id
}, ++ $row_count )
658 if defined $p { tr_proc
};
660 warn "data row redux: " . Dumper
$row if $p { debug
};
663 $p { td_proc
}->( $new_tr_node , $row );
664 push @table_rows , $new_tr_node ;
671 $_ -> detach for @proto_tr ;
673 $tr_parent -> push_content ( @table_rows ) if ( @table_rows ) ;
678 sub HTML
:: Element
:: unroll_select
{
680 my ( $s , %select ) = @_ ;
684 warn "Select Hash: " . Dumper
( \
%select ) if $select { debug
};
686 my $select_node = $s -> look_down ( id
=> $select { select_label
});
687 warn "Select Node: " . $select_node if $select { debug
};
689 unless ( $select { append
}) {
690 for my $option ( $select_node -> look_down ( '_tag' => 'option' )) {
696 my $option = HTML
:: Element
-> new ( 'option' );
697 warn "Option Node: " . $option if $select { debug
};
701 while ( my $row = $select { data_iter
}->( $select { data
}))
703 warn "Data Row:" . Dumper
( $row ) if $select { debug
};
704 my $o = $option -> clone ;
705 $o -> attr ( 'value' , $select { option_value
}->( $row ));
706 $o -> attr ( 'SELECTED' , 1 ) if ( exists $select { option_selected
} and $select { option_selected
}->( $row )) ;
708 $o -> replace_content ( $select { option_content
}->( $row ));
709 $select_node -> push_content ( $o );
710 warn $o -> as_HTML if $select { debug
};
718 sub HTML
:: Element
:: set_sibling_content
{
719 my ( $elt , $content ) = @_ ;
721 $elt -> parent -> splice_content ( $elt -> pindex + 1 , 1 , $content );
725 sub HTML
:: TreeBuilder
:: parse_string
{
726 my ( $package , $string ) = @_ ;
728 my $h = HTML
:: TreeBuilder
-> new ;
729 HTML
:: TreeBuilder
-> parse ( $string );
737 # Below is stub documentation for your module. You'd better edit it!
741 HTML::Element::Library - HTML::Element convenience functions
745 use HTML::Element::Library;
746 use HTML::TreeBuilder;
750 This method provides API calls for common actions on trees when using
755 The test suite contains examples of each of these methods in a
758 =head2 Positional Querying Methods
760 =head3 $elem->siblings
762 Return a list of all nodes under the same parent.
766 Return the index of C<$elem> into the array of siblings of which it is
767 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
768 that is a descriptive name. And such naming is deceptively close to the
769 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
770 backwards compatibility, both methods are available.
776 =head3 $elem->position()
778 Returns the coordinates of this element in the tree it inhabits.
779 This is accomplished by succesively calling addr() on ancestor
780 elements until either a) an element that does not support these
781 methods is found, or b) there are no more parents. The resulting
782 list is the n-dimensional coordinates of the element in the tree.
784 =head2 Element Decoration Methods
786 =head3 HTML::Element::Library::super_literal($text)
788 In L<HTML::Element>, Sean Burke discusses super-literals. They are
789 text which does not get escaped. Great for includng Javascript in
790 HTML. Also great for including foreign language into a document.
792 So, you basically toss C<super_literal> your text and back comes
793 your text wrapped in a C<~literal> element.
795 One of these days, I'll around to writing a nice C<EXPORT> section.
797 =head2 Tree Rewriting Methods
799 =head3 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
801 This method is designed to take a hashref and populate a series of elements. For example:
805 <tr sclass="tr" class="alt" align="left" valign="top">
806 <td smap="people_id">1</td>
807 <td smap="phone">(877) 255-3239</td>
808 <td smap="password">*********</td>
812 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
814 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
816 Then a single API call allows us to populate the HTML while excluding those ones we dont:
818 $tree->hashmap('sid' => \%data, ['password']);
821 Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
822 you plan to use for hash mapping.
824 Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
825 (which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
827 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
830 =head3 $elem->replace_content(@new_elem)
832 Replaces all of C<$elem>'s content with C<@new_elem>.
834 =head3 $elem->wrap_content($wrapper_element)
836 Wraps the existing content in the provided element. If the provided element
837 happens to be a non-element, a push_content is performed instead.
839 =head3 $elem->set_child_content(@look_down, $content)
841 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
843 After finding the node, it detaches the node's content and pushes $content as the node's content.
845 =head3 $tree->content_handler(%id_content)
847 This is a convenience method. Because the look_down criteria will often simply be:
853 <a id=fixme href=http://www.somesite.org>replace_content</a>
855 You can call this method to shorten your typing a bit. You can simply type
857 $elem->content_handler( fixme => 'new text' )
861 $elem->set_child_content(sid => 'fixme', 'new text')
863 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:
865 my %id_content = (name => "Terrence Brannon",
866 email => 'tbrannon@in.com',
868 content => $main_content);
870 $tree->content_handler(%id_content);
872 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
874 This allows for "if-then-else" style processing. Highlander was a movie in
875 which only one would survive. Well, in terms of a tree when looking at a
876 structure that you want to process in C<if-then-else> style, only one child
877 will survive. For example, given this HTML template:
879 <span klass="highlander" id="age_dialog">
881 Hello, does your mother know you're
882 using her AOL account?
885 Sorry, you're not old enough to enter
886 (and too dumb to lie about your age)
893 We only want one child of the C<span> tag with id C<age_dialog> to remain
894 based on the age of the person visiting the page.
896 So, let's setup a call that will prune the subtree as a function of age:
900 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
905 under10 => sub { $_[0] < 10} ,
906 under18 => sub { $_[0] < 18} ,
912 And there we have it. If the age is less than 10, then the node with
913 id C<under10> remains. For age less than 18, the node with id C<under18>
915 Otherwise our "else" condition fires and the child with id C<welcome> remains.
917 =head3 $tree->passover($id_of_element)
919 In some cases, you know exactly which element should survive. In this case,
920 you can simply call C<passover> to remove it's siblings. For the HTML
921 above, you could delete C<under10> and C<welcome> by simply calling:
923 $tree->passover('under18');
925 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
927 Right around the same time that C<table2()> came into being, Seamstress
928 began to tackle tougher and tougher processing problems. It became clear that
929 a more powerful highlander was needed... one that not only snipped the tree
930 of the nodes that should not survive, but one that allows for
931 post-processing of the survivor node. And one that was more flexible with
932 how to find the nodes to snip.
934 Thus (drum roll) C<highlander2()>.
936 So let's look at our HTML which requires post-selection processing:
938 <span klass="highlander" id="age_dialog">
940 Hello, little <span id=age>AGE</span>-year old,
941 does your mother know you're using her AOL account?
944 Sorry, you're only <span id=age>AGE</span>
945 (and too dumb to lie about your age)
948 Welcome, isn't it good to be <span id=age>AGE</span> years old?
952 In this case, a branch survives, but it has dummy data in it. We must take
953 the surviving segment of HTML and rewrite the age C<span> with the age.
954 Here is how we use C<highlander2()> to do so:
959 $branch->look_down(id => 'age')->replace_content($age);
962 my $if_then = $tree->look_down(id => 'age_dialog');
964 $if_then->highlander2(
982 We pass it the tree (C<$if_then>), an arrayref of conditions
983 (C<cond>) and an arrayref of arguments which are passed to the
984 C<cond>s and to the replacement subs.
986 The C<under10>, C<under18> and C<welcome> are id attributes in the
987 tree of the siblings of which only one will survive. However,
988 should you need to do
989 more complex look-downs to find the survivor,
990 then supply an array ref instead of a simple
994 $if_then->highlander2(
996 [class => 'r12'] => [
1000 [class => 'z22'] => [
1004 [class => 'w88'] => [
1009 cond_arg => [ $age ]
1013 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
1015 This method is designed for taking a tree and reworking a set of nodes in
1016 a stereotyped fashion. For instance let's say you have 3 remote image
1017 archives, but you don't want to put long URLs in your img src
1018 tags for reasons of abstraction, re-use and brevity. So instead you do this:
1020 <img src="/img/smiley-face.jpg" fixup="src lnc">
1021 <img src="/img/hot-babe.jpg" fixup="src playboy">
1022 <img src="/img/footer.jpg" fixup="src foobar">
1024 and then when the tree of HTML is being processed, you make this call:
1027 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
1028 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
1029 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
1032 $tree->overwrite_attr(fixup => \%closures) ;
1034 and the tags come out modified like so:
1036 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1037 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1038 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1040 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1042 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1043 assumes the return value of the
1044 closure is supposed overwrite an attribute value and does it for you.
1045 C<mute_elem> is a more general function which does nothing but
1046 hand the closure the element and let it mutate it as it jolly well pleases :)
1048 In fact, here is the implementation of C<overwrite_attr>
1049 to give you a taste of how C<mute_attr> is used:
1051 sub overwrite_action {
1052 my ($mute_node, %X) = @_;
1054 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1058 sub HTML::Element::overwrite_attr {
1061 $tree->mute_elem(@_, \&overwrite_action);
1067 =head2 Tree-Building Methods
1071 =head3 Unrolling an array via a single sample element (<ul> container)
1073 This is best described by example. Given this HTML:
1075 <strong>Here are the things I need from the store:</strong>
1077 <li class="store_items">Sample item</li>
1080 We can unroll it like so:
1082 my $li = $tree->look_down(class => 'store_items');
1084 my @items = qw(bread butter vodka);
1086 $tree->iter($li => @items);
1093 <body>Here are the things I need from the store:
1095 <li class="store_items">bread</li>
1096 <li class="store_items">butter</li>
1097 <li class="store_items">vodka</li>
1102 =head3 Unrolling an array via n sample elements (<dl> container)
1104 C<iter()> was fine for awhile, but some things
1105 (e.g. definition lists) need a more general function to make them easy to
1106 do. Hence C<iter2()>. This function will be explained by example of unrolling
1107 a simple definition list.
1109 So here's our mock-up HTML from the designer:
1111 <dl class="dual_iter" id="service_plan">
1116 A person who draws blood.
1123 A clone of Iggy Pop.
1130 A relative of Edgar Allan Poe.
1133 <dt class="adstyle">sample header</dt>
1134 <dd class="adstyle2">sample data</dd>
1139 And we want to unroll our data set:
1142 ['the pros' => 'never have to worry about service again'],
1143 ['the cons' => 'upfront extra charge on purchase'],
1144 ['our choice' => 'go with the extended service plan']
1148 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1149 Let's assume that we want only the last <dt> and it's accompanying <dd>
1150 (the one with "sample data") to be used as the sample data
1151 for unrolling with our data set. Let's further assume that we want them to
1152 remain in the final output.
1154 So now, the API to C<iter2()> will be discussed and we will explain how our
1155 goal of getting our data into HTML fits into the API.
1161 This is how to look down and find the container of all the elements we will
1162 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1165 If you pass an anonymous subroutine, then it is presumed that execution of
1166 this subroutine will return the HTML::Element representing the container tag.
1167 If you pass an array ref, then this will be dereferenced and passed to
1168 C<HTML::Element::look_down()>.
1170 default value: C<< ['_tag' => 'dl'] >>
1172 Based on the mock HTML above, this default is fine for finding our container
1173 tag. So let's move on.
1175 =item * wrapper_data
1177 This is an array reference of data that we will be putting into the container.
1178 You must supply this. C<@items> above is our C<wrapper_data>.
1180 =item * wrapper_proc
1182 After we find the container via C<wrapper_ld>, we may want to pre-process
1183 some aspect of this tree. In our case the first two sets of dt and dd need
1184 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1191 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1192 be cloned and populated with item data
1193 (item data is a "row" of C<wrapper_data>).
1195 default: returns an arrayref consisting of the dt and dd element inside the
1200 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1201 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1202 I hope that makes sense.
1204 default: shifts C<wrapper_data>.
1208 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1209 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1210 eventually be spliced into the container.
1212 Note that this subroutine MUST return the new items. This is done
1213 So that more items than were passed in can be returned. This is
1214 useful when, for example, you must return 2 dts for an input data item.
1215 And when would you do this? When a single term has multiple spellings
1218 default: expects C<item_data> to be an arrayref of two elements and
1219 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1220 content of the C<HTML::Element>s with the C<item_data>.
1224 After building up an array of C<@item_elems>, the subroutine passed as
1225 C<splice> will be given the parent container HTML::Element and the
1226 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1227 routine: it could put half of them in. It could unshift them or whatever.
1229 default: C<< $container->splice_content(0, 2, @item_elems) >>
1230 In other words, kill the 2 sample elements with the newly generated
1235 So now that we have documented the API, let's see the call we need:
1238 # default wrapper_ld ok.
1239 wrapper_data => \@items,
1240 wrapper_proc => sub {
1241 my ($container) = @_;
1243 # only keep the last 2 dts and dds
1244 my @content_list = $container->content_list;
1245 $container->splice_content(0, @content_list - 2);
1248 # default item_ld is fine.
1249 # default item_data is fine.
1250 # default item_proc is fine.
1252 my ($container, @item_elems) = @_;
1253 $container->unshift_content(@item_elems);
1261 =head3 Select Unrolling
1263 The C<unroll_select> method has this API:
1265 $tree->unroll_select(
1266 select_label => $id_label,
1267 option_value => $closure, # how to get option value from data row
1268 option_content => $closure, # how to get option content from data row
1269 option_selected => $closure, # boolean to decide if SELECTED
1270 data => $data # the data to be put into the SELECT
1271 data_iter => $closure # the thing that will get a row of data
1273 append => $boolean, # remove the sample <OPTION> data or append?
1278 $tree->unroll_select(
1279 select_label => 'clan_list',
1280 option_value => sub { my $row = shift; $row->clan_id },
1281 option_content => sub { my $row = shift; $row->clan_name },
1282 option_selected => sub { my $row = shift; $row->selected },
1283 data => \@query_results,
1284 data_iter => sub { my $data = shift; $data->next },
1291 =head2 Tree-Building Methods: Table Generation
1293 Matthew Sisk has a much more intuitive (imperative)
1294 way to generate tables via his module
1295 L<HTML::ElementTable|HTML::ElementTable>.
1296 However, for those with callback fever, the following
1297 method is available. First, we look at a nuts and bolts way to build a table
1298 using only standard L<HTML::Tree> API calls. Then the C<table> method
1299 available here is discussed.
1303 package Simple::Class;
1307 my @name = qw(bob bill brian babette bobo bix);
1308 my @age = qw(99 12 44 52 12 43);
1309 my @weight = qw(99 52 80 124 120 230);
1314 bless {}, ref($this) || $this;
1322 age => $age[rand $#age] + int rand 20,
1323 name => shift @name,
1324 weight => $weight[rand $#weight] + int rand 40
1328 Set::Array->new(@data);
1335 =head4 Sample Usage:
1337 my $data = Simple::Class->load_data;
1338 ++$_->{age} for @$data
1340 =head3 Inline Code to Unroll a Table
1346 <table id="load_data">
1348 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1352 <td id="name"> NATURE BOY RIC FLAIR </td>
1353 <td id="age"> 35 </td>
1354 <td id="weight"> 220 </td>
1363 =head4 The manual way (*NOT* recommended)
1365 require 'simple-class.pl';
1366 use HTML::Seamstress;
1369 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1372 my $o = Simple::Class->new;
1373 my $data = $o->load_data;
1375 # find the <table> and <tr>
1376 my $table_node = $seamstress->look_down('id', 'load_data');
1377 my $iter_node = $table_node->look_down('id', 'iterate');
1378 my $table_parent = $table_node->parent;
1381 # drop the sample <table> and <tr> from the HTML
1382 # only add them in if there is data in the model
1383 # this is achieved via the $add_table flag
1385 $table_node->detach;
1389 # Get a row of model data
1390 while (my $row = shift @$data) {
1392 # We got row data. Set the flag indicating ok to hook the table into the HTML
1395 # clone the sample <tr>
1396 my $new_iter_node = $iter_node->clone;
1398 # find the tags labeled name age and weight and
1399 # set their content to the row data
1400 $new_iter_node->content_handler($_ => $row->{$_})
1401 for qw(name age weight);
1403 $table_node->push_content($new_iter_node);
1407 # reattach the table to the HTML tree if we loaded data into some table rows
1409 $table_parent->push_content($table_node) if $add_table;
1411 print $seamstress->as_HTML;
1415 =head3 $tree->table() : API call to Unroll a Table
1417 require 'simple-class.pl';
1418 use HTML::Seamstress;
1421 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1423 my $o = Simple::Class->new;
1427 # tell seamstress where to find the table, via the method call
1428 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1429 # HTML tree automatically if no table rows can be built
1431 gi_table => 'load_data',
1433 # tell seamstress where to find the tr. This is a bit useless as
1434 # the <tr> usually can be found as the first child of the parent
1438 # the model data to be pushed into the table
1440 table_data => $o->load_data,
1442 # the way to take the model data and obtain one row
1443 # if the table data were a hashref, we would do:
1444 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1446 tr_data => sub { my ($self, $data) = @_;
1450 # the way to take a row of data and fill the <td> tags
1452 td_data => sub { my ($tr_node, $tr_data) = @_;
1453 $tr_node->content_handler($_ => $tr_data->{$_})
1454 for qw(name age weight) }
1459 print $seamstress->as_HTML;
1463 =head4 Looping over Multiple Sample Rows
1469 <table id="load_data" CELLPADDING=8 BORDER=2>
1471 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1473 <tr id="iterate1" BGCOLOR="white" >
1475 <td id="name"> NATURE BOY RIC FLAIR </td>
1476 <td id="age"> 35 </td>
1477 <td id="weight"> 220 </td>
1480 <tr id="iterate2" BGCOLOR="#CCCC99">
1482 <td id="name"> NATURE BOY RIC FLAIR </td>
1483 <td id="age"> 35 </td>
1484 <td id="weight"> 220 </td>
1493 * Only one change to last API call.
1501 gi_tr => ['iterate1', 'iterate2']
1503 =head3 $tree->table2() : New API Call to Unroll a Table
1505 After 2 or 3 years with C<table()>, I began to develop
1506 production websites with it and decided it needed a cleaner
1507 interface, particularly in the area of handling the fact that
1508 C<id> tags will be the same after cloning a table row.
1510 First, I will give a dry listing of the function's argument parameters.
1511 This will not be educational most likely. A better way to understand how
1512 to use the function is to read through the incremental unrolling of the
1513 function's interface given in conversational style after the dry listing.
1514 But take your pick. It's the same information given in two different
1517 =head4 Dry/technical parameter documentation
1519 C<< $tree->table2(%param) >> takes the following arguments:
1523 =item * C<< table_ld => $look_down >> : optional
1525 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1526 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1527 passing it C<$tree>.
1529 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1531 =item * C<< table_data => $tabular_data >> : required
1533 The data to fill the table with. I<Must> be passed in.
1535 =item * C<< table_proc => $code_ref >> : not implemented
1537 A subroutine to do something to the table once it is found.
1538 Not currently implemented. Not obviously necessary. Just
1539 created because there is a C<tr_proc> and C<td_proc>.
1541 =item * C<< tr_ld => $look_down >> : optional
1543 Same as C<table_ld> but for finding the table row elements. Please note
1544 that the C<tr_ld> is done on the table node that was found I<instead>
1545 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1546 below the table that was just found.
1548 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1550 =item * C<< tr_data => $code_ref >> : optional
1552 How to take the C<table_data> and return a row. Defaults to:
1554 sub { my ($self, $data) = @_;
1558 =item * C<< tr_proc => $code_ref >> : optional
1560 Something to do to the table row we are about to add to the
1561 table we are making. Defaults to a routine which makes the C<id>
1565 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1566 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1569 =item * C<< td_proc => $code_ref >> : required
1571 This coderef will take the row of data and operate on the C<td> cells that
1572 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1574 Here's a sample one:
1577 my ($tr, $data) = @_;
1578 my @td = $tr->look_down('_tag' => 'td');
1579 for my $i (0..$#td) {
1580 $td[$i]->splice_content(0, 1, $data->[$i]);
1586 =head4 Conversational parameter documentation
1588 The first thing you need is a table. So we need a look down for that. If you
1589 don't give one, it defaults to
1593 What good is a table to display in without data to display?!
1594 So you must supply a scalar representing your tabular
1595 data source. This scalar might be an array reference, a C<next>able iterator,
1596 a DBI statement handle. Whatever it is, it can be iterated through to build
1597 up rows of table data.
1598 These two required fields (the way to find the table and the data to
1599 display in the table) are C<table_ld> and C<table_data>
1600 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1602 of the code ref is presumed to return the C<HTML::Element>
1603 representing the table in the HTML tree.
1605 Next, we get the row or rows which serve as sample C<tr> elements by doing
1606 a C<look_down> from the C<table_elem>. While normally one sample row
1607 is enough to unroll a table, consider when you have alternating
1608 table rows. This API call would need one of each row so that it can
1610 sample rows as it loops through the data.
1611 Alternatively, you could always just use one row and
1612 make the necessary changes to the single C<tr> row by
1613 mutating the element in C<tr_proc>,
1614 discussed below. The default C<tr_ld> is
1615 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1616 it with a subroutine, then it is expected that the subroutine will return
1617 the C<HTML::Element>(s)
1618 which are C<tr> element(s).
1619 The reason a subroutine might be preferred is in the case
1620 that the HTML designers gave you 8 sample C<tr> rows but only one
1621 prototype row is needed.
1622 So you can write a subroutine, to splice out the 7 rows you don't need
1623 and leave the one sample
1624 row remaining so that this API call can clone it and supply it to
1625 the C<tr_proc> and C<td_proc> calls.
1627 Now, as we move through the table rows with table data,
1628 we need to do two different things on
1633 =item * get one row of data from the C<table_data> via C<tr_data>
1635 The default procedure assumes the C<table_data> is an array reference and
1636 shifts a row off of it:
1638 sub { my ($self, $data) = @_;
1642 Your function MUST return undef when there is no more rows to lay out.
1644 =item * take the C<tr> element and mutate it via C<tr_proc>
1646 The default procedure simply makes the id of the table row unique:
1648 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1649 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1654 Now that we have our row of data, we call C<td_proc> so that it can
1655 take the data and the C<td> cells in this C<tr> and process them.
1656 This function I<must> be supplied.
1659 =head3 Whither a Table with No Rows
1661 Often when a table has no rows, we want to display a message
1662 indicating this to the view. Use conditional processing to decide what
1666 <table><tr><td>No Data is Good Data</td></tr></table>
1671 <table id="load_data">
1673 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1677 <td id="name"> NATURE BOY RIC FLAIR </td>
1678 <td id="age"> 35 </td>
1679 <td id="weight"> 220 </td>
1696 =item * L<HTML::Tree>
1698 A perl package for creating and manipulating HTML trees
1700 =item * L<HTML::ElementTable>
1702 An L<HTML::Tree> - based module which allows for manipulation of HTML
1703 trees using cartesian coordinations.
1705 =item * L<HTML::Seamstress>
1707 An L<HTML::Tree> - based module inspired by
1708 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1709 HTML generation via tree rewriting.
1717 currently the API expects the subtrees to survive or be pruned to be
1720 $if_then->highlander2([
1721 under10 => sub { $_[0] < 10} ,
1722 under18 => sub { $_[0] < 18} ,
1727 $branch->look_down(id => 'age')->replace_content($age);
1734 but, it should be more flexible. the C<under10>, and C<under18> are
1735 expected to be ids in the tree... but it is not hard to have a check to
1736 see if this field is an array reference and if it, then to do a look
1739 $if_then->highlander2([
1740 [class => 'under10'] => sub { $_[0] < 10} ,
1741 [class => 'under18'] => sub { $_[0] < 18} ,
1742 [class => 'welcome'] => [
1746 $branch->look_down(id => 'age')->replace_content($age);
1761 =head1 AUTHOR / SOURCE
1763 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1765 Many thanks to BARBIE for his RT bug report.
1767 The source is at L<http://github.com/metaperl/html-element-library/tree/master>
1769 =head1 COPYRIGHT AND LICENSE
1771 Copyright (C) 2004 by Terrence Brannon
1773 This library is free software; you can redistribute it and/or modify
1774 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1775 at your option, any later version of Perl 5 you may have available.
This page took 0.09757 seconds and 3 git commands to generate.