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