]> iEval git - html-element-library.git/blame - lib/HTML/Element/Library.pm
Bump version and update Changes
[html-element-library.git] / lib / HTML / Element / Library.pm
CommitLineData
67e78ff2 1package HTML::Element::Library;
67e78ff2 2use strict;
3use warnings;
4
13f94226 5our $VERSION = '5.220000';
67e78ff2 6our $DEBUG = 0;
67e78ff2 7
6c20681a
MG
8use Array::Group ':all';
9use Carp 'confess';
67e78ff2 10use Data::Dumper;
6c20681a 11use Data::Rmap 'rmap_array';
67e78ff2 12use HTML::Element;
6c20681a
MG
13use HTML::FillInForm;
14use List::MoreUtils ':all';
67e78ff2 15use List::Rotation::Cycle;
6c20681a
MG
16use List::Util 'first';
17use Params::Validate ':all';
18use Scalar::Listify;
67e78ff2 19
2fcbbeb3
TB
20# https://rt.cpan.org/Ticket/Display.html?id=44105
21sub HTML::Element::fillinform {
6c20681a
MG
22 my ($tree, $hashref, $return_tree, $guts) = @_;
23 (ref $hashref) eq 'HASH' or confess 'hashref not supplied as argument' ;
2fcbbeb3 24
6c20681a
MG
25 my $html = $tree->as_HTML;
26 my $new_html = HTML::FillInForm->fill(\$html, $hashref);
63007e38 27
6c20681a 28 if ($return_tree) {
e87db89a 29 $tree = HTML::TreeBuilder->new_from_content($new_html);
6c20681a
MG
30 $tree = $guts ? $tree->guts : $tree ;
31 } else {
32 $new_html;
33 }
2fcbbeb3
TB
34}
35
67e78ff2 36sub HTML::Element::siblings {
6c20681a
MG
37 my $element = shift;
38 my $p = $element->parent;
39 return () unless $p;
40 $p->content_list;
67e78ff2 41}
42
f25dca7f 43sub HTML::Element::defmap {
6c20681a
MG
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 }
f25dca7f 53 }
f25dca7f
TB
54}
55
ce4e9192 56sub HTML::Element::_only_empty_content {
6c20681a
MG
57 my ($self) = @_;
58 my @c = $self->content_list;
59 my $length = scalar @c;
ce4e9192 60
6c20681a 61 scalar @c == 1 and not length $c[0];
ce4e9192
TB
62}
63
64sub HTML::Element::prune {
6c20681a 65 my ($self) = @_;
ce4e9192 66
6c20681a
MG
67 for my $c ($self->content_list) {
68 next unless ref $c;
69 $c->prune;
70 }
ce4e9192 71
6c20681a
MG
72 # post-order:
73 $self->delete if ($self->is_empty or $self->_only_empty_content);
74 $self;
ce4e9192
TB
75}
76
855ca7e9 77sub HTML::Element::newchild {
6c20681a
MG
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;
271d5078 87}
ce4e9192 88
e87db89a 89sub HTML::Element::crunch { ## no critic (RequireArgUnpacking)
6c20681a
MG
90 my $container = shift;
91
92 my %p = validate(@_, {
93 look_down => { type => ARRAYREF },
94 leave => { default => 1 },
95 });
d161c455 96
6c20681a
MG
97 my @look_down = @{$p{look_down}} ;
98 my @elem = $container->look_down(@look_down) ;
d161c455 99
e87db89a 100 my $detached;
d161c455 101
6c20681a 102 for my $elem (@elem) {
e87db89a 103 $elem->detach if $detached++ >= $p{leave};
6c20681a 104 }
d161c455 105}
f25dca7f 106
e87db89a 107sub HTML::Element::hash_map { ## no critic (RequireArgUnpacking)
6c20681a
MG
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
e87db89a 121 my @same_as = $container->look_down( $p{to_attr} => qr/.+/s ) ;
6c20681a
MG
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});
d9f4bd5a 133 }
3dad7198
TB
134}
135
f25dca7f 136sub HTML::Element::hashmap {
6c20681a 137 my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
f25dca7f 138
6c20681a 139 $excluding ||= [] ;
f25dca7f 140
e87db89a
MG
141 $container->hash_map(
142 hash => $hashref,
143 to_attr => $attr_name,
144 excluding => $excluding,
145 debug => $debug);
f25dca7f
TB
146}
147
3dad7198 148
de64e3d9 149sub HTML::Element::passover {
6c20681a 150 my ($tree, @to_preserve) = @_;
de64e3d9 151
e87db89a 152 warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
6c20681a 153 warn $tree->as_HTML(undef, ' ') if $DEBUG;
de64e3d9 154
6c20681a 155 my $exodus = $tree->look_down(id => $to_preserve[0]);
3dad7198 156
6c20681a 157 warn "E: $exodus" if $DEBUG;
de64e3d9 158
6c20681a 159 my @s = HTML::Element::siblings($exodus);
de64e3d9 160
6c20681a
MG
161 for my $s (@s) {
162 next unless ref $s;
163 $s->delete unless first { $s->attr('id') eq $_ } @to_preserve;
164 }
de64e3d9 165
6c20681a 166 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
de64e3d9 167}
168
67e78ff2 169sub HTML::Element::sibdex {
6c20681a
MG
170 my $element = shift;
171 firstidx { $_ eq $element } $element->siblings
67e78ff2 172}
173
174sub HTML::Element::addr { goto &HTML::Element::sibdex }
175
176sub HTML::Element::replace_content {
6c20681a
MG
177 my $elem = shift;
178 $elem->delete_content;
179 $elem->push_content(@_);
67e78ff2 180}
181
182sub HTML::Element::wrap_content {
6c20681a
MG
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;
67e78ff2 193}
194
195sub HTML::Element::Library::super_literal {
6c20681a
MG
196 my($text) = @_;
197 HTML::Element->new('~literal', text => $text);
67e78ff2 198}
199
67e78ff2 200sub HTML::Element::position {
6c20681a
MG
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;
e87db89a 210 unshift @pos, $a if defined $a;
6c20681a
MG
211 $p = $p->parent;
212 }
213 @pos;
67e78ff2 214}
215
67e78ff2 216sub HTML::Element::content_handler {
6c20681a 217 my ($tree, %content_hash) = @_;
67e78ff2 218
6c20681a
MG
219 for my $k (keys %content_hash) {
220 $tree->set_child_content(id => $k, $content_hash{$k});
221 }
237e9506
TB
222}
223
6c20681a 224sub HTML::Element::assign { goto &HTML::Element::content_handler }
67e78ff2 225
226sub make_counter {
6c20681a
MG
227 my $i = 1;
228 sub {
229 shift() . ':' . $i++
230 }
67e78ff2 231}
232
67e78ff2 233sub HTML::Element::iter {
6c20681a 234 my ($tree, $p, @data) = @_;
67e78ff2 235
6c20681a
MG
236 # warn 'P: ' , $p->attr('id') ;
237 # warn 'H: ' , $p->as_HTML;
67e78ff2 238
6c20681a
MG
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;
67e78ff2 245
6c20681a 246 $p->replace_with(@item);
67e78ff2 247}
248
dbfa87a3
MG
249sub 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
e87db89a 262sub HTML::Element::iter2 { ## no critic (RequireArgUnpacking)
6c20681a
MG
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 {
e87db89a 274 my $tr = shift;
6c20681a 275 [
e87db89a
MG
276 $tr->look_down('_tag' => 'dt'),
277 $tr->look_down('_tag' => 'dd')
6c20681a
MG
278 ];
279 }},
280 item_data => {
281 default => sub {
282 my ($wrapper_data) = @_;
e87db89a 283 shift @{$wrapper_data};
6c20681a
MG
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 }
67e78ff2 296 },
6c20681a
MG
297 debug => {default => 0}
298 }
299 );
67e78ff2 300
e87db89a 301 warn 'wrapper_data: ' . Dumper $p{wrapper_data} if $p{debug} ;
67e78ff2 302
6c20681a 303 my $container = ref_or_ld($tree, $p{wrapper_ld});
e87db89a
MG
304 warn 'container: ' . $container if $p{debug} ;
305 warn 'wrapper_(preproc): ' . $container->as_HTML if $p{debug} ;
6c20681a 306 $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ;
e87db89a 307 warn 'wrapper_(postproc): ' . $container->as_HTML if $p{debug} ;
67e78ff2 308
6c20681a 309 my $_item_elems = $p{item_ld}->($container);
67e78ff2 310
6c20681a
MG
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;
67e78ff2 316
aa016126 317 warn Dumper('item_data', $item_data) if $p{debug};
67e78ff2 318
6c20681a 319 my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;
67e78ff2 320
6c20681a
MG
321 if ($p{debug}) {
322 for (@{$item_elems}) {
aa016126 323 warn 'ITEM_ELEMS ', $_->as_HTML if $p{debug};
6c20681a
MG
324 }
325 }
67e78ff2 326
6c20681a 327 my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);
67e78ff2 328
6c20681a
MG
329 if ($p{debug}) {
330 for (@{$new_item_elems}) {
aa016126 331 warn 'NEWITEM_ELEMS ', $_->as_HTML if $p{debug};
6c20681a
MG
332 }
333 }
67e78ff2 334
6c20681a
MG
335 push @item_elem, @{$new_item_elems} ;
336 }
67e78ff2 337
e87db89a 338 warn 'pushing ' . @item_elem . ' elems' if $p{debug} ;
67e78ff2 339
6c20681a 340 $p{splice}->($container, @item_elem);
67e78ff2 341}
342
343sub HTML::Element::dual_iter {
6c20681a 344 my ($parent, $data) = @_;
67e78ff2 345
6c20681a 346 my ($prototype_a, $prototype_b) = $parent->content_list;
67e78ff2 347
6c20681a 348 # my $id_incr = make_counter;
67e78ff2 349
6c20681a 350 my $i;
67e78ff2 351
6c20681a 352 @$data %2 == 0 or confess 'dataset does not contain an even number of members';
67e78ff2 353
6c20681a 354 my @iterable_data = ngroup 2 => @$data;
67e78ff2 355
6c20681a
MG
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;
67e78ff2 363
6c20681a 364 $parent->splice_content(0, 2, @item);
67e78ff2 365}
366
e87db89a 367sub HTML::Element::set_child_content { ## no critic (RequireArgUnpacking)
6c20681a
MG
368 my $tree = shift;
369 my $content = pop;
370 my @look_down = @_;
67e78ff2 371
6c20681a 372 my $content_tag = $tree->look_down(@look_down);
67e78ff2 373
6c20681a
MG
374 unless ($content_tag) {
375 warn "criteria [@look_down] not found";
376 return;
377 }
67e78ff2 378
6c20681a 379 $content_tag->replace_content($content);
67e78ff2 380}
381
382sub HTML::Element::highlander {
6c20681a 383 my ($tree, $local_root_id, $aref, @arg) = @_;
67e78ff2 384
e87db89a 385 ref $aref eq 'ARRAY' or confess 'must supply array reference';
67e78ff2 386
6c20681a 387 my @aref = @$aref;
e87db89a 388 @aref % 2 == 0 or confess 'supplied array ref must have an even number of entries';
67e78ff2 389
6c20681a 390 warn __PACKAGE__ if $DEBUG;
67e78ff2 391
6c20681a
MG
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 }
67e78ff2 400
6c20681a
MG
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;
67e78ff2 406
6c20681a 407 warn "survivor: $survivor" if $DEBUG;
e87db89a 408 warn 'tree: ' . $tree->as_HTML if $DEBUG;
67e78ff2 409
6c20681a 410 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
67e78ff2 411
6c20681a
MG
412 my $survivor_node_parent = $survivor_node->parent;
413 $survivor_node = $survivor_node->clone;
414 $survivor_node_parent->replace_content($survivor_node);
67e78ff2 415
e87db89a 416 warn 'new tree: ' . $tree->as_HTML if $DEBUG;
67e78ff2 417
6c20681a 418 $survivor_node;
67e78ff2 419}
420
e87db89a 421sub HTML::Element::highlander2 { ## no critic (RequireArgUnpacking)
6c20681a
MG
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}};
e87db89a 434 @cond % 2 == 0 or confess 'supplied array ref must have an even number of entries';
6c20681a
MG
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 }
67e78ff2 457
6c20681a 458 my @ld = (ref $survivor eq 'ARRAY') ? @$survivor : (id => $survivor);
67e78ff2 459
e87db89a
MG
460 warn 'survivor: ', $survivor if $p{debug};
461 warn 'survivor_ld: ', Dumper \@ld if $p{debug};
67e78ff2 462
6c20681a 463 my $survivor_node = $tree->look_down(@ld);
67e78ff2 464
6c20681a 465 $survivor_node or confess "search for @ld failed in tree($tree): " . $tree->as_HTML;
67e78ff2 466
6c20681a
MG
467 my $survivor_node_parent = $survivor_node->parent;
468 $survivor_node = $survivor_node->clone;
469 $survivor_node_parent->replace_content($survivor_node);
67e78ff2 470
6c20681a
MG
471 # **************** NEW FUNCTIONALITY *******************
472 # apply transforms on survivor node
67e78ff2 473
e87db89a 474 warn 'SURV::pre_trans ' . $survivor_node->as_HTML if $p{debug};
6c20681a 475 $then->($survivor_node, @cond_arg);
e87db89a 476 warn 'SURV::post_trans ' . $survivor_node->as_HTML if $p{debug};
6c20681a 477 # **************** NEW FUNCTIONALITY *******************
67e78ff2 478
6c20681a 479 $survivor_node;
67e78ff2 480}
481
67e78ff2 482sub overwrite_action {
6c20681a 483 my ($mute_node, %X) = @_;
67e78ff2 484
6c20681a 485 $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
67e78ff2 486}
487
67e78ff2 488sub HTML::Element::overwrite_attr {
6c20681a 489 my $tree = shift;
67e78ff2 490
6c20681a
MG
491 $tree->mute_elem(@_, \&overwrite_action);
492}
67e78ff2 493
494sub HTML::Element::mute_elem {
6c20681a
MG
495 my ($tree, $mute_attr, $closures, $post_hook) = @_;
496
e87db89a 497 my @mute_node = $tree->look_down($mute_attr => qr/.*/s) ;
6c20681a
MG
498
499 for my $mute_node (@mute_node) {
e87db89a 500 my ($local_attr,$mute_key) = split /\s+/s, $mute_node->attr($mute_attr);
6c20681a
MG
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 }
67e78ff2 515}
516
517
518
519sub HTML::Element::table {
6c20681a
MG
520 my ($s, %table) = @_;
521 my $table = {};
67e78ff2 522
6c20681a
MG
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}";
67e78ff2 526
6c20681a
MG
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;
67e78ff2 534
e87db89a 535 warn 'found ' . @iter_node . ' iter nodes ' if $DEBUG;
6c20681a 536 my $iter_node = List::Rotation::Cycle->new(@iter_node);
67e78ff2 537
6c20681a
MG
538 # warn $iter_node;
539 warn Dumper ($iter_node, \@iter_node) if $DEBUG;
67e78ff2 540
6c20681a
MG
541 # $table->{content} = $table{content};
542 # $table->{parent} = $table->{table_node}->parent;
67e78ff2 543
6c20681a
MG
544 # $table->{table_node}->detach;
545 # $_->detach for @iter_node;
67e78ff2 546
6c20681a 547 my @table_rows;
67e78ff2 548
6c20681a
MG
549 while (1) {
550 my $row = $table{tr_data}->($table, $table{table_data});
551 last unless defined $row;
67e78ff2 552
6c20681a
MG
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;
67e78ff2 557
6c20681a
MG
558 $table{td_data}->($new_iter_node, $row);
559 push @table_rows, $new_iter_node;
560 }
67e78ff2 561
6c20681a
MG
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 }
67e78ff2 567}
568
569sub ref_or_ld {
6c20681a 570 my ($tree, $slot) = @_;
67e78ff2 571
6c20681a
MG
572 if (ref($slot) eq 'CODE') {
573 $slot->($tree);
574 } else {
575 $tree->look_down(@$slot);
576 }
67e78ff2 577}
578
e87db89a 579sub HTML::Element::table2 { ## no critic (RequireArgUnpacking)
6c20681a
MG
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) = @_;
e87db89a 591 shift @{$data};
6c20681a
MG
592 }},
593 tr_base_id => { default => undef },
594 tr_proc => { default => sub {} },
595 td_proc => 1,
596 debug => {default => 0}
597 }
598 );
599
e87db89a
MG
600 warn 'INPUT TO TABLE2: ', Dumper \@_ if $p{debug};
601 warn 'table_data: ' . Dumper $p{table_data} if $p{debug} ;
6c20681a
MG
602
603 my $table = {};
604
605 # Get the table element
606 $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ;
e87db89a 607 $table->{table_node} or confess 'table tag not found via ' . Dumper($p{table_ld}) ;
6c20681a 608
e87db89a 609 warn 'table: ' . $table->{table_node}->as_HTML if $p{debug};
6c20681a
MG
610
611 # Get the prototype tr element(s)
612 my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ;
613
e87db89a 614 warn 'found ' . @proto_tr . ' iter nodes' if $p{debug};
6c20681a
MG
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);
67e78ff2 622
6c20681a 623 my $tr_parent = $proto_tr[0]->parent;
e87db89a 624 warn 'parent element of trs: ' . $tr_parent->as_HTML if $p{debug};
67e78ff2 625
6c20681a 626 my $row_count;
67e78ff2 627
6c20681a 628 my @table_rows;
67e78ff2 629
6c20681a
MG
630 while(1) {
631 my $row = $p{tr_data}->($table, $p{table_data}, $row_count);
e87db89a 632 warn 'data row: ' . Dumper $row if $p{debug};
6c20681a 633 last unless defined $row;
67e78ff2 634
6c20681a
MG
635 # wont work: my $new_iter_node = $table->{iter_node}->clone;
636 my $new_tr_node = $proto_tr->next->clone;
e87db89a 637 warn "new_tr_node: $new_tr_node" if $p{debug};
67e78ff2 638
6c20681a 639 $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count) if defined $p{tr_proc};
67e78ff2 640
e87db89a 641 warn 'data row redux: ' . Dumper $row if $p{debug};
67e78ff2 642
6c20681a
MG
643 $p{td_proc}->($new_tr_node, $row);
644 push @table_rows, $new_tr_node;
645 }
67e78ff2 646
6c20681a 647 $_->detach for @proto_tr;
67e78ff2 648
6c20681a 649 $tr_parent->push_content(@table_rows) if (@table_rows) ;
67e78ff2 650}
651
67e78ff2 652sub HTML::Element::unroll_select {
6c20681a 653 my ($s, %select) = @_;
67e78ff2 654
6c20681a 655 my $select = {};
e87db89a 656 warn 'Select Hash: ' . Dumper(\%select) if $select{debug};
67e78ff2 657
6c20681a 658 my $select_node = $s->look_down(id => $select{select_label});
e87db89a 659 warn "Select Node: $select_node" if $select{debug};
67e78ff2 660
6c20681a
MG
661 unless ($select{append}) {
662 for my $option ($select_node->look_down('_tag' => 'option')) {
663 $option->delete;
664 }
665 }
67e78ff2 666
6c20681a 667 my $option = HTML::Element->new('option');
e87db89a 668 warn "Option Node: $option" if $select{debug};
3caedb5b 669
6c20681a 670 $option->detach;
67e78ff2 671
6c20681a 672 while (my $row = $select{data_iter}->($select{data})) {
e87db89a 673 warn 'Data Row: ' . Dumper($row) if $select{debug};
6c20681a
MG
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));
67e78ff2 677
6c20681a
MG
678 $o->replace_content($select{option_content}->($row));
679 $select_node->push_content($o);
680 warn $o->as_HTML if $select{debug};
681 }
67e78ff2 682}
683
67e78ff2 684sub HTML::Element::set_sibling_content {
6c20681a 685 my ($elt, $content) = @_;
67e78ff2 686
6c20681a 687 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
67e78ff2 688}
689
690sub HTML::TreeBuilder::parse_string {
6c20681a 691 my ($package, $string) = @_;
67e78ff2 692
6c20681a
MG
693 my $h = HTML::TreeBuilder->new;
694 HTML::TreeBuilder->parse($string);
67e78ff2 695}
696
dbfa87a3
MG
697sub HTML::Element::fid { shift->look_down(id => $_[0]) }
698sub HTML::Element::fclass { shift->look_down(class => qr/\b$_[0]\b/s) }
699
67e78ff2 7001;
701__END__
0b6e6b69
MG
702
703=encoding utf-8
704
705=head1 NAME
706
707HTML::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
df110877 716HTML:::Element::Library provides extra methods for HTML::Element.
0b6e6b69
MG
717
718=head1 METHODS
719
dbfa87a3
MG
720=head2 Aliases
721
722These are short aliases for common operations:
723
724=over
725
726=item I<$el>->B<fid>(I<$id>)
727
728Finds an element given its id. Equivalent to C<< $el->look_down(id => $id) >>.
729
730=item I<$el>->B<fclass>(I<$class>)
731
732Finds 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
0b6e6b69
MG
736=head2 Positional Querying Methods
737
738=head3 $elem->siblings
739
740Return a list of all nodes under the same parent.
741
742=head3 $elem->sibdex
743
744Return the index of C<$elem> into the array of siblings of which it is
745a part. L<HTML::ElementSuper> calls this method C<addr> but I don't
746think that is a descriptive name. And such naming is deceptively close
747to the C<address> function of C<HTML::Element>. HOWEVER, in the
748interest of backwards compatibility, both methods are available.
749
750=head3 $elem->addr
751
752Same as sibdex
753
754=head3 $elem->position()
755
756Returns the coordinates of this element in the tree it inhabits. This
757is accomplished by succesively calling addr() on ancestor elements
758until either a) an element that does not support these methods is
759found, or b) there are no more parents. The resulting list is the
760n-dimensional coordinates of the element in the tree.
761
762=head2 Element Decoration Methods
763
764=head3 HTML::Element::Library::super_literal($text)
765
766In L<HTML::Element>, Sean Burke discusses super-literals. They are
767text which does not get escaped. Great for includng Javascript in
768HTML. Also great for including foreign language into a document.
769
770So, you basically toss C<super_literal> your text and back comes your
771text wrapped in a C<~literal> element.
772
773One 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
779Oftentimes, 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
788But, before you begin to rewrite the HTML with your model data, you
789typically only want 1 or 2 sample rows.
790
791Thus, you want to "crunch" the multiple sample rows to a specified
792amount. Hence the C<crunch> method:
793
794 $tree->crunch(look_down => [ '_tag' => 'li' ], leave => 2) ;
795
796The 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
806Since HTML::FillInForm gets and returns strings, using HTML::Element
807instances 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
815I've filed a bug about this:
816L<https://rt.cpan.org/Ticket/Display.html?id=44105>
817
818This 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
825It is very common to get a hashref of data from some external source -
826flat file, database, XML, etc. Therefore, it is important to have a
827convenient way of mapping this data to HTML.
828
829As it turns out, there are 3 ways to do this in
830HTML::Element::Library. The most strict and structured way to do this
831is with C<content_handler>. Two other methods, C<hashmap> and
832C<datamap> require less manual mapping and may prove even more easy to
833use in certain cases.
834
835As is usual with Perl, a practical example is always best. So let's
836take 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
843Now, let's say our data structure is this:
844
845 $ref = { email => 'jim@beam.com', gender => 'lots' } ;
846
847And 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
851In this case, you manually state the mapping between id tags and
852hashref keys and then C<content_handler> retrieves the hashref data
853and pops it in the specified place.
854
855Now let's look at the two (actually 2 and a half) other hash-mapping
856methods.
857
858 $tree->hashmap(id => $ref);
859
860Now, what this function does is super-destructive. It finds every
861element in the tree with an attribute named id (since 'id' is a
862parameter, it could find every element with some other attribute also)
863and replaces the content of those elements with the hashref value.
864
865So, in the case above, the
866
867 <span id="name">?</span>
868
869would come out as
870
871 <span id="name"></span>
872
873(it would be blank) - because there is nothing in the hash with that
874value, so it substituted
875
876 $ref->{name}
877
878which was blank and emptied the contents.
879
880Now, let's assume we want to protect name from being auto-assigned.
881Here is what you do:
882
883 $tree->hashmap(id => $ref, ['name']);
884
885That last array ref is an exclusion list.
886
887But wouldnt it be nice if you could do a hashmap, but only assigned
888things which are defined in the hashref? C<< defmap() >> to the
889rescue:
890
891 $tree->defmap(id => $ref);
892
893does just that, so
894
895 <span id="name">?</span>
896
897would be left alone.
898
899=head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug)
900
901This method is designed to take a hashref and populate a series of
902elements. 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
912In the table above, there are several attributes named C<< smap >>. If
913we have a hashref whose keys are the same:
914
915 my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render');
916
917Then a single API call allows us to populate the HTML while excluding
e0dfa7be 918those ones we don't:
0b6e6b69
MG
919
920 $tree->hashmap(smap => \%data, ['password']);
921
922Note: the other way to prevent rendering some of the hash mapping is
923to not give that element the attr you plan to use for hash mapping.
924
925Also note: the function C<< hashmap >> has a simple easy-to-type API.
926Interally, it calls C<< hash_map >> (which has a more verbose keyword
927calling API). Thus, the above call to C<hashmap()> results in this
928call:
929
930 $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']);
931
932=head4 $elem->defmap($attr_name, \%hashref, $debug)
933
934C<defmap> was described above.
935
936=head3 $elem->replace_content(@new_elem)
937
938Replaces all of C<$elem>'s content with C<@new_elem>.
939
940=head3 $elem->wrap_content($wrapper_element)
941
942Wraps the existing content in the provided element. If the provided
943element happens to be a non-element, a push_content is performed
944instead.
945
946=head3 $elem->set_child_content(@look_down, $content)
947
948This method looks down $tree using the criteria specified in
949@look_down using the the HTML::Element look_down() method.
950
951After 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
956This is a convenience method. Because the look_down criteria will
957often simply be:
958
959 id => 'fixme'
960
961to find things like:
962
963 <a id=fixme href=http://www.somesite.org>replace_content</a>
964
965You can call this method to shorten your typing a bit. You can simply
966type
967
968 $elem->content_handler( fixme => 'new text' )
969
970Instead of typing:
971
972 $elem->set_child_content(sid => 'fixme', 'new text')
973
974ALSO NOTE: you can pass a hash whose keys are C<id>s and whose values
975are the content you want there and it will perform the replacement on
976each 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
986This allows for "if-then-else" style processing. Highlander was a
987movie in which only one would survive. Well, in terms of a tree when
988looking at a structure that you want to process in C<if-then-else>
989style, only one child will survive. For example, given this HTML
990template:
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
1006We only want one child of the C<span> tag with id C<age_dialog> to
1007remain based on the age of the person visiting the page.
1008
1009So, let's setup a call that will prune the subtree as a function of
1010age:
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
1026And there we have it. If the age is less than 10, then the node with
1027id C<under10> remains. For age less than 18, the node with id
1028C<under18> remains. Otherwise our "else" condition fires and the child
1029with id C<welcome> remains.
1030
1031=head3 $tree->passover(@id_of_element)
1032
1033In some cases, you know exactly which element(s) should survive. In
1034this case, you can simply call C<passover> to remove it's (their)
1035siblings. For the HTML above, you could delete C<under10> and
1036C<welcome> by simply calling:
1037
1038 $tree->passover('under18');
1039
1040Because passover takes an array, you can specify several children to
1041preserve.
1042
1043=head3 $tree->highlander2($tree, $conditionals, @conditionals_args)
1044
1045Right around the same time that C<table2()> came into being,
1046Seamstress began to tackle tougher and tougher processing problems. It
1047became clear that a more powerful highlander was needed... one that
1048not only snipped the tree of the nodes that should not survive, but
1049one that allows for post-processing of the survivor node. And one that
1050was more flexible with how to find the nodes to snip.
1051
1052Thus (drum roll) C<highlander2()>.
1053
1054So 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
1070In this case, a branch survives, but it has dummy data in it. We must
1071take the surviving segment of HTML and rewrite the age C<span> with
1072the 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
1100We pass it the tree (C<$if_then>), an arrayref of conditions (C<cond>)
1101and an arrayref of arguments which are passed to the C<cond>s and to
1102the replacement subs.
1103
1104The C<under10>, C<under18> and C<welcome> are id attributes in the
1105tree of the siblings of which only one will survive. However, should
1106you need to do more complex look-downs to find the survivor, then
1107supply 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
1129This method is designed for taking a tree and reworking a set of nodes
1130in a stereotyped fashion. For instance let's say you have 3 remote
1131image archives, but you don't want to put long URLs in your img src
1132tags for reasons of abstraction, re-use and brevity. So instead you do
1133this:
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
1139and 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
1149and 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
1157This is a generalization of C<overwrite_attr>. C<overwrite_attr>
1158assumes the return value of the closure is supposed overwrite an
1159attribute value and does it for you. C<mute_elem> is a more general
1160function which does nothing but hand the closure the element and let
1161it mutate it as it jolly well pleases :)
1162
1163In fact, here is the implementation of C<overwrite_attr> to give you a
1164taste 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
1183This 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
1190We 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
1198To 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
1211Now, you might be wondering why the API call is:
1212
1213 $tree->iter($li => @items)
1214
1215instead of:
1216
1217 $li->iter(@items)
1218
1219and there is no good answer. The latter would be more concise and it
1220is what I should have done.
1221
dbfa87a3
MG
1222=head3 Unrolling an array via a single sample element and a callback (<ul> container)
1223
1224This is a more advanced version of the previous method. Instead of
1225cloning the sample element several times and calling
1226C<replace_content> on the clone with the array element, a custom
1227callback is called with the clone and array element.
1228
1229Here 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
1236Code:
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
1247Output 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
1260Here 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
1267Code:
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
1285Produces:
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
0b6e6b69
MG
1294=head3 Unrolling an array via n sample elements (<dl> container)
1295
1296C<iter()> was fine for awhile, but some things (e.g. definition lists)
1297need a more general function to make them easy to do. Hence
1298C<iter2()>. This function will be explained by example of unrolling a
1299simple definition list.
1300
1301So 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
1318And 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
1327Now, let's make this problem a bit harder to show off the power of
1328C<iter2()>. Let's assume that we want only the last <dt> and it's
1329accompanying <dd> (the one with "sample data") to be used as the
1330sample data for unrolling with our data set. Let's further assume that
1331we want them to remain in the final output.
1332
1333So now, the API to C<iter2()> will be discussed and we will explain
1334how our goal of getting our data into HTML fits into the API.
1335
1336=over 4
1337
1338=item * wrapper_ld
1339
1340This is how to look down and find the container of all the elements we
1341will be unrolling. The <dl> tag is the container for the dt and dd
1342tags we will be unrolling.
1343
1344If you pass an anonymous subroutine, then it is presumed that
1345execution of this subroutine will return the HTML::Element
1346representing the container tag. If you pass an array ref, then this
1347will be dereferenced and passed to C<HTML::Element::look_down()>.
1348
1349default value: C<< ['_tag' => 'dl'] >>
1350
1351Based on the mock HTML above, this default is fine for finding our
1352container tag. So let's move on.
1353
1354=item * wrapper_data
1355
1356This is an array reference of data that we will be putting into the
1357container. You must supply this. C<@items> above is our
1358C<wrapper_data>.
1359
1360=item * wrapper_proc
1361
1362After we find the container via C<wrapper_ld>, we may want to
1363pre-process some aspect of this tree. In our case the first two sets
1364of dt and dd need to be removed, leaving the last dt and dd. So, we
1365supply a C<wrapper_proc> which will do this.
1366
1367default: undef
1368
1369=item * item_ld
1370
1371This anonymous subroutine returns an array ref of C<HTML::Element>s
1372that will be cloned and populated with item data (item data is a "row"
1373of C<wrapper_data>).
1374
1375default: returns an arrayref consisting of the dt and dd element
1376inside the container.
1377
1378=item * item_data
1379
1380This 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
1382C<item_ld>. I hope that makes sense.
1383
1384default: shifts C<wrapper_data>.
1385
1386=item * item_proc
1387
1388This is a subroutine that takes the C<item_data> and the
1389C<HTML::Element>s found via C<item_ld> and produces an arrayref of
1390C<HTML::Element>s which will eventually be spliced into the container.
1391
1392Note that this subroutine MUST return the new items. This is done So
1393that more items than were passed in can be returned. This is useful
1394when, for example, you must return 2 dts for an input data item. And
1395when would you do this? When a single term has multiple spellings for
1396instance.
1397
1398default: expects C<item_data> to be an arrayref of two elements and
1399C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces
1400the content of the C<HTML::Element>s with the C<item_data>.
1401
1402=item * splice
1403
1404After building up an array of C<@item_elems>, the subroutine passed as
1405C<splice> will be given the parent container HTML::Element and the
1406C<@item_elems>. How the C<@item_elems> end up in the container is up
1407to this routine: it could put half of them in. It could unshift them
1408or whatever.
1409
1410default: C<< $container->splice_content(0, 2, @item_elems) >> In other
1411words, kill the 2 sample elements with the newly generated @item_elems
1412
1413=back
1414
1415So 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
1440The 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
1453Here'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
1468Matthew Sisk has a much more intuitive (imperative) way to generate
1469tables via his module L<HTML::ElementTable|HTML::ElementTable>.
1470
1471However, for those with callback fever, the following method is
1472available. First, we look at a nuts and bolts way to build a table
1473using only standard L<HTML::Tree> API calls. Then the C<table> method
1474available 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
1648This:
1649
1650 gi_tr => 'iterate',
1651
1652becomes this:
1653
1654 gi_tr => ['iterate1', 'iterate2']
1655
1656=head3 $tree->table2() : New API Call to Unroll a Table
1657
1658After 2 or 3 years with C<table()>, I began to develop production
1659websites with it and decided it needed a cleaner interface,
1660particularly in the area of handling the fact that C<id> tags will be
1661the same after cloning a table row.
1662
1663First, I will give a dry listing of the function's argument
1664parameters. This will not be educational most likely. A better way to
1665understand how to use the function is to read through the incremental
1666unrolling of the function's interface given in conversational style
1667after the dry listing. But take your pick. It's the same information
1668given in two different ways.
1669
1670=head4 Dry/technical parameter documentation
1671
1672C<< $tree->table2(%param) >> takes the following arguments:
1673
1674=over
1675
1676=item * C<< table_ld => $look_down >> : optional
1677
1678How to find the C<table> element in C<$tree>. If C<$look_down> is an
1679arrayref, then use C<look_down>. If it is a CODE ref, then call it,
1680passing it C<$tree>.
1681
1682Defaults to C<< ['_tag' => 'table'] >> if not passed in.
1683
1684=item * C<< table_data => $tabular_data >> : required
1685
1686The data to fill the table with. I<Must> be passed in.
1687
1688=item * C<< table_proc => $code_ref >> : not implemented
1689
1690A subroutine to do something to the table once it is found. Not
1691currently implemented. Not obviously necessary. Just created because
1692there is a C<tr_proc> and C<td_proc>.
1693
1694=item * C<< tr_ld => $look_down >> : optional
1695
1696Same as C<table_ld> but for finding the table row elements. Please
1697note that the C<tr_ld> is done on the table node that was found
1698I<instead> of the whole HTML tree. This makes sense. The C<tr>s that
1699you want exist below the table that was just found.
1700
1701Defaults to C<< ['_tag' => 'tr'] >> if not passed in.
1702
1703=item * C<< tr_data => $code_ref >> : optional
1704
1705How 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
1713Something to do to the table row we are about to add to the table we
1714are making. Defaults to a routine which makes the C<id> attribute
1715unique:
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
1724This coderef will take the row of data and operate on the C<td> cells
1725that are children of the C<tr>. See C<t/table2.t> for several usage
1726examples.
1727
1728Here'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
1742The first thing you need is a table. So we need a look down for that.
1743If you don't give one, it defaults to
1744
1745 ['_tag' => 'table']
1746
1747What good is a table to display in without data to display?! So you
1748must supply a scalar representing your tabular data source. This
1749scalar might be an array reference, a C<next>able iterator, a DBI
1750statement handle. Whatever it is, it can be iterated through to build
1751up rows of table data. These two required fields (the way to find the
1752table and the data to display in the table) are C<table_ld> and
1753C<table_data> respectively. A little more on C<table_ld>. If this
1754happens to be a CODE ref, then execution of the code ref is presumed
1755to return the C<HTML::Element> representing the table in the HTML
1756tree.
1757
1758Next, we get the row or rows which serve as sample C<tr> elements by
1759doing a C<look_down> from the C<table_elem>. While normally one sample
1760row is enough to unroll a table, consider when you have alternating
1761table rows. This API call would need one of each row so that it can
1762cycle through the sample rows as it loops through the data.
1763Alternatively, you could always just use one row and make the
1764necessary changes to the single C<tr> row by mutating the element in
1765C<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
1767a subroutine, then it is expected that the subroutine will return the
1768C<HTML::Element>(s) which are C<tr> element(s). The reason a
1769subroutine might be preferred is in the case that the HTML designers
1770gave you 8 sample C<tr> rows but only one prototype row is needed. So
1771you can write a subroutine, to splice out the 7 rows you don't need
1772and leave the one sample row remaining so that this API call can clone
1773it and supply it to the C<tr_proc> and C<td_proc> calls.
1774
1775Now, as we move through the table rows with table data, we need to do
1776two 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
1782The default procedure assumes the C<table_data> is an array reference
1783and shifts a row off of it:
1784
1785 sub {
1786 my ($self, $data) = @_;
1787 shift @{$data};
1788 }
1789
1790Your 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
1794The 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
1803Now that we have our row of data, we call C<td_proc> so that it can
1804take the data and the C<td> cells in this C<tr> and process them. This
1805function I<must> be supplied.
1806
1807=head3 Whither a Table with No Rows
1808
1809Often when a table has no rows, we want to display a message
1810indicating this to the view. Use conditional processing to decide what
1811to 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
1833This removes any nodes from the tree which consist of nothing or
1834nothing but whitespace. See also delete_ignorable_whitespace in
1835L<HTML::Element>.
1836
1837=head2 Loltree Functions
1838
1839A loltree is an arrayref consisting of arrayrefs which is used by C<<
1840new_from__lol >> in L<HTML::Element> to produce HTML trees. The CPAN
1841distro L<XML::Element::Tolol> creates such XML trees by parsing XML
e0dfa7be 1842files, analogous to L<XML::Toolkit>. The purpose of the functions in
0b6e6b69
MG
1843this section is to allow you manipulate a loltree programmatically.
1844
1845These could not be methods because if you bless a loltree, then
1846HTML::Tree will barf.
1847
1848=head3 HTML::Element::newchild($lol, $parent_label, @newchild)
1849
1850Given this initial loltree:
1851
1852 my $initial_lol = [ note => [ shopping => [ item => 'sample' ] ] ];
1853
1854This 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
1885Thanks to kcott and the other Perlmonks in this thread:
1886http://www.perlmonks.org/?node_id=912416
1887
1888
1889=head1 SEE ALSO
1890
1891=head2 L<HTML::Tree>
1892
1893A perl package for creating and manipulating HTML trees.
1894
1895=head2 L<HTML::ElementTable>
1896
1897An L<HTML::Tree> - based module which allows for manipulation of HTML
1898trees using cartesian coordinations.
1899
1900=head2 L<HTML::Seamstress>
1901
1902An L<HTML::Tree> - based module inspired by XMLC
1903(L<http://xmlc.enhydra.org>), allowing for dynamic HTML generation via
1904tree rewriting.
1905
1906=head2 Push-style templating systems
1907
1908A comprehensive cross-language
1909L<list of push-style templating systems|http://perlmonks.org/?node_id=674225>.
1910
1911=head1 TODO
1912
1913=over
1914
1915=item * highlander2
1916
1917currently the API expects the subtrees to survive or be pruned to be
1918identified 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
1932but, it should be more flexible. the C<under10>, and C<under18> are
1933expected to be ids in the tree... but it is not hard to have a check
1934to see if this field is an array reference and if it, then to do a
1935look 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
1953Original author Terrence Brannon, E<lt>tbone@cpan.orgE<gt>.
1954
1955Adopted by Marius Gavrilescu C<< <marius@ieval.ro> >>.
1956
1957I appreciate the feedback from M. David Moussa Leo Keita regarding
1958some issues with the test suite, namely (1) CRLF leading to test
1959breakage in F<t/crunch.t> and (2) using the wrong module in
1960F<t/prune.t> thus not having the right functionality available.
1961
1962Many thanks to BARBIE for his RT bug report.
1963
1964Many thanks to perlmonk kcott for his work on array rewriting:
1965L<http://www.perlmonks.org/?node_id=912416>. It was crucial in the
1966development of newchild.
1967
1968=head1 COPYRIGHT AND LICENSE
1969
13f94226 1970Coypright (C) 2014-2016 by Marius Gavrilescu
0b6e6b69
MG
1971
1972Copyright (C) 2004-2012 by Terrence Brannon
1973
1974This library is free software; you can redistribute it and/or modify
1975it under the same terms as Perl itself, either Perl version 5.8.4 or,
1976at your option, any later version of Perl 5 you may have available.
1977
1978
1979=cut
This page took 0.236559 seconds and 4 git commands to generate.