fillinform tests
[html-element-library.git] / lib / HTML / Element / Library.pm
1 package HTML::Element::Library;
2
3 use 5.006001;
4 use strict;
5 use warnings;
6
7
8 our $DEBUG = 0;
9 #our $DEBUG = 1;
10
11 use Array::Group qw(:all);
12 use Carp qw(confess);
13 use Data::Dumper;
14 use HTML::Element;
15 use List::Util qw(first);
16 use List::MoreUtils qw/:all/;
17 use Params::Validate qw(:all);
18 use Scalar::Listify;
19 #use Tie::Cycle;
20 use List::Rotation::Cycle;
21
22 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
23 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
24 our @EXPORT = qw();
25
26
27
28 our $VERSION = '3.53';
29
30
31
32 # Preloaded methods go here.
33
34 # https://rt.cpan.org/Ticket/Display.html?id=44105
35 sub HTML::Element::fillinform {
36
37 my ($tree, $hashref)=@_;
38
39 (ref $hashref) eq 'HASH' or die 'hashref not supplied as argument' ;
40
41 use HTML::FillInForm;
42 my $html = $tree->as_HTML;
43 my $new_html = HTML::FillInForm->fill(\$html, $hashref);
44
45 }
46
47 sub HTML::Element::siblings {
48 my $element = shift;
49 my $p = $element->parent;
50 return () unless $p;
51 $p->content_list;
52 }
53
54 sub HTML::Element::defmap {
55 my($tree,$attr,$hashref,$debug)=@_;
56
57 while (my ($k, $v) = (each %$hashref)) {
58 warn "defmap looks for ($attr => $k)" if $debug;
59 my $found = $tree->look_down($attr => $k);
60 if ($found) {
61 warn "($attr => $k) was found.. replacing with '$v'" if $debug;
62 $found->replace_content( $v );
63 }
64 }
65
66 }
67
68
69 sub HTML::Element::hash_map {
70 my $container = shift;
71
72 my %p = validate(@_, {
73 hash => { type => HASHREF },
74 to_attr => 1,
75 excluding => { type => ARRAYREF , default => [] },
76 debug => { default => 0 },
77 });
78
79 warn 'The container tag is ', $container->tag if $p{debug} ;
80 warn 'hash' . Dumper($p{hash}) if $p{debug} ;
81 warn 'at_under' . Dumper(\@_) if $p{debug} ;
82
83 my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ;
84
85 warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ;
86
87
88 for my $same_as (@same_as) {
89 my $attr_val = $same_as->attr($p{to_attr}) ;
90 if (first { $attr_val eq $_ } @{$p{excluding}}) {
91 warn "excluding $attr_val" if $p{debug} ;
92 next;
93 }
94 warn "processing $attr_val" if $p{debug} ;
95 $same_as->replace_content( $p{hash}->{$attr_val} ) ;
96 }
97
98 }
99
100 sub HTML::Element::hashmap {
101 my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
102
103 $excluding ||= [] ;
104
105 $container->hash_map(hash => $hashref,
106 to_attr => $attr_name,
107 excluding => $excluding,
108 debug => $debug);
109
110 }
111
112
113 sub HTML::Element::passover {
114 my ($tree, @to_preserve) = @_;
115
116 warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
117 warn $tree->as_HTML(undef, ' ') if $DEBUG;
118
119 my $exodus = $tree->look_down(id => $to_preserve[0]);
120
121 warn "E: $exodus" if $DEBUG;
122
123 my @s = HTML::Element::siblings($exodus);
124
125 for my $s (@s) {
126 next unless ref $s;
127 if (first { $s->attr('id') eq $_ } @to_preserve) {
128 ;
129 } else {
130 $s->delete;
131 }
132 }
133
134 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
135
136 }
137
138 sub HTML::Element::sibdex {
139
140 my $element = shift;
141 firstidx { $_ eq $element } $element->siblings
142
143 }
144
145 sub HTML::Element::addr { goto &HTML::Element::sibdex }
146
147 sub HTML::Element::replace_content {
148 my $elem = shift;
149 $elem->delete_content;
150 $elem->push_content(@_);
151 }
152
153 sub HTML::Element::wrap_content {
154 my($self, $wrap) = @_;
155 my $content = $self->content;
156 if (ref $content) {
157 $wrap->push_content(@$content);
158 @$content = ($wrap);
159 }
160 else {
161 $self->push_content($wrap);
162 }
163 $wrap;
164 }
165
166 sub HTML::Element::Library::super_literal {
167 my($text) = @_;
168
169 HTML::Element->new('~literal', text => $text);
170 }
171
172
173 sub HTML::Element::position {
174 # Report coordinates by chasing addr's up the
175 # HTML::ElementSuper tree. We know we've reached
176 # the top when a) there is no parent, or b) the
177 # parent is some HTML::Element unable to report
178 # it's position.
179 my $p = shift;
180 my @pos;
181 while ($p) {
182 my $a = $p->addr;
183 unshift(@pos, $a) if defined $a;
184 $p = $p->parent;
185 }
186 @pos;
187 }
188
189
190 sub HTML::Element::content_handler {
191 my ($tree, %content_hash) = @_;
192
193 for my $k (keys %content_hash) {
194 $tree->set_child_content(id => $k, $content_hash{$k});
195 }
196
197
198 }
199
200
201 sub make_counter {
202 my $i = 1;
203 sub {
204 shift() . ':' . $i++
205 }
206 }
207
208
209 sub HTML::Element::iter {
210 my ($tree, $p, @data) = @_;
211
212 # warn 'P: ' , $p->attr('id') ;
213 # warn 'H: ' , $p->as_HTML;
214
215 # my $id_incr = make_counter;
216 my @item = map {
217 my $new_item = clone $p;
218 $new_item->replace_content($_);
219 $new_item;
220 } @data;
221
222 $p->replace_with(@item);
223
224 }
225
226
227 sub HTML::Element::iter2 {
228
229 my $tree = shift;
230
231 #warn "INPUT TO TABLE2: ", Dumper \@_;
232
233 my %p = validate(
234 @_, {
235 wrapper_ld => { default => ['_tag' => 'dl'] },
236 wrapper_data => 1,
237 wrapper_proc => { default => undef },
238 item_ld => { default => sub {
239 my $tree = shift;
240 [
241 $tree->look_down('_tag' => 'dt'),
242 $tree->look_down('_tag' => 'dd')
243 ];
244 }
245 },
246 item_data => { default => sub { my ($wrapper_data) = @_;
247 shift(@{$wrapper_data}) ;
248 }},
249 item_proc => {
250 default => sub {
251 my ($item_elems, $item_data, $row_count) = @_;
252 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
253 $item_elems;
254 }},
255 splice => { default => sub {
256 my ($container, @item_elems) = @_;
257 $container->splice_content(0, 2, @item_elems);
258 }
259 },
260 debug => {default => 0}
261 }
262 );
263
264 warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ;
265
266 my $container = ref_or_ld($tree, $p{wrapper_ld});
267 warn "container: " . $container if $p{debug} ;
268 warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ;
269 $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ;
270 warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ;
271
272 my $_item_elems = $p{item_ld}->($container);
273
274
275
276 my $row_count;
277 my @item_elem;
278 {
279 my $item_data = $p{item_data}->($p{wrapper_data});
280 last unless defined $item_data;
281
282 warn Dumper("item_data", $item_data);
283
284
285 my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
286
287 if ($p{debug}) {
288 for (@{$item_elems}) {
289 warn "ITEM_ELEMS ", $_->as_HTML;
290 }
291 }
292
293 my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);
294
295 if ($p{debug}) {
296 for (@{$new_item_elems}) {
297 warn "NEWITEM_ELEMS ", $_->as_HTML;
298 }
299 }
300
301
302 push @item_elem, @{$new_item_elems} ;
303
304 redo;
305 }
306
307 warn "pushing " . @item_elem . " elems " if $p{debug} ;
308
309 $p{splice}->($container, @item_elem);
310
311 }
312
313 sub HTML::Element::dual_iter {
314 my ($parent, $data) = @_;
315
316 my ($prototype_a, $prototype_b) = $parent->content_list;
317
318 # my $id_incr = make_counter;
319
320 my $i;
321
322 @$data %2 == 0 or
323 confess 'dataset does not contain an even number of members';
324
325 my @iterable_data = ngroup 2 => @$data;
326
327 my @item = map {
328 my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ;
329 $new_a->splice_content(0,1, $_->[0]);
330 $new_b->splice_content(0,1, $_->[1]);
331 #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
332 ($new_a, $new_b)
333 } @iterable_data;
334
335 $parent->splice_content(0, 2, @item);
336
337 }
338
339
340 sub HTML::Element::set_child_content {
341 my $tree = shift;
342 my $content = pop;
343 my @look_down = @_;
344
345 my $content_tag = $tree->look_down(@look_down);
346
347 unless ($content_tag) {
348 warn "criteria [@look_down] not found";
349 return;
350 }
351
352 $content_tag->replace_content($content);
353
354 }
355
356 sub HTML::Element::highlander {
357 my ($tree, $local_root_id, $aref, @arg) = @_;
358
359 ref $aref eq 'ARRAY' or confess
360 "must supply array reference";
361
362 my @aref = @$aref;
363 @aref % 2 == 0 or confess
364 "supplied array ref must have an even number of entries";
365
366 warn __PACKAGE__ if $DEBUG;
367
368 my $survivor;
369 while (my ($id, $test) = splice @aref, 0, 2) {
370 warn $id if $DEBUG;
371 if ($test->(@arg)) {
372 $survivor = $id;
373 last;
374 }
375 }
376
377
378 my @id_survivor = (id => $survivor);
379 my $survivor_node = $tree->look_down(@id_survivor);
380 # warn $survivor;
381 # warn $local_root_id;
382 # warn $node;
383
384 warn "survivor: $survivor" if $DEBUG;
385 warn "tree: " . $tree->as_HTML if $DEBUG;
386
387 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
388
389 my $survivor_node_parent = $survivor_node->parent;
390 $survivor_node = $survivor_node->clone;
391 $survivor_node_parent->replace_content($survivor_node);
392
393 warn "new tree: " . $tree->as_HTML if $DEBUG;
394
395 $survivor_node;
396 }
397
398
399 sub HTML::Element::highlander2 {
400 my $tree = shift;
401
402 my %p = validate(@_, {
403 cond => { type => ARRAYREF },
404 cond_arg => { type => ARRAYREF,
405 default => []
406 },
407 debug => { default => 0 }
408 }
409 );
410
411
412 my @cond = @{$p{cond}};
413 @cond % 2 == 0 or confess
414 "supplied array ref must have an even number of entries";
415
416 warn __PACKAGE__ if $p{debug};
417
418 my @cond_arg = @{$p{cond_arg}};
419
420 my $survivor; my $then;
421 while (my ($id, $if_then) = splice @cond, 0, 2) {
422
423 warn $id if $p{debug};
424 my ($if, $_then);
425
426 if (ref $if_then eq 'ARRAY') {
427 ($if, $_then) = @$if_then;
428 } else {
429 ($if, $_then) = ($if_then, sub {});
430 }
431
432 if ($if->(@cond_arg)) {
433 $survivor = $id;
434 $then = $_then;
435 last;
436 }
437
438 }
439
440 my @ld = (ref $survivor eq 'ARRAY')
441 ? @$survivor
442 : (id => $survivor)
443 ;
444
445 warn "survivor: ", $survivor if $p{debug};
446 warn "survivor_ld: ", Dumper \@ld if $p{debug};
447
448
449 my $survivor_node = $tree->look_down(@ld);
450
451 $survivor_node or confess
452 "search for @ld failed in tree($tree): " . $tree->as_HTML;
453
454 my $survivor_node_parent = $survivor_node->parent;
455 $survivor_node = $survivor_node->clone;
456 $survivor_node_parent->replace_content($survivor_node);
457
458
459 # **************** NEW FUNCTIONALITY *******************
460
461 # apply transforms on survivor node
462
463
464 warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug};
465 $then->($survivor_node, @cond_arg);
466 warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug};
467
468 # **************** NEW FUNCTIONALITY *******************
469
470
471
472
473 $survivor_node;
474 }
475
476
477 sub overwrite_action {
478 my ($mute_node, %X) = @_;
479
480 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
481 }
482
483
484 sub HTML::Element::overwrite_attr {
485 my $tree = shift;
486
487 $tree->mute_elem(@_, \&overwrite_action);
488 }
489
490
491
492 sub HTML::Element::mute_elem {
493 my ($tree, $mute_attr, $closures, $post_hook) = @_;
494
495 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
496 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
497
498 for my $mute_node (@mute_node) {
499 my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr);
500 my $local_attr_value_current = $mute_node->attr($local_attr);
501 my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
502 $post_hook->(
503 $mute_node,
504 tree => $tree,
505 local_attr => {
506 name => $local_attr,
507 value => {
508 current => $local_attr_value_current,
509 new => $local_attr_value_new
510 }
511 }
512 ) if ($post_hook) ;
513 }
514 }
515
516
517
518 sub HTML::Element::table {
519
520 my ($s, %table) = @_;
521
522 my $table = {};
523
524 # use Data::Dumper; warn Dumper \%table;
525
526 # ++$DEBUG if $table{debug} ;
527
528
529 # Get the table element
530 $table->{table_node} = $s->look_down(id => $table{gi_table});
531 $table->{table_node} or confess
532 "table tag not found via (id => $table{gi_table}";
533
534 # Get the prototype tr element(s)
535 my @table_gi_tr = listify $table{gi_tr} ;
536 my @iter_node = map
537 {
538 my $tr = $table->{table_node}->look_down(id => $_);
539 $tr or confess "tr with id => $_ not found";
540 $tr;
541 } @table_gi_tr;
542
543 warn "found " . @iter_node . " iter nodes " if $DEBUG;
544 # tie my $iter_node, 'Tie::Cycle', \@iter_node;
545 my $iter_node = List::Rotation::Cycle->new(@iter_node);
546
547 # warn $iter_node;
548 warn Dumper ($iter_node, \@iter_node) if $DEBUG;
549
550 # $table->{content} = $table{content};
551 #$table->{parent} = $table->{table_node}->parent;
552
553
554 # $table->{table_node}->detach;
555 # $_->detach for @iter_node;
556
557 my @table_rows;
558
559 {
560 my $row = $table{tr_data}->($table, $table{table_data});
561 last unless defined $row;
562
563 # get a sample table row and clone it.
564 my $I = $iter_node->next;
565 warn "I: $I" if $DEBUG;
566 my $new_iter_node = $I->clone;
567
568
569 $table{td_data}->($new_iter_node, $row);
570 push @table_rows, $new_iter_node;
571
572 redo;
573 }
574
575 if (@table_rows) {
576
577 my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ;
578 for (@table_gi_tr) {
579 $s->look_down(id => $_)->detach;
580 }
581
582 $replace_with_elem->replace_with(@table_rows);
583
584 }
585
586 }
587
588 sub ref_or_ld {
589
590 my ($tree, $slot) = @_;
591
592 if (ref($slot) eq 'CODE') {
593 $slot->($tree);
594 } else {
595 $tree->look_down(@$slot);
596 }
597 }
598
599
600
601 sub HTML::Element::table2 {
602
603 my $tree = shift;
604
605
606
607 my %p = validate(
608 @_, {
609 table_ld => { default => ['_tag' => 'table'] },
610 table_data => 1,
611 table_proc => { default => undef },
612
613 tr_ld => { default => ['_tag' => 'tr'] },
614 tr_data => { default => sub { my ($self, $data) = @_;
615 shift(@{$data}) ;
616 }},
617 tr_base_id => { default => undef },
618 tr_proc => { default => sub {} },
619 td_proc => 1,
620 debug => {default => 0}
621 }
622 );
623
624 warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug};
625
626 warn "table_data: " . Dumper $p{table_data} if $p{debug} ;
627
628 my $table = {};
629
630 # use Data::Dumper; warn Dumper \%table;
631
632 # ++$DEBUG if $table{debug} ;
633
634 # Get the table element
635 #warn 1;
636 $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ;
637 #warn 2;
638 $table->{table_node} or confess
639 "table tag not found via " . Dumper($p{table_ld}) ;
640
641 warn "table: " . $table->{table_node}->as_HTML if $p{debug};
642
643
644 # Get the prototype tr element(s)
645 my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ;
646
647 warn "found " . @proto_tr . " iter nodes " if $p{debug};
648
649 @proto_tr or return ;
650
651 if ($p{debug}) {
652 warn $_->as_HTML for @proto_tr;
653 }
654 my $proto_tr = List::Rotation::Cycle->new(@proto_tr);
655
656 my $tr_parent = $proto_tr[0]->parent;
657 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug};
658
659 my $row_count;
660
661 my @table_rows;
662
663 {
664 my $row = $p{tr_data}->($table, $p{table_data}, $row_count);
665 warn "data row: " . Dumper $row if $p{debug};
666 last unless defined $row;
667
668 # wont work: my $new_iter_node = $table->{iter_node}->clone;
669 my $new_tr_node = $proto_tr->next->clone;
670 warn "new_tr_node: $new_tr_node" if $p{debug};
671
672 $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count)
673 if defined $p{tr_proc};
674
675 warn "data row redux: " . Dumper $row if $p{debug};
676 #warn 3.3;
677
678 $p{td_proc}->($new_tr_node, $row);
679 push @table_rows, $new_tr_node;
680
681 #warn 4.4;
682
683 redo;
684 }
685
686 $_->detach for @proto_tr;
687
688 $tr_parent->push_content(@table_rows) if (@table_rows) ;
689
690 }
691
692
693 sub HTML::Element::unroll_select {
694
695 my ($s, %select) = @_;
696
697 my $select = {};
698
699 warn "Select Hash: " . Dumper(\%select) if $select{debug};
700
701 my $select_node = $s->look_down(id => $select{select_label});
702 warn "Select Node: " . $select_node if $select{debug};
703
704 unless ($select{append}) {
705 for my $option ($select_node->look_down('_tag' => 'option')) {
706 $option->delete;
707 }
708 }
709
710
711 my $option = HTML::Element->new('option');
712 warn "Option Node: " . $option if $select{debug};
713
714 $option->detach;
715
716 while (my $row = $select{data_iter}->($select{data}))
717 {
718 warn "Data Row:" . Dumper($row) if $select{debug};
719 my $o = $option->clone;
720 $o->attr('value', $select{option_value}->($row));
721 $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)) ;
722
723 $o->replace_content($select{option_content}->($row));
724 $select_node->push_content($o);
725 warn $o->as_HTML if $select{debug};
726 }
727
728
729 }
730
731
732
733 sub HTML::Element::set_sibling_content {
734 my ($elt, $content) = @_;
735
736 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
737
738 }
739
740 sub HTML::TreeBuilder::parse_string {
741 my ($package, $string) = @_;
742
743 my $h = HTML::TreeBuilder->new;
744 HTML::TreeBuilder->parse($string);
745
746 }
747
748
749
750 1;
751 __END__
752 # Below is stub documentation for your module. You'd better edit it!
753
754 =head1 NAME
755
756 HTML::Element::Library - HTML::Element convenience functions
757
758 =head1 SYNOPSIS
759
760 use HTML::Element::Library;
761 use HTML::TreeBuilder;
762
763 =head1 DESCRIPTION
764
765 This method provides API calls for common actions on trees when using
766 L<HTML::Tree>.
767
768 =head1 METHODS
769
770 The test suite contains examples of each of these methods in a
771 file C<t/$method.t>
772
773 =head2 Positional Querying Methods
774
775 =head3 $elem->siblings
776
777 Return a list of all nodes under the same parent.
778
779 =head3 $elem->sibdex
780
781 Return the index of C<$elem> into the array of siblings of which it is
782 a part. L<HTML::ElementSuper> calls this method C<addr> but I don't think
783 that is a descriptive name. And such naming is deceptively close to the
784 C<address> function of C<HTML::Element>. HOWEVER, in the interest of
785 backwards compatibility, both methods are available.
786
787 =head3 $elem->addr
788
789 Same as sibdex
790
791 =head3 $elem->position()
792
793 Returns the coordinates of this element in the tree it inhabits.
794 This is accomplished by succesively calling addr() on ancestor
795 elements until either a) an element that does not support these
796 methods is found, or b) there are no more parents. The resulting
797 list is the n-dimensional coordinates of the element in the tree.
798
799 =head2 Element Decoration Methods
800
801 =head3 HTML::Element::Library::super_literal($text)
802
803 In L<HTML::Element>, Sean Burke discusses super-literals. They are
804 text which does not get escaped. Great for includng Javascript in
805 HTML. Also great for including foreign language into a document.
806
807 So, you basically toss C<super_literal> your text and back comes
808 your text wrapped in a C<~literal> element.
809
810 One of these days, I'll around to writing a nice C<EXPORT> section.
811
812 =head2 Tree Rewriting Methods
813
814 =head3 Simplifying calls to HTML::FillInForm
815
816 Since HTML::FillInForm gets and returns strings, using HTML::Element instances
817 becomes tedious:
818
819 1. Seamstress has an HTML tree that it wants the form filled in on
820 2. Seamstress converts this tree to a string
821 3. FillInForm parses the string into an HTML tree and then fills in the form
822 4. FillInForm converts the HTML tree to a string
823 5. Seamstress re-parses the HTML for additional processing
824
825 I've filed a bug about this:
826 L<https://rt.cpan.org/Ticket/Display.html?id=44105>
827
828 This function, fillinform,
829 allows you to pass a tree to fillinform (along with your data structure) and
830 get back a tree:
831
832 my $new_tree = $html_tree->fillinform($data_structure);
833
834
835 =head3 Mapping a hashref to HTML elements
836
837 It is very common to get a hashref of data from some external source - flat file, database, XML, etc.
838 Therefore, it is important to have a convenient way of mapping this data to HTML.
839
840 As it turns out, there are 3 ways to do this in HTML::Element::Library.
841 The most strict and structured way to do this is with
842 C<content_handler>. Two other methods, C<hashmap> and C<datamap> require less manual mapping and may prove
843 even more easy to use in certain cases.
844
845 As is usual with Perl, a practical example is always best. So let's take some sample HTML:
846
847 <h1>user data</h1>
848 <span id="name">?</span>
849 <span id="email">?</span>
850 <span id="gender">?</span>
851
852 Now, let's say our data structure is this:
853
854 $ref = { email => 'jim@beam.com', gender => 'lots' } ;
855
856 And let's start with the most strict way to get what you want:
857
858 $tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ;
859
860
861 In this case, you manually state the mapping between id tags and hashref keys and
862 then C<content_handler> retrieves the hashref data and pops it in the specified place.
863
864 Now let's look at the two (actually 2 and a half) other hash-mapping methods.
865
866 $tree->hashmap(id => $ref);
867
868 Now, what this function does is super-destructive. It finds every element in the tree
869 with an attribute named id (since 'id' is a parameter, it could find every element with
870 some other attribute also) and replaces the content of those elements with the hashref
871 value.
872
873 So, in the case above, the
874
875 <span id="name">?</span>
876
877 would come out as
878
879 <span id="name"></span>
880
881 (it would be blank) - because there is nothing in the hash with that value, so it substituted
882
883 $ref->{name}
884
885 which was blank and emptied the contents.
886
887 Now, let's assume we want to protect name from being auto-assigned. Here is what you do:
888
889 $tree->hashmap(id => $ref, ['name']);
890
891 That last array ref is an exclusion list.
892
893 But wouldnt it be nice if you could do a hashmap, but only assigned things which are defined
894 in the hashref? C<< defmap() >> to the rescue:
895
896 $tree->defmap(id => $ref);
897
898 does just that, so
899
900 <span id="name">?</span>
901
902 would be left alone.
903
904
905 =head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
906
907 This method is designed to take a hashref and populate a series of elements. For example:
908
909
910 <table>
911 <tr sclass="tr" class="alt" align="left" valign="top">
912 <td smap="people_id">1</td>
913 <td smap="phone">(877) 255-3239</td>
914 <td smap="password">*********</td>
915 </tr>
916 </table>
917
918 In the table above, there are several attributes named C<< smap >>. If we have a hashref whose keys are the same:
919
920 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
921
922 Then a single API call allows us to populate the HTML while excluding those ones we dont:
923
924 $tree->hashmap(smap => \%data, ['password']);
925
926
927 Note: the other way to prevent rendering some of the hash mapping is to not give that element the attr
928 you plan to use for hash mapping.
929
930 Also note: the function C<< hashmap >> has a simple easy-to-type API. Interally, it calls C<< hash_map >>
931 (which has a more verbose keyword calling API). Thus, the above call to C<hashmap()> results in this call:
932
933 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
934
935 =head4 $elem->defmap($attr_name, \%hashref, $debug)
936
937 C<defmap> was described above.
938
939
940 =head4 $elem->content_handler(%hashref)
941
942 C<content_handler> is described below.
943
944
945 =head3 $elem->replace_content(@new_elem)
946
947 Replaces all of C<$elem>'s content with C<@new_elem>.
948
949 =head3 $elem->wrap_content($wrapper_element)
950
951 Wraps the existing content in the provided element. If the provided element
952 happens to be a non-element, a push_content is performed instead.
953
954 =head3 $elem->set_child_content(@look_down, $content)
955
956 This method looks down $tree using the criteria specified in @look_down using the the HTML::Element look_down() method.
957
958 After finding the node, it detaches the node's content and pushes $content as the node's content.
959
960 =head3 $tree->content_handler(%id_content)
961
962 This is a convenience method. Because the look_down criteria will often simply be:
963
964 id => 'fixme'
965
966 to find things like:
967
968 <a id=fixme href=http://www.somesite.org>replace_content</a>
969
970 You can call this method to shorten your typing a bit. You can simply type
971
972 $elem->content_handler( fixme => 'new text' )
973
974 Instead of typing:
975
976 $elem->set_child_content(sid => 'fixme', 'new text')
977
978 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:
979
980 my %id_content = (name => "Terrence Brannon",
981 email => 'tbrannon@in.com',
982 balance => 666,
983 content => $main_content);
984
985 $tree->content_handler(%id_content);
986
987 =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args)
988
989 This allows for "if-then-else" style processing. Highlander was a movie in
990 which only one would survive. Well, in terms of a tree when looking at a
991 structure that you want to process in C<if-then-else> style, only one child
992 will survive. For example, given this HTML template:
993
994 <span klass="highlander" id="age_dialog">
995 <span id="under10">
996 Hello, does your mother know you're
997 using her AOL account?
998 </span>
999 <span id="under18">
1000 Sorry, you're not old enough to enter
1001 (and too dumb to lie about your age)
1002 </span>
1003 <span id="welcome">
1004 Welcome
1005 </span>
1006 </span>
1007
1008 We only want one child of the C<span> tag with id C<age_dialog> to remain
1009 based on the age of the person visiting the page.
1010
1011 So, let's setup a call that will prune the subtree as a function of age:
1012
1013 sub process_page {
1014 my $age = shift;
1015 my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html');
1016
1017 $tree->highlander
1018 (age_dialog =>
1019 [
1020 under10 => sub { $_[0] < 10} ,
1021 under18 => sub { $_[0] < 18} ,
1022 welcome => sub { 1 }
1023 ],
1024 $age
1025 );
1026
1027 And there we have it. If the age is less than 10, then the node with
1028 id C<under10> remains. For age less than 18, the node with id C<under18>
1029 remains.
1030 Otherwise our "else" condition fires and the child with id C<welcome> remains.
1031
1032 =head3 $tree->passover(@id_of_element)
1033
1034 In some cases, you know exactly which element(s) should survive. In this case,
1035 you can simply call C<passover> to remove it's (their) siblings. For the HTML
1036 above, you could delete C<under10> and C<welcome> by simply calling:
1037
1038 $tree->passover('under18');
1039
1040 Because passover takes an array, you can specify several children to preserve.
1041
1042 =head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
1043
1044 Right around the same time that C<table2()> came into being, Seamstress
1045 began to tackle tougher and tougher processing problems. It became clear that
1046 a more powerful highlander was needed... one that not only snipped the tree
1047 of the nodes that should not survive, but one that allows for
1048 post-processing of the survivor node. And one that was more flexible with
1049 how to find the nodes to snip.
1050
1051 Thus (drum roll) C<highlander2()>.
1052
1053 So let's look at our HTML which requires post-selection processing:
1054
1055 <span klass="highlander" id="age_dialog">
1056 <span id="under10">
1057 Hello, little <span id=age>AGE</span>-year old,
1058 does your mother know you're using her AOL account?
1059 </span>
1060 <span id="under18">
1061 Sorry, you're only <span id=age>AGE</span>
1062 (and too dumb to lie about your age)
1063 </span>
1064 <span id="welcome">
1065 Welcome, isn't it good to be <span id=age>AGE</span> years old?
1066 </span>
1067 </span>
1068
1069 In this case, a branch survives, but it has dummy data in it. We must take
1070 the surviving segment of HTML and rewrite the age C<span> with the age.
1071 Here is how we use C<highlander2()> to do so:
1072
1073 sub replace_age {
1074 my $branch = shift;
1075 my $age = shift;
1076 $branch->look_down(id => 'age')->replace_content($age);
1077 }
1078
1079 my $if_then = $tree->look_down(id => 'age_dialog');
1080
1081 $if_then->highlander2(
1082 cond => [
1083 under10 => [
1084 sub { $_[0] < 10} ,
1085 \&replace_age
1086 ],
1087 under18 => [
1088 sub { $_[0] < 18} ,
1089 \&replace_age
1090 ],
1091 welcome => [
1092 sub { 1 },
1093 \&replace_age
1094 ]
1095 ],
1096 cond_arg => [ $age ]
1097 );
1098
1099 We pass it the tree (C<$if_then>), an arrayref of conditions
1100 (C<cond>) and an arrayref of arguments which are passed to the
1101 C<cond>s and to the replacement subs.
1102
1103 The C<under10>, C<under18> and C<welcome> are id attributes in the
1104 tree of the siblings of which only one will survive. However,
1105 should you need to do
1106 more complex look-downs to find the survivor,
1107 then supply an array ref instead of a simple
1108 scalar:
1109
1110
1111 $if_then->highlander2(
1112 cond => [
1113 [class => 'r12'] => [
1114 sub { $_[0] < 10} ,
1115 \&replace_age
1116 ],
1117 [class => 'z22'] => [
1118 sub { $_[0] < 18} ,
1119 \&replace_age
1120 ],
1121 [class => 'w88'] => [
1122 sub { 1 },
1123 \&replace_age
1124 ]
1125 ],
1126 cond_arg => [ $age ]
1127 );
1128
1129
1130 =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures)
1131
1132 This method is designed for taking a tree and reworking a set of nodes in
1133 a stereotyped fashion. For instance let's say you have 3 remote image
1134 archives, but you don't want to put long URLs in your img src
1135 tags for reasons of abstraction, re-use and brevity. So instead you do this:
1136
1137 <img src="/img/smiley-face.jpg" fixup="src lnc">
1138 <img src="/img/hot-babe.jpg" fixup="src playboy">
1139 <img src="/img/footer.jpg" fixup="src foobar">
1140
1141 and then when the tree of HTML is being processed, you make this call:
1142
1143 my %closures = (
1144 lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" },
1145 playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" }
1146 foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" }
1147 )
1148
1149 $tree->overwrite_attr(fixup => \%closures) ;
1150
1151 and the tags come out modified like so:
1152
1153 <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc">
1154 <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy">
1155 <img src="http://foobar.info/img/footer.jpg" fixup="src foobar">
1156
1157 =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] )
1158
1159 This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1160 assumes the return value of the
1161 closure is supposed overwrite an attribute value and does it for you.
1162 C<mute_elem> is a more general function which does nothing but
1163 hand the closure the element and let it mutate it as it jolly well pleases :)
1164
1165 In fact, here is the implementation of C<overwrite_attr>
1166 to give you a taste of how C<mute_attr> is used:
1167
1168 sub overwrite_action {
1169 my ($mute_node, %X) = @_;
1170
1171 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
1172 }
1173
1174
1175 sub HTML::Element::overwrite_attr {
1176 my $tree = shift;
1177
1178 $tree->mute_elem(@_, \&overwrite_action);
1179 }
1180
1181
1182
1183
1184 =head2 Tree-Building Methods
1185
1186
1187
1188 =head3 Unrolling an array via a single sample element (<ul> container)
1189
1190 This is best described by example. Given this HTML:
1191
1192 <strong>Here are the things I need from the store:</strong>
1193 <ul>
1194 <li class="store_items">Sample item</li>
1195 </ul>
1196
1197 We can unroll it like so:
1198
1199 my $li = $tree->look_down(class => 'store_items');
1200
1201 my @items = qw(bread butter vodka);
1202
1203 $tree->iter($li => @items);
1204
1205 To produce this:
1206
1207
1208 <html>
1209 <head></head>
1210 <body>Here are the things I need from the store:
1211 <ul>
1212 <li class="store_items">bread</li>
1213 <li class="store_items">butter</li>
1214 <li class="store_items">vodka</li>
1215 </ul>
1216 </body>
1217 </html>
1218
1219 Now, you might be wondering why the API call is:
1220
1221 $tree->iter($li => @items)
1222
1223 instead of:
1224
1225 $li->iter(@items)
1226
1227 and there is no good answer. The latter would be more concise and it is what I
1228 should have done.
1229
1230 =head3 Unrolling an array via n sample elements (<dl> container)
1231
1232 C<iter()> was fine for awhile, but some things
1233 (e.g. definition lists) need a more general function to make them easy to
1234 do. Hence C<iter2()>. This function will be explained by example of unrolling
1235 a simple definition list.
1236
1237 So here's our mock-up HTML from the designer:
1238
1239 <dl class="dual_iter" id="service_plan">
1240 <dt>
1241 Artist
1242 </dt>
1243 <dd>
1244 A person who draws blood.
1245 </dd>
1246
1247 <dt>
1248 Musician
1249 </dt>
1250 <dd>
1251 A clone of Iggy Pop.
1252 </dd>
1253
1254 <dt>
1255 Poet
1256 </dt>
1257 <dd>
1258 A relative of Edgar Allan Poe.
1259 </dd>
1260
1261 <dt class="adstyle">sample header</dt>
1262 <dd class="adstyle2">sample data</dd>
1263
1264 </dl>
1265
1266
1267 And we want to unroll our data set:
1268
1269 my @items = (
1270 ['the pros' => 'never have to worry about service again'],
1271 ['the cons' => 'upfront extra charge on purchase'],
1272 ['our choice' => 'go with the extended service plan']
1273 );
1274
1275
1276 Now, let's make this problem a bit harder to show off the power of C<iter2()>.
1277 Let's assume that we want only the last <dt> and it's accompanying <dd>
1278 (the one with "sample data") to be used as the sample data
1279 for unrolling with our data set. Let's further assume that we want them to
1280 remain in the final output.
1281
1282 So now, the API to C<iter2()> will be discussed and we will explain how our
1283 goal of getting our data into HTML fits into the API.
1284
1285 =over 4
1286
1287 =item * wrapper_ld
1288
1289 This is how to look down and find the container of all the elements we will
1290 be unrolling. The <dl> tag is the container for the dt and dd tags we will be
1291 unrolling.
1292
1293 If you pass an anonymous subroutine, then it is presumed that execution of
1294 this subroutine will return the HTML::Element representing the container tag.
1295 If you pass an array ref, then this will be dereferenced and passed to
1296 C<HTML::Element::look_down()>.
1297
1298 default value: C<< ['_tag' => 'dl'] >>
1299
1300 Based on the mock HTML above, this default is fine for finding our container
1301 tag. So let's move on.
1302
1303 =item * wrapper_data
1304
1305 This is an array reference of data that we will be putting into the container.
1306 You must supply this. C<@items> above is our C<wrapper_data>.
1307
1308 =item * wrapper_proc
1309
1310 After we find the container via C<wrapper_ld>, we may want to pre-process
1311 some aspect of this tree. In our case the first two sets of dt and dd need
1312 to be removed, leaving the last dt and dd. So, we supply a C<wrapper_proc>
1313 which will do this.
1314
1315 default: undef
1316
1317 =item * item_ld
1318
1319 This anonymous subroutine returns an array ref of C<HTML::Element>s that will
1320 be cloned and populated with item data
1321 (item data is a "row" of C<wrapper_data>).
1322
1323 default: returns an arrayref consisting of the dt and dd element inside the
1324 container.
1325
1326 =item * item_data
1327
1328 This is a subroutine that takes C<wrapper_data> and retrieves one "row"
1329 to be "pasted" into the array ref of C<HTML::Element>s found via C<item_ld>.
1330 I hope that makes sense.
1331
1332 default: shifts C<wrapper_data>.
1333
1334 =item * item_proc
1335
1336 This is a subroutine that takes the C<item_data> and the C<HTML::Element>s
1337 found via C<item_ld> and produces an arrayref of C<HTML::Element>s which will
1338 eventually be spliced into the container.
1339
1340 Note that this subroutine MUST return the new items. This is done
1341 So that more items than were passed in can be returned. This is
1342 useful when, for example, you must return 2 dts for an input data item.
1343 And when would you do this? When a single term has multiple spellings
1344 for instance.
1345
1346 default: expects C<item_data> to be an arrayref of two elements and
1347 C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces the
1348 content of the C<HTML::Element>s with the C<item_data>.
1349
1350 =item * splice
1351
1352 After building up an array of C<@item_elems>, the subroutine passed as
1353 C<splice> will be given the parent container HTML::Element and the
1354 C<@item_elems>. How the C<@item_elems> end up in the container is up to this
1355 routine: it could put half of them in. It could unshift them or whatever.
1356
1357 default: C<< $container->splice_content(0, 2, @item_elems) >>
1358 In other words, kill the 2 sample elements with the newly generated
1359 @item_elems
1360
1361 =back
1362
1363 So now that we have documented the API, let's see the call we need:
1364
1365 $tree->iter2(
1366 # default wrapper_ld ok.
1367 wrapper_data => \@items,
1368 wrapper_proc => sub {
1369 my ($container) = @_;
1370
1371 # only keep the last 2 dts and dds
1372 my @content_list = $container->content_list;
1373 $container->splice_content(0, @content_list - 2);
1374 },
1375
1376 # default item_ld is fine.
1377 # default item_data is fine.
1378 # default item_proc is fine.
1379 splice => sub {
1380 my ($container, @item_elems) = @_;
1381 $container->unshift_content(@item_elems);
1382 },
1383 debug => 1,
1384 );
1385
1386
1387
1388
1389 =head3 Select Unrolling
1390
1391 The C<unroll_select> method has this API:
1392
1393 $tree->unroll_select(
1394 select_label => $id_label,
1395 option_value => $closure, # how to get option value from data row
1396 option_content => $closure, # how to get option content from data row
1397 option_selected => $closure, # boolean to decide if SELECTED
1398 data => $data # the data to be put into the SELECT
1399 data_iter => $closure # the thing that will get a row of data
1400 debug => $boolean,
1401 append => $boolean, # remove the sample <OPTION> data or append?
1402 );
1403
1404 Here's an example:
1405
1406 $tree->unroll_select(
1407 select_label => 'clan_list',
1408 option_value => sub { my $row = shift; $row->clan_id },
1409 option_content => sub { my $row = shift; $row->clan_name },
1410 option_selected => sub { my $row = shift; $row->selected },
1411 data => \@query_results,
1412 data_iter => sub { my $data = shift; $data->next },
1413 append => 0,
1414 debug => 0
1415 );
1416
1417
1418
1419 =head2 Tree-Building Methods: Table Generation
1420
1421 Matthew Sisk has a much more intuitive (imperative)
1422 way to generate tables via his module
1423 L<HTML::ElementTable|HTML::ElementTable>.
1424 However, for those with callback fever, the following
1425 method is available. First, we look at a nuts and bolts way to build a table
1426 using only standard L<HTML::Tree> API calls. Then the C<table> method
1427 available here is discussed.
1428
1429 =head3 Sample Model
1430
1431 package Simple::Class;
1432
1433 use Set::Array;
1434
1435 my @name = qw(bob bill brian babette bobo bix);
1436 my @age = qw(99 12 44 52 12 43);
1437 my @weight = qw(99 52 80 124 120 230);
1438
1439
1440 sub new {
1441 my $this = shift;
1442 bless {}, ref($this) || $this;
1443 }
1444
1445 sub load_data {
1446 my @data;
1447
1448 for (0 .. 5) {
1449 push @data, {
1450 age => $age[rand $#age] + int rand 20,
1451 name => shift @name,
1452 weight => $weight[rand $#weight] + int rand 40
1453 }
1454 }
1455
1456 Set::Array->new(@data);
1457 }
1458
1459
1460 1;
1461
1462
1463 =head4 Sample Usage:
1464
1465 my $data = Simple::Class->load_data;
1466 ++$_->{age} for @$data
1467
1468 =head3 Inline Code to Unroll a Table
1469
1470 =head4 HTML
1471
1472 <html>
1473
1474 <table id="load_data">
1475
1476 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1477
1478 <tr id="iterate">
1479
1480 <td id="name"> NATURE BOY RIC FLAIR </td>
1481 <td id="age"> 35 </td>
1482 <td id="weight"> 220 </td>
1483
1484 </tr>
1485
1486 </table>
1487
1488 </html>
1489
1490
1491 =head4 The manual way (*NOT* recommended)
1492
1493 require 'simple-class.pl';
1494 use HTML::Seamstress;
1495
1496 # load the view
1497 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1498
1499 # load the model
1500 my $o = Simple::Class->new;
1501 my $data = $o->load_data;
1502
1503 # find the <table> and <tr>
1504 my $table_node = $seamstress->look_down('id', 'load_data');
1505 my $iter_node = $table_node->look_down('id', 'iterate');
1506 my $table_parent = $table_node->parent;
1507
1508
1509 # drop the sample <table> and <tr> from the HTML
1510 # only add them in if there is data in the model
1511 # this is achieved via the $add_table flag
1512
1513 $table_node->detach;
1514 $iter_node->detach;
1515 my $add_table;
1516
1517 # Get a row of model data
1518 while (my $row = shift @$data) {
1519
1520 # We got row data. Set the flag indicating ok to hook the table into the HTML
1521 ++$add_table;
1522
1523 # clone the sample <tr>
1524 my $new_iter_node = $iter_node->clone;
1525
1526 # find the tags labeled name age and weight and
1527 # set their content to the row data
1528 $new_iter_node->content_handler($_ => $row->{$_})
1529 for qw(name age weight);
1530
1531 $table_node->push_content($new_iter_node);
1532
1533 }
1534
1535 # reattach the table to the HTML tree if we loaded data into some table rows
1536
1537 $table_parent->push_content($table_node) if $add_table;
1538
1539 print $seamstress->as_HTML;
1540
1541
1542
1543 =head3 $tree->table() : API call to Unroll a Table
1544
1545 require 'simple-class.pl';
1546 use HTML::Seamstress;
1547
1548 # load the view
1549 my $seamstress = HTML::Seamstress->new_from_file('simple.html');
1550 # load the model
1551 my $o = Simple::Class->new;
1552
1553 $seamstress->table
1554 (
1555 # tell seamstress where to find the table, via the method call
1556 # ->look_down('id', $gi_table). Seamstress detaches the table from the
1557 # HTML tree automatically if no table rows can be built
1558
1559 gi_table => 'load_data',
1560
1561 # tell seamstress where to find the tr. This is a bit useless as
1562 # the <tr> usually can be found as the first child of the parent
1563
1564 gi_tr => 'iterate',
1565
1566 # the model data to be pushed into the table
1567
1568 table_data => $o->load_data,
1569
1570 # the way to take the model data and obtain one row
1571 # if the table data were a hashref, we would do:
1572 # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key}
1573
1574 tr_data => sub { my ($self, $data) = @_;
1575 shift(@{$data}) ;
1576 },
1577
1578 # the way to take a row of data and fill the <td> tags
1579
1580 td_data => sub { my ($tr_node, $tr_data) = @_;
1581 $tr_node->content_handler($_ => $tr_data->{$_})
1582 for qw(name age weight) }
1583
1584 );
1585
1586
1587 print $seamstress->as_HTML;
1588
1589
1590
1591 =head4 Looping over Multiple Sample Rows
1592
1593 * HTML
1594
1595 <html>
1596
1597 <table id="load_data" CELLPADDING=8 BORDER=2>
1598
1599 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1600
1601 <tr id="iterate1" BGCOLOR="white" >
1602
1603 <td id="name"> NATURE BOY RIC FLAIR </td>
1604 <td id="age"> 35 </td>
1605 <td id="weight"> 220 </td>
1606
1607 </tr>
1608 <tr id="iterate2" BGCOLOR="#CCCC99">
1609
1610 <td id="name"> NATURE BOY RIC FLAIR </td>
1611 <td id="age"> 35 </td>
1612 <td id="weight"> 220 </td>
1613
1614 </tr>
1615
1616 </table>
1617
1618 </html>
1619
1620
1621 * Only one change to last API call.
1622
1623 This:
1624
1625 gi_tr => 'iterate',
1626
1627 becomes this:
1628
1629 gi_tr => ['iterate1', 'iterate2']
1630
1631 =head3 $tree->table2() : New API Call to Unroll a Table
1632
1633 After 2 or 3 years with C<table()>, I began to develop
1634 production websites with it and decided it needed a cleaner
1635 interface, particularly in the area of handling the fact that
1636 C<id> tags will be the same after cloning a table row.
1637
1638 First, I will give a dry listing of the function's argument parameters.
1639 This will not be educational most likely. A better way to understand how
1640 to use the function is to read through the incremental unrolling of the
1641 function's interface given in conversational style after the dry listing.
1642 But take your pick. It's the same information given in two different
1643 ways.
1644
1645 =head4 Dry/technical parameter documentation
1646
1647 C<< $tree->table2(%param) >> takes the following arguments:
1648
1649 =over
1650
1651 =item * C<< table_ld => $look_down >> : optional
1652
1653 How to find the C<table> element in C<$tree>. If C<$look_down> is an
1654 arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1655 passing it C<$tree>.
1656
1657 Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1658
1659 =item * C<< table_data => $tabular_data >> : required
1660
1661 The data to fill the table with. I<Must> be passed in.
1662
1663 =item * C<< table_proc => $code_ref >> : not implemented
1664
1665 A subroutine to do something to the table once it is found.
1666 Not currently implemented. Not obviously necessary. Just
1667 created because there is a C<tr_proc> and C<td_proc>.
1668
1669 =item * C<< tr_ld => $look_down >> : optional
1670
1671 Same as C<table_ld> but for finding the table row elements. Please note
1672 that the C<tr_ld> is done on the table node that was found I<instead>
1673 of the whole HTML tree. This makes sense. The C<tr>s that you want exist
1674 below the table that was just found.
1675
1676 Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1677
1678 =item * C<< tr_data => $code_ref >> : optional
1679
1680 How to take the C<table_data> and return a row. Defaults to:
1681
1682 sub { my ($self, $data) = @_;
1683 shift(@{$data}) ;
1684 }
1685
1686 =item * C<< tr_proc => $code_ref >> : optional
1687
1688 Something to do to the table row we are about to add to the
1689 table we are making. Defaults to a routine which makes the C<id>
1690 attribute unique:
1691
1692 sub {
1693 my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_;
1694 $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count);
1695 }
1696
1697 =item * C<< td_proc => $code_ref >> : required
1698
1699 This coderef will take the row of data and operate on the C<td> cells that
1700 are children of the C<tr>. See C<t/table2.t> for several usage examples.
1701
1702 Here's a sample one:
1703
1704 sub {
1705 my ($tr, $data) = @_;
1706 my @td = $tr->look_down('_tag' => 'td');
1707 for my $i (0..$#td) {
1708 $td[$i]->splice_content(0, 1, $data->[$i]);
1709 }
1710 }
1711
1712 =cut
1713
1714 =head4 Conversational parameter documentation
1715
1716 The first thing you need is a table. So we need a look down for that. If you
1717 don't give one, it defaults to
1718
1719 ['_tag' => 'table']
1720
1721 What good is a table to display in without data to display?!
1722 So you must supply a scalar representing your tabular
1723 data source. This scalar might be an array reference, a C<next>able iterator,
1724 a DBI statement handle. Whatever it is, it can be iterated through to build
1725 up rows of table data.
1726 These two required fields (the way to find the table and the data to
1727 display in the table) are C<table_ld> and C<table_data>
1728 respectively. A little more on C<table_ld>. If this happens to be a CODE ref,
1729 then execution
1730 of the code ref is presumed to return the C<HTML::Element>
1731 representing the table in the HTML tree.
1732
1733 Next, we get the row or rows which serve as sample C<tr> elements by doing
1734 a C<look_down> from the C<table_elem>. While normally one sample row
1735 is enough to unroll a table, consider when you have alternating
1736 table rows. This API call would need one of each row so that it can
1737 cycle through the
1738 sample rows as it loops through the data.
1739 Alternatively, you could always just use one row and
1740 make the necessary changes to the single C<tr> row by
1741 mutating the element in C<tr_proc>,
1742 discussed below. The default C<tr_ld> is
1743 C<< ['_tag' => 'tr'] >> but you can overwrite it. Note well, if you overwrite
1744 it with a subroutine, then it is expected that the subroutine will return
1745 the C<HTML::Element>(s)
1746 which are C<tr> element(s).
1747 The reason a subroutine might be preferred is in the case
1748 that the HTML designers gave you 8 sample C<tr> rows but only one
1749 prototype row is needed.
1750 So you can write a subroutine, to splice out the 7 rows you don't need
1751 and leave the one sample
1752 row remaining so that this API call can clone it and supply it to
1753 the C<tr_proc> and C<td_proc> calls.
1754
1755 Now, as we move through the table rows with table data,
1756 we need to do two different things on
1757 each table row:
1758
1759 =over 4
1760
1761 =item * get one row of data from the C<table_data> via C<tr_data>
1762
1763 The default procedure assumes the C<table_data> is an array reference and
1764 shifts a row off of it:
1765
1766 sub { my ($self, $data) = @_;
1767 shift(@{$data}) ;
1768 }
1769
1770 Your function MUST return undef when there is no more rows to lay out.
1771
1772 =item * take the C<tr> element and mutate it via C<tr_proc>
1773
1774 The default procedure simply makes the id of the table row unique:
1775
1776 sub { my ($self, $tr, $tr_data, $row_count, $root_id) = @_;
1777 $tr->attr(id => sprintf "%s_%d", $root_id, $row_count);
1778 }
1779
1780 =back
1781
1782 Now that we have our row of data, we call C<td_proc> so that it can
1783 take the data and the C<td> cells in this C<tr> and process them.
1784 This function I<must> be supplied.
1785
1786
1787 =head3 Whither a Table with No Rows
1788
1789 Often when a table has no rows, we want to display a message
1790 indicating this to the view. Use conditional processing to decide what
1791 to display:
1792
1793 <span id=no_data>
1794 <table><tr><td>No Data is Good Data</td></tr></table>
1795 </span>
1796 <span id=load_data>
1797 <html>
1798
1799 <table id="load_data">
1800
1801 <tr> <th>name</th><th>age</th><th>weight</th> </tr>
1802
1803 <tr id="iterate">
1804
1805 <td id="name"> NATURE BOY RIC FLAIR </td>
1806 <td id="age"> 35 </td>
1807 <td id="weight"> 220 </td>
1808
1809 </tr>
1810
1811 </table>
1812
1813 </html>
1814
1815 </span>
1816
1817
1818
1819
1820 =head1 SEE ALSO
1821
1822 =over
1823
1824 =item * L<HTML::Tree>
1825
1826 A perl package for creating and manipulating HTML trees
1827
1828 =item * L<HTML::ElementTable>
1829
1830 An L<HTML::Tree> - based module which allows for manipulation of HTML
1831 trees using cartesian coordinations.
1832
1833 =item * L<HTML::Seamstress>
1834
1835 An L<HTML::Tree> - based module inspired by
1836 XMLC (L<http://xmlc.enhydra.org>), allowing for dynamic
1837 HTML generation via tree rewriting.
1838
1839 =head1 TODO
1840
1841 =over
1842
1843 =item * highlander2
1844
1845 currently the API expects the subtrees to survive or be pruned to be
1846 identified by id:
1847
1848 $if_then->highlander2([
1849 under10 => sub { $_[0] < 10} ,
1850 under18 => sub { $_[0] < 18} ,
1851 welcome => [
1852 sub { 1 },
1853 sub {
1854 my $branch = shift;
1855 $branch->look_down(id => 'age')->replace_content($age);
1856 }
1857 ]
1858 ],
1859 $age
1860 );
1861
1862 but, it should be more flexible. the C<under10>, and C<under18> are
1863 expected to be ids in the tree... but it is not hard to have a check to
1864 see if this field is an array reference and if it, then to do a look
1865 down instead:
1866
1867 $if_then->highlander2([
1868 [class => 'under10'] => sub { $_[0] < 10} ,
1869 [class => 'under18'] => sub { $_[0] < 18} ,
1870 [class => 'welcome'] => [
1871 sub { 1 },
1872 sub {
1873 my $branch = shift;
1874 $branch->look_down(id => 'age')->replace_content($age);
1875 }
1876 ]
1877 ],
1878 $age
1879 );
1880
1881
1882
1883 =cut
1884
1885 =head1 SEE ALSO
1886
1887 L<HTML::Seamstress>
1888
1889 =head1 AUTHOR / SOURCE
1890
1891 Terrence Brannon, E<lt>tbone@cpan.orgE<gt>
1892
1893 Many thanks to BARBIE for his RT bug report.
1894
1895 The source is at L<http://github.com/metaperl/html-element-library/tree/master>
1896
1897 =head1 COPYRIGHT AND LICENSE
1898
1899 Copyright (C) 2004 by Terrence Brannon
1900
1901 This library is free software; you can redistribute it and/or modify
1902 it under the same terms as Perl itself, either Perl version 5.8.4 or,
1903 at your option, any later version of Perl 5 you may have available.
1904
1905
1906 =cut
This page took 0.106846 seconds and 4 git commands to generate.