]>
Commit | Line | Data |
---|---|---|
67e78ff2 | 1 | package HTML::Element::Library; |
67e78ff2 | 2 | use strict; |
3 | use warnings; | |
4 | ||
13f94226 | 5 | our $VERSION = '5.220000'; |
67e78ff2 | 6 | our $DEBUG = 0; |
67e78ff2 | 7 | |
6c20681a MG |
8 | use Array::Group ':all'; |
9 | use Carp 'confess'; | |
67e78ff2 | 10 | use Data::Dumper; |
6c20681a | 11 | use Data::Rmap 'rmap_array'; |
67e78ff2 | 12 | use HTML::Element; |
6c20681a MG |
13 | use HTML::FillInForm; |
14 | use List::MoreUtils ':all'; | |
67e78ff2 | 15 | use List::Rotation::Cycle; |
6c20681a MG |
16 | use List::Util 'first'; |
17 | use Params::Validate ':all'; | |
18 | use Scalar::Listify; | |
67e78ff2 | 19 | |
2fcbbeb3 TB |
20 | # https://rt.cpan.org/Ticket/Display.html?id=44105 |
21 | sub 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 | 36 | sub 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 | 43 | sub 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 | 56 | sub 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 | ||
64 | sub 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 | 77 | sub 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 | 89 | sub 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 | 107 | sub 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 | 136 | sub 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 | 149 | sub 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 | 169 | sub HTML::Element::sibdex { |
6c20681a MG |
170 | my $element = shift; |
171 | firstidx { $_ eq $element } $element->siblings | |
67e78ff2 | 172 | } |
173 | ||
174 | sub HTML::Element::addr { goto &HTML::Element::sibdex } | |
175 | ||
176 | sub HTML::Element::replace_content { | |
6c20681a MG |
177 | my $elem = shift; |
178 | $elem->delete_content; | |
179 | $elem->push_content(@_); | |
67e78ff2 | 180 | } |
181 | ||
182 | sub 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 | ||
195 | sub HTML::Element::Library::super_literal { | |
6c20681a MG |
196 | my($text) = @_; |
197 | HTML::Element->new('~literal', text => $text); | |
67e78ff2 | 198 | } |
199 | ||
67e78ff2 | 200 | sub 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 | 216 | sub 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 | 224 | sub HTML::Element::assign { goto &HTML::Element::content_handler } |
67e78ff2 | 225 | |
226 | sub make_counter { | |
6c20681a MG |
227 | my $i = 1; |
228 | sub { | |
229 | shift() . ':' . $i++ | |
230 | } | |
67e78ff2 | 231 | } |
232 | ||
67e78ff2 | 233 | sub 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 |
249 | sub HTML::Element::itercb { |
250 | my ($self, $data, $code) = @_; | |
251 | my $orig = $self; | |
252 | my $prev = $orig; | |
253 | for my $el (@$data) { | |
254 | my $current = $orig->clone; | |
255 | $code->($el, $current); | |
256 | $prev->postinsert($current); | |
257 | $prev = $current; | |
258 | } | |
259 | $orig->detach; | |
260 | } | |
261 | ||
e87db89a | 262 | sub 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 | ||
343 | sub 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 | 367 | sub 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 | ||
382 | sub 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 | 421 | sub 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 | 482 | sub 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 | 488 | sub HTML::Element::overwrite_attr { |
6c20681a | 489 | my $tree = shift; |
67e78ff2 | 490 | |
6c20681a MG |
491 | $tree->mute_elem(@_, \&overwrite_action); |
492 | } | |
67e78ff2 | 493 | |
494 | sub 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 | ||
519 | sub 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 | ||
569 | sub 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 | 579 | sub 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 | 652 | sub 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 | 684 | sub 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 | ||
690 | sub 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 |
697 | sub HTML::Element::fid { shift->look_down(id => $_[0]) } |
698 | sub HTML::Element::fclass { shift->look_down(class => qr/\b$_[0]\b/s) } | |
699 | ||
67e78ff2 | 700 | 1; |
701 | __END__ | |
0b6e6b69 MG |
702 | |
703 | =encoding utf-8 | |
704 | ||
705 | =head1 NAME | |
706 | ||
707 | HTML::Element::Library - HTML::Element convenience functions | |
708 | ||
709 | =head1 SYNOPSIS | |
710 | ||
711 | use HTML::Element::Library; | |
712 | use HTML::TreeBuilder; | |
713 | ||
714 | =head1 DESCRIPTION | |
715 | ||
df110877 | 716 | HTML:::Element::Library provides extra methods for HTML::Element. |
0b6e6b69 MG |
717 | |
718 | =head1 METHODS | |
719 | ||
dbfa87a3 MG |
720 | =head2 Aliases |
721 | ||
722 | These are short aliases for common operations: | |
723 | ||
724 | =over | |
725 | ||
726 | =item I<$el>->B<fid>(I<$id>) | |
727 | ||
728 | Finds an element given its id. Equivalent to C<< $el->look_down(id => $id) >>. | |
729 | ||
730 | =item I<$el>->B<fclass>(I<$class>) | |
731 | ||
732 | Finds one or more elements given one of their classes. Equivalent to C<< $el->look_down(class => qr/\b$class\b/s) >> | |
733 | ||
734 | =back | |
735 | ||
0b6e6b69 MG |
736 | =head2 Positional Querying Methods |
737 | ||
738 | =head3 $elem->siblings | |
739 | ||
740 | Return a list of all nodes under the same parent. | |
741 | ||
742 | =head3 $elem->sibdex | |
743 | ||
744 | Return the index of C<$elem> into the array of siblings of which it is | |
745 | a part. L<HTML::ElementSuper> calls this method C<addr> but I don't | |
746 | think that is a descriptive name. And such naming is deceptively close | |
747 | to the C<address> function of C<HTML::Element>. HOWEVER, in the | |
748 | interest of backwards compatibility, both methods are available. | |
749 | ||
750 | =head3 $elem->addr | |
751 | ||
752 | Same as sibdex | |
753 | ||
754 | =head3 $elem->position() | |
755 | ||
756 | Returns the coordinates of this element in the tree it inhabits. This | |
757 | is accomplished by succesively calling addr() on ancestor elements | |
758 | until either a) an element that does not support these methods is | |
759 | found, or b) there are no more parents. The resulting list is the | |
760 | n-dimensional coordinates of the element in the tree. | |
761 | ||
762 | =head2 Element Decoration Methods | |
763 | ||
764 | =head3 HTML::Element::Library::super_literal($text) | |
765 | ||
766 | In L<HTML::Element>, Sean Burke discusses super-literals. They are | |
767 | text which does not get escaped. Great for includng Javascript in | |
768 | HTML. Also great for including foreign language into a document. | |
769 | ||
770 | So, you basically toss C<super_literal> your text and back comes your | |
771 | text wrapped in a C<~literal> element. | |
772 | ||
773 | One of these days, I'll around to writing a nice C<EXPORT> section. | |
774 | ||
775 | =head2 Tree Rewriting Methods | |
776 | ||
777 | =head3 "de-prepping" HTML | |
778 | ||
779 | Oftentimes, the HTML to be worked with will have multiple sample rows: | |
780 | ||
781 | <OL> | |
782 | <LI>bread | |
783 | <LI>butter | |
784 | <LI>beer | |
785 | <LI>bacon | |
786 | </OL> | |
787 | ||
788 | But, before you begin to rewrite the HTML with your model data, you | |
789 | typically only want 1 or 2 sample rows. | |
790 | ||
791 | Thus, you want to "crunch" the multiple sample rows to a specified | |
792 | amount. Hence the C<crunch> method: | |
793 | ||
794 | $tree->crunch(look_down => [ '_tag' => 'li' ], leave => 2) ; | |
795 | ||
796 | The C<leave> argument defaults to 1 if not given. The call above would | |
797 | "crunch" the above 4 sample rows to: | |
798 | ||
799 | <OL> | |
800 | <LI>bread | |
801 | <LI>butter | |
802 | </OL> | |
803 | ||
804 | =head3 Simplifying calls to HTML::FillInForm | |
805 | ||
806 | Since HTML::FillInForm gets and returns strings, using HTML::Element | |
807 | instances becomes tedious: | |
808 | ||
809 | 1. Seamstress has an HTML tree that it wants the form filled in on | |
810 | 2. Seamstress converts this tree to a string | |
811 | 3. FillInForm parses the string into an HTML tree and then fills in the form | |
812 | 4. FillInForm converts the HTML tree to a string | |
813 | 5. Seamstress re-parses the HTML for additional processing | |
814 | ||
815 | I've filed a bug about this: | |
816 | L<https://rt.cpan.org/Ticket/Display.html?id=44105> | |
817 | ||
818 | This function, fillinform, allows you to pass a tree to fillinform | |
819 | (along with your data structure) and get back a tree: | |
820 | ||
821 | my $new_tree = $html_tree->fillinform($data_structure); | |
822 | ||
823 | =head3 Mapping a hashref to HTML elements | |
824 | ||
825 | It is very common to get a hashref of data from some external source - | |
826 | flat file, database, XML, etc. Therefore, it is important to have a | |
827 | convenient way of mapping this data to HTML. | |
828 | ||
829 | As it turns out, there are 3 ways to do this in | |
830 | HTML::Element::Library. The most strict and structured way to do this | |
831 | is with C<content_handler>. Two other methods, C<hashmap> and | |
832 | C<datamap> require less manual mapping and may prove even more easy to | |
833 | use in certain cases. | |
834 | ||
835 | As is usual with Perl, a practical example is always best. So let's | |
836 | take some sample HTML: | |
837 | ||
838 | <h1>user data</h1> | |
839 | <span id="name">?</span> | |
840 | <span id="email">?</span> | |
841 | <span id="gender">?</span> | |
842 | ||
843 | Now, let's say our data structure is this: | |
844 | ||
845 | $ref = { email => 'jim@beam.com', gender => 'lots' } ; | |
846 | ||
847 | And let's start with the most strict way to get what you want: | |
848 | ||
849 | $tree->content_handler(email => $ref->{email} , gender => $ref->{gender}) ; | |
850 | ||
851 | In this case, you manually state the mapping between id tags and | |
852 | hashref keys and then C<content_handler> retrieves the hashref data | |
853 | and pops it in the specified place. | |
854 | ||
855 | Now let's look at the two (actually 2 and a half) other hash-mapping | |
856 | methods. | |
857 | ||
858 | $tree->hashmap(id => $ref); | |
859 | ||
860 | Now, what this function does is super-destructive. It finds every | |
861 | element in the tree with an attribute named id (since 'id' is a | |
862 | parameter, it could find every element with some other attribute also) | |
863 | and replaces the content of those elements with the hashref value. | |
864 | ||
865 | So, in the case above, the | |
866 | ||
867 | <span id="name">?</span> | |
868 | ||
869 | would come out as | |
870 | ||
871 | <span id="name"></span> | |
872 | ||
873 | (it would be blank) - because there is nothing in the hash with that | |
874 | value, so it substituted | |
875 | ||
876 | $ref->{name} | |
877 | ||
878 | which was blank and emptied the contents. | |
879 | ||
880 | Now, let's assume we want to protect name from being auto-assigned. | |
881 | Here is what you do: | |
882 | ||
883 | $tree->hashmap(id => $ref, ['name']); | |
884 | ||
885 | That last array ref is an exclusion list. | |
886 | ||
887 | But wouldnt it be nice if you could do a hashmap, but only assigned | |
888 | things which are defined in the hashref? C<< defmap() >> to the | |
889 | rescue: | |
890 | ||
891 | $tree->defmap(id => $ref); | |
892 | ||
893 | does just that, so | |
894 | ||
895 | <span id="name">?</span> | |
896 | ||
897 | would be left alone. | |
898 | ||
899 | =head4 $elem->hashmap($attr_name, \%hashref, \@excluded, $debug) | |
900 | ||
901 | This method is designed to take a hashref and populate a series of | |
902 | elements. For example: | |
903 | ||
904 | <table> | |
905 | <tr sclass="tr" class="alt" align="left" valign="top"> | |
906 | <td smap="people_id">1</td> | |
907 | <td smap="phone">(877) 255-3239</td> | |
908 | <td smap="password">*********</td> | |
909 | </tr> | |
910 | </table> | |
911 | ||
912 | In the table above, there are several attributes named C<< smap >>. If | |
913 | we have a hashref whose keys are the same: | |
914 | ||
915 | my %data = (people_id => 888, phone => '444-4444', password => 'dont-you-dare-render'); | |
916 | ||
917 | Then a single API call allows us to populate the HTML while excluding | |
e0dfa7be | 918 | those ones we don't: |
0b6e6b69 MG |
919 | |
920 | $tree->hashmap(smap => \%data, ['password']); | |
921 | ||
922 | Note: the other way to prevent rendering some of the hash mapping is | |
923 | to not give that element the attr you plan to use for hash mapping. | |
924 | ||
925 | Also note: the function C<< hashmap >> has a simple easy-to-type API. | |
926 | Interally, it calls C<< hash_map >> (which has a more verbose keyword | |
927 | calling API). Thus, the above call to C<hashmap()> results in this | |
928 | call: | |
929 | ||
930 | $tree->hash_map(hash => \%data, to_attr => 'sid', excluding => ['password']); | |
931 | ||
932 | =head4 $elem->defmap($attr_name, \%hashref, $debug) | |
933 | ||
934 | C<defmap> was described above. | |
935 | ||
936 | =head3 $elem->replace_content(@new_elem) | |
937 | ||
938 | Replaces all of C<$elem>'s content with C<@new_elem>. | |
939 | ||
940 | =head3 $elem->wrap_content($wrapper_element) | |
941 | ||
942 | Wraps the existing content in the provided element. If the provided | |
943 | element happens to be a non-element, a push_content is performed | |
944 | instead. | |
945 | ||
946 | =head3 $elem->set_child_content(@look_down, $content) | |
947 | ||
948 | This method looks down $tree using the criteria specified in | |
949 | @look_down using the the HTML::Element look_down() method. | |
950 | ||
951 | After finding the node, it detaches the node's content and pushes | |
952 | $content as the node's content. | |
953 | ||
954 | =head3 $tree->content_handler(%id_content) | |
955 | ||
956 | This is a convenience method. Because the look_down criteria will | |
957 | often simply be: | |
958 | ||
959 | id => 'fixme' | |
960 | ||
961 | to find things like: | |
962 | ||
963 | <a id=fixme href=http://www.somesite.org>replace_content</a> | |
964 | ||
965 | You can call this method to shorten your typing a bit. You can simply | |
966 | type | |
967 | ||
968 | $elem->content_handler( fixme => 'new text' ) | |
969 | ||
970 | Instead of typing: | |
971 | ||
972 | $elem->set_child_content(sid => 'fixme', 'new text') | |
973 | ||
974 | ALSO NOTE: you can pass a hash whose keys are C<id>s and whose values | |
975 | are the content you want there and it will perform the replacement on | |
976 | each hash member: | |
977 | ||
978 | my %id_content = (name => "Terrence Brannon", | |
979 | email => 'tbrannon@in.com', | |
980 | balance => 666, | |
981 | content => $main_content); | |
982 | $tree->content_handler(%id_content); | |
983 | ||
984 | =head3 $tree->highlander($subtree_span_id, $conditionals, @conditionals_args) | |
985 | ||
986 | This allows for "if-then-else" style processing. Highlander was a | |
987 | movie in which only one would survive. Well, in terms of a tree when | |
988 | looking at a structure that you want to process in C<if-then-else> | |
989 | style, only one child will survive. For example, given this HTML | |
990 | template: | |
991 | ||
992 | <span klass="highlander" id="age_dialog"> | |
993 | <span id="under10"> | |
994 | Hello, does your mother know you're | |
995 | using her AOL account? | |
996 | </span> | |
997 | <span id="under18"> | |
998 | Sorry, you're not old enough to enter | |
999 | (and too dumb to lie about your age) | |
1000 | </span> | |
1001 | <span id="welcome"> | |
1002 | Welcome | |
1003 | </span> | |
1004 | </span> | |
1005 | ||
1006 | We only want one child of the C<span> tag with id C<age_dialog> to | |
1007 | remain based on the age of the person visiting the page. | |
1008 | ||
1009 | So, let's setup a call that will prune the subtree as a function of | |
1010 | age: | |
1011 | ||
1012 | sub process_page { | |
1013 | my $age = shift; | |
1014 | my $tree = HTML::TreeBuilder->new_from_file('t/html/highlander.html'); | |
1015 | ||
1016 | $tree->highlander | |
1017 | (age_dialog => | |
1018 | [ | |
1019 | under10 => sub { $_[0] < 10}, | |
1020 | under18 => sub { $_[0] < 18}, | |
1021 | welcome => sub { 1 } | |
1022 | ], | |
1023 | $age | |
1024 | ); | |
1025 | ||
1026 | And there we have it. If the age is less than 10, then the node with | |
1027 | id C<under10> remains. For age less than 18, the node with id | |
1028 | C<under18> remains. Otherwise our "else" condition fires and the child | |
1029 | with id C<welcome> remains. | |
1030 | ||
1031 | =head3 $tree->passover(@id_of_element) | |
1032 | ||
1033 | In some cases, you know exactly which element(s) should survive. In | |
1034 | this case, you can simply call C<passover> to remove it's (their) | |
1035 | siblings. For the HTML above, you could delete C<under10> and | |
1036 | C<welcome> by simply calling: | |
1037 | ||
1038 | $tree->passover('under18'); | |
1039 | ||
1040 | Because passover takes an array, you can specify several children to | |
1041 | preserve. | |
1042 | ||
1043 | =head3 $tree->highlander2($tree, $conditionals, @conditionals_args) | |
1044 | ||
1045 | Right around the same time that C<table2()> came into being, | |
1046 | Seamstress began to tackle tougher and tougher processing problems. It | |
1047 | became clear that a more powerful highlander was needed... one that | |
1048 | not only snipped the tree of the nodes that should not survive, but | |
1049 | one that allows for post-processing of the survivor node. And one that | |
1050 | was more flexible with how to find the nodes to snip. | |
1051 | ||
1052 | Thus (drum roll) C<highlander2()>. | |
1053 | ||
1054 | So let's look at our HTML which requires post-selection processing: | |
1055 | ||
1056 | <span klass="highlander" id="age_dialog"> | |
1057 | <span id="under10"> | |
1058 | Hello, little <span id=age>AGE</span>-year old, | |
1059 | does your mother know you're using her AOL account? | |
1060 | </span> | |
1061 | <span id="under18"> | |
1062 | Sorry, you're only <span id=age>AGE</span> | |
1063 | (and too dumb to lie about your age) | |
1064 | </span> | |
1065 | <span id="welcome"> | |
1066 | Welcome, isn't it good to be <span id=age>AGE</span> years old? | |
1067 | </span> | |
1068 | </span> | |
1069 | ||
1070 | In this case, a branch survives, but it has dummy data in it. We must | |
1071 | take the surviving segment of HTML and rewrite the age C<span> with | |
1072 | the age. Here is how we use C<highlander2()> to do so: | |
1073 | ||
1074 | sub replace_age { | |
1075 | my $branch = shift; | |
1076 | my $age = shift; | |
1077 | $branch->look_down(id => 'age')->replace_content($age); | |
1078 | } | |
1079 | ||
1080 | my $if_then = $tree->look_down(id => 'age_dialog'); | |
1081 | ||
1082 | $if_then->highlander2( | |
1083 | cond => [ | |
1084 | under10 => [ | |
1085 | sub { $_[0] < 10} , | |
1086 | \&replace_age | |
1087 | ], | |
1088 | under18 => [ | |
1089 | sub { $_[0] < 18} , | |
1090 | \&replace_age | |
1091 | ], | |
1092 | welcome => [ | |
1093 | sub { 1 }, | |
1094 | \&replace_age | |
1095 | ] | |
1096 | ], | |
1097 | cond_arg => [ $age ] | |
1098 | ); | |
1099 | ||
1100 | We pass it the tree (C<$if_then>), an arrayref of conditions (C<cond>) | |
1101 | and an arrayref of arguments which are passed to the C<cond>s and to | |
1102 | the replacement subs. | |
1103 | ||
1104 | The C<under10>, C<under18> and C<welcome> are id attributes in the | |
1105 | tree of the siblings of which only one will survive. However, should | |
1106 | you need to do more complex look-downs to find the survivor, then | |
1107 | supply an array ref instead of a simple scalar: | |
1108 | ||
1109 | $if_then->highlander2( | |
1110 | cond => [ | |
1111 | [class => 'r12'] => [ | |
1112 | sub { $_[0] < 10} , | |
1113 | \&replace_age | |
1114 | ], | |
1115 | [class => 'z22'] => [ | |
1116 | sub { $_[0] < 18} , | |
1117 | \&replace_age | |
1118 | ], | |
1119 | [class => 'w88'] => [ | |
1120 | sub { 1 }, | |
1121 | \&replace_age | |
1122 | ] | |
1123 | ], | |
1124 | cond_arg => [ $age ] | |
1125 | ); | |
1126 | ||
1127 | =head3 $tree->overwrite_attr($mutation_attr => $mutating_closures) | |
1128 | ||
1129 | This method is designed for taking a tree and reworking a set of nodes | |
1130 | in a stereotyped fashion. For instance let's say you have 3 remote | |
1131 | image archives, but you don't want to put long URLs in your img src | |
1132 | tags for reasons of abstraction, re-use and brevity. So instead you do | |
1133 | this: | |
1134 | ||
1135 | <img src="/img/smiley-face.jpg" fixup="src lnc"> | |
1136 | <img src="/img/hot-babe.jpg" fixup="src playboy"> | |
1137 | <img src="/img/footer.jpg" fixup="src foobar"> | |
1138 | ||
1139 | and then when the tree of HTML is being processed, you make this call: | |
1140 | ||
1141 | my %closures = ( | |
1142 | lnc => sub { my ($tree, $mute_node, $attr_value)= @_; "http://lnc.usc.edu$attr_value" }, | |
1143 | playboy => sub { my ($tree, $mute_node, $attr_value)= @_; "http://playboy.com$attr_value" } | |
1144 | foobar => sub { my ($tree, $mute_node, $attr_value)= @_; "http://foobar.info$attr_value" } | |
1145 | ) | |
1146 | ||
1147 | $tree->overwrite_attr(fixup => \%closures) ; | |
1148 | ||
1149 | and the tags come out modified like so: | |
1150 | ||
1151 | <img src="http://lnc.usc.edu/img/smiley-face.jpg" fixup="src lnc"> | |
1152 | <img src="http://playboy.com/img/hot-babe.jpg" fixup="src playboy"> | |
1153 | <img src="http://foobar.info/img/footer.jpg" fixup="src foobar"> | |
1154 | ||
1155 | =head3 $tree->mute_elem($mutation_attr => $mutating_closures, [ $post_hook ] ) | |
1156 | ||
1157 | This is a generalization of C<overwrite_attr>. C<overwrite_attr> | |
1158 | assumes the return value of the closure is supposed overwrite an | |
1159 | attribute value and does it for you. C<mute_elem> is a more general | |
1160 | function which does nothing but hand the closure the element and let | |
1161 | it mutate it as it jolly well pleases :) | |
1162 | ||
1163 | In fact, here is the implementation of C<overwrite_attr> to give you a | |
1164 | taste of how C<mute_attr> is used: | |
1165 | ||
1166 | sub overwrite_action { | |
1167 | my ($mute_node, %X) = @_; | |
1168 | ||
1169 | $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new}); | |
1170 | } | |
1171 | ||
1172 | ||
1173 | sub HTML::Element::overwrite_attr { | |
1174 | my $tree = shift; | |
1175 | ||
1176 | $tree->mute_elem(@_, \&overwrite_action); | |
1177 | } | |
1178 | ||
1179 | =head2 Tree-Building Methods | |
1180 | ||
1181 | =head3 Unrolling an array via a single sample element (<ul> container) | |
1182 | ||
1183 | This is best described by example. Given this HTML: | |
1184 | ||
1185 | <strong>Here are the things I need from the store:</strong> | |
1186 | <ul> | |
1187 | <li class="store_items">Sample item</li> | |
1188 | </ul> | |
1189 | ||
1190 | We can unroll it like so: | |
1191 | ||
1192 | my $li = $tree->look_down(class => 'store_items'); | |
1193 | ||
1194 | my @items = qw(bread butter vodka); | |
1195 | ||
1196 | $tree->iter($li => @items); | |
1197 | ||
1198 | To produce this: | |
1199 | ||
1200 | <html> | |
1201 | <head></head> | |
1202 | <body>Here are the things I need from the store: | |
1203 | <ul> | |
1204 | <li class="store_items">bread</li> | |
1205 | <li class="store_items">butter</li> | |
1206 | <li class="store_items">vodka</li> | |
1207 | </ul> | |
1208 | </body> | |
1209 | </html> | |
1210 | ||
1211 | Now, you might be wondering why the API call is: | |
1212 | ||
1213 | $tree->iter($li => @items) | |
1214 | ||
1215 | instead of: | |
1216 | ||
1217 | $li->iter(@items) | |
1218 | ||
1219 | and there is no good answer. The latter would be more concise and it | |
1220 | is what I should have done. | |
1221 | ||
dbfa87a3 MG |
1222 | =head3 Unrolling an array via a single sample element and a callback (<ul> container) |
1223 | ||
1224 | This is a more advanced version of the previous method. Instead of | |
1225 | cloning the sample element several times and calling | |
1226 | C<replace_content> on the clone with the array element, a custom | |
1227 | callback is called with the clone and array element. | |
1228 | ||
1229 | Here is the example from before. | |
1230 | ||
1231 | <strong>Here are the things I need from the store:</strong> | |
1232 | <ul> | |
1233 | <li class="store_items">Sample item</li> | |
1234 | </ul> | |
1235 | ||
1236 | Code: | |
1237 | ||
1238 | sub cb { | |
1239 | my ($data, $li) = @_; | |
1240 | $li->replace_content($data); | |
1241 | } | |
1242 | ||
1243 | my $li = $tree->look_down(class => 'store_items'); | |
1244 | my @items = qw(bread butter vodka); | |
1245 | $li->itercb(\@items, \&cb); | |
1246 | ||
1247 | Output is as before: | |
1248 | ||
1249 | <html> | |
1250 | <head></head> | |
1251 | <body>Here are the things I need from the store: | |
1252 | <ul> | |
1253 | <li class="store_items">bread</li> | |
1254 | <li class="store_items">butter</li> | |
1255 | <li class="store_items">vodka</li> | |
1256 | </ul> | |
1257 | </body> | |
1258 | </html> | |
1259 | ||
1260 | Here is a more complex example (unrolling a table). HTML: | |
1261 | ||
1262 | <table><thead><th>First Name<th>Last Name<th>Option</thead> | |
1263 | <tbody> | |
1264 | <tr><td class="first">First<td class="last">Last<td class="option">1 | |
1265 | </tbody></table> | |
1266 | ||
1267 | Code: | |
1268 | ||
1269 | sub tr_cb { | |
1270 | my ($data, $tr) = @_; | |
1271 | $tr->look_down(class => 'first')->replace_content($data->{first}); | |
1272 | $tr->look_down(class => 'last')->replace_content($data->{last}); | |
1273 | $tr->look_down(class => 'option')->replace_content($data->{option}); | |
1274 | } | |
1275 | ||
1276 | my @data = ( | |
1277 | {first => 'Foo', last => 'Bar', option => 2}, | |
1278 | {first => 'Bar', last => 'Bar', option => 3}, | |
1279 | {first => 'Baz', last => 'Bar', option => 4}, | |
1280 | ); | |
1281 | ||
1282 | my $tr = $tree->find('table')->find('tbody')->find('tr'); | |
1283 | $tr->itercb(\@data, \&tr_cb); | |
1284 | ||
1285 | Produces: | |
1286 | ||
1287 | <table><thead><th>First Name<th>Last Name<th>Option</thead> | |
1288 | <tbody> | |
1289 | <tr><td class="first">Foo<td class="last">Bar<td class="option">2 | |
1290 | <tr><td class="first">Bar<td class="last">Bar<td class="option">3 | |
1291 | <tr><td class="first">Baz<td class="last">Bar<td class="option">4 | |
1292 | </tbody></table> | |
1293 | ||
0b6e6b69 MG |
1294 | =head3 Unrolling an array via n sample elements (<dl> container) |
1295 | ||
1296 | C<iter()> was fine for awhile, but some things (e.g. definition lists) | |
1297 | need a more general function to make them easy to do. Hence | |
1298 | C<iter2()>. This function will be explained by example of unrolling a | |
1299 | simple definition list. | |
1300 | ||
1301 | So here's our mock-up HTML from the designer: | |
1302 | ||
1303 | <dl class="dual_iter" id="service_plan"> | |
1304 | <dt>Artist</dt> | |
1305 | <dd>A person who draws blood.</dd> | |
1306 | ||
1307 | <dt>Musician</dt> | |
1308 | <dd>A clone of Iggy Pop.</dd> | |
1309 | ||
1310 | <dt>Poet</dt> | |
1311 | <dd>A relative of Edgar Allan Poe.</dd> | |
1312 | ||
1313 | <dt class="adstyle">sample header</dt> | |
1314 | <dd class="adstyle2">sample data</dd> | |
1315 | </dl> | |
1316 | ||
1317 | ||
1318 | And we want to unroll our data set: | |
1319 | ||
1320 | my @items = ( | |
1321 | ['the pros' => 'never have to worry about service again'], | |
1322 | ['the cons' => 'upfront extra charge on purchase'], | |
1323 | ['our choice' => 'go with the extended service plan'] | |
1324 | ); | |
1325 | ||
1326 | ||
1327 | Now, let's make this problem a bit harder to show off the power of | |
1328 | C<iter2()>. Let's assume that we want only the last <dt> and it's | |
1329 | accompanying <dd> (the one with "sample data") to be used as the | |
1330 | sample data for unrolling with our data set. Let's further assume that | |
1331 | we want them to remain in the final output. | |
1332 | ||
1333 | So now, the API to C<iter2()> will be discussed and we will explain | |
1334 | how our goal of getting our data into HTML fits into the API. | |
1335 | ||
1336 | =over 4 | |
1337 | ||
1338 | =item * wrapper_ld | |
1339 | ||
1340 | This is how to look down and find the container of all the elements we | |
1341 | will be unrolling. The <dl> tag is the container for the dt and dd | |
1342 | tags we will be unrolling. | |
1343 | ||
1344 | If you pass an anonymous subroutine, then it is presumed that | |
1345 | execution of this subroutine will return the HTML::Element | |
1346 | representing the container tag. If you pass an array ref, then this | |
1347 | will be dereferenced and passed to C<HTML::Element::look_down()>. | |
1348 | ||
1349 | default value: C<< ['_tag' => 'dl'] >> | |
1350 | ||
1351 | Based on the mock HTML above, this default is fine for finding our | |
1352 | container tag. So let's move on. | |
1353 | ||
1354 | =item * wrapper_data | |
1355 | ||
1356 | This is an array reference of data that we will be putting into the | |
1357 | container. You must supply this. C<@items> above is our | |
1358 | C<wrapper_data>. | |
1359 | ||
1360 | =item * wrapper_proc | |
1361 | ||
1362 | After we find the container via C<wrapper_ld>, we may want to | |
1363 | pre-process some aspect of this tree. In our case the first two sets | |
1364 | of dt and dd need to be removed, leaving the last dt and dd. So, we | |
1365 | supply a C<wrapper_proc> which will do this. | |
1366 | ||
1367 | default: undef | |
1368 | ||
1369 | =item * item_ld | |
1370 | ||
1371 | This anonymous subroutine returns an array ref of C<HTML::Element>s | |
1372 | that will be cloned and populated with item data (item data is a "row" | |
1373 | of C<wrapper_data>). | |
1374 | ||
1375 | default: returns an arrayref consisting of the dt and dd element | |
1376 | inside the container. | |
1377 | ||
1378 | =item * item_data | |
1379 | ||
1380 | This is a subroutine that takes C<wrapper_data> and retrieves one | |
1381 | "row" to be "pasted" into the array ref of C<HTML::Element>s found via | |
1382 | C<item_ld>. I hope that makes sense. | |
1383 | ||
1384 | default: shifts C<wrapper_data>. | |
1385 | ||
1386 | =item * item_proc | |
1387 | ||
1388 | This is a subroutine that takes the C<item_data> and the | |
1389 | C<HTML::Element>s found via C<item_ld> and produces an arrayref of | |
1390 | C<HTML::Element>s which will eventually be spliced into the container. | |
1391 | ||
1392 | Note that this subroutine MUST return the new items. This is done So | |
1393 | that more items than were passed in can be returned. This is useful | |
1394 | when, for example, you must return 2 dts for an input data item. And | |
1395 | when would you do this? When a single term has multiple spellings for | |
1396 | instance. | |
1397 | ||
1398 | default: expects C<item_data> to be an arrayref of two elements and | |
1399 | C<item_elems> to be an arrayref of two C<HTML::Element>s. It replaces | |
1400 | the content of the C<HTML::Element>s with the C<item_data>. | |
1401 | ||
1402 | =item * splice | |
1403 | ||
1404 | After building up an array of C<@item_elems>, the subroutine passed as | |
1405 | C<splice> will be given the parent container HTML::Element and the | |
1406 | C<@item_elems>. How the C<@item_elems> end up in the container is up | |
1407 | to this routine: it could put half of them in. It could unshift them | |
1408 | or whatever. | |
1409 | ||
1410 | default: C<< $container->splice_content(0, 2, @item_elems) >> In other | |
1411 | words, kill the 2 sample elements with the newly generated @item_elems | |
1412 | ||
1413 | =back | |
1414 | ||
1415 | So now that we have documented the API, let's see the call we need: | |
1416 | ||
1417 | $tree->iter2( | |
1418 | # default wrapper_ld ok. | |
1419 | wrapper_data => \@items, | |
1420 | wrapper_proc => sub { | |
1421 | my ($container) = @_; | |
1422 | ||
1423 | # only keep the last 2 dts and dds | |
1424 | my @content_list = $container->content_list; | |
1425 | $container->splice_content(0, @content_list - 2); | |
1426 | }, | |
1427 | ||
1428 | # default item_ld is fine. | |
1429 | # default item_data is fine. | |
1430 | # default item_proc is fine. | |
1431 | splice => sub { | |
1432 | my ($container, @item_elems) = @_; | |
1433 | $container->unshift_content(@item_elems); | |
1434 | }, | |
1435 | debug => 1, | |
1436 | ); | |
1437 | ||
1438 | =head3 Select Unrolling | |
1439 | ||
1440 | The C<unroll_select> method has this API: | |
1441 | ||
1442 | $tree->unroll_select( | |
1443 | select_label => $id_label, | |
1444 | option_value => $closure, # how to get option value from data row | |
1445 | option_content => $closure, # how to get option content from data row | |
1446 | option_selected => $closure, # boolean to decide if SELECTED | |
1447 | data => $data # the data to be put into the SELECT | |
1448 | data_iter => $closure # the thing that will get a row of data | |
1449 | debug => $boolean, | |
1450 | append => $boolean, # remove the sample <OPTION> data or append? | |
1451 | ); | |
1452 | ||
1453 | Here's an example: | |
1454 | ||
1455 | $tree->unroll_select( | |
1456 | select_label => 'clan_list', | |
1457 | option_value => sub { my $row = shift; $row->clan_id }, | |
1458 | option_content => sub { my $row = shift; $row->clan_name }, | |
1459 | option_selected => sub { my $row = shift; $row->selected }, | |
1460 | data => \@query_results, | |
1461 | data_iter => sub { my $data = shift; $data->next }, | |
1462 | append => 0, | |
1463 | debug => 0 | |
1464 | ); | |
1465 | ||
1466 | =head2 Tree-Building Methods: Table Generation | |
1467 | ||
1468 | Matthew Sisk has a much more intuitive (imperative) way to generate | |
1469 | tables via his module L<HTML::ElementTable|HTML::ElementTable>. | |
1470 | ||
1471 | However, for those with callback fever, the following method is | |
1472 | available. First, we look at a nuts and bolts way to build a table | |
1473 | using only standard L<HTML::Tree> API calls. Then the C<table> method | |
1474 | available here is discussed. | |
1475 | ||
1476 | =head3 Sample Model | |
1477 | ||
1478 | package Simple::Class; | |
1479 | ||
1480 | use Set::Array; | |
1481 | ||
1482 | my @name = qw(bob bill brian babette bobo bix); | |
1483 | my @age = qw(99 12 44 52 12 43); | |
1484 | my @weight = qw(99 52 80 124 120 230); | |
1485 | ||
1486 | ||
1487 | sub new { | |
1488 | my $this = shift; | |
1489 | bless {}, ref($this) || $this; | |
1490 | } | |
1491 | ||
1492 | sub load_data { | |
1493 | my @data; | |
1494 | ||
1495 | for (0 .. 5) { | |
1496 | push @data, { | |
1497 | age => $age[rand $#age] + int rand 20, | |
1498 | name => shift @name, | |
1499 | weight => $weight[rand $#weight] + int rand 40 | |
1500 | } | |
1501 | } | |
1502 | ||
1503 | Set::Array->new(@data); | |
1504 | } | |
1505 | ||
1506 | 1; | |
1507 | ||
1508 | =head4 Sample Usage: | |
1509 | ||
1510 | my $data = Simple::Class->load_data; | |
1511 | ++$_->{age} for @$data | |
1512 | ||
1513 | =head3 Inline Code to Unroll a Table | |
1514 | ||
1515 | =head4 HTML | |
1516 | ||
1517 | <html> | |
1518 | <table id="load_data"> | |
1519 | <tr> <th>name</th><th>age</th><th>weight</th> </tr> | |
1520 | <tr id="iterate"> | |
1521 | <td id="name"> NATURE BOY RIC FLAIR </td> | |
1522 | <td id="age"> 35 </td> | |
1523 | <td id="weight"> 220 </td> | |
1524 | </tr> | |
1525 | </table> | |
1526 | </html> | |
1527 | ||
1528 | ||
1529 | =head4 The manual way (*NOT* recommended) | |
1530 | ||
1531 | require 'simple-class.pl'; | |
1532 | use HTML::Seamstress; | |
1533 | ||
1534 | # load the view | |
1535 | my $seamstress = HTML::Seamstress->new_from_file('simple.html'); | |
1536 | ||
1537 | # load the model | |
1538 | my $o = Simple::Class->new; | |
1539 | my $data = $o->load_data; | |
1540 | ||
1541 | # find the <table> and <tr> | |
1542 | my $table_node = $seamstress->look_down('id', 'load_data'); | |
1543 | my $iter_node = $table_node->look_down('id', 'iterate'); | |
1544 | my $table_parent = $table_node->parent; | |
1545 | ||
1546 | ||
1547 | # drop the sample <table> and <tr> from the HTML | |
1548 | # only add them in if there is data in the model | |
1549 | # this is achieved via the $add_table flag | |
1550 | ||
1551 | $table_node->detach; | |
1552 | $iter_node->detach; | |
1553 | my $add_table; | |
1554 | ||
1555 | # Get a row of model data | |
1556 | while (my $row = shift @$data) { | |
1557 | ||
1558 | # We got row data. Set the flag indicating ok to hook the table into the HTML | |
1559 | ++$add_table; | |
1560 | ||
1561 | # clone the sample <tr> | |
1562 | my $new_iter_node = $iter_node->clone; | |
1563 | ||
1564 | # find the tags labeled name age and weight and | |
1565 | # set their content to the row data | |
1566 | $new_iter_node->content_handler($_ => $row->{$_}) | |
1567 | for qw(name age weight); | |
1568 | ||
1569 | $table_node->push_content($new_iter_node); | |
1570 | ||
1571 | } | |
1572 | ||
1573 | # reattach the table to the HTML tree if we loaded data into some table rows | |
1574 | ||
1575 | $table_parent->push_content($table_node) if $add_table; | |
1576 | ||
1577 | print $seamstress->as_HTML; | |
1578 | ||
1579 | =head3 $tree->table() : API call to Unroll a Table | |
1580 | ||
1581 | require 'simple-class.pl'; | |
1582 | use HTML::Seamstress; | |
1583 | ||
1584 | # load the view | |
1585 | my $seamstress = HTML::Seamstress->new_from_file('simple.html'); | |
1586 | # load the model | |
1587 | my $o = Simple::Class->new; | |
1588 | ||
1589 | $seamstress->table | |
1590 | ( | |
1591 | # tell seamstress where to find the table, via the method call | |
1592 | # ->look_down('id', $gi_table). Seamstress detaches the table from the | |
1593 | # HTML tree automatically if no table rows can be built | |
1594 | ||
1595 | gi_table => 'load_data', | |
1596 | ||
1597 | # tell seamstress where to find the tr. This is a bit useless as | |
1598 | # the <tr> usually can be found as the first child of the parent | |
1599 | ||
1600 | gi_tr => 'iterate', | |
1601 | ||
1602 | # the model data to be pushed into the table | |
1603 | ||
1604 | table_data => $o->load_data, | |
1605 | ||
1606 | # the way to take the model data and obtain one row | |
1607 | # if the table data were a hashref, we would do: | |
1608 | # my $key = (keys %$data)[0]; my $val = $data->{$key}; delete $data->{$key} | |
1609 | ||
1610 | tr_data => sub { | |
1611 | my ($self, $data) = @_; | |
1612 | shift @{$data} ; | |
1613 | }, | |
1614 | ||
1615 | # the way to take a row of data and fill the <td> tags | |
1616 | ||
1617 | td_data => sub { | |
1618 | my ($tr_node, $tr_data) = @_; | |
1619 | $tr_node->content_handler($_ => $tr_data->{$_}) | |
1620 | for qw(name age weight) | |
1621 | } | |
1622 | ); | |
1623 | ||
1624 | print $seamstress->as_HTML; | |
1625 | ||
1626 | =head4 Looping over Multiple Sample Rows | |
1627 | ||
1628 | * HTML | |
1629 | ||
1630 | <html> | |
1631 | <table id="load_data" CELLPADDING=8 BORDER=2> | |
1632 | <tr> <th>name</th><th>age</th><th>weight</th> </tr> | |
1633 | <tr id="iterate1" BGCOLOR="white" > | |
1634 | <td id="name"> NATURE BOY RIC FLAIR </td> | |
1635 | <td id="age"> 35 </td> | |
1636 | <td id="weight"> 220 </td> | |
1637 | </tr> | |
1638 | <tr id="iterate2" BGCOLOR="#CCCC99"> | |
1639 | <td id="name"> NATURE BOY RIC FLAIR </td> | |
1640 | <td id="age"> 35 </td> | |
1641 | <td id="weight"> 220 </td> | |
1642 | </tr> | |
1643 | </table> | |
1644 | </html> | |
1645 | ||
1646 | * Only one change to last API call. | |
1647 | ||
1648 | This: | |
1649 | ||
1650 | gi_tr => 'iterate', | |
1651 | ||
1652 | becomes this: | |
1653 | ||
1654 | gi_tr => ['iterate1', 'iterate2'] | |
1655 | ||
1656 | =head3 $tree->table2() : New API Call to Unroll a Table | |
1657 | ||
1658 | After 2 or 3 years with C<table()>, I began to develop production | |
1659 | websites with it and decided it needed a cleaner interface, | |
1660 | particularly in the area of handling the fact that C<id> tags will be | |
1661 | the same after cloning a table row. | |
1662 | ||
1663 | First, I will give a dry listing of the function's argument | |
1664 | parameters. This will not be educational most likely. A better way to | |
1665 | understand how to use the function is to read through the incremental | |
1666 | unrolling of the function's interface given in conversational style | |
1667 | after the dry listing. But take your pick. It's the same information | |
1668 | given in two different ways. | |
1669 | ||
1670 | =head4 Dry/technical parameter documentation | |
1671 | ||
1672 | C<< $tree->table2(%param) >> takes the following arguments: | |
1673 | ||
1674 | =over | |
1675 | ||
1676 | =item * C<< table_ld => $look_down >> : optional | |
1677 | ||
1678 | How to find the C<table> element in C<$tree>. If C<$look_down> is an | |
1679 | arrayref, then use C<look_down>. If it is a CODE ref, then call it, | |
1680 | passing it C<$tree>. | |
1681 | ||
1682 | Defaults to C<< ['_tag' => 'table'] >> if not passed in. | |
1683 | ||
1684 | =item * C<< table_data => $tabular_data >> : required | |
1685 | ||
1686 | The data to fill the table with. I<Must> be passed in. | |
1687 | ||
1688 | =item * C<< table_proc => $code_ref >> : not implemented | |
1689 | ||
1690 | A subroutine to do something to the table once it is found. Not | |
1691 | currently implemented. Not obviously necessary. Just created because | |
1692 | there is a C<tr_proc> and C<td_proc>. | |
1693 | ||
1694 | =item * C<< tr_ld => $look_down >> : optional | |
1695 | ||
1696 | Same as C<table_ld> but for finding the table row elements. Please | |
1697 | note that the C<tr_ld> is done on the table node that was found | |
1698 | I<instead> of the whole HTML tree. This makes sense. The C<tr>s that | |
1699 | you want exist below the table that was just found. | |
1700 | ||
1701 | Defaults to C<< ['_tag' => 'tr'] >> if not passed in. | |
1702 | ||
1703 | =item * C<< tr_data => $code_ref >> : optional | |
1704 | ||
1705 | How to take the C<table_data> and return a row. Defaults to: | |
1706 | ||
1707 | sub { my ($self, $data) = @_; | |
1708 | shift(@{$data}) ; | |
1709 | } | |
1710 | ||
1711 | =item * C<< tr_proc => $code_ref >> : optional | |
1712 | ||
1713 | Something to do to the table row we are about to add to the table we | |
1714 | are making. Defaults to a routine which makes the C<id> attribute | |
1715 | unique: | |
1716 | ||
1717 | sub { | |
1718 | my ($self, $tr, $tr_data, $tr_base_id, $row_count) = @_; | |
1719 | $tr->attr(id => sprintf "%s_%d", $tr_base_id, $row_count); | |
1720 | } | |
1721 | ||
1722 | =item * C<< td_proc => $code_ref >> : required | |
1723 | ||
1724 | This coderef will take the row of data and operate on the C<td> cells | |
1725 | that are children of the C<tr>. See C<t/table2.t> for several usage | |
1726 | examples. | |
1727 | ||
1728 | Here's a sample one: | |
1729 | ||
1730 | sub { | |
1731 | my ($tr, $data) = @_; | |
1732 | my @td = $tr->look_down('_tag' => 'td'); | |
1733 | for my $i (0..$#td) { | |
1734 | $td[$i]->splice_content(0, 1, $data->[$i]); | |
1735 | } | |
1736 | } | |
1737 | ||
1738 | =back | |
1739 | ||
1740 | =head4 Conversational parameter documentation | |
1741 | ||
1742 | The first thing you need is a table. So we need a look down for that. | |
1743 | If you don't give one, it defaults to | |
1744 | ||
1745 | ['_tag' => 'table'] | |
1746 | ||
1747 | What good is a table to display in without data to display?! So you | |
1748 | must supply a scalar representing your tabular data source. This | |
1749 | scalar might be an array reference, a C<next>able iterator, a DBI | |
1750 | statement handle. Whatever it is, it can be iterated through to build | |
1751 | up rows of table data. These two required fields (the way to find the | |
1752 | table and the data to display in the table) are C<table_ld> and | |
1753 | C<table_data> respectively. A little more on C<table_ld>. If this | |
1754 | happens to be a CODE ref, then execution of the code ref is presumed | |
1755 | to return the C<HTML::Element> representing the table in the HTML | |
1756 | tree. | |
1757 | ||
1758 | Next, we get the row or rows which serve as sample C<tr> elements by | |
1759 | doing a C<look_down> from the C<table_elem>. While normally one sample | |
1760 | row is enough to unroll a table, consider when you have alternating | |
1761 | table rows. This API call would need one of each row so that it can | |
1762 | cycle through the sample rows as it loops through the data. | |
1763 | Alternatively, you could always just use one row and make the | |
1764 | necessary changes to the single C<tr> row by mutating the element in | |
1765 | C<tr_proc>, discussed below. The default C<tr_ld> is C<< ['_tag' => | |
1766 | 'tr'] >> but you can overwrite it. Note well, if you overwrite it with | |
1767 | a subroutine, then it is expected that the subroutine will return the | |
1768 | C<HTML::Element>(s) which are C<tr> element(s). The reason a | |
1769 | subroutine might be preferred is in the case that the HTML designers | |
1770 | gave you 8 sample C<tr> rows but only one prototype row is needed. So | |
1771 | you can write a subroutine, to splice out the 7 rows you don't need | |
1772 | and leave the one sample row remaining so that this API call can clone | |
1773 | it and supply it to the C<tr_proc> and C<td_proc> calls. | |
1774 | ||
1775 | Now, as we move through the table rows with table data, we need to do | |
1776 | two different things on each table row: | |
1777 | ||
1778 | =over 4 | |
1779 | ||
1780 | =item * get one row of data from the C<table_data> via C<tr_data> | |
1781 | ||
1782 | The default procedure assumes the C<table_data> is an array reference | |
1783 | and shifts a row off of it: | |
1784 | ||
1785 | sub { | |
1786 | my ($self, $data) = @_; | |
1787 | shift @{$data}; | |
1788 | } | |
1789 | ||
1790 | Your function MUST return undef when there is no more rows to lay out. | |
1791 | ||
1792 | =item * take the C<tr> element and mutate it via C<tr_proc> | |
1793 | ||
1794 | The default procedure simply makes the id of the table row unique: | |
1795 | ||
1796 | sub { | |
1797 | my ($self, $tr, $tr_data, $row_count, $root_id) = @_; | |
1798 | $tr->attr(id => sprintf "%s_%d", $root_id, $row_count); | |
1799 | } | |
1800 | ||
1801 | =back | |
1802 | ||
1803 | Now that we have our row of data, we call C<td_proc> so that it can | |
1804 | take the data and the C<td> cells in this C<tr> and process them. This | |
1805 | function I<must> be supplied. | |
1806 | ||
1807 | =head3 Whither a Table with No Rows | |
1808 | ||
1809 | Often when a table has no rows, we want to display a message | |
1810 | indicating this to the view. Use conditional processing to decide what | |
1811 | to display: | |
1812 | ||
1813 | <span id=no_data> | |
1814 | <table><tr><td>No Data is Good Data</td></tr></table> | |
1815 | </span> | |
1816 | <span id=load_data> | |
1817 | <html> | |
1818 | <table id="load_data"> | |
1819 | <tr> <th>name</th><th>age</th><th>weight</th> </tr> | |
1820 | <tr id="iterate"> | |
1821 | <td id="name"> NATURE BOY RIC FLAIR </td> | |
1822 | <td id="age"> 35 </td> | |
1823 | <td id="weight"> 220 </td> | |
1824 | </tr> | |
1825 | </table> | |
1826 | </html> | |
1827 | </span> | |
1828 | ||
1829 | =head2 Tree-Killing Methods | |
1830 | ||
1831 | =head3 $tree->prune | |
1832 | ||
1833 | This removes any nodes from the tree which consist of nothing or | |
1834 | nothing but whitespace. See also delete_ignorable_whitespace in | |
1835 | L<HTML::Element>. | |
1836 | ||
1837 | =head2 Loltree Functions | |
1838 | ||
1839 | A loltree is an arrayref consisting of arrayrefs which is used by C<< | |
1840 | new_from__lol >> in L<HTML::Element> to produce HTML trees. The CPAN | |
1841 | distro L<XML::Element::Tolol> creates such XML trees by parsing XML | |
e0dfa7be | 1842 | files, analogous to L<XML::Toolkit>. The purpose of the functions in |
0b6e6b69 MG |
1843 | this section is to allow you manipulate a loltree programmatically. |
1844 | ||
1845 | These could not be methods because if you bless a loltree, then | |
1846 | HTML::Tree will barf. | |
1847 | ||
1848 | =head3 HTML::Element::newchild($lol, $parent_label, @newchild) | |
1849 | ||
1850 | Given this initial loltree: | |
1851 | ||
1852 | my $initial_lol = [ note => [ shopping => [ item => 'sample' ] ] ]; | |
1853 | ||
1854 | This code: | |
1855 | ||
1856 | sub shopping_items { | |
1857 | my @shopping_items = map { [ item => _ ] } qw(bread butter beans); | |
1858 | @shopping_items; | |
1859 | } | |
1860 | ||
1861 | my $new_lol = HTML::Element::newnode($initial_lol, item => shopping_items()); | |
1862 | ||
1863 | will replace the single sample with a list of shopping items: | |
1864 | ||
1865 | [ | |
1866 | 'note', | |
1867 | [ | |
1868 | 'shopping', | |
1869 | [ | |
1870 | 'item', | |
1871 | 'bread' | |
1872 | ], | |
1873 | [ | |
1874 | 'item', | |
1875 | 'butter' | |
1876 | ], | |
1877 | [ | |
1878 | 'item', | |
1879 | 'beans' | |
1880 | ] | |
1881 | ||
1882 | ] | |
1883 | ]; | |
1884 | ||
1885 | Thanks to kcott and the other Perlmonks in this thread: | |
1886 | http://www.perlmonks.org/?node_id=912416 | |
1887 | ||
1888 | ||
1889 | =head1 SEE ALSO | |
1890 | ||
1891 | =head2 L<HTML::Tree> | |
1892 | ||
1893 | A perl package for creating and manipulating HTML trees. | |
1894 | ||
1895 | =head2 L<HTML::ElementTable> | |
1896 | ||
1897 | An L<HTML::Tree> - based module which allows for manipulation of HTML | |
1898 | trees using cartesian coordinations. | |
1899 | ||
1900 | =head2 L<HTML::Seamstress> | |
1901 | ||
1902 | An L<HTML::Tree> - based module inspired by XMLC | |
1903 | (L<http://xmlc.enhydra.org>), allowing for dynamic HTML generation via | |
1904 | tree rewriting. | |
1905 | ||
1906 | =head2 Push-style templating systems | |
1907 | ||
1908 | A comprehensive cross-language | |
1909 | L<list of push-style templating systems|http://perlmonks.org/?node_id=674225>. | |
1910 | ||
1911 | =head1 TODO | |
1912 | ||
1913 | =over | |
1914 | ||
1915 | =item * highlander2 | |
1916 | ||
1917 | currently the API expects the subtrees to survive or be pruned to be | |
1918 | identified by id: | |
1919 | ||
1920 | $if_then->highlander2([ | |
1921 | under10 => sub { $_[0] < 10} , | |
1922 | under18 => sub { $_[0] < 18} , | |
1923 | welcome => [ | |
1924 | sub { 1 }, | |
1925 | sub { | |
1926 | my $branch = shift; | |
1927 | $branch->look_down(id => 'age')->replace_content($age); | |
1928 | } | |
1929 | ] | |
1930 | ], $age); | |
1931 | ||
1932 | but, it should be more flexible. the C<under10>, and C<under18> are | |
1933 | expected to be ids in the tree... but it is not hard to have a check | |
1934 | to see if this field is an array reference and if it, then to do a | |
1935 | look down instead: | |
1936 | ||
1937 | $if_then->highlander2([ | |
1938 | [class => 'under10'] => sub { $_[0] < 10} , | |
1939 | [class => 'under18'] => sub { $_[0] < 18} , | |
1940 | [class => 'welcome'] => [ | |
1941 | sub { 1 }, | |
1942 | sub { | |
1943 | my $branch = shift; | |
1944 | $branch->look_down(id => 'age')->replace_content($age); | |
1945 | } | |
1946 | ] | |
1947 | ], $age); | |
1948 | ||
1949 | =back | |
1950 | ||
1951 | =head1 AUTHOR | |
1952 | ||
1953 | Original author Terrence Brannon, E<lt>tbone@cpan.orgE<gt>. | |
1954 | ||
1955 | Adopted by Marius Gavrilescu C<< <marius@ieval.ro> >>. | |
1956 | ||
1957 | I appreciate the feedback from M. David Moussa Leo Keita regarding | |
1958 | some issues with the test suite, namely (1) CRLF leading to test | |
1959 | breakage in F<t/crunch.t> and (2) using the wrong module in | |
1960 | F<t/prune.t> thus not having the right functionality available. | |
1961 | ||
1962 | Many thanks to BARBIE for his RT bug report. | |
1963 | ||
1964 | Many thanks to perlmonk kcott for his work on array rewriting: | |
1965 | L<http://www.perlmonks.org/?node_id=912416>. It was crucial in the | |
1966 | development of newchild. | |
1967 | ||
1968 | =head1 COPYRIGHT AND LICENSE | |
1969 | ||
13f94226 | 1970 | Coypright (C) 2014-2016 by Marius Gavrilescu |
0b6e6b69 MG |
1971 | |
1972 | Copyright (C) 2004-2012 by Terrence Brannon | |
1973 | ||
1974 | This library is free software; you can redistribute it and/or modify | |
1975 | it under the same terms as Perl itself, either Perl version 5.8.4 or, | |
1976 | at your option, any later version of Perl 5 you may have available. | |
1977 | ||
1978 | ||
1979 | =cut |