]>
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 , $return_tree )= @_ ;
39 ( ref $hashref ) eq 'HASH' or die 'hashref not supplied as argument' ;
42 my $html = $tree -> as_HTML ;
43 my $new_html = HTML
:: FillInForm
-> fill ( \
$html , $hashref );
46 HTML
:: TreeBuilder
-> new_from_content ( $new_html );
53 sub HTML
:: Element
:: siblings
{
55 my $p = $element -> parent ;
60 sub HTML
:: Element
:: defmap
{
61 my ( $tree , $attr , $hashref , $debug )= @_ ;
63 while ( my ( $k , $v ) = ( each % $hashref )) {
64 warn "defmap looks for ( $attr => $k )" if $debug ;
65 my $found = $tree -> look_down ( $attr => $k );
67 warn "( $attr => $k ) was found.. replacing with ' $v '" if $debug ;
68 $found -> replace_content ( $v );
75 sub HTML
:: Element
:: hash_map
{
76 my $container = shift ;
78 my %p = validate
( @_ , {
79 hash
=> { type
=> HASHREF
},
81 excluding
=> { type
=> ARRAYREF
, default => [] },
82 debug
=> { default => 0 },
85 warn 'The container tag is ' , $container -> tag if $p { debug
} ;
86 warn 'hash' . Dumper
( $p { hash
}) if $p { debug
} ;
87 warn 'at_under' . Dumper
( \
@_ ) if $p { debug
} ;
89 my @same_as = $container -> look_down ( $p { to_attr
} => qr/.+/ ) ;
91 warn 'Found ' . scalar ( @same_as ) . ' nodes' if $p { debug
} ;
94 for my $same_as ( @same_as ) {
95 my $attr_val = $same_as -> attr ( $p { to_attr
}) ;
96 if ( first
{ $attr_val eq $_ } @
{ $p { excluding
}}) {
97 warn "excluding $attr_val " if $p { debug
} ;
100 warn "processing $attr_val " if $p { debug
} ;
101 $same_as -> replace_content ( $p { hash
}->{ $attr_val } ) ;
106 sub HTML
:: Element
:: hashmap
{
107 my ( $container , $attr_name , $hashref , $excluding , $debug ) = @_ ;
111 $container -> hash_map ( hash
=> $hashref ,
112 to_attr
=> $attr_name ,
113 excluding
=> $excluding ,
119 sub HTML
:: Element
:: passover
{
120 my ( $tree , @to_preserve ) = @_ ;
122 warn "ARGS: my ( $tree , @to_preserve )" if $DEBUG ;
123 warn $tree -> as_HTML ( undef , ' ' ) if $DEBUG ;
125 my $exodus = $tree -> look_down ( id
=> $to_preserve [ 0 ]);
127 warn "E: $exodus " if $DEBUG ;
129 my @s = HTML
:: Element
:: siblings
( $exodus );
133 if ( first
{ $s -> attr ( 'id' ) eq $_ } @to_preserve ) {
140 return $exodus ; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
144 sub HTML
:: Element
:: sibdex
{
147 firstidx
{ $_ eq $element } $element -> siblings
151 sub HTML
:: Element
:: addr
{ goto & HTML
:: Element
:: sibdex
}
153 sub HTML
:: Element
:: replace_content
{
155 $elem -> delete_content ;
156 $elem -> push_content ( @_ );
159 sub HTML
:: Element
:: wrap_content
{
160 my ( $self , $wrap ) = @_ ;
161 my $content = $self -> content ;
163 $wrap -> push_content ( @
$content );
167 $self -> push_content ( $wrap );
172 sub HTML
:: Element
:: Library
:: super_literal
{
175 HTML
:: Element
-> new ( '~literal' , text
=> $text );
179 sub HTML
:: Element
:: position
{
180 # Report coordinates by chasing addr's up the
181 # HTML::ElementSuper tree. We know we've reached
182 # the top when a) there is no parent, or b) the
183 # parent is some HTML::Element unable to report
189 unshift ( @pos , $a ) if defined $a ;
196 sub HTML
:: Element
:: content_handler
{
197 my ( $tree , %content_hash ) = @_ ;
199 for my $k ( keys %content_hash ) {
200 $tree -> set_child_content ( id
=> $k , $content_hash { $k });
215 sub HTML
:: Element
:: iter
{
216 my ( $tree , $p , @data ) = @_ ;
218 # warn 'P: ' , $p->attr('id') ;
219 # warn 'H: ' , $p->as_HTML;
221 # my $id_incr = make_counter;
223 my $new_item = clone
$p ;
224 $new_item -> replace_content ( $_ );
228 $p -> replace_with ( @item );
233 sub HTML
:: Element
:: iter2
{
237 #warn "INPUT TO TABLE2: ", Dumper \@_;
241 wrapper_ld
=> { default => [ '_tag' => 'dl' ] },
243 wrapper_proc
=> { default => undef },
244 item_ld
=> { default => sub {
247 $tree -> look_down ( '_tag' => 'dt' ),
248 $tree -> look_down ( '_tag' => 'dd' )
252 item_data
=> { default => sub { my ( $wrapper_data ) = @_ ;
253 shift ( @
{ $wrapper_data }) ;
257 my ( $item_elems , $item_data , $row_count ) = @_ ;
258 $item_elems ->[ $_ ]-> replace_content ( $item_data ->[ $_ ]) for ( 0 , 1 ) ;
261 splice => { default => sub {
262 my ( $container , @item_elems ) = @_ ;
263 $container -> splice_content ( 0 , 2 , @item_elems );
266 debug
=> { default => 0 }
270 warn "wrapper_data: " . Dumper
$p { wrapper_data
} if $p { debug
} ;
272 my $container = ref_or_ld
( $tree , $p { wrapper_ld
});
273 warn "container: " . $container if $p { debug
} ;
274 warn "wrapper_(preproc): " . $container -> as_HTML if $p { debug
} ;
275 $p { wrapper_proc
}->( $container ) if defined $p { wrapper_proc
} ;
276 warn "wrapper_(postproc): " . $container -> as_HTML if $p { debug
} ;
278 my $_item_elems = $p { item_ld
}->( $container );
285 my $item_data = $p { item_data
}->( $p { wrapper_data
});
286 last unless defined $item_data ;
288 warn Dumper
( "item_data" , $item_data );
291 my $item_elems = [ map { $_ -> clone } @
{ $_item_elems } ] ;
294 for ( @
{ $item_elems }) {
295 warn "ITEM_ELEMS " , $_ -> as_HTML ;
299 my $new_item_elems = $p { item_proc
}->( $item_elems , $item_data , ++ $row_count );
302 for ( @
{ $new_item_elems }) {
303 warn "NEWITEM_ELEMS " , $_ -> as_HTML ;
308 push @item_elem , @
{ $new_item_elems } ;
313 warn "pushing " . @item_elem . " elems " if $p { debug
} ;
315 $p { splice }->( $container , @item_elem );
319 sub HTML
:: Element
:: dual_iter
{
320 my ( $parent , $data ) = @_ ;
322 my ( $prototype_a , $prototype_b ) = $parent -> content_list ;
324 # my $id_incr = make_counter;
329 confess
'dataset does not contain an even number of members' ;
331 my @iterable_data = ngroup
2 => @
$data ;
334 my ( $new_a , $new_b ) = map { clone
$_ } ( $prototype_a , $prototype_b ) ;
335 $new_a -> splice_content ( 0 , 1 , $_ ->[ 0 ]);
336 $new_b -> splice_content ( 0 , 1 , $_ ->[ 1 ]);
337 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
341 $parent -> splice_content ( 0 , 2 , @item );
346 sub HTML
:: Element
:: set_child_content
{
351 my $content_tag = $tree -> look_down ( @look_down );
353 unless ( $content_tag ) {
354 warn "criteria [ @look_down ] not found" ;
358 $content_tag -> replace_content ( $content );
362 sub HTML
:: Element
:: highlander
{
363 my ( $tree , $local_root_id , $aref , @arg ) = @_ ;
365 ref $aref eq 'ARRAY' or confess
366 "must supply array reference" ;
369 @aref % 2 == 0 or confess
370 "supplied array ref must have an even number of entries" ;
372 warn __PACKAGE__
if $DEBUG ;
375 while ( my ( $id , $test ) = splice @aref , 0 , 2 ) {
384 my @id_survivor = ( id
=> $survivor );
385 my $survivor_node = $tree -> look_down ( @id_survivor );
387 # warn $local_root_id;
390 warn "survivor: $survivor " if $DEBUG ;
391 warn "tree: " . $tree -> as_HTML if $DEBUG ;
393 $survivor_node or die "search for @id_survivor failed in tree( $tree ): " . $tree -> as_HTML ;
395 my $survivor_node_parent = $survivor_node -> parent ;
396 $survivor_node = $survivor_node -> clone ;
397 $survivor_node_parent -> replace_content ( $survivor_node );
399 warn "new tree: " . $tree -> as_HTML if $DEBUG ;
405 sub HTML
:: Element
:: highlander2
{
408 my %p = validate
( @_ , {
409 cond
=> { type
=> ARRAYREF
},
410 cond_arg
=> { type
=> ARRAYREF
,
413 debug
=> { default => 0 }
418 my @cond = @
{ $p { cond
}};
419 @cond % 2 == 0 or confess
420 "supplied array ref must have an even number of entries" ;
422 warn __PACKAGE__
if $p { debug
};
424 my @cond_arg = @
{ $p { cond_arg
}};
426 my $survivor ; my $then ;
427 while ( my ( $id , $if_then ) = splice @cond , 0 , 2 ) {
429 warn $id if $p { debug
};
432 if ( ref $if_then eq 'ARRAY' ) {
433 ( $if , $_then ) = @
$if_then ;
435 ( $if , $_then ) = ( $if_then , sub {});
438 if ( $if ->( @cond_arg )) {
446 my @ld = ( ref $survivor eq 'ARRAY' )
451 warn "survivor: " , $survivor if $p { debug
};
452 warn "survivor_ld: " , Dumper \
@ld if $p { debug
};
455 my $survivor_node = $tree -> look_down ( @ld );
457 $survivor_node or confess
458 "search for @ld failed in tree( $tree ): " . $tree -> as_HTML ;
460 my $survivor_node_parent = $survivor_node -> parent ;
461 $survivor_node = $survivor_node -> clone ;
462 $survivor_node_parent -> replace_content ( $survivor_node );
465 # **************** NEW FUNCTIONALITY *******************
467 # apply transforms on survivor node
470 warn "SURV::pre_trans " . $survivor_node -> as_HTML if $p { debug
};
471 $then ->( $survivor_node , @cond_arg );
472 warn "SURV::post_trans " . $survivor_node -> as_HTML if $p { debug
};
474 # **************** NEW FUNCTIONALITY *******************
483 sub overwrite_action
{
484 my ( $mute_node , %X ) = @_ ;
486 $mute_node -> attr ( $X { local_attr
}{ name
} => $X { local_attr
}{ value
}{ new
});
490 sub HTML
:: Element
:: overwrite_attr
{
493 $tree -> mute_elem ( @_ , \
& overwrite_action
);
498 sub HTML
:: Element
:: mute_elem
{
499 my ( $tree , $mute_attr , $closures , $post_hook ) = @_ ;
501 warn "my mute_node = $tree ->look_down( $mute_attr => qr/.*/) ;" ;
502 my @mute_node = $tree -> look_down ( $mute_attr => qr/.*/ ) ;
504 for my $mute_node ( @mute_node ) {
505 my ( $local_attr , $mute_key ) = split /\s+/ , $mute_node -> attr ( $mute_attr );
506 my $local_attr_value_current = $mute_node -> attr ( $local_attr );
507 my $local_attr_value_new = $closures ->{ $mute_key }->( $tree , $mute_node , $local_attr_value_current );
514 current
=> $local_attr_value_current ,
515 new
=> $local_attr_value_new
524 sub HTML
:: Element
:: table
{
526 my ( $s , %table ) = @_ ;
530 # use Data::Dumper; warn Dumper \%table;
532 # ++$DEBUG if $table{debug} ;
535 # Get the table element
536 $table ->{ table_node
} = $s -> look_down ( id
=> $table { gi_table
});
537 $table ->{ table_node
} or confess
538 "table tag not found via (id => $table {gi_table}" ;
540 # Get the prototype tr element(s)
541 my @table_gi_tr = listify
$table { gi_tr
} ;
544 my $tr = $table ->{ table_node
}-> look_down ( id
=> $_ );
545 $tr or confess
"tr with id => $_ not found" ;
549 warn "found " . @iter_node . " iter nodes " if $DEBUG ;
550 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
551 my $iter_node = List
:: Rotation
:: Cycle
-> new ( @iter_node );
554 warn Dumper
( $iter_node , \
@iter_node ) if $DEBUG ;
556 # $table->{content} = $table{content};
557 #$table->{parent} = $table->{table_node}->parent;
560 # $table->{table_node}->detach;
561 # $_->detach for @iter_node;
566 my $row = $table { tr_data
}->( $table , $table { table_data
});
567 last unless defined $row ;
569 # get a sample table row and clone it.
570 my $I = $iter_node -> next ;
571 warn "I: $I " if $DEBUG ;
572 my $new_iter_node = $I -> clone ;
575 $table { td_data
}->( $new_iter_node , $row );
576 push @table_rows , $new_iter_node ;
583 my $replace_with_elem = $s -> look_down ( id
=> shift @table_gi_tr ) ;
585 $s -> look_down ( id
=> $_ )-> detach ;
588 $replace_with_elem -> replace_with ( @table_rows );
596 my ( $tree , $slot ) = @_ ;
598 if ( ref ( $slot ) eq 'CODE' ) {
601 $tree -> look_down ( @
$slot );
607 sub HTML
:: Element
:: table2
{
615 table_ld
=> { default => [ '_tag' => 'table' ] },
617 table_proc
=> { default => undef },
619 tr_ld
=> { default => [ '_tag' => 'tr' ] },
620 tr_data
=> { default => sub { my ( $self , $data ) = @_ ;
623 tr_base_id
=> { default => undef },
624 tr_proc
=> { default => sub {} },
626 debug
=> { default => 0 }
630 warn "INPUT TO TABLE2: " , Dumper \
@_ if $p { debug
};
632 warn "table_data: " . Dumper
$p { table_data
} if $p { debug
} ;
636 # use Data::Dumper; warn Dumper \%table;
638 # ++$DEBUG if $table{debug} ;
640 # Get the table element
642 $table ->{ table_node
} = ref_or_ld
( $tree , $p { table_ld
} ) ;
644 $table ->{ table_node
} or confess
645 "table tag not found via " . Dumper
( $p { table_ld
}) ;
647 warn "table: " . $table ->{ table_node
}-> as_HTML if $p { debug
};
650 # Get the prototype tr element(s)
651 my @proto_tr = ref_or_ld
( $table ->{ table_node
}, $p { tr_ld
} ) ;
653 warn "found " . @proto_tr . " iter nodes " if $p { debug
};
655 @proto_tr or return ;
658 warn $_ -> as_HTML for @proto_tr ;
660 my $proto_tr = List
:: Rotation
:: Cycle
-> new ( @proto_tr );
662 my $tr_parent = $proto_tr [ 0 ]-> parent ;
663 warn "parent element of trs: " . $tr_parent -> as_HTML if $p { debug
};
670 my $row = $p { tr_data
}->( $table , $p { table_data
}, $row_count );
671 warn "data row: " . Dumper
$row if $p { debug
};
672 last unless defined $row ;
674 # wont work: my $new_iter_node = $table->{iter_node}->clone;
675 my $new_tr_node = $proto_tr -> next -> clone ;
676 warn "new_tr_node: $new_tr_node " if $p { debug
};
678 $p { tr_proc
}->( $tree , $new_tr_node , $row , $p { tr_base_id
}, ++ $row_count )
679 if defined $p { tr_proc
};
681 warn "data row redux: " . Dumper
$row if $p { debug
};
684 $p { td_proc
}->( $new_tr_node , $row );
685 push @table_rows , $new_tr_node ;
692 $_ -> detach for @proto_tr ;
694 $tr_parent -> push_content ( @table_rows ) if ( @table_rows ) ;
699 sub HTML
:: Element
:: unroll_select
{
701 my ( $s , %select ) = @_ ;
705 warn "Select Hash: " . Dumper
( \
%select ) if $select { debug
};
707 my $select_node = $s -> look_down ( id
=> $select { select_label
});
708 warn "Select Node: " . $select_node if $select { debug
};
710 unless ( $select { append
}) {
711 for my $option ( $select_node -> look_down ( '_tag' => 'option' )) {
717 my $option = HTML
:: Element
-> new ( 'option' );
718 warn "Option Node: " . $option if $select { debug
};
722 while ( my $row = $select { data_iter
}->( $select { data
}))
724 warn "Data Row:" . Dumper
( $row ) if $select { debug
};
725 my $o = $option -> clone ;
726 $o -> attr ( 'value' , $select { option_value
}->( $row ));
727 $o -> attr ( 'SELECTED' , 1 ) if ( exists $select { option_selected
} and $select { option_selected
}->( $row )) ;
729 $o -> replace_content ( $select { option_content
}->( $row ));
730 $select_node -> push_content ( $o );
731 warn $o -> as_HTML if $select { debug
};
739 sub HTML
:: Element
:: set_sibling_content
{
740 my ( $elt , $content ) = @_ ;
742 $elt -> parent -> splice_content ( $elt -> pindex + 1 , 1 , $content );
746 sub HTML
:: TreeBuilder
:: parse_string
{
747 my ( $package , $string ) = @_ ;
749 my $h = HTML
:: TreeBuilder
-> new ;
750 HTML
:: TreeBuilder
-> parse ( $string );
758 # Below is stub documentation for your module. You'd better edit it!
762 HTML::Element::Library - HTML::Element convenience functions
766 use HTML::Element::Library;
767 use HTML::TreeBuilder;
771 This method provides API calls for common actions on trees when using
776 The test suite contains examples of each of these methods in a
779 =head2 Positional Querying Methods
781 =head3 $elem->siblings
783 Return a list of all nodes under the same parent.
787 Return the index of C<$elem> into the array of siblings of which it is
788 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
789 that is a descriptive name. And such naming is deceptively close to the
790 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
791 backwards compatibility, both methods are available.
797 =head3 $elem->position()
799 Returns the coordinates of this element in the tree it inhabits.
800 This is accomplished by succesively calling addr() on ancestor
801 elements until either a) an element that does not support these
802 methods is found, or b) there are no more parents. The resulting
803 list is the n-dimensional coordinates of the element in the tree.
805 =head2 Element Decoration Methods
807 =head3 HTML::Element::Library::super_literal($text)
809 In L<HTML::Element>, Sean Burke discusses super-literals. They are
810 text which does not get escaped. Great for includng Javascript in
811 HTML. Also great for including foreign language into a document.
813 So, you basically toss C<super_literal> your text and back comes
814 your text wrapped in a C<~literal> element.
816 One of these days, I'll around to writing a nice C<EXPORT> section.
818 =head2 Tree Rewriting Methods
820 =head3 Simplifying calls to HTML::FillInForm
822 Since HTML::FillInForm gets and returns strings, using HTML::Element instances
825 1. Seamstress has an HTML tree that it wants the form filled in on
826 2. Seamstress converts this tree to a string
827 3. FillInForm parses the string into an HTML tree and then fills in the form
828 4. FillInForm converts the HTML tree to a string
829 5. Seamstress re-parses the HTML for additional processing
831 I've filed a bug about this:
832 L<https://rt.cpan.org/Ticket/Display.html?id=44105>
834 This function, fillinform,
835 allows you to pass a tree to fillinform (along with your data structure) and
838 my $new_tree = $html_tree->fillinform($data_structure);
841 =head3 Mapping a hashref to HTML elements
843 It is very common to get a hashref of data from some external source - flat file, database, XML, etc.
844 Therefore, it is important to have a convenient way of mapping this data to HTML.
846 As it turns out, there are 3 ways to do this in HTML::Element::Library.
847 The most strict and structured way to do this is with
848 C<content_handler>. Two other methods, C<hashmap> and C<datamap> require less manual mapping and may prove
849 even more easy to use in certain cases.
851 As is usual with Perl, a practical example is always best. So let's take some sample HTML:
854 <span id="name">?</span>
855 <span id="email">?</span>
856 <span id="gender">?</span>
858 Now, let's say our data structure is this:
860 $ref = { email => 'jim@beam.com', gender => 'lots' } ;
862 And let's start with the most strict way to get what you want:
864 $tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ;
867 In this case, you manually state the mapping between id tags and hashref keys and
868 then C<content_handler> retrieves the hashref data and pops it in the specified place.
870 Now let's look at the two (actually 2 and a half) other hash-mapping methods.
872 $tree->hashmap(id => $ref);
874 Now, what this function does is super-destructive. It finds every element in the tree
875 with an attribute named id (since 'id' is a parameter, it could find every element with
876 some other attribute also) and replaces the content of those elements with the hashref
879 So, in the case above, the
881 <span id="name">?</span>
885 <span id="name"></span>
887 (it would be blank) - because there is nothing in the hash with that value, so it substituted
891 which was blank and emptied the contents.
893 Now, let's assume we want to protect name from being auto-assigned. Here is what you do:
895 $tree->hashmap(id => $ref, ['name']);
897 That last array ref is an exclusion list.
899 But wouldnt it be nice if you could do a hashmap, but only assigned things which are defined
900 in the hashref? C<< defmap() >> to the rescue:
902 $tree->defmap(id => $ref);
906 <span id="name">?</span>
911 =head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
913 This method is designed to take a hashref and populate a series of elements. For example:
917 <tr sclass="tr" class="alt" align="left" valign="top">
918 <td smap="people_id">1</td>
919 <td smap="phone">(877) 255-3239</td>
920 <td smap="password">*********</td>
924 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
926 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
928 Then a single API call allows us to populate the HTML while excluding those ones we dont:
930 $tree->hashmap(smap => \%data, ['password']);
933 Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
934 you plan to use for hash mapping.
936 Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
937 (which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
939 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
941 =head4 $elem->defmap($attr_name, \%hashref, $debug)
943 C<defmap> was described above.
946 =head4 $elem->content_handler(%hashref)
948 C<content_handler> is described below.
951 =head3 $elem->replace_content(@new_elem)
953 Replaces all of C<$elem>'s content with C<@new_elem>.
955 =head3 $elem->wrap_content($wrapper_element)
957 Wraps the existing content in the provided element. If the provided element
958 happens to be a non-element, a push_content is performed instead.
960 =head3 $elem->set_child_content(@look_down, $content)
962 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
964 After finding the node, it detaches the node's content and pushes $content as the node's content.
966 =head3 $tree->content_handler(%id_content)
968 This is a convenience method. Because the look_down criteria will often simply be:
974 <a id=fixme href=http://www.somesite.org>replace_content</a>
976 You can call this method to shorten your typing a bit. You can simply type
978 $elem->content_handler( fixme => 'new text' )
982 $elem->set_child_content(sid => 'fixme', 'new text')
984 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:
986 my %id_content = (name => "Terrence Brannon",
987 email => 'tbrannon@in.com',
989 content => $main_content);
991 $tree->content_handler(%id_content);
993 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
995 This allows for "if-then-else" style processing. Highlander was a movie in
996 which only one would survive. Well, in terms of a tree when looking at a
997 structure that you want to process in C<if-then-else> style, only one child
998 will survive. For example, given this HTML template:
1000 <span klass="highlander" id="age_dialog">
1002 Hello, does your mother know you're
1003 using her AOL account?
1006 Sorry, you're not old enough to enter
1007 (and too dumb to lie about your age)
1014 We only want one child of the C<span> tag with id C<age_dialog> to remain
1015 based on the age of the person visiting the page.
1017 So, let's setup a call that will prune the subtree as a function of age:
1021 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
1026 under10 => sub { $_[0] < 10} ,
1027 under18 => sub { $_[0] < 18} ,
1028 welcome => sub { 1 }
1033 And there we have it. If the age is less than 10, then the node with
1034 id C<under10> remains. For age less than 18, the node with id C<under18>
1036 Otherwise our "else" condition fires and the child with id C<welcome> remains.
1038 =head3 $tree->passover(@id_of_element)
1040 In some cases, you know exactly which element(s) should survive. In this case,
1041 you can simply call C<passover> to remove it's (their) siblings. For the HTML
1042 above, you could delete C<under10> and C<welcome> by simply calling:
1044 $tree->passover('under18');
1046 Because passover takes an array, you can specify several children to preserve.
1048 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
1050 Right around the same time that C<table2()> came into being, Seamstress
1051 began to tackle tougher and tougher processing problems. It became clear that
1052 a more powerful highlander was needed... one that not only snipped the tree
1053 of the nodes that should not survive, but one that allows for
1054 post-processing of the survivor node. And one that was more flexible with
1055 how to find the nodes to snip.
1057 Thus (drum roll) C<highlander2()>.
1059 So let's look at our HTML which requires post-selection processing:
1061 <span klass="highlander" id="age_dialog">
1063 Hello, little <span id=age>AGE</span>-year old,
1064 does your mother know you're using her AOL account?
1067 Sorry, you're only <span id=age>AGE</span>
1068 (and too dumb to lie about your age)
1071 Welcome, isn't it good to be <span id=age>AGE</span> years old?
1075 In this case, a branch survives, but it has dummy data in it. We must take
1076 the surviving segment of HTML and rewrite the age C<span> with the age.
1077 Here is how we use C<highlander2()> to do so:
1082 $branch->look_down(id => 'age')->replace_content($age);
1085 my $if_then = $tree->look_down(id => 'age_dialog');
1087 $if_then->highlander2(
1102 cond_arg => [ $age ]
1105 We pass it the tree (C<$if_then>), an arrayref of conditions
1106 (C<cond>) and an arrayref of arguments which are passed to the
1107 C<cond>s and to the replacement subs.
1109 The C<under10>, C<under18> and C<welcome> are id attributes in the
1110 tree of the siblings of which only one will survive. However,
1111 should you need to do
1112 more complex look-downs to find the survivor,
1113 then supply an array ref instead of a simple
1117 $if_then->highlander2(
1119 [class => 'r12'] => [
1123 [class => 'z22'] => [
1127 [class => 'w88'] => [
1132 cond_arg => [ $age ]
1136 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
1138 This method is designed for taking a tree and reworking a set of nodes in
1139 a stereotyped fashion. For instance let's say you have 3 remote image
1140 archives, but you don't want to put long URLs in your img src
1141 tags for reasons of abstraction, re-use and brevity. So instead you do this:
1143 <img src="/img/smiley-face.jpg" fixup="src lnc">
1144 <img src="/img/hot-babe.jpg" fixup="src playboy">
1145 <img src="/img/footer.jpg" fixup="src foobar">
1147 and then when the tree of HTML is being processed, you make this call:
1150 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
1151 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
1152 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
1155 $tree->overwrite_attr(fixup => \%closures) ;
1157 and the tags come out modified like so:
1159 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1160 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1161 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1163 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1165 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1166 assumes the return value of the
1167 closure is supposed overwrite an attribute value and does it for you.
1168 C<mute_elem> is a more general function which does nothing but
1169 hand the closure the element and let it mutate it as it jolly well pleases :)
1171 In fact, here is the implementation of C<overwrite_attr>
1172 to give you a taste of how C<mute_attr> is used:
1174 sub overwrite_action {
1175 my ($mute_node, %X) = @_;
1177 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1181 sub HTML::Element::overwrite_attr {
1184 $tree->mute_elem(@_, \&overwrite_action);
1190 =head2 Tree-Building Methods
1194 =head3 Unrolling an array via a single sample element (<ul> container)
1196 This is best described by example. Given this HTML:
1198 <strong>Here are the things I need from the store:</strong>
1200 <li class="store_items">Sample item</li>
1203 We can unroll it like so:
1205 my $li = $tree->look_down(class => 'store_items');
1207 my @items = qw(bread butter vodka);
1209 $tree->iter($li => @items);
1216 <body>Here are the things I need from the store:
1218 <li class="store_items">bread</li>
1219 <li class="store_items">butter</li>
1220 <li class="store_items">vodka</li>
1225 Now, you might be wondering why the API call is:
1227 $tree->iter($li => @items)
1233 and there is no good answer. The latter would be more concise and it is what I
1236 =head3 Unrolling an array via n sample elements (<dl> container)
1238 C<iter()> was fine for awhile, but some things
1239 (e.g. definition lists) need a more general function to make them easy to
1240 do. Hence C<iter2()>. This function will be explained by example of unrolling
1241 a simple definition list.
1243 So here's our mock-up HTML from the designer:
1245 <dl class="dual_iter" id="service_plan">
1250 A person who draws blood.
1257 A clone of Iggy Pop.
1264 A relative of Edgar Allan Poe.
1267 <dt class="adstyle">sample header</dt>
1268 <dd class="adstyle2">sample data</dd>
1273 And we want to unroll our data set:
1276 ['the pros' => 'never have to worry about service again'],
1277 ['the cons' => 'upfront extra charge on purchase'],
1278 ['our choice' => 'go with the extended service plan']
1282 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1283 Let's assume that we want only the last <dt> and it's accompanying <dd>
1284 (the one with "sample data") to be used as the sample data
1285 for unrolling with our data set. Let's further assume that we want them to
1286 remain in the final output.
1288 So now, the API to C<iter2()> will be discussed and we will explain how our
1289 goal of getting our data into HTML fits into the API.
1295 This is how to look down and find the container of all the elements we will
1296 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1299 If you pass an anonymous subroutine, then it is presumed that execution of
1300 this subroutine will return the HTML::Element representing the container tag.
1301 If you pass an array ref, then this will be dereferenced and passed to
1302 C<HTML::Element::look_down()>.
1304 default value: C<< ['_tag' => 'dl'] >>
1306 Based on the mock HTML above, this default is fine for finding our container
1307 tag. So let's move on.
1309 =item * wrapper_data
1311 This is an array reference of data that we will be putting into the container.
1312 You must supply this. C<@items> above is our C<wrapper_data>.
1314 =item * wrapper_proc
1316 After we find the container via C<wrapper_ld>, we may want to pre-process
1317 some aspect of this tree. In our case the first two sets of dt and dd need
1318 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1325 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1326 be cloned and populated with item data
1327 (item data is a "row" of C<wrapper_data>).
1329 default: returns an arrayref consisting of the dt and dd element inside the
1334 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1335 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1336 I hope that makes sense.
1338 default: shifts C<wrapper_data>.
1342 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1343 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1344 eventually be spliced into the container.
1346 Note that this subroutine MUST return the new items. This is done
1347 So that more items than were passed in can be returned. This is
1348 useful when, for example, you must return 2 dts for an input data item.
1349 And when would you do this? When a single term has multiple spellings
1352 default: expects C<item_data> to be an arrayref of two elements and
1353 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1354 content of the C<HTML::Element>s with the C<item_data>.
1358 After building up an array of C<@item_elems>, the subroutine passed as
1359 C<splice> will be given the parent container HTML::Element and the
1360 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1361 routine: it could put half of them in. It could unshift them or whatever.
1363 default: C<< $container->splice_content(0, 2, @item_elems) >>
1364 In other words, kill the 2 sample elements with the newly generated
1369 So now that we have documented the API, let's see the call we need:
1372 # default wrapper_ld ok.
1373 wrapper_data => \@items,
1374 wrapper_proc => sub {
1375 my ($container) = @_;
1377 # only keep the last 2 dts and dds
1378 my @content_list = $container->content_list;
1379 $container->splice_content(0, @content_list - 2);
1382 # default item_ld is fine.
1383 # default item_data is fine.
1384 # default item_proc is fine.
1386 my ($container, @item_elems) = @_;
1387 $container->unshift_content(@item_elems);
1395 =head3 Select Unrolling
1397 The C<unroll_select> method has this API:
1399 $tree->unroll_select(
1400 select_label => $id_label,
1401 option_value => $closure, # how to get option value from data row
1402 option_content => $closure, # how to get option content from data row
1403 option_selected => $closure, # boolean to decide if SELECTED
1404 data => $data # the data to be put into the SELECT
1405 data_iter => $closure # the thing that will get a row of data
1407 append => $boolean, # remove the sample <OPTION> data or append?
1412 $tree->unroll_select(
1413 select_label => 'clan_list',
1414 option_value => sub { my $row = shift; $row->clan_id },
1415 option_content => sub { my $row = shift; $row->clan_name },
1416 option_selected => sub { my $row = shift; $row->selected },
1417 data => \@query_results,
1418 data_iter => sub { my $data = shift; $data->next },
1425 =head2 Tree-Building Methods: Table Generation
1427 Matthew Sisk has a much more intuitive (imperative)
1428 way to generate tables via his module
1429 L<HTML::ElementTable|HTML::ElementTable>.
1430 However, for those with callback fever, the following
1431 method is available. First, we look at a nuts and bolts way to build a table
1432 using only standard L<HTML::Tree> API calls. Then the C<table> method
1433 available here is discussed.
1437 package Simple::Class;
1441 my @name = qw(bob bill brian babette bobo bix);
1442 my @age = qw(99 12 44 52 12 43);
1443 my @weight = qw(99 52 80 124 120 230);
1448 bless {}, ref($this) || $this;
1456 age => $age[rand $#age] + int rand 20,
1457 name => shift @name,
1458 weight => $weight[rand $#weight] + int rand 40
1462 Set::Array->new(@data);
1469 =head4 Sample Usage:
1471 my $data = Simple::Class->load_data;
1472 ++$_->{age} for @$data
1474 =head3 Inline Code to Unroll a Table
1480 <table id="load_data">
1482 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1486 <td id="name"> NATURE BOY RIC FLAIR </td>
1487 <td id="age"> 35 </td>
1488 <td id="weight"> 220 </td>
1497 =head4 The manual way (*NOT* recommended)
1499 require 'simple-class.pl';
1500 use HTML::Seamstress;
1503 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1506 my $o = Simple::Class->new;
1507 my $data = $o->load_data;
1509 # find the <table> and <tr>
1510 my $table_node = $seamstress->look_down('id', 'load_data');
1511 my $iter_node = $table_node->look_down('id', 'iterate');
1512 my $table_parent = $table_node->parent;
1515 # drop the sample <table> and <tr> from the HTML
1516 # only add them in if there is data in the model
1517 # this is achieved via the $add_table flag
1519 $table_node->detach;
1523 # Get a row of model data
1524 while (my $row = shift @$data) {
1526 # We got row data. Set the flag indicating ok to hook the table into the HTML
1529 # clone the sample <tr>
1530 my $new_iter_node = $iter_node->clone;
1532 # find the tags labeled name age and weight and
1533 # set their content to the row data
1534 $new_iter_node->content_handler($_ => $row->{$_})
1535 for qw(name age weight);
1537 $table_node->push_content($new_iter_node);
1541 # reattach the table to the HTML tree if we loaded data into some table rows
1543 $table_parent->push_content($table_node) if $add_table;
1545 print $seamstress->as_HTML;
1549 =head3 $tree->table() : API call to Unroll a Table
1551 require 'simple-class.pl';
1552 use HTML::Seamstress;
1555 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1557 my $o = Simple::Class->new;
1561 # tell seamstress where to find the table, via the method call
1562 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1563 # HTML tree automatically if no table rows can be built
1565 gi_table => 'load_data',
1567 # tell seamstress where to find the tr. This is a bit useless as
1568 # the <tr> usually can be found as the first child of the parent
1572 # the model data to be pushed into the table
1574 table_data => $o->load_data,
1576 # the way to take the model data and obtain one row
1577 # if the table data were a hashref, we would do:
1578 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1580 tr_data => sub { my ($self, $data) = @_;
1584 # the way to take a row of data and fill the <td> tags
1586 td_data => sub { my ($tr_node, $tr_data) = @_;
1587 $tr_node->content_handler($_ => $tr_data->{$_})
1588 for qw(name age weight) }
1593 print $seamstress->as_HTML;
1597 =head4 Looping over Multiple Sample Rows
1603 <table id="load_data" CELLPADDING=8 BORDER=2>
1605 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1607 <tr id="iterate1" BGCOLOR="white" >
1609 <td id="name"> NATURE BOY RIC FLAIR </td>
1610 <td id="age"> 35 </td>
1611 <td id="weight"> 220 </td>
1614 <tr id="iterate2" BGCOLOR="#CCCC99">
1616 <td id="name"> NATURE BOY RIC FLAIR </td>
1617 <td id="age"> 35 </td>
1618 <td id="weight"> 220 </td>
1627 * Only one change to last API call.
1635 gi_tr => ['iterate1', 'iterate2']
1637 =head3 $tree->table2() : New API Call to Unroll a Table
1639 After 2 or 3 years with C<table()>, I began to develop
1640 production websites with it and decided it needed a cleaner
1641 interface, particularly in the area of handling the fact that
1642 C<id> tags will be the same after cloning a table row.
1644 First, I will give a dry listing of the function's argument parameters.
1645 This will not be educational most likely. A better way to understand how
1646 to use the function is to read through the incremental unrolling of the
1647 function's interface given in conversational style after the dry listing.
1648 But take your pick. It's the same information given in two different
1651 =head4 Dry/technical parameter documentation
1653 C<< $tree->table2(%param) >> takes the following arguments:
1657 =item * C<< table_ld => $look_down >> : optional
1659 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1660 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1661 passing it C<$tree>.
1663 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1665 =item * C<< table_data => $tabular_data >> : required
1667 The data to fill the table with. I<Must> be passed in.
1669 =item * C<< table_proc => $code_ref >> : not implemented
1671 A subroutine to do something to the table once it is found.
1672 Not currently implemented. Not obviously necessary. Just
1673 created because there is a C<tr_proc> and C<td_proc>.
1675 =item * C<< tr_ld => $look_down >> : optional
1677 Same as C<table_ld> but for finding the table row elements. Please note
1678 that the C<tr_ld> is done on the table node that was found I<instead>
1679 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1680 below the table that was just found.
1682 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1684 =item * C<< tr_data => $code_ref >> : optional
1686 How to take the C<table_data> and return a row. Defaults to:
1688 sub { my ($self, $data) = @_;
1692 =item * C<< tr_proc => $code_ref >> : optional
1694 Something to do to the table row we are about to add to the
1695 table we are making. Defaults to a routine which makes the C<id>
1699 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1700 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1703 =item * C<< td_proc => $code_ref >> : required
1705 This coderef will take the row of data and operate on the C<td> cells that
1706 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1708 Here's a sample one:
1711 my ($tr, $data) = @_;
1712 my @td = $tr->look_down('_tag' => 'td');
1713 for my $i (0..$#td) {
1714 $td[$i]->splice_content(0, 1, $data->[$i]);
1720 =head4 Conversational parameter documentation
1722 The first thing you need is a table. So we need a look down for that. If you
1723 don't give one, it defaults to
1727 What good is a table to display in without data to display?!
1728 So you must supply a scalar representing your tabular
1729 data source. This scalar might be an array reference, a C<next>able iterator,
1730 a DBI statement handle. Whatever it is, it can be iterated through to build
1731 up rows of table data.
1732 These two required fields (the way to find the table and the data to
1733 display in the table) are C<table_ld> and C<table_data>
1734 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1736 of the code ref is presumed to return the C<HTML::Element>
1737 representing the table in the HTML tree.
1739 Next, we get the row or rows which serve as sample C<tr> elements by doing
1740 a C<look_down> from the C<table_elem>. While normally one sample row
1741 is enough to unroll a table, consider when you have alternating
1742 table rows. This API call would need one of each row so that it can
1744 sample rows as it loops through the data.
1745 Alternatively, you could always just use one row and
1746 make the necessary changes to the single C<tr> row by
1747 mutating the element in C<tr_proc>,
1748 discussed below. The default C<tr_ld> is
1749 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1750 it with a subroutine, then it is expected that the subroutine will return
1751 the C<HTML::Element>(s)
1752 which are C<tr> element(s).
1753 The reason a subroutine might be preferred is in the case
1754 that the HTML designers gave you 8 sample C<tr> rows but only one
1755 prototype row is needed.
1756 So you can write a subroutine, to splice out the 7 rows you don't need
1757 and leave the one sample
1758 row remaining so that this API call can clone it and supply it to
1759 the C<tr_proc> and C<td_proc> calls.
1761 Now, as we move through the table rows with table data,
1762 we need to do two different things on
1767 =item * get one row of data from the C<table_data> via C<tr_data>
1769 The default procedure assumes the C<table_data> is an array reference and
1770 shifts a row off of it:
1772 sub { my ($self, $data) = @_;
1776 Your function MUST return undef when there is no more rows to lay out.
1778 =item * take the C<tr> element and mutate it via C<tr_proc>
1780 The default procedure simply makes the id of the table row unique:
1782 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1783 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1788 Now that we have our row of data, we call C<td_proc> so that it can
1789 take the data and the C<td> cells in this C<tr> and process them.
1790 This function I<must> be supplied.
1793 =head3 Whither a Table with No Rows
1795 Often when a table has no rows, we want to display a message
1796 indicating this to the view. Use conditional processing to decide what
1800 <table><tr><td>No Data is Good Data</td></tr></table>
1805 <table id="load_data">
1807 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1811 <td id="name"> NATURE BOY RIC FLAIR </td>
1812 <td id="age"> 35 </td>
1813 <td id="weight"> 220 </td>
1830 =item * L<HTML::Tree>
1832 A perl package for creating and manipulating HTML trees
1834 =item * L<HTML::ElementTable>
1836 An L<HTML::Tree> - based module which allows for manipulation of HTML
1837 trees using cartesian coordinations.
1839 =item * L<HTML::Seamstress>
1841 An L<HTML::Tree> - based module inspired by
1842 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1843 HTML generation via tree rewriting.
1851 currently the API expects the subtrees to survive or be pruned to be
1854 $if_then->highlander2([
1855 under10 => sub { $_[0] < 10} ,
1856 under18 => sub { $_[0] < 18} ,
1861 $branch->look_down(id => 'age')->replace_content($age);
1868 but, it should be more flexible. the C<under10>, and C<under18> are
1869 expected to be ids in the tree... but it is not hard to have a check to
1870 see if this field is an array reference and if it, then to do a look
1873 $if_then->highlander2([
1874 [class => 'under10'] => sub { $_[0] < 10} ,
1875 [class => 'under18'] => sub { $_[0] < 18} ,
1876 [class => 'welcome'] => [
1880 $branch->look_down(id => 'age')->replace_content($age);
1895 =head1 AUTHOR / SOURCE
1897 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1899 Many thanks to BARBIE for his RT bug report.
1901 The source is at L<http://github.com/metaperl/html-element-library/tree/master>
1903 =head1 COPYRIGHT AND LICENSE
1905 Copyright (C) 2004 by Terrence Brannon
1907 This library is free software; you can redistribute it and/or modify
1908 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1909 at your option, any later version of Perl 5 you may have available.
This page took 0.175836 seconds and 5 git commands to generate.