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