]>
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' ;
32 # Preloaded methods go here.
34 # https://rt.cpan.org/Ticket/Display.html?id=44105
35 sub HTML
:: Element
:: fillinform
{
37 my ( $tree , $hashref )= @_ ;
40 my $html = $tree -> as_HTML ;
41 my $new_html = HTML
:: FillInForm
-> fill ( \
$html , $hashref );
45 sub HTML
:: Element
:: siblings
{
47 my $p = $element -> parent ;
52 sub HTML
:: Element
:: defmap
{
53 my ( $tree , $attr , $hashref , $debug )= @_ ;
55 while ( my ( $k , $v ) = ( each % $hashref )) {
56 warn "defmap looks for ( $attr => $k )" if $debug ;
57 my $found = $tree -> look_down ( $attr => $k );
59 warn "( $attr => $k ) was found.. replacing with ' $v '" if $debug ;
60 $found -> replace_content ( $v );
67 sub HTML
:: Element
:: hash_map
{
68 my $container = shift ;
70 my %p = validate
( @_ , {
71 hash
=> { type
=> HASHREF
},
73 excluding
=> { type
=> ARRAYREF
, default => [] },
74 debug
=> { default => 0 },
77 warn 'The container tag is ' , $container -> tag if $p { debug
} ;
78 warn 'hash' . Dumper
( $p { hash
}) if $p { debug
} ;
79 warn 'at_under' . Dumper
( \
@_ ) if $p { debug
} ;
81 my @same_as = $container -> look_down ( $p { to_attr
} => qr/.+/ ) ;
83 warn 'Found ' . scalar ( @same_as ) . ' nodes' if $p { debug
} ;
86 for my $same_as ( @same_as ) {
87 my $attr_val = $same_as -> attr ( $p { to_attr
}) ;
88 if ( first
{ $attr_val eq $_ } @
{ $p { excluding
}}) {
89 warn "excluding $attr_val " if $p { debug
} ;
92 warn "processing $attr_val " if $p { debug
} ;
93 $same_as -> replace_content ( $p { hash
}->{ $attr_val } ) ;
98 sub HTML
:: Element
:: hashmap
{
99 my ( $container , $attr_name , $hashref , $excluding , $debug ) = @_ ;
103 $container -> hash_map ( hash
=> $hashref ,
104 to_attr
=> $attr_name ,
105 excluding
=> $excluding ,
111 sub HTML
:: Element
:: passover
{
112 my ( $tree , @to_preserve ) = @_ ;
114 warn "ARGS: my ( $tree , @to_preserve )" if $DEBUG ;
115 warn $tree -> as_HTML ( undef , ' ' ) if $DEBUG ;
117 my $exodus = $tree -> look_down ( id
=> $to_preserve [ 0 ]);
119 warn "E: $exodus " if $DEBUG ;
121 my @s = HTML
:: Element
:: siblings
( $exodus );
125 if ( first
{ $s -> attr ( 'id' ) eq $_ } @to_preserve ) {
132 return $exodus ; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
136 sub HTML
:: Element
:: sibdex
{
139 firstidx
{ $_ eq $element } $element -> siblings
143 sub HTML
:: Element
:: addr
{ goto & HTML
:: Element
:: sibdex
}
145 sub HTML
:: Element
:: replace_content
{
147 $elem -> delete_content ;
148 $elem -> push_content ( @_ );
151 sub HTML
:: Element
:: wrap_content
{
152 my ( $self , $wrap ) = @_ ;
153 my $content = $self -> content ;
155 $wrap -> push_content ( @
$content );
159 $self -> push_content ( $wrap );
164 sub HTML
:: Element
:: Library
:: super_literal
{
167 HTML
:: Element
-> new ( '~literal' , text
=> $text );
171 sub HTML
:: Element
:: position
{
172 # Report coordinates by chasing addr's up the
173 # HTML::ElementSuper tree. We know we've reached
174 # the top when a) there is no parent, or b) the
175 # parent is some HTML::Element unable to report
181 unshift ( @pos , $a ) if defined $a ;
188 sub HTML
:: Element
:: content_handler
{
189 my ( $tree , %content_hash ) = @_ ;
191 for my $k ( keys %content_hash ) {
192 $tree -> set_child_content ( id
=> $k , $content_hash { $k });
207 sub HTML
:: Element
:: iter
{
208 my ( $tree , $p , @data ) = @_ ;
210 # warn 'P: ' , $p->attr('id') ;
211 # warn 'H: ' , $p->as_HTML;
213 # my $id_incr = make_counter;
215 my $new_item = clone
$p ;
216 $new_item -> replace_content ( $_ );
220 $p -> replace_with ( @item );
225 sub HTML
:: Element
:: iter2
{
229 #warn "INPUT TO TABLE2: ", Dumper \@_;
233 wrapper_ld
=> { default => [ '_tag' => 'dl' ] },
235 wrapper_proc
=> { default => undef },
236 item_ld
=> { default => sub {
239 $tree -> look_down ( '_tag' => 'dt' ),
240 $tree -> look_down ( '_tag' => 'dd' )
244 item_data
=> { default => sub { my ( $wrapper_data ) = @_ ;
245 shift ( @
{ $wrapper_data }) ;
249 my ( $item_elems , $item_data , $row_count ) = @_ ;
250 $item_elems ->[ $_ ]-> replace_content ( $item_data ->[ $_ ]) for ( 0 , 1 ) ;
253 splice => { default => sub {
254 my ( $container , @item_elems ) = @_ ;
255 $container -> splice_content ( 0 , 2 , @item_elems );
258 debug
=> { default => 0 }
262 warn "wrapper_data: " . Dumper
$p { wrapper_data
} if $p { debug
} ;
264 my $container = ref_or_ld
( $tree , $p { wrapper_ld
});
265 warn "container: " . $container if $p { debug
} ;
266 warn "wrapper_(preproc): " . $container -> as_HTML if $p { debug
} ;
267 $p { wrapper_proc
}->( $container ) if defined $p { wrapper_proc
} ;
268 warn "wrapper_(postproc): " . $container -> as_HTML if $p { debug
} ;
270 my $_item_elems = $p { item_ld
}->( $container );
277 my $item_data = $p { item_data
}->( $p { wrapper_data
});
278 last unless defined $item_data ;
280 warn Dumper
( "item_data" , $item_data );
283 my $item_elems = [ map { $_ -> clone } @
{ $_item_elems } ] ;
286 for ( @
{ $item_elems }) {
287 warn "ITEM_ELEMS " , $_ -> as_HTML ;
291 my $new_item_elems = $p { item_proc
}->( $item_elems , $item_data , ++ $row_count );
294 for ( @
{ $new_item_elems }) {
295 warn "NEWITEM_ELEMS " , $_ -> as_HTML ;
300 push @item_elem , @
{ $new_item_elems } ;
305 warn "pushing " . @item_elem . " elems " if $p { debug
} ;
307 $p { splice }->( $container , @item_elem );
311 sub HTML
:: Element
:: dual_iter
{
312 my ( $parent , $data ) = @_ ;
314 my ( $prototype_a , $prototype_b ) = $parent -> content_list ;
316 # my $id_incr = make_counter;
321 confess
'dataset does not contain an even number of members' ;
323 my @iterable_data = ngroup
2 => @
$data ;
326 my ( $new_a , $new_b ) = map { clone
$_ } ( $prototype_a , $prototype_b ) ;
327 $new_a -> splice_content ( 0 , 1 , $_ ->[ 0 ]);
328 $new_b -> splice_content ( 0 , 1 , $_ ->[ 1 ]);
329 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
333 $parent -> splice_content ( 0 , 2 , @item );
338 sub HTML
:: Element
:: set_child_content
{
343 my $content_tag = $tree -> look_down ( @look_down );
345 unless ( $content_tag ) {
346 warn "criteria [ @look_down ] not found" ;
350 $content_tag -> replace_content ( $content );
354 sub HTML
:: Element
:: highlander
{
355 my ( $tree , $local_root_id , $aref , @arg ) = @_ ;
357 ref $aref eq 'ARRAY' or confess
358 "must supply array reference" ;
361 @aref % 2 == 0 or confess
362 "supplied array ref must have an even number of entries" ;
364 warn __PACKAGE__
if $DEBUG ;
367 while ( my ( $id , $test ) = splice @aref , 0 , 2 ) {
376 my @id_survivor = ( id
=> $survivor );
377 my $survivor_node = $tree -> look_down ( @id_survivor );
379 # warn $local_root_id;
382 warn "survivor: $survivor " if $DEBUG ;
383 warn "tree: " . $tree -> as_HTML if $DEBUG ;
385 $survivor_node or die "search for @id_survivor failed in tree( $tree ): " . $tree -> as_HTML ;
387 my $survivor_node_parent = $survivor_node -> parent ;
388 $survivor_node = $survivor_node -> clone ;
389 $survivor_node_parent -> replace_content ( $survivor_node );
391 warn "new tree: " . $tree -> as_HTML if $DEBUG ;
397 sub HTML
:: Element
:: highlander2
{
400 my %p = validate
( @_ , {
401 cond
=> { type
=> ARRAYREF
},
402 cond_arg
=> { type
=> ARRAYREF
,
405 debug
=> { default => 0 }
410 my @cond = @
{ $p { cond
}};
411 @cond % 2 == 0 or confess
412 "supplied array ref must have an even number of entries" ;
414 warn __PACKAGE__
if $p { debug
};
416 my @cond_arg = @
{ $p { cond_arg
}};
418 my $survivor ; my $then ;
419 while ( my ( $id , $if_then ) = splice @cond , 0 , 2 ) {
421 warn $id if $p { debug
};
424 if ( ref $if_then eq 'ARRAY' ) {
425 ( $if , $_then ) = @
$if_then ;
427 ( $if , $_then ) = ( $if_then , sub {});
430 if ( $if ->( @cond_arg )) {
438 my @ld = ( ref $survivor eq 'ARRAY' )
443 warn "survivor: " , $survivor if $p { debug
};
444 warn "survivor_ld: " , Dumper \
@ld if $p { debug
};
447 my $survivor_node = $tree -> look_down ( @ld );
449 $survivor_node or confess
450 "search for @ld failed in tree( $tree ): " . $tree -> as_HTML ;
452 my $survivor_node_parent = $survivor_node -> parent ;
453 $survivor_node = $survivor_node -> clone ;
454 $survivor_node_parent -> replace_content ( $survivor_node );
457 # **************** NEW FUNCTIONALITY *******************
459 # apply transforms on survivor node
462 warn "SURV::pre_trans " . $survivor_node -> as_HTML if $p { debug
};
463 $then ->( $survivor_node , @cond_arg );
464 warn "SURV::post_trans " . $survivor_node -> as_HTML if $p { debug
};
466 # **************** NEW FUNCTIONALITY *******************
475 sub overwrite_action
{
476 my ( $mute_node , %X ) = @_ ;
478 $mute_node -> attr ( $X { local_attr
}{ name
} => $X { local_attr
}{ value
}{ new
});
482 sub HTML
:: Element
:: overwrite_attr
{
485 $tree -> mute_elem ( @_ , \
& overwrite_action
);
490 sub HTML
:: Element
:: mute_elem
{
491 my ( $tree , $mute_attr , $closures , $post_hook ) = @_ ;
493 warn "my mute_node = $tree ->look_down( $mute_attr => qr/.*/) ;" ;
494 my @mute_node = $tree -> look_down ( $mute_attr => qr/.*/ ) ;
496 for my $mute_node ( @mute_node ) {
497 my ( $local_attr , $mute_key ) = split /\s+/ , $mute_node -> attr ( $mute_attr );
498 my $local_attr_value_current = $mute_node -> attr ( $local_attr );
499 my $local_attr_value_new = $closures ->{ $mute_key }->( $tree , $mute_node , $local_attr_value_current );
506 current
=> $local_attr_value_current ,
507 new
=> $local_attr_value_new
516 sub HTML
:: Element
:: table
{
518 my ( $s , %table ) = @_ ;
522 # use Data::Dumper; warn Dumper \%table;
524 # ++$DEBUG if $table{debug} ;
527 # Get the table element
528 $table ->{ table_node
} = $s -> look_down ( id
=> $table { gi_table
});
529 $table ->{ table_node
} or confess
530 "table tag not found via (id => $table {gi_table}" ;
532 # Get the prototype tr element(s)
533 my @table_gi_tr = listify
$table { gi_tr
} ;
536 my $tr = $table ->{ table_node
}-> look_down ( id
=> $_ );
537 $tr or confess
"tr with id => $_ not found" ;
541 warn "found " . @iter_node . " iter nodes " if $DEBUG ;
542 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
543 my $iter_node = List
:: Rotation
:: Cycle
-> new ( @iter_node );
546 warn Dumper
( $iter_node , \
@iter_node ) if $DEBUG ;
548 # $table->{content} = $table{content};
549 #$table->{parent} = $table->{table_node}->parent;
552 # $table->{table_node}->detach;
553 # $_->detach for @iter_node;
558 my $row = $table { tr_data
}->( $table , $table { table_data
});
559 last unless defined $row ;
561 # get a sample table row and clone it.
562 my $I = $iter_node -> next ;
563 warn "I: $I " if $DEBUG ;
564 my $new_iter_node = $I -> clone ;
567 $table { td_data
}->( $new_iter_node , $row );
568 push @table_rows , $new_iter_node ;
575 my $replace_with_elem = $s -> look_down ( id
=> shift @table_gi_tr ) ;
577 $s -> look_down ( id
=> $_ )-> detach ;
580 $replace_with_elem -> replace_with ( @table_rows );
588 my ( $tree , $slot ) = @_ ;
590 if ( ref ( $slot ) eq 'CODE' ) {
593 $tree -> look_down ( @
$slot );
599 sub HTML
:: Element
:: table2
{
607 table_ld
=> { default => [ '_tag' => 'table' ] },
609 table_proc
=> { default => undef },
611 tr_ld
=> { default => [ '_tag' => 'tr' ] },
612 tr_data
=> { default => sub { my ( $self , $data ) = @_ ;
615 tr_base_id
=> { default => undef },
616 tr_proc
=> { default => sub {} },
618 debug
=> { default => 0 }
622 warn "INPUT TO TABLE2: " , Dumper \
@_ if $p { debug
};
624 warn "table_data: " . Dumper
$p { table_data
} if $p { debug
} ;
628 # use Data::Dumper; warn Dumper \%table;
630 # ++$DEBUG if $table{debug} ;
632 # Get the table element
634 $table ->{ table_node
} = ref_or_ld
( $tree , $p { table_ld
} ) ;
636 $table ->{ table_node
} or confess
637 "table tag not found via " . Dumper
( $p { table_ld
}) ;
639 warn "table: " . $table ->{ table_node
}-> as_HTML if $p { debug
};
642 # Get the prototype tr element(s)
643 my @proto_tr = ref_or_ld
( $table ->{ table_node
}, $p { tr_ld
} ) ;
645 warn "found " . @proto_tr . " iter nodes " if $p { debug
};
647 @proto_tr or return ;
650 warn $_ -> as_HTML for @proto_tr ;
652 my $proto_tr = List
:: Rotation
:: Cycle
-> new ( @proto_tr );
654 my $tr_parent = $proto_tr [ 0 ]-> parent ;
655 warn "parent element of trs: " . $tr_parent -> as_HTML if $p { debug
};
662 my $row = $p { tr_data
}->( $table , $p { table_data
}, $row_count );
663 warn "data row: " . Dumper
$row if $p { debug
};
664 last unless defined $row ;
666 # wont work: my $new_iter_node = $table->{iter_node}->clone;
667 my $new_tr_node = $proto_tr -> next -> clone ;
668 warn "new_tr_node: $new_tr_node " if $p { debug
};
670 $p { tr_proc
}->( $tree , $new_tr_node , $row , $p { tr_base_id
}, ++ $row_count )
671 if defined $p { tr_proc
};
673 warn "data row redux: " . Dumper
$row if $p { debug
};
676 $p { td_proc
}->( $new_tr_node , $row );
677 push @table_rows , $new_tr_node ;
684 $_ -> detach for @proto_tr ;
686 $tr_parent -> push_content ( @table_rows ) if ( @table_rows ) ;
691 sub HTML
:: Element
:: unroll_select
{
693 my ( $s , %select ) = @_ ;
697 warn "Select Hash: " . Dumper
( \
%select ) if $select { debug
};
699 my $select_node = $s -> look_down ( id
=> $select { select_label
});
700 warn "Select Node: " . $select_node if $select { debug
};
702 unless ( $select { append
}) {
703 for my $option ( $select_node -> look_down ( '_tag' => 'option' )) {
709 my $option = HTML
:: Element
-> new ( 'option' );
710 warn "Option Node: " . $option if $select { debug
};
714 while ( my $row = $select { data_iter
}->( $select { data
}))
716 warn "Data Row:" . Dumper
( $row ) if $select { debug
};
717 my $o = $option -> clone ;
718 $o -> attr ( 'value' , $select { option_value
}->( $row ));
719 $o -> attr ( 'SELECTED' , 1 ) if ( exists $select { option_selected
} and $select { option_selected
}->( $row )) ;
721 $o -> replace_content ( $select { option_content
}->( $row ));
722 $select_node -> push_content ( $o );
723 warn $o -> as_HTML if $select { debug
};
731 sub HTML
:: Element
:: set_sibling_content
{
732 my ( $elt , $content ) = @_ ;
734 $elt -> parent -> splice_content ( $elt -> pindex + 1 , 1 , $content );
738 sub HTML
:: TreeBuilder
:: parse_string
{
739 my ( $package , $string ) = @_ ;
741 my $h = HTML
:: TreeBuilder
-> new ;
742 HTML
:: TreeBuilder
-> parse ( $string );
750 # Below is stub documentation for your module. You'd better edit it!
754 HTML::Element::Library - HTML::Element convenience functions
758 use HTML::Element::Library;
759 use HTML::TreeBuilder;
763 This method provides API calls for common actions on trees when using
768 The test suite contains examples of each of these methods in a
771 =head2 Positional Querying Methods
773 =head3 $elem->siblings
775 Return a list of all nodes under the same parent.
779 Return the index of C<$elem> into the array of siblings of which it is
780 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
781 that is a descriptive name. And such naming is deceptively close to the
782 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
783 backwards compatibility, both methods are available.
789 =head3 $elem->position()
791 Returns the coordinates of this element in the tree it inhabits.
792 This is accomplished by succesively calling addr() on ancestor
793 elements until either a) an element that does not support these
794 methods is found, or b) there are no more parents. The resulting
795 list is the n-dimensional coordinates of the element in the tree.
797 =head2 Element Decoration Methods
799 =head3 HTML::Element::Library::super_literal($text)
801 In L<HTML::Element>, Sean Burke discusses super-literals. They are
802 text which does not get escaped. Great for includng Javascript in
803 HTML. Also great for including foreign language into a document.
805 So, you basically toss C<super_literal> your text and back comes
806 your text wrapped in a C<~literal> element.
808 One of these days, I'll around to writing a nice C<EXPORT> section.
810 =head2 Tree Rewriting Methods
812 =head3 Simplifying calls to HTML::FillInForm
814 Since HTML::FillInForm gets and returns strings, using HTML::Element instances
817 1. Seamstress has an HTML tree that it wants the form filled in on
818 2. Seamstress converts this tree to a string
819 3. FillInForm parses the string into an HTML tree and then fills in the form
820 4. FillInForm converts the HTML tree to a string
821 5. Seamstress re-parses the HTML for additional processing
823 I've filed a bug about this:
824 L<https://rt.cpan.org/Ticket/Display.html?id=44105>
826 This function, fillinform,
827 allows you to pass a tree to fillinform (along with your data structure) and
830 my $new_tree = $html_tree->fillinform($data_structure);
833 =head3 Mapping a hashref to HTML elements
835 It is very common to get a hashref of data from some external source - flat file, database, XML, etc.
836 Therefore, it is important to have a convenient way of mapping this data to HTML.
838 As it turns out, there are 3 ways to do this in HTML::Element::Library.
839 The most strict and structured way to do this is with
840 C<content_handler>. Two other methods, C<hashmap> and C<datamap> require less manual mapping and may prove
841 even more easy to use in certain cases.
843 As is usual with Perl, a practical example is always best. So let's take some sample HTML:
846 <span id="name">?</span>
847 <span id="email">?</span>
848 <span id="gender">?</span>
850 Now, let's say our data structure is this:
852 $ref = { email => 'jim@beam.com', gender => 'lots' } ;
854 And let's start with the most strict way to get what you want:
856 $tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ;
859 In this case, you manually state the mapping between id tags and hashref keys and
860 then C<content_handler> retrieves the hashref data and pops it in the specified place.
862 Now let's look at the two (actually 2 and a half) other hash-mapping methods.
864 $tree->hashmap(id => $ref);
866 Now, what this function does is super-destructive. It finds every element in the tree
867 with an attribute named id (since 'id' is a parameter, it could find every element with
868 some other attribute also) and replaces the content of those elements with the hashref
871 So, in the case above, the
873 <span id="name">?</span>
877 <span id="name"></span>
879 (it would be blank) - because there is nothing in the hash with that value, so it substituted
883 which was blank and emptied the contents.
885 Now, let's assume we want to protect name from being auto-assigned. Here is what you do:
887 $tree->hashmap(id => $ref, ['name']);
889 That last array ref is an exclusion list.
891 But wouldnt it be nice if you could do a hashmap, but only assigned things which are defined
892 in the hashref? C<< defmap() >> to the rescue:
894 $tree->defmap(id => $ref);
898 <span id="name">?</span>
903 =head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
905 This method is designed to take a hashref and populate a series of elements. For example:
909 <tr sclass="tr" class="alt" align="left" valign="top">
910 <td smap="people_id">1</td>
911 <td smap="phone">(877) 255-3239</td>
912 <td smap="password">*********</td>
916 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
918 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
920 Then a single API call allows us to populate the HTML while excluding those ones we dont:
922 $tree->hashmap(smap => \%data, ['password']);
925 Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
926 you plan to use for hash mapping.
928 Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
929 (which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
931 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
933 =head4 $elem->defmap($attr_name, \%hashref, $debug)
935 C<defmap> was described above.
938 =head4 $elem->content_handler(%hashref)
940 C<content_handler> is described below.
943 =head3 $elem->replace_content(@new_elem)
945 Replaces all of C<$elem>'s content with C<@new_elem>.
947 =head3 $elem->wrap_content($wrapper_element)
949 Wraps the existing content in the provided element. If the provided element
950 happens to be a non-element, a push_content is performed instead.
952 =head3 $elem->set_child_content(@look_down, $content)
954 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
956 After finding the node, it detaches the node's content and pushes $content as the node's content.
958 =head3 $tree->content_handler(%id_content)
960 This is a convenience method. Because the look_down criteria will often simply be:
966 <a id=fixme href=http://www.somesite.org>replace_content</a>
968 You can call this method to shorten your typing a bit. You can simply type
970 $elem->content_handler( fixme => 'new text' )
974 $elem->set_child_content(sid => 'fixme', 'new text')
976 ALSO 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:
978 my %id_content = (name => "Terrence Brannon",
979 email => 'tbrannon@in.com',
981 content => $main_content);
983 $tree->content_handler(%id_content);
985 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
987 This allows for "if-then-else" style processing. Highlander was a movie in
988 which only one would survive. Well, in terms of a tree when looking at a
989 structure that you want to process in C<if-then-else> style, only one child
990 will survive. For example, given this HTML template:
992 <span klass="highlander" id="age_dialog">
994 Hello, does your mother know you're
995 using her AOL account?
998 Sorry, you're not old enough to enter
999 (and too dumb to lie about your age)
1006 We only want one child of the C<span> tag with id C<age_dialog> to remain
1007 based on the age of the person visiting the page.
1009 So, let's setup a call that will prune the subtree as a function of age:
1013 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
1018 under10 => sub { $_[0] < 10} ,
1019 under18 => sub { $_[0] < 18} ,
1020 welcome => sub { 1 }
1025 And there we have it. If the age is less than 10, then the node with
1026 id C<under10> remains. For age less than 18, the node with id C<under18>
1028 Otherwise our "else" condition fires and the child with id C<welcome> remains.
1030 =head3 $tree->passover(@id_of_element)
1032 In some cases, you know exactly which element(s) should survive. In this case,
1033 you can simply call C<passover> to remove it's (their) siblings. For the HTML
1034 above, you could delete C<under10> and C<welcome> by simply calling:
1036 $tree->passover('under18');
1038 Because passover takes an array, you can specify several children to preserve.
1040 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
1042 Right around the same time that C<table2()> came into being, Seamstress
1043 began to tackle tougher and tougher processing problems. It became clear that
1044 a more powerful highlander was needed... one that not only snipped the tree
1045 of the nodes that should not survive, but one that allows for
1046 post-processing of the survivor node. And one that was more flexible with
1047 how to find the nodes to snip.
1049 Thus (drum roll) C<highlander2()>.
1051 So let's look at our HTML which requires post-selection processing:
1053 <span klass="highlander" id="age_dialog">
1055 Hello, little <span id=age>AGE</span>-year old,
1056 does your mother know you're using her AOL account?
1059 Sorry, you're only <span id=age>AGE</span>
1060 (and too dumb to lie about your age)
1063 Welcome, isn't it good to be <span id=age>AGE</span> years old?
1067 In this case, a branch survives, but it has dummy data in it. We must take
1068 the surviving segment of HTML and rewrite the age C<span> with the age.
1069 Here is how we use C<highlander2()> to do so:
1074 $branch->look_down(id => 'age')->replace_content($age);
1077 my $if_then = $tree->look_down(id => 'age_dialog');
1079 $if_then->highlander2(
1094 cond_arg => [ $age ]
1097 We pass it the tree (C<$if_then>), an arrayref of conditions
1098 (C<cond>) and an arrayref of arguments which are passed to the
1099 C<cond>s and to the replacement subs.
1101 The C<under10>, C<under18> and C<welcome> are id attributes in the
1102 tree of the siblings of which only one will survive. However,
1103 should you need to do
1104 more complex look-downs to find the survivor,
1105 then supply an array ref instead of a simple
1109 $if_then->highlander2(
1111 [class => 'r12'] => [
1115 [class => 'z22'] => [
1119 [class => 'w88'] => [
1124 cond_arg => [ $age ]
1128 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
1130 This method is designed for taking a tree and reworking a set of nodes in
1131 a stereotyped fashion. For instance let's say you have 3 remote image
1132 archives, but you don't want to put long URLs in your img src
1133 tags for reasons of abstraction, re-use and brevity. So instead you do this:
1135 <img src="/img/smiley-face.jpg" fixup="src lnc">
1136 <img src="/img/hot-babe.jpg" fixup="src playboy">
1137 <img src="/img/footer.jpg" fixup="src foobar">
1139 and then when the tree of HTML is being processed, you make this call:
1142 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
1143 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
1144 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
1147 $tree->overwrite_attr(fixup => \%closures) ;
1149 and the tags come out modified like so:
1151 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1152 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1153 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1155 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1157 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1158 assumes the return value of the
1159 closure is supposed overwrite an attribute value and does it for you.
1160 C<mute_elem> is a more general function which does nothing but
1161 hand the closure the element and let it mutate it as it jolly well pleases :)
1163 In fact, here is the implementation of C<overwrite_attr>
1164 to give you a taste of how C<mute_attr> is used:
1166 sub overwrite_action {
1167 my ($mute_node, %X) = @_;
1169 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1173 sub HTML::Element::overwrite_attr {
1176 $tree->mute_elem(@_, \&overwrite_action);
1182 =head2 Tree-Building Methods
1186 =head3 Unrolling an array via a single sample element (<ul> container)
1188 This is best described by example. Given this HTML:
1190 <strong>Here are the things I need from the store:</strong>
1192 <li class="store_items">Sample item</li>
1195 We can unroll it like so:
1197 my $li = $tree->look_down(class => 'store_items');
1199 my @items = qw(bread butter vodka);
1201 $tree->iter($li => @items);
1208 <body>Here are the things I need from the store:
1210 <li class="store_items">bread</li>
1211 <li class="store_items">butter</li>
1212 <li class="store_items">vodka</li>
1217 Now, you might be wondering why the API call is:
1219 $tree->iter($li => @items)
1225 and there is no good answer. The latter would be more concise and it is what I
1228 =head3 Unrolling an array via n sample elements (<dl> container)
1230 C<iter()> was fine for awhile, but some things
1231 (e.g. definition lists) need a more general function to make them easy to
1232 do. Hence C<iter2()>. This function will be explained by example of unrolling
1233 a simple definition list.
1235 So here's our mock-up HTML from the designer:
1237 <dl class="dual_iter" id="service_plan">
1242 A person who draws blood.
1249 A clone of Iggy Pop.
1256 A relative of Edgar Allan Poe.
1259 <dt class="adstyle">sample header</dt>
1260 <dd class="adstyle2">sample data</dd>
1265 And we want to unroll our data set:
1268 ['the pros' => 'never have to worry about service again'],
1269 ['the cons' => 'upfront extra charge on purchase'],
1270 ['our choice' => 'go with the extended service plan']
1274 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1275 Let's assume that we want only the last <dt> and it's accompanying <dd>
1276 (the one with "sample data") to be used as the sample data
1277 for unrolling with our data set. Let's further assume that we want them to
1278 remain in the final output.
1280 So now, the API to C<iter2()> will be discussed and we will explain how our
1281 goal of getting our data into HTML fits into the API.
1287 This is how to look down and find the container of all the elements we will
1288 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1291 If you pass an anonymous subroutine, then it is presumed that execution of
1292 this subroutine will return the HTML::Element representing the container tag.
1293 If you pass an array ref, then this will be dereferenced and passed to
1294 C<HTML::Element::look_down()>.
1296 default value: C<< ['_tag' => 'dl'] >>
1298 Based on the mock HTML above, this default is fine for finding our container
1299 tag. So let's move on.
1301 =item * wrapper_data
1303 This is an array reference of data that we will be putting into the container.
1304 You must supply this. C<@items> above is our C<wrapper_data>.
1306 =item * wrapper_proc
1308 After we find the container via C<wrapper_ld>, we may want to pre-process
1309 some aspect of this tree. In our case the first two sets of dt and dd need
1310 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1317 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1318 be cloned and populated with item data
1319 (item data is a "row" of C<wrapper_data>).
1321 default: returns an arrayref consisting of the dt and dd element inside the
1326 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1327 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1328 I hope that makes sense.
1330 default: shifts C<wrapper_data>.
1334 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1335 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1336 eventually be spliced into the container.
1338 Note that this subroutine MUST return the new items. This is done
1339 So that more items than were passed in can be returned. This is
1340 useful when, for example, you must return 2 dts for an input data item.
1341 And when would you do this? When a single term has multiple spellings
1344 default: expects C<item_data> to be an arrayref of two elements and
1345 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1346 content of the C<HTML::Element>s with the C<item_data>.
1350 After building up an array of C<@item_elems>, the subroutine passed as
1351 C<splice> will be given the parent container HTML::Element and the
1352 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1353 routine: it could put half of them in. It could unshift them or whatever.
1355 default: C<< $container->splice_content(0, 2, @item_elems) >>
1356 In other words, kill the 2 sample elements with the newly generated
1361 So now that we have documented the API, let's see the call we need:
1364 # default wrapper_ld ok.
1365 wrapper_data => \@items,
1366 wrapper_proc => sub {
1367 my ($container) = @_;
1369 # only keep the last 2 dts and dds
1370 my @content_list = $container->content_list;
1371 $container->splice_content(0, @content_list - 2);
1374 # default item_ld is fine.
1375 # default item_data is fine.
1376 # default item_proc is fine.
1378 my ($container, @item_elems) = @_;
1379 $container->unshift_content(@item_elems);
1387 =head3 Select Unrolling
1389 The C<unroll_select> method has this API:
1391 $tree->unroll_select(
1392 select_label => $id_label,
1393 option_value => $closure, # how to get option value from data row
1394 option_content => $closure, # how to get option content from data row
1395 option_selected => $closure, # boolean to decide if SELECTED
1396 data => $data # the data to be put into the SELECT
1397 data_iter => $closure # the thing that will get a row of data
1399 append => $boolean, # remove the sample <OPTION> data or append?
1404 $tree->unroll_select(
1405 select_label => 'clan_list',
1406 option_value => sub { my $row = shift; $row->clan_id },
1407 option_content => sub { my $row = shift; $row->clan_name },
1408 option_selected => sub { my $row = shift; $row->selected },
1409 data => \@query_results,
1410 data_iter => sub { my $data = shift; $data->next },
1417 =head2 Tree-Building Methods: Table Generation
1419 Matthew Sisk has a much more intuitive (imperative)
1420 way to generate tables via his module
1421 L<HTML::ElementTable|HTML::ElementTable>.
1422 However, for those with callback fever, the following
1423 method is available. First, we look at a nuts and bolts way to build a table
1424 using only standard L<HTML::Tree> API calls. Then the C<table> method
1425 available here is discussed.
1429 package Simple::Class;
1433 my @name = qw(bob bill brian babette bobo bix);
1434 my @age = qw(99 12 44 52 12 43);
1435 my @weight = qw(99 52 80 124 120 230);
1440 bless {}, ref($this) || $this;
1448 age => $age[rand $#age] + int rand 20,
1449 name => shift @name,
1450 weight => $weight[rand $#weight] + int rand 40
1454 Set::Array->new(@data);
1461 =head4 Sample Usage:
1463 my $data = Simple::Class->load_data;
1464 ++$_->{age} for @$data
1466 =head3 Inline Code to Unroll a Table
1472 <table id="load_data">
1474 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1478 <td id="name"> NATURE BOY RIC FLAIR </td>
1479 <td id="age"> 35 </td>
1480 <td id="weight"> 220 </td>
1489 =head4 The manual way (*NOT* recommended)
1491 require 'simple-class.pl';
1492 use HTML::Seamstress;
1495 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1498 my $o = Simple::Class->new;
1499 my $data = $o->load_data;
1501 # find the <table> and <tr>
1502 my $table_node = $seamstress->look_down('id', 'load_data');
1503 my $iter_node = $table_node->look_down('id', 'iterate');
1504 my $table_parent = $table_node->parent;
1507 # drop the sample <table> and <tr> from the HTML
1508 # only add them in if there is data in the model
1509 # this is achieved via the $add_table flag
1511 $table_node->detach;
1515 # Get a row of model data
1516 while (my $row = shift @$data) {
1518 # We got row data. Set the flag indicating ok to hook the table into the HTML
1521 # clone the sample <tr>
1522 my $new_iter_node = $iter_node->clone;
1524 # find the tags labeled name age and weight and
1525 # set their content to the row data
1526 $new_iter_node->content_handler($_ => $row->{$_})
1527 for qw(name age weight);
1529 $table_node->push_content($new_iter_node);
1533 # reattach the table to the HTML tree if we loaded data into some table rows
1535 $table_parent->push_content($table_node) if $add_table;
1537 print $seamstress->as_HTML;
1541 =head3 $tree->table() : API call to Unroll a Table
1543 require 'simple-class.pl';
1544 use HTML::Seamstress;
1547 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1549 my $o = Simple::Class->new;
1553 # tell seamstress where to find the table, via the method call
1554 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1555 # HTML tree automatically if no table rows can be built
1557 gi_table => 'load_data',
1559 # tell seamstress where to find the tr. This is a bit useless as
1560 # the <tr> usually can be found as the first child of the parent
1564 # the model data to be pushed into the table
1566 table_data => $o->load_data,
1568 # the way to take the model data and obtain one row
1569 # if the table data were a hashref, we would do:
1570 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1572 tr_data => sub { my ($self, $data) = @_;
1576 # the way to take a row of data and fill the <td> tags
1578 td_data => sub { my ($tr_node, $tr_data) = @_;
1579 $tr_node->content_handler($_ => $tr_data->{$_})
1580 for qw(name age weight) }
1585 print $seamstress->as_HTML;
1589 =head4 Looping over Multiple Sample Rows
1595 <table id="load_data" CELLPADDING=8 BORDER=2>
1597 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1599 <tr id="iterate1" BGCOLOR="white" >
1601 <td id="name"> NATURE BOY RIC FLAIR </td>
1602 <td id="age"> 35 </td>
1603 <td id="weight"> 220 </td>
1606 <tr id="iterate2" BGCOLOR="#CCCC99">
1608 <td id="name"> NATURE BOY RIC FLAIR </td>
1609 <td id="age"> 35 </td>
1610 <td id="weight"> 220 </td>
1619 * Only one change to last API call.
1627 gi_tr => ['iterate1', 'iterate2']
1629 =head3 $tree->table2() : New API Call to Unroll a Table
1631 After 2 or 3 years with C<table()>, I began to develop
1632 production websites with it and decided it needed a cleaner
1633 interface, particularly in the area of handling the fact that
1634 C<id> tags will be the same after cloning a table row.
1636 First, I will give a dry listing of the function's argument parameters.
1637 This will not be educational most likely. A better way to understand how
1638 to use the function is to read through the incremental unrolling of the
1639 function's interface given in conversational style after the dry listing.
1640 But take your pick. It's the same information given in two different
1643 =head4 Dry/technical parameter documentation
1645 C<< $tree->table2(%param) >> takes the following arguments:
1649 =item * C<< table_ld => $look_down >> : optional
1651 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1652 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1653 passing it C<$tree>.
1655 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1657 =item * C<< table_data => $tabular_data >> : required
1659 The data to fill the table with. I<Must> be passed in.
1661 =item * C<< table_proc => $code_ref >> : not implemented
1663 A subroutine to do something to the table once it is found.
1664 Not currently implemented. Not obviously necessary. Just
1665 created because there is a C<tr_proc> and C<td_proc>.
1667 =item * C<< tr_ld => $look_down >> : optional
1669 Same as C<table_ld> but for finding the table row elements. Please note
1670 that the C<tr_ld> is done on the table node that was found I<instead>
1671 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1672 below the table that was just found.
1674 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1676 =item * C<< tr_data => $code_ref >> : optional
1678 How to take the C<table_data> and return a row. Defaults to:
1680 sub { my ($self, $data) = @_;
1684 =item * C<< tr_proc => $code_ref >> : optional
1686 Something to do to the table row we are about to add to the
1687 table we are making. Defaults to a routine which makes the C<id>
1691 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1692 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1695 =item * C<< td_proc => $code_ref >> : required
1697 This coderef will take the row of data and operate on the C<td> cells that
1698 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1700 Here's a sample one:
1703 my ($tr, $data) = @_;
1704 my @td = $tr->look_down('_tag' => 'td');
1705 for my $i (0..$#td) {
1706 $td[$i]->splice_content(0, 1, $data->[$i]);
1712 =head4 Conversational parameter documentation
1714 The first thing you need is a table. So we need a look down for that. If you
1715 don't give one, it defaults to
1719 What good is a table to display in without data to display?!
1720 So you must supply a scalar representing your tabular
1721 data source. This scalar might be an array reference, a C<next>able iterator,
1722 a DBI statement handle. Whatever it is, it can be iterated through to build
1723 up rows of table data.
1724 These two required fields (the way to find the table and the data to
1725 display in the table) are C<table_ld> and C<table_data>
1726 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1728 of the code ref is presumed to return the C<HTML::Element>
1729 representing the table in the HTML tree.
1731 Next, we get the row or rows which serve as sample C<tr> elements by doing
1732 a C<look_down> from the C<table_elem>. While normally one sample row
1733 is enough to unroll a table, consider when you have alternating
1734 table rows. This API call would need one of each row so that it can
1736 sample rows as it loops through the data.
1737 Alternatively, you could always just use one row and
1738 make the necessary changes to the single C<tr> row by
1739 mutating the element in C<tr_proc>,
1740 discussed below. The default C<tr_ld> is
1741 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1742 it with a subroutine, then it is expected that the subroutine will return
1743 the C<HTML::Element>(s)
1744 which are C<tr> element(s).
1745 The reason a subroutine might be preferred is in the case
1746 that the HTML designers gave you 8 sample C<tr> rows but only one
1747 prototype row is needed.
1748 So you can write a subroutine, to splice out the 7 rows you don't need
1749 and leave the one sample
1750 row remaining so that this API call can clone it and supply it to
1751 the C<tr_proc> and C<td_proc> calls.
1753 Now, as we move through the table rows with table data,
1754 we need to do two different things on
1759 =item * get one row of data from the C<table_data> via C<tr_data>
1761 The default procedure assumes the C<table_data> is an array reference and
1762 shifts a row off of it:
1764 sub { my ($self, $data) = @_;
1768 Your function MUST return undef when there is no more rows to lay out.
1770 =item * take the C<tr> element and mutate it via C<tr_proc>
1772 The default procedure simply makes the id of the table row unique:
1774 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1775 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1780 Now that we have our row of data, we call C<td_proc> so that it can
1781 take the data and the C<td> cells in this C<tr> and process them.
1782 This function I<must> be supplied.
1785 =head3 Whither a Table with No Rows
1787 Often when a table has no rows, we want to display a message
1788 indicating this to the view. Use conditional processing to decide what
1792 <table><tr><td>No Data is Good Data</td></tr></table>
1797 <table id="load_data">
1799 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1803 <td id="name"> NATURE BOY RIC FLAIR </td>
1804 <td id="age"> 35 </td>
1805 <td id="weight"> 220 </td>
1822 =item * L<HTML::Tree>
1824 A perl package for creating and manipulating HTML trees
1826 =item * L<HTML::ElementTable>
1828 An L<HTML::Tree> - based module which allows for manipulation of HTML
1829 trees using cartesian coordinations.
1831 =item * L<HTML::Seamstress>
1833 An L<HTML::Tree> - based module inspired by
1834 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1835 HTML generation via tree rewriting.
1843 currently the API expects the subtrees to survive or be pruned to be
1846 $if_then->highlander2([
1847 under10 => sub { $_[0] < 10} ,
1848 under18 => sub { $_[0] < 18} ,
1853 $branch->look_down(id => 'age')->replace_content($age);
1860 but, it should be more flexible. the C<under10>, and C<under18> are
1861 expected to be ids in the tree... but it is not hard to have a check to
1862 see if this field is an array reference and if it, then to do a look
1865 $if_then->highlander2([
1866 [class => 'under10'] => sub { $_[0] < 10} ,
1867 [class => 'under18'] => sub { $_[0] < 18} ,
1868 [class => 'welcome'] => [
1872 $branch->look_down(id => 'age')->replace_content($age);
1887 =head1 AUTHOR / SOURCE
1889 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1891 Many thanks to BARBIE for his RT bug report.
1893 The source is at L<http://github.com/metaperl/html-element-library/tree/master>
1895 =head1 COPYRIGHT AND LICENSE
1897 Copyright (C) 2004 by Terrence Brannon
1899 This library is free software; you can redistribute it and/or modify
1900 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1901 at your option, any later version of Perl 5 you may have available.
This page took 0.123182 seconds and 4 git commands to generate.