]>
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
:: defmap
{
41 my ( $tree , $attr , $hashref , $debug )= @_ ;
43 while ( my ( $k , $v ) = ( each % $hashref )) {
44 warn "defmap looks for ( $attr => $k )" if $debug ;
45 my $found = $tree -> look_down ( $attr => $k );
47 warn "( $attr => $k ) was found.. replacing with ' $v '" if $debug ;
48 $found -> replace_content ( $v );
55 sub HTML
:: Element
:: hash_map
{
56 my $container = shift ;
58 my %p = validate
( @_ , {
59 hash
=> { type
=> HASHREF
},
61 excluding
=> { type
=> ARRAYREF
, default => [] },
62 debug
=> { default => 0 },
65 warn 'The container tag is ' , $container -> tag if $p { debug
} ;
66 warn 'hash' . Dumper
( $p { hash
}) if $p { debug
} ;
67 warn 'at_under' . Dumper
( \
@_ ) if $p { debug
} ;
69 my @same_as = $container -> look_down ( $p { to_attr
} => qr/.+/ ) ;
71 warn 'Found ' . scalar ( @same_as ) . ' nodes' if $p { debug
} ;
74 for my $same_as ( @same_as ) {
75 my $attr_val = $same_as -> attr ( $p { to_attr
}) ;
76 if ( first
{ $attr_val eq $_ } @
{ $p { excluding
}}) {
77 warn "excluding $attr_val " if $p { debug
} ;
80 warn "processing $attr_val " if $p { debug
} ;
81 $same_as -> replace_content ( $p { hash
}->{ $attr_val } ) ;
86 sub HTML
:: Element
:: hashmap
{
87 my ( $container , $attr_name , $hashref , $excluding , $debug ) = @_ ;
91 $container -> hash_map ( hash
=> $hashref ,
92 to_attr
=> $attr_name ,
93 excluding
=> $excluding ,
99 sub HTML
:: Element
:: passover
{
100 my ( $tree , $child_id ) = @_ ;
102 warn "ARGS: my ( $tree , $child_id )" if $DEBUG ;
103 warn $tree -> as_HTML ( undef , ' ' ) if $DEBUG ;
105 my $exodus = $tree -> look_down ( id
=> $child_id );
107 warn "E: $exodus " if $DEBUG ;
109 my @s = HTML
:: Element
:: siblings
( $exodus );
113 if ( $s -> attr ( 'id' ) eq $child_id ) {
120 return $exodus ; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
124 sub HTML
:: Element
:: sibdex
{
127 firstidx
{ $_ eq $element } $element -> siblings
131 sub HTML
:: Element
:: addr
{ goto & HTML
:: Element
:: sibdex
}
133 sub HTML
:: Element
:: replace_content
{
135 $elem -> delete_content ;
136 $elem -> push_content ( @_ );
139 sub HTML
:: Element
:: wrap_content
{
140 my ( $self , $wrap ) = @_ ;
141 my $content = $self -> content ;
143 $wrap -> push_content ( @
$content );
147 $self -> push_content ( $wrap );
152 sub HTML
:: Element
:: Library
:: super_literal
{
155 HTML
:: Element
-> new ( '~literal' , text
=> $text );
159 sub HTML
:: Element
:: position
{
160 # Report coordinates by chasing addr's up the
161 # HTML::ElementSuper tree. We know we've reached
162 # the top when a) there is no parent, or b) the
163 # parent is some HTML::Element unable to report
169 unshift ( @pos , $a ) if defined $a ;
176 sub HTML
:: Element
:: content_handler
{
177 my ( $tree , %content_hash ) = @_ ;
179 for my $k ( keys %content_hash ) {
180 $tree -> set_child_content ( id
=> $k , $content_hash { $k });
195 sub HTML
:: Element
:: iter
{
196 my ( $tree , $p , @data ) = @_ ;
198 # warn 'P: ' , $p->attr('id') ;
199 # warn 'H: ' , $p->as_HTML;
201 # my $id_incr = make_counter;
203 my $new_item = clone
$p ;
204 $new_item -> replace_content ( $_ );
208 $p -> replace_with ( @item );
213 sub HTML
:: Element
:: iter2
{
217 #warn "INPUT TO TABLE2: ", Dumper \@_;
221 wrapper_ld
=> { default => [ '_tag' => 'dl' ] },
223 wrapper_proc
=> { default => undef },
224 item_ld
=> { default => sub {
227 $tree -> look_down ( '_tag' => 'dt' ),
228 $tree -> look_down ( '_tag' => 'dd' )
232 item_data
=> { default => sub { my ( $wrapper_data ) = @_ ;
233 shift ( @
{ $wrapper_data }) ;
237 my ( $item_elems , $item_data , $row_count ) = @_ ;
238 $item_elems ->[ $_ ]-> replace_content ( $item_data ->[ $_ ]) for ( 0 , 1 ) ;
241 splice => { default => sub {
242 my ( $container , @item_elems ) = @_ ;
243 $container -> splice_content ( 0 , 2 , @item_elems );
246 debug
=> { default => 0 }
250 warn "wrapper_data: " . Dumper
$p { wrapper_data
} if $p { debug
} ;
252 my $container = ref_or_ld
( $tree , $p { wrapper_ld
});
253 warn "container: " . $container if $p { debug
} ;
254 warn "wrapper_(preproc): " . $container -> as_HTML if $p { debug
} ;
255 $p { wrapper_proc
}->( $container ) if defined $p { wrapper_proc
} ;
256 warn "wrapper_(postproc): " . $container -> as_HTML if $p { debug
} ;
258 my $_item_elems = $p { item_ld
}->( $container );
265 my $item_data = $p { item_data
}->( $p { wrapper_data
});
266 last unless defined $item_data ;
268 warn Dumper
( "item_data" , $item_data );
271 my $item_elems = [ map { $_ -> clone } @
{ $_item_elems } ] ;
274 for ( @
{ $item_elems }) {
275 warn "ITEM_ELEMS " , $_ -> as_HTML ;
279 my $new_item_elems = $p { item_proc
}->( $item_elems , $item_data , ++ $row_count );
282 for ( @
{ $new_item_elems }) {
283 warn "NEWITEM_ELEMS " , $_ -> as_HTML ;
288 push @item_elem , @
{ $new_item_elems } ;
293 warn "pushing " . @item_elem . " elems " if $p { debug
} ;
295 $p { splice }->( $container , @item_elem );
299 sub HTML
:: Element
:: dual_iter
{
300 my ( $parent , $data ) = @_ ;
302 my ( $prototype_a , $prototype_b ) = $parent -> content_list ;
304 # my $id_incr = make_counter;
309 confess
'dataset does not contain an even number of members' ;
311 my @iterable_data = ngroup
2 => @
$data ;
314 my ( $new_a , $new_b ) = map { clone
$_ } ( $prototype_a , $prototype_b ) ;
315 $new_a -> splice_content ( 0 , 1 , $_ ->[ 0 ]);
316 $new_b -> splice_content ( 0 , 1 , $_ ->[ 1 ]);
317 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
321 $parent -> splice_content ( 0 , 2 , @item );
326 sub HTML
:: Element
:: set_child_content
{
331 my $content_tag = $tree -> look_down ( @look_down );
333 unless ( $content_tag ) {
334 warn "criteria [ @look_down ] not found" ;
338 $content_tag -> replace_content ( $content );
342 sub HTML
:: Element
:: highlander
{
343 my ( $tree , $local_root_id , $aref , @arg ) = @_ ;
345 ref $aref eq 'ARRAY' or confess
346 "must supply array reference" ;
349 @aref % 2 == 0 or confess
350 "supplied array ref must have an even number of entries" ;
352 warn __PACKAGE__
if $DEBUG ;
355 while ( my ( $id , $test ) = splice @aref , 0 , 2 ) {
364 my @id_survivor = ( id
=> $survivor );
365 my $survivor_node = $tree -> look_down ( @id_survivor );
367 # warn $local_root_id;
370 warn "survivor: $survivor " if $DEBUG ;
371 warn "tree: " . $tree -> as_HTML if $DEBUG ;
373 $survivor_node or die "search for @id_survivor failed in tree( $tree ): " . $tree -> as_HTML ;
375 my $survivor_node_parent = $survivor_node -> parent ;
376 $survivor_node = $survivor_node -> clone ;
377 $survivor_node_parent -> replace_content ( $survivor_node );
379 warn "new tree: " . $tree -> as_HTML if $DEBUG ;
385 sub HTML
:: Element
:: highlander2
{
388 my %p = validate
( @_ , {
389 cond
=> { type
=> ARRAYREF
},
390 cond_arg
=> { type
=> ARRAYREF
,
393 debug
=> { default => 0 }
398 my @cond = @
{ $p { cond
}};
399 @cond % 2 == 0 or confess
400 "supplied array ref must have an even number of entries" ;
402 warn __PACKAGE__
if $p { debug
};
404 my @cond_arg = @
{ $p { cond_arg
}};
406 my $survivor ; my $then ;
407 while ( my ( $id , $if_then ) = splice @cond , 0 , 2 ) {
409 warn $id if $p { debug
};
412 if ( ref $if_then eq 'ARRAY' ) {
413 ( $if , $_then ) = @
$if_then ;
415 ( $if , $_then ) = ( $if_then , sub {});
418 if ( $if ->( @cond_arg )) {
426 my @ld = ( ref $survivor eq 'ARRAY' )
431 warn "survivor: " , $survivor if $p { debug
};
432 warn "survivor_ld: " , Dumper \
@ld if $p { debug
};
435 my $survivor_node = $tree -> look_down ( @ld );
437 $survivor_node or confess
438 "search for @ld failed in tree( $tree ): " . $tree -> as_HTML ;
440 my $survivor_node_parent = $survivor_node -> parent ;
441 $survivor_node = $survivor_node -> clone ;
442 $survivor_node_parent -> replace_content ( $survivor_node );
445 # **************** NEW FUNCTIONALITY *******************
447 # apply transforms on survivor node
450 warn "SURV::pre_trans " . $survivor_node -> as_HTML if $p { debug
};
451 $then ->( $survivor_node , @cond_arg );
452 warn "SURV::post_trans " . $survivor_node -> as_HTML if $p { debug
};
454 # **************** NEW FUNCTIONALITY *******************
463 sub overwrite_action
{
464 my ( $mute_node , %X ) = @_ ;
466 $mute_node -> attr ( $X { local_attr
}{ name
} => $X { local_attr
}{ value
}{ new
});
470 sub HTML
:: Element
:: overwrite_attr
{
473 $tree -> mute_elem ( @_ , \
& overwrite_action
);
478 sub HTML
:: Element
:: mute_elem
{
479 my ( $tree , $mute_attr , $closures , $post_hook ) = @_ ;
481 warn "my mute_node = $tree ->look_down( $mute_attr => qr/.*/) ;" ;
482 my @mute_node = $tree -> look_down ( $mute_attr => qr/.*/ ) ;
484 for my $mute_node ( @mute_node ) {
485 my ( $local_attr , $mute_key ) = split /\s+/ , $mute_node -> attr ( $mute_attr );
486 my $local_attr_value_current = $mute_node -> attr ( $local_attr );
487 my $local_attr_value_new = $closures ->{ $mute_key }->( $tree , $mute_node , $local_attr_value_current );
494 current
=> $local_attr_value_current ,
495 new
=> $local_attr_value_new
504 sub HTML
:: Element
:: table
{
506 my ( $s , %table ) = @_ ;
510 # use Data::Dumper; warn Dumper \%table;
512 # ++$DEBUG if $table{debug} ;
515 # Get the table element
516 $table ->{ table_node
} = $s -> look_down ( id
=> $table { gi_table
});
517 $table ->{ table_node
} or confess
518 "table tag not found via (id => $table {gi_table}" ;
520 # Get the prototype tr element(s)
521 my @table_gi_tr = listify
$table { gi_tr
} ;
524 my $tr = $table ->{ table_node
}-> look_down ( id
=> $_ );
525 $tr or confess
"tr with id => $_ not found" ;
529 warn "found " . @iter_node . " iter nodes " if $DEBUG ;
530 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
531 my $iter_node = List
:: Rotation
:: Cycle
-> new ( @iter_node );
534 warn Dumper
( $iter_node , \
@iter_node ) if $DEBUG ;
536 # $table->{content} = $table{content};
537 #$table->{parent} = $table->{table_node}->parent;
540 # $table->{table_node}->detach;
541 # $_->detach for @iter_node;
546 my $row = $table { tr_data
}->( $table , $table { table_data
});
547 last unless defined $row ;
549 # get a sample table row and clone it.
550 my $I = $iter_node -> next ;
551 warn "I: $I " if $DEBUG ;
552 my $new_iter_node = $I -> clone ;
555 $table { td_data
}->( $new_iter_node , $row );
556 push @table_rows , $new_iter_node ;
563 my $replace_with_elem = $s -> look_down ( id
=> shift @table_gi_tr ) ;
565 $s -> look_down ( id
=> $_ )-> detach ;
568 $replace_with_elem -> replace_with ( @table_rows );
576 my ( $tree , $slot ) = @_ ;
578 if ( ref ( $slot ) eq 'CODE' ) {
581 $tree -> look_down ( @
$slot );
587 sub HTML
:: Element
:: table2
{
595 table_ld
=> { default => [ '_tag' => 'table' ] },
597 table_proc
=> { default => undef },
599 tr_ld
=> { default => [ '_tag' => 'tr' ] },
600 tr_data
=> { default => sub { my ( $self , $data ) = @_ ;
603 tr_base_id
=> { default => undef },
604 tr_proc
=> { default => sub {} },
606 debug
=> { default => 0 }
610 warn "INPUT TO TABLE2: " , Dumper \
@_ if $p { debug
};
612 warn "table_data: " . Dumper
$p { table_data
} if $p { debug
} ;
616 # use Data::Dumper; warn Dumper \%table;
618 # ++$DEBUG if $table{debug} ;
620 # Get the table element
622 $table ->{ table_node
} = ref_or_ld
( $tree , $p { table_ld
} ) ;
624 $table ->{ table_node
} or confess
625 "table tag not found via " . Dumper
( $p { table_ld
}) ;
627 warn "table: " . $table ->{ table_node
}-> as_HTML if $p { debug
};
630 # Get the prototype tr element(s)
631 my @proto_tr = ref_or_ld
( $table ->{ table_node
}, $p { tr_ld
} ) ;
633 warn "found " . @proto_tr . " iter nodes " if $p { debug
};
635 @proto_tr or return ;
638 warn $_ -> as_HTML for @proto_tr ;
640 my $proto_tr = List
:: Rotation
:: Cycle
-> new ( @proto_tr );
642 my $tr_parent = $proto_tr [ 0 ]-> parent ;
643 warn "parent element of trs: " . $tr_parent -> as_HTML if $p { debug
};
650 my $row = $p { tr_data
}->( $table , $p { table_data
}, $row_count );
651 warn "data row: " . Dumper
$row if $p { debug
};
652 last unless defined $row ;
654 # wont work: my $new_iter_node = $table->{iter_node}->clone;
655 my $new_tr_node = $proto_tr -> next -> clone ;
656 warn "new_tr_node: $new_tr_node " if $p { debug
};
658 $p { tr_proc
}->( $tree , $new_tr_node , $row , $p { tr_base_id
}, ++ $row_count )
659 if defined $p { tr_proc
};
661 warn "data row redux: " . Dumper
$row if $p { debug
};
664 $p { td_proc
}->( $new_tr_node , $row );
665 push @table_rows , $new_tr_node ;
672 $_ -> detach for @proto_tr ;
674 $tr_parent -> push_content ( @table_rows ) if ( @table_rows ) ;
679 sub HTML
:: Element
:: unroll_select
{
681 my ( $s , %select ) = @_ ;
685 warn "Select Hash: " . Dumper
( \
%select ) if $select { debug
};
687 my $select_node = $s -> look_down ( id
=> $select { select_label
});
688 warn "Select Node: " . $select_node if $select { debug
};
690 unless ( $select { append
}) {
691 for my $option ( $select_node -> look_down ( '_tag' => 'option' )) {
697 my $option = HTML
:: Element
-> new ( 'option' );
698 warn "Option Node: " . $option if $select { debug
};
702 while ( my $row = $select { data_iter
}->( $select { data
}))
704 warn "Data Row:" . Dumper
( $row ) if $select { debug
};
705 my $o = $option -> clone ;
706 $o -> attr ( 'value' , $select { option_value
}->( $row ));
707 $o -> attr ( 'SELECTED' , 1 ) if ( exists $select { option_selected
} and $select { option_selected
}->( $row )) ;
709 $o -> replace_content ( $select { option_content
}->( $row ));
710 $select_node -> push_content ( $o );
711 warn $o -> as_HTML if $select { debug
};
719 sub HTML
:: Element
:: set_sibling_content
{
720 my ( $elt , $content ) = @_ ;
722 $elt -> parent -> splice_content ( $elt -> pindex + 1 , 1 , $content );
726 sub HTML
:: TreeBuilder
:: parse_string
{
727 my ( $package , $string ) = @_ ;
729 my $h = HTML
:: TreeBuilder
-> new ;
730 HTML
:: TreeBuilder
-> parse ( $string );
738 # Below is stub documentation for your module. You'd better edit it!
742 HTML::Element::Library - HTML::Element convenience functions
746 use HTML::Element::Library;
747 use HTML::TreeBuilder;
751 This method provides API calls for common actions on trees when using
756 The test suite contains examples of each of these methods in a
759 =head2 Positional Querying Methods
761 =head3 $elem->siblings
763 Return a list of all nodes under the same parent.
767 Return the index of C<$elem> into the array of siblings of which it is
768 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
769 that is a descriptive name. And such naming is deceptively close to the
770 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
771 backwards compatibility, both methods are available.
777 =head3 $elem->position()
779 Returns the coordinates of this element in the tree it inhabits.
780 This is accomplished by succesively calling addr() on ancestor
781 elements until either a) an element that does not support these
782 methods is found, or b) there are no more parents. The resulting
783 list is the n-dimensional coordinates of the element in the tree.
785 =head2 Element Decoration Methods
787 =head3 HTML::Element::Library::super_literal($text)
789 In L<HTML::Element>, Sean Burke discusses super-literals. They are
790 text which does not get escaped. Great for includng Javascript in
791 HTML. Also great for including foreign language into a document.
793 So, you basically toss C<super_literal> your text and back comes
794 your text wrapped in a C<~literal> element.
796 One of these days, I'll around to writing a nice C<EXPORT> section.
798 =head2 Tree Rewriting Methods
800 =head3 Mapping a hashref to HTML elements
802 It is very common to get a hashref of data from some external source - flat file, database, XML, etc.
803 Therefore, it is important to have a convenient way of mapping this data to HTML.
805 As it turns out, there are 3 ways to do this in HTML::Element::Library.
806 The most strict and structured way to do this is with
807 C<content_handler>. Two other methods, C<hashmap> and C<datamap> require less manual mapping and may prove
808 even more easy to use in certain cases.
810 As is usual with Perl, a practical example is always best. So let's take some sample HTML:
813 <span id="name">?</span>
814 <span id="email">?</span>
815 <span id="gender">?</span>
817 Now, let's say our data structure is this:
819 $ref = { email => 'jim@beam.com', gender => 'lots' } ;
821 And let's start with the most strict way to get what you want:
823 $tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ;
826 In this case, you manually state the mapping between id tags and hashref keys and
827 then C<content_handler> retrieves the hashref data and pops it in the specified place.
829 Now let's look at the two (actually 2 and a half) other hash-mapping methods.
831 $tree->hashmap(id => $ref);
833 Now, what this function does is super-destructive. It finds every element in the tree
834 with an attribute named id (since 'id' is a parameter, it could find every element with
835 some other attribute also) and replaces the content of those elements with the hashref
838 So, in the case above, the
840 <span id="name">?</span>
844 <span id="name"></span>
846 (it would be blank) - because there is nothing in the hash with that value, so it substituted
850 which was blank and emptied the contents.
852 Now, let's assume we want to protect name from being auto-assigned. Here is what you do:
854 $tree->hashmap(id => $ref, ['name']);
856 That last array ref is an exclusion list.
858 But wouldnt it be nice if you could do a hashmap, but only assigned things which are defined
859 in the hashref? C<< defmap() >> to the rescue:
861 $tree->defmap(id => $ref);
865 <span id="name">?</span>
870 =head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
872 This method is designed to take a hashref and populate a series of elements. For example:
876 <tr sclass="tr" class="alt" align="left" valign="top">
877 <td smap="people_id">1</td>
878 <td smap="phone">(877) 255-3239</td>
879 <td smap="password">*********</td>
883 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
885 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
887 Then a single API call allows us to populate the HTML while excluding those ones we dont:
889 $tree->hashmap('sid' => \%data, ['password']);
892 Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
893 you plan to use for hash mapping.
895 Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
896 (which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
898 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
900 =head4 $elem->defmap($attr_name, \%hashref, $debug)
902 C<defmap> was described above.
905 =head4 $elem->content_handler(%hashref)
907 C<content_handler> is described below.
910 =head3 $elem->replace_content(@new_elem)
912 Replaces all of C<$elem>'s content with C<@new_elem>.
914 =head3 $elem->wrap_content($wrapper_element)
916 Wraps the existing content in the provided element. If the provided element
917 happens to be a non-element, a push_content is performed instead.
919 =head3 $elem->set_child_content(@look_down, $content)
921 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
923 After finding the node, it detaches the node's content and pushes $content as the node's content.
925 =head3 $tree->content_handler(%id_content)
927 This is a convenience method. Because the look_down criteria will often simply be:
933 <a id=fixme href=http://www.somesite.org>replace_content</a>
935 You can call this method to shorten your typing a bit. You can simply type
937 $elem->content_handler( fixme => 'new text' )
941 $elem->set_child_content(sid => 'fixme', 'new text')
943 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:
945 my %id_content = (name => "Terrence Brannon",
946 email => 'tbrannon@in.com',
948 content => $main_content);
950 $tree->content_handler(%id_content);
952 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
954 This allows for "if-then-else" style processing. Highlander was a movie in
955 which only one would survive. Well, in terms of a tree when looking at a
956 structure that you want to process in C<if-then-else> style, only one child
957 will survive. For example, given this HTML template:
959 <span klass="highlander" id="age_dialog">
961 Hello, does your mother know you're
962 using her AOL account?
965 Sorry, you're not old enough to enter
966 (and too dumb to lie about your age)
973 We only want one child of the C<span> tag with id C<age_dialog> to remain
974 based on the age of the person visiting the page.
976 So, let's setup a call that will prune the subtree as a function of age:
980 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
985 under10 => sub { $_[0] < 10} ,
986 under18 => sub { $_[0] < 18} ,
992 And there we have it. If the age is less than 10, then the node with
993 id C<under10> remains. For age less than 18, the node with id C<under18>
995 Otherwise our "else" condition fires and the child with id C<welcome> remains.
997 =head3 $tree->passover($id_of_element)
999 In some cases, you know exactly which element should survive. In this case,
1000 you can simply call C<passover> to remove it's siblings. For the HTML
1001 above, you could delete C<under10> and C<welcome> by simply calling:
1003 $tree->passover('under18');
1005 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
1007 Right around the same time that C<table2()> came into being, Seamstress
1008 began to tackle tougher and tougher processing problems. It became clear that
1009 a more powerful highlander was needed... one that not only snipped the tree
1010 of the nodes that should not survive, but one that allows for
1011 post-processing of the survivor node. And one that was more flexible with
1012 how to find the nodes to snip.
1014 Thus (drum roll) C<highlander2()>.
1016 So let's look at our HTML which requires post-selection processing:
1018 <span klass="highlander" id="age_dialog">
1020 Hello, little <span id=age>AGE</span>-year old,
1021 does your mother know you're using her AOL account?
1024 Sorry, you're only <span id=age>AGE</span>
1025 (and too dumb to lie about your age)
1028 Welcome, isn't it good to be <span id=age>AGE</span> years old?
1032 In this case, a branch survives, but it has dummy data in it. We must take
1033 the surviving segment of HTML and rewrite the age C<span> with the age.
1034 Here is how we use C<highlander2()> to do so:
1039 $branch->look_down(id => 'age')->replace_content($age);
1042 my $if_then = $tree->look_down(id => 'age_dialog');
1044 $if_then->highlander2(
1059 cond_arg => [ $age ]
1062 We pass it the tree (C<$if_then>), an arrayref of conditions
1063 (C<cond>) and an arrayref of arguments which are passed to the
1064 C<cond>s and to the replacement subs.
1066 The C<under10>, C<under18> and C<welcome> are id attributes in the
1067 tree of the siblings of which only one will survive. However,
1068 should you need to do
1069 more complex look-downs to find the survivor,
1070 then supply an array ref instead of a simple
1074 $if_then->highlander2(
1076 [class => 'r12'] => [
1080 [class => 'z22'] => [
1084 [class => 'w88'] => [
1089 cond_arg => [ $age ]
1093 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
1095 This method is designed for taking a tree and reworking a set of nodes in
1096 a stereotyped fashion. For instance let's say you have 3 remote image
1097 archives, but you don't want to put long URLs in your img src
1098 tags for reasons of abstraction, re-use and brevity. So instead you do this:
1100 <img src="/img/smiley-face.jpg" fixup="src lnc">
1101 <img src="/img/hot-babe.jpg" fixup="src playboy">
1102 <img src="/img/footer.jpg" fixup="src foobar">
1104 and then when the tree of HTML is being processed, you make this call:
1107 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
1108 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
1109 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
1112 $tree->overwrite_attr(fixup => \%closures) ;
1114 and the tags come out modified like so:
1116 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1117 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1118 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1120 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1122 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1123 assumes the return value of the
1124 closure is supposed overwrite an attribute value and does it for you.
1125 C<mute_elem> is a more general function which does nothing but
1126 hand the closure the element and let it mutate it as it jolly well pleases :)
1128 In fact, here is the implementation of C<overwrite_attr>
1129 to give you a taste of how C<mute_attr> is used:
1131 sub overwrite_action {
1132 my ($mute_node, %X) = @_;
1134 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1138 sub HTML::Element::overwrite_attr {
1141 $tree->mute_elem(@_, \&overwrite_action);
1147 =head2 Tree-Building Methods
1151 =head3 Unrolling an array via a single sample element (<ul> container)
1153 This is best described by example. Given this HTML:
1155 <strong>Here are the things I need from the store:</strong>
1157 <li class="store_items">Sample item</li>
1160 We can unroll it like so:
1162 my $li = $tree->look_down(class => 'store_items');
1164 my @items = qw(bread butter vodka);
1166 $tree->iter($li => @items);
1173 <body>Here are the things I need from the store:
1175 <li class="store_items">bread</li>
1176 <li class="store_items">butter</li>
1177 <li class="store_items">vodka</li>
1182 Now, you might be wondering why the API call is:
1184 $tree->iter($li => @items)
1190 and there is no good answer. The latter would be more concise and it is what I
1193 =head3 Unrolling an array via n sample elements (<dl> container)
1195 C<iter()> was fine for awhile, but some things
1196 (e.g. definition lists) need a more general function to make them easy to
1197 do. Hence C<iter2()>. This function will be explained by example of unrolling
1198 a simple definition list.
1200 So here's our mock-up HTML from the designer:
1202 <dl class="dual_iter" id="service_plan">
1207 A person who draws blood.
1214 A clone of Iggy Pop.
1221 A relative of Edgar Allan Poe.
1224 <dt class="adstyle">sample header</dt>
1225 <dd class="adstyle2">sample data</dd>
1230 And we want to unroll our data set:
1233 ['the pros' => 'never have to worry about service again'],
1234 ['the cons' => 'upfront extra charge on purchase'],
1235 ['our choice' => 'go with the extended service plan']
1239 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1240 Let's assume that we want only the last <dt> and it's accompanying <dd>
1241 (the one with "sample data") to be used as the sample data
1242 for unrolling with our data set. Let's further assume that we want them to
1243 remain in the final output.
1245 So now, the API to C<iter2()> will be discussed and we will explain how our
1246 goal of getting our data into HTML fits into the API.
1252 This is how to look down and find the container of all the elements we will
1253 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1256 If you pass an anonymous subroutine, then it is presumed that execution of
1257 this subroutine will return the HTML::Element representing the container tag.
1258 If you pass an array ref, then this will be dereferenced and passed to
1259 C<HTML::Element::look_down()>.
1261 default value: C<< ['_tag' => 'dl'] >>
1263 Based on the mock HTML above, this default is fine for finding our container
1264 tag. So let's move on.
1266 =item * wrapper_data
1268 This is an array reference of data that we will be putting into the container.
1269 You must supply this. C<@items> above is our C<wrapper_data>.
1271 =item * wrapper_proc
1273 After we find the container via C<wrapper_ld>, we may want to pre-process
1274 some aspect of this tree. In our case the first two sets of dt and dd need
1275 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1282 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1283 be cloned and populated with item data
1284 (item data is a "row" of C<wrapper_data>).
1286 default: returns an arrayref consisting of the dt and dd element inside the
1291 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1292 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1293 I hope that makes sense.
1295 default: shifts C<wrapper_data>.
1299 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1300 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1301 eventually be spliced into the container.
1303 Note that this subroutine MUST return the new items. This is done
1304 So that more items than were passed in can be returned. This is
1305 useful when, for example, you must return 2 dts for an input data item.
1306 And when would you do this? When a single term has multiple spellings
1309 default: expects C<item_data> to be an arrayref of two elements and
1310 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1311 content of the C<HTML::Element>s with the C<item_data>.
1315 After building up an array of C<@item_elems>, the subroutine passed as
1316 C<splice> will be given the parent container HTML::Element and the
1317 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1318 routine: it could put half of them in. It could unshift them or whatever.
1320 default: C<< $container->splice_content(0, 2, @item_elems) >>
1321 In other words, kill the 2 sample elements with the newly generated
1326 So now that we have documented the API, let's see the call we need:
1329 # default wrapper_ld ok.
1330 wrapper_data => \@items,
1331 wrapper_proc => sub {
1332 my ($container) = @_;
1334 # only keep the last 2 dts and dds
1335 my @content_list = $container->content_list;
1336 $container->splice_content(0, @content_list - 2);
1339 # default item_ld is fine.
1340 # default item_data is fine.
1341 # default item_proc is fine.
1343 my ($container, @item_elems) = @_;
1344 $container->unshift_content(@item_elems);
1352 =head3 Select Unrolling
1354 The C<unroll_select> method has this API:
1356 $tree->unroll_select(
1357 select_label => $id_label,
1358 option_value => $closure, # how to get option value from data row
1359 option_content => $closure, # how to get option content from data row
1360 option_selected => $closure, # boolean to decide if SELECTED
1361 data => $data # the data to be put into the SELECT
1362 data_iter => $closure # the thing that will get a row of data
1364 append => $boolean, # remove the sample <OPTION> data or append?
1369 $tree->unroll_select(
1370 select_label => 'clan_list',
1371 option_value => sub { my $row = shift; $row->clan_id },
1372 option_content => sub { my $row = shift; $row->clan_name },
1373 option_selected => sub { my $row = shift; $row->selected },
1374 data => \@query_results,
1375 data_iter => sub { my $data = shift; $data->next },
1382 =head2 Tree-Building Methods: Table Generation
1384 Matthew Sisk has a much more intuitive (imperative)
1385 way to generate tables via his module
1386 L<HTML::ElementTable|HTML::ElementTable>.
1387 However, for those with callback fever, the following
1388 method is available. First, we look at a nuts and bolts way to build a table
1389 using only standard L<HTML::Tree> API calls. Then the C<table> method
1390 available here is discussed.
1394 package Simple::Class;
1398 my @name = qw(bob bill brian babette bobo bix);
1399 my @age = qw(99 12 44 52 12 43);
1400 my @weight = qw(99 52 80 124 120 230);
1405 bless {}, ref($this) || $this;
1413 age => $age[rand $#age] + int rand 20,
1414 name => shift @name,
1415 weight => $weight[rand $#weight] + int rand 40
1419 Set::Array->new(@data);
1426 =head4 Sample Usage:
1428 my $data = Simple::Class->load_data;
1429 ++$_->{age} for @$data
1431 =head3 Inline Code to Unroll a Table
1437 <table id="load_data">
1439 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1443 <td id="name"> NATURE BOY RIC FLAIR </td>
1444 <td id="age"> 35 </td>
1445 <td id="weight"> 220 </td>
1454 =head4 The manual way (*NOT* recommended)
1456 require 'simple-class.pl';
1457 use HTML::Seamstress;
1460 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1463 my $o = Simple::Class->new;
1464 my $data = $o->load_data;
1466 # find the <table> and <tr>
1467 my $table_node = $seamstress->look_down('id', 'load_data');
1468 my $iter_node = $table_node->look_down('id', 'iterate');
1469 my $table_parent = $table_node->parent;
1472 # drop the sample <table> and <tr> from the HTML
1473 # only add them in if there is data in the model
1474 # this is achieved via the $add_table flag
1476 $table_node->detach;
1480 # Get a row of model data
1481 while (my $row = shift @$data) {
1483 # We got row data. Set the flag indicating ok to hook the table into the HTML
1486 # clone the sample <tr>
1487 my $new_iter_node = $iter_node->clone;
1489 # find the tags labeled name age and weight and
1490 # set their content to the row data
1491 $new_iter_node->content_handler($_ => $row->{$_})
1492 for qw(name age weight);
1494 $table_node->push_content($new_iter_node);
1498 # reattach the table to the HTML tree if we loaded data into some table rows
1500 $table_parent->push_content($table_node) if $add_table;
1502 print $seamstress->as_HTML;
1506 =head3 $tree->table() : API call to Unroll a Table
1508 require 'simple-class.pl';
1509 use HTML::Seamstress;
1512 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1514 my $o = Simple::Class->new;
1518 # tell seamstress where to find the table, via the method call
1519 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1520 # HTML tree automatically if no table rows can be built
1522 gi_table => 'load_data',
1524 # tell seamstress where to find the tr. This is a bit useless as
1525 # the <tr> usually can be found as the first child of the parent
1529 # the model data to be pushed into the table
1531 table_data => $o->load_data,
1533 # the way to take the model data and obtain one row
1534 # if the table data were a hashref, we would do:
1535 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1537 tr_data => sub { my ($self, $data) = @_;
1541 # the way to take a row of data and fill the <td> tags
1543 td_data => sub { my ($tr_node, $tr_data) = @_;
1544 $tr_node->content_handler($_ => $tr_data->{$_})
1545 for qw(name age weight) }
1550 print $seamstress->as_HTML;
1554 =head4 Looping over Multiple Sample Rows
1560 <table id="load_data" CELLPADDING=8 BORDER=2>
1562 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1564 <tr id="iterate1" BGCOLOR="white" >
1566 <td id="name"> NATURE BOY RIC FLAIR </td>
1567 <td id="age"> 35 </td>
1568 <td id="weight"> 220 </td>
1571 <tr id="iterate2" BGCOLOR="#CCCC99">
1573 <td id="name"> NATURE BOY RIC FLAIR </td>
1574 <td id="age"> 35 </td>
1575 <td id="weight"> 220 </td>
1584 * Only one change to last API call.
1592 gi_tr => ['iterate1', 'iterate2']
1594 =head3 $tree->table2() : New API Call to Unroll a Table
1596 After 2 or 3 years with C<table()>, I began to develop
1597 production websites with it and decided it needed a cleaner
1598 interface, particularly in the area of handling the fact that
1599 C<id> tags will be the same after cloning a table row.
1601 First, I will give a dry listing of the function's argument parameters.
1602 This will not be educational most likely. A better way to understand how
1603 to use the function is to read through the incremental unrolling of the
1604 function's interface given in conversational style after the dry listing.
1605 But take your pick. It's the same information given in two different
1608 =head4 Dry/technical parameter documentation
1610 C<< $tree->table2(%param) >> takes the following arguments:
1614 =item * C<< table_ld => $look_down >> : optional
1616 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1617 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1618 passing it C<$tree>.
1620 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1622 =item * C<< table_data => $tabular_data >> : required
1624 The data to fill the table with. I<Must> be passed in.
1626 =item * C<< table_proc => $code_ref >> : not implemented
1628 A subroutine to do something to the table once it is found.
1629 Not currently implemented. Not obviously necessary. Just
1630 created because there is a C<tr_proc> and C<td_proc>.
1632 =item * C<< tr_ld => $look_down >> : optional
1634 Same as C<table_ld> but for finding the table row elements. Please note
1635 that the C<tr_ld> is done on the table node that was found I<instead>
1636 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1637 below the table that was just found.
1639 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1641 =item * C<< tr_data => $code_ref >> : optional
1643 How to take the C<table_data> and return a row. Defaults to:
1645 sub { my ($self, $data) = @_;
1649 =item * C<< tr_proc => $code_ref >> : optional
1651 Something to do to the table row we are about to add to the
1652 table we are making. Defaults to a routine which makes the C<id>
1656 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1657 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1660 =item * C<< td_proc => $code_ref >> : required
1662 This coderef will take the row of data and operate on the C<td> cells that
1663 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1665 Here's a sample one:
1668 my ($tr, $data) = @_;
1669 my @td = $tr->look_down('_tag' => 'td');
1670 for my $i (0..$#td) {
1671 $td[$i]->splice_content(0, 1, $data->[$i]);
1677 =head4 Conversational parameter documentation
1679 The first thing you need is a table. So we need a look down for that. If you
1680 don't give one, it defaults to
1684 What good is a table to display in without data to display?!
1685 So you must supply a scalar representing your tabular
1686 data source. This scalar might be an array reference, a C<next>able iterator,
1687 a DBI statement handle. Whatever it is, it can be iterated through to build
1688 up rows of table data.
1689 These two required fields (the way to find the table and the data to
1690 display in the table) are C<table_ld> and C<table_data>
1691 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1693 of the code ref is presumed to return the C<HTML::Element>
1694 representing the table in the HTML tree.
1696 Next, we get the row or rows which serve as sample C<tr> elements by doing
1697 a C<look_down> from the C<table_elem>. While normally one sample row
1698 is enough to unroll a table, consider when you have alternating
1699 table rows. This API call would need one of each row so that it can
1701 sample rows as it loops through the data.
1702 Alternatively, you could always just use one row and
1703 make the necessary changes to the single C<tr> row by
1704 mutating the element in C<tr_proc>,
1705 discussed below. The default C<tr_ld> is
1706 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1707 it with a subroutine, then it is expected that the subroutine will return
1708 the C<HTML::Element>(s)
1709 which are C<tr> element(s).
1710 The reason a subroutine might be preferred is in the case
1711 that the HTML designers gave you 8 sample C<tr> rows but only one
1712 prototype row is needed.
1713 So you can write a subroutine, to splice out the 7 rows you don't need
1714 and leave the one sample
1715 row remaining so that this API call can clone it and supply it to
1716 the C<tr_proc> and C<td_proc> calls.
1718 Now, as we move through the table rows with table data,
1719 we need to do two different things on
1724 =item * get one row of data from the C<table_data> via C<tr_data>
1726 The default procedure assumes the C<table_data> is an array reference and
1727 shifts a row off of it:
1729 sub { my ($self, $data) = @_;
1733 Your function MUST return undef when there is no more rows to lay out.
1735 =item * take the C<tr> element and mutate it via C<tr_proc>
1737 The default procedure simply makes the id of the table row unique:
1739 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1740 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1745 Now that we have our row of data, we call C<td_proc> so that it can
1746 take the data and the C<td> cells in this C<tr> and process them.
1747 This function I<must> be supplied.
1750 =head3 Whither a Table with No Rows
1752 Often when a table has no rows, we want to display a message
1753 indicating this to the view. Use conditional processing to decide what
1757 <table><tr><td>No Data is Good Data</td></tr></table>
1762 <table id="load_data">
1764 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1768 <td id="name"> NATURE BOY RIC FLAIR </td>
1769 <td id="age"> 35 </td>
1770 <td id="weight"> 220 </td>
1787 =item * L<HTML::Tree>
1789 A perl package for creating and manipulating HTML trees
1791 =item * L<HTML::ElementTable>
1793 An L<HTML::Tree> - based module which allows for manipulation of HTML
1794 trees using cartesian coordinations.
1796 =item * L<HTML::Seamstress>
1798 An L<HTML::Tree> - based module inspired by
1799 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1800 HTML generation via tree rewriting.
1808 currently the API expects the subtrees to survive or be pruned to be
1811 $if_then->highlander2([
1812 under10 => sub { $_[0] < 10} ,
1813 under18 => sub { $_[0] < 18} ,
1818 $branch->look_down(id => 'age')->replace_content($age);
1825 but, it should be more flexible. the C<under10>, and C<under18> are
1826 expected to be ids in the tree... but it is not hard to have a check to
1827 see if this field is an array reference and if it, then to do a look
1830 $if_then->highlander2([
1831 [class => 'under10'] => sub { $_[0] < 10} ,
1832 [class => 'under18'] => sub { $_[0] < 18} ,
1833 [class => 'welcome'] => [
1837 $branch->look_down(id => 'age')->replace_content($age);
1852 =head1 AUTHOR / SOURCE
1854 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1856 Many thanks to BARBIE for his RT bug report.
1858 The source is at L<http://github.com/metaperl/html-element-library/tree/master>
1860 =head1 COPYRIGHT AND LICENSE
1862 Copyright (C) 2004 by Terrence Brannon
1864 This library is free software; you can redistribute it and/or modify
1865 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1866 at your option, any later version of Perl 5 you may have available.
This page took 0.102596 seconds and 4 git commands to generate.