]>
Commit | Line | Data |
---|---|---|
67e78ff2 | 1 | package HTML::Element::Library; |
ce4e9192 | 2 | # ABSTRACT: Convenience methods for HTML::TreeBuilder and HTML::Element |
237e9506 | 3 | |
67e78ff2 | 4 | use strict; |
5 | use warnings; | |
6 | ||
7 | ||
8 | our $DEBUG = 0; | |
9 | #our $DEBUG = 1; | |
10 | ||
11 | use Array::Group qw(:all); | |
12 | use Carp qw(confess); | |
13 | use Data::Dumper; | |
14 | use HTML::Element; | |
3dad7198 | 15 | use List::Util qw(first); |
67e78ff2 | 16 | use List::MoreUtils qw/:all/; |
17 | use Params::Validate qw(:all); | |
18 | use Scalar::Listify; | |
19 | #use Tie::Cycle; | |
20 | use List::Rotation::Cycle; | |
21 | ||
22 | our %EXPORT_TAGS = ( 'all' => [ qw() ] ); | |
23 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | |
24 | our @EXPORT = qw(); | |
25 | ||
26 | ||
27 | ||
6c133526 | 28 | our $VERSION = '4.3'; |
67e78ff2 | 29 | |
30 | ||
2fcbbeb3 | 31 | |
67e78ff2 | 32 | # Preloaded methods go here. |
33 | ||
2fcbbeb3 TB |
34 | # https://rt.cpan.org/Ticket/Display.html?id=44105 |
35 | sub HTML::Element::fillinform { | |
36 | ||
237e9506 | 37 | my ($tree, $hashref, $return_tree, $guts)=@_; |
2fcbbeb3 | 38 | |
674cdd66 TB |
39 | (ref $hashref) eq 'HASH' or die 'hashref not supplied as argument' ; |
40 | ||
2fcbbeb3 TB |
41 | use HTML::FillInForm; |
42 | my $html = $tree->as_HTML; | |
43 | my $new_html = HTML::FillInForm->fill(\$html, $hashref); | |
44 | ||
63007e38 | 45 | if ($return_tree) { |
237e9506 TB |
46 | my $tree = HTML::TreeBuilder->new_from_content($new_html); |
47 | $tree = $guts ? $tree->guts : $tree ; | |
63007e38 TB |
48 | } else { |
49 | $new_html; | |
50 | } | |
51 | ||
2fcbbeb3 TB |
52 | } |
53 | ||
67e78ff2 | 54 | sub HTML::Element::siblings { |
55 | my $element = shift; | |
56 | my $p = $element->parent; | |
57 | return () unless $p; | |
58 | $p->content_list; | |
59 | } | |
60 | ||
f25dca7f | 61 | sub HTML::Element::defmap { |
9a087986 | 62 | my($tree,$attr,$hashref,$debug)=@_; |
f25dca7f TB |
63 | |
64 | while (my ($k, $v) = (each %$hashref)) { | |
9a087986 | 65 | warn "defmap looks for ($attr => $k)" if $debug; |
f25dca7f TB |
66 | my $found = $tree->look_down($attr => $k); |
67 | if ($found) { | |
9a087986 | 68 | warn "($attr => $k) was found.. replacing with '$v'" if $debug; |
f25dca7f TB |
69 | $found->replace_content( $v ); |
70 | } | |
71 | } | |
72 | ||
73 | } | |
74 | ||
ce4e9192 TB |
75 | sub HTML::Element::_only_empty_content { |
76 | my ($self)=@_; | |
77 | my @c = $self->content_list; | |
78 | my $length = scalar @c; | |
79 | ||
80 | #use Data::Dumper; | |
81 | #warn sprintf 'Testing %s (%s)' , $self->starttag, Dumper(\@c); | |
82 | #warn sprintf "\t\tlength of content: %d ", $length; | |
83 | ||
84 | scalar @c == 1 and not length($c[0]); | |
85 | } | |
86 | ||
87 | sub HTML::Element::prune { | |
88 | my ($self)=@_; | |
89 | ||
90 | for my $c ($self->content_list) { | |
91 | next unless ref $c; | |
92 | #warn "C: " . Dumper($c); | |
93 | $c->prune; | |
94 | } | |
95 | ||
96 | # post-order: | |
97 | $self->delete if ($self->is_empty or $self->_only_empty_content); | |
98 | $self; | |
99 | } | |
100 | ||
271d5078 TB |
101 | sub HTML::Element::newnode { |
102 | my ($lol, $node_label, $new_node)=@_; | |
103 | ||
104 | use Data::Rmap qw(rmap_array); | |
105 | ||
106 | my ($mapresult) = rmap_array { | |
107 | ||
108 | ||
109 | if ($_->[0] eq $node_label) { | |
110 | $_ = $new_node; | |
111 | Data::Rmap::cut($_); | |
112 | } else { | |
113 | $_; | |
114 | } | |
115 | ||
116 | } $lol; | |
117 | ||
118 | $mapresult; | |
119 | ||
120 | } | |
ce4e9192 | 121 | |
d161c455 TB |
122 | sub HTML::Element::crunch { |
123 | my $container = shift; | |
124 | ||
125 | my %p = validate(@_, { | |
126 | look_down => { type => ARRAYREF }, | |
127 | leave => { default => 1 }, | |
128 | }); | |
129 | ||
130 | my @look_down = @{$p{look_down}} ; | |
131 | my @elem = $container->look_down( @look_down ) ; | |
132 | ||
133 | my $left; | |
134 | ||
135 | for my $elem (@elem) { | |
136 | $elem->detach if $left++ >= $p{leave} ; | |
137 | } | |
138 | ||
139 | } | |
f25dca7f | 140 | |
9b7a5679 TB |
141 | sub HTML::Element::hash_map { |
142 | my $container = shift; | |
143 | ||
144 | my %p = validate(@_, { | |
145 | hash => { type => HASHREF }, | |
146 | to_attr => 1, | |
d9f4bd5a | 147 | excluding => { type => ARRAYREF , default => [] }, |
9b7a5679 TB |
148 | debug => { default => 0 }, |
149 | }); | |
150 | ||
d9f4bd5a TB |
151 | warn 'The container tag is ', $container->tag if $p{debug} ; |
152 | warn 'hash' . Dumper($p{hash}) if $p{debug} ; | |
237e9506 | 153 | #warn 'at_under' . Dumper(\@_) if $p{debug} ; |
d9f4bd5a TB |
154 | |
155 | my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ; | |
156 | ||
157 | warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ; | |
158 | ||
9b7a5679 TB |
159 | |
160 | for my $same_as (@same_as) { | |
d9f4bd5a TB |
161 | my $attr_val = $same_as->attr($p{to_attr}) ; |
162 | if (first { $attr_val eq $_ } @{$p{excluding}}) { | |
163 | warn "excluding $attr_val" if $p{debug} ; | |
164 | next; | |
165 | } | |
166 | warn "processing $attr_val" if $p{debug} ; | |
167 | $same_as->replace_content( $p{hash}->{$attr_val} ) ; | |
9b7a5679 | 168 | } |
3dad7198 TB |
169 | |
170 | } | |
171 | ||
f25dca7f TB |
172 | sub HTML::Element::hashmap { |
173 | my ($container, $attr_name, $hashref, $excluding, $debug) = @_; | |
174 | ||
175 | $excluding ||= [] ; | |
176 | ||
177 | $container->hash_map(hash => $hashref, | |
178 | to_attr => $attr_name, | |
179 | excluding => $excluding, | |
180 | debug => $debug); | |
181 | ||
182 | } | |
183 | ||
3dad7198 | 184 | |
de64e3d9 | 185 | sub HTML::Element::passover { |
96cec221 | 186 | my ($tree, @to_preserve) = @_; |
de64e3d9 | 187 | |
96cec221 | 188 | warn "ARGS: my ($tree, @to_preserve)" if $DEBUG; |
3dad7198 | 189 | warn $tree->as_HTML(undef, ' ') if $DEBUG; |
de64e3d9 | 190 | |
96cec221 | 191 | my $exodus = $tree->look_down(id => $to_preserve[0]); |
de64e3d9 | 192 | |
3dad7198 TB |
193 | warn "E: $exodus" if $DEBUG; |
194 | ||
de64e3d9 | 195 | my @s = HTML::Element::siblings($exodus); |
196 | ||
de64e3d9 | 197 | for my $s (@s) { |
de64e3d9 | 198 | next unless ref $s; |
96cec221 | 199 | if (first { $s->attr('id') eq $_ } @to_preserve) { |
de64e3d9 | 200 | ; |
201 | } else { | |
202 | $s->delete; | |
203 | } | |
204 | } | |
205 | ||
206 | return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover | |
207 | ||
208 | } | |
209 | ||
67e78ff2 | 210 | sub HTML::Element::sibdex { |
211 | ||
212 | my $element = shift; | |
213 | firstidx { $_ eq $element } $element->siblings | |
214 | ||
215 | } | |
216 | ||
217 | sub HTML::Element::addr { goto &HTML::Element::sibdex } | |
218 | ||
219 | sub HTML::Element::replace_content { | |
220 | my $elem = shift; | |
221 | $elem->delete_content; | |
222 | $elem->push_content(@_); | |
223 | } | |
224 | ||
225 | sub HTML::Element::wrap_content { | |
226 | my($self, $wrap) = @_; | |
227 | my $content = $self->content; | |
228 | if (ref $content) { | |
229 | $wrap->push_content(@$content); | |
230 | @$content = ($wrap); | |
231 | } | |
232 | else { | |
233 | $self->push_content($wrap); | |
234 | } | |
235 | $wrap; | |
236 | } | |
237 | ||
238 | sub HTML::Element::Library::super_literal { | |
239 | my($text) = @_; | |
240 | ||
241 | HTML::Element->new('~literal', text => $text); | |
242 | } | |
243 | ||
244 | ||
245 | sub HTML::Element::position { | |
246 | # Report coordinates by chasing addr's up the | |
247 | # HTML::ElementSuper tree. We know we've reached | |
248 | # the top when a) there is no parent, or b) the | |
249 | # parent is some HTML::Element unable to report | |
250 | # it's position. | |
251 | my $p = shift; | |
252 | my @pos; | |
253 | while ($p) { | |
254 | my $a = $p->addr; | |
255 | unshift(@pos, $a) if defined $a; | |
256 | $p = $p->parent; | |
257 | } | |
258 | @pos; | |
259 | } | |
260 | ||
261 | ||
262 | sub HTML::Element::content_handler { | |
3c14ea1e | 263 | my ($tree, %content_hash) = @_; |
264 | ||
265 | for my $k (keys %content_hash) { | |
266 | $tree->set_child_content(id => $k, $content_hash{$k}); | |
267 | } | |
67e78ff2 | 268 | |
67e78ff2 | 269 | |
270 | } | |
271 | ||
237e9506 TB |
272 | sub HTML::Element::assign { |
273 | goto &HTML::Element::content_handler; | |
274 | } | |
275 | ||
67e78ff2 | 276 | |
277 | sub make_counter { | |
278 | my $i = 1; | |
279 | sub { | |
280 | shift() . ':' . $i++ | |
281 | } | |
282 | } | |
283 | ||
284 | ||
285 | sub HTML::Element::iter { | |
286 | my ($tree, $p, @data) = @_; | |
287 | ||
288 | # warn 'P: ' , $p->attr('id') ; | |
289 | # warn 'H: ' , $p->as_HTML; | |
290 | ||
291 | # my $id_incr = make_counter; | |
292 | my @item = map { | |
293 | my $new_item = clone $p; | |
294 | $new_item->replace_content($_); | |
67e78ff2 | 295 | $new_item; |
296 | } @data; | |
297 | ||
298 | $p->replace_with(@item); | |
299 | ||
300 | } | |
301 | ||
302 | ||
303 | sub HTML::Element::iter2 { | |
304 | ||
305 | my $tree = shift; | |
306 | ||
307 | #warn "INPUT TO TABLE2: ", Dumper \@_; | |
308 | ||
309 | my %p = validate( | |
310 | @_, { | |
311 | wrapper_ld => { default => ['_tag' => 'dl'] }, | |
312 | wrapper_data => 1, | |
313 | wrapper_proc => { default => undef }, | |
314 | item_ld => { default => sub { | |
315 | my $tree = shift; | |
316 | [ | |
317 | $tree->look_down('_tag' => 'dt'), | |
318 | $tree->look_down('_tag' => 'dd') | |
319 | ]; | |
320 | } | |
321 | }, | |
322 | item_data => { default => sub { my ($wrapper_data) = @_; | |
323 | shift(@{$wrapper_data}) ; | |
324 | }}, | |
325 | item_proc => { | |
326 | default => sub { | |
327 | my ($item_elems, $item_data, $row_count) = @_; | |
328 | $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ; | |
329 | $item_elems; | |
330 | }}, | |
331 | splice => { default => sub { | |
332 | my ($container, @item_elems) = @_; | |
333 | $container->splice_content(0, 2, @item_elems); | |
334 | } | |
335 | }, | |
336 | debug => {default => 0} | |
337 | } | |
338 | ); | |
339 | ||
340 | warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ; | |
341 | ||
342 | my $container = ref_or_ld($tree, $p{wrapper_ld}); | |
3dad7198 | 343 | warn "container: " . $container if $p{debug} ; |
67e78ff2 | 344 | warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ; |
345 | $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ; | |
346 | warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ; | |
347 | ||
348 | my $_item_elems = $p{item_ld}->($container); | |
349 | ||
350 | ||
351 | ||
352 | my $row_count; | |
353 | my @item_elem; | |
354 | { | |
355 | my $item_data = $p{item_data}->($p{wrapper_data}); | |
356 | last unless defined $item_data; | |
357 | ||
358 | warn Dumper("item_data", $item_data); | |
359 | ||
360 | ||
361 | my $item_elems = [ map { $_->clone } @{$_item_elems} ] ; | |
362 | ||
363 | if ($p{debug}) { | |
364 | for (@{$item_elems}) { | |
365 | warn "ITEM_ELEMS ", $_->as_HTML; | |
366 | } | |
367 | } | |
368 | ||
369 | my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count); | |
370 | ||
371 | if ($p{debug}) { | |
372 | for (@{$new_item_elems}) { | |
373 | warn "NEWITEM_ELEMS ", $_->as_HTML; | |
374 | } | |
375 | } | |
376 | ||
377 | ||
378 | push @item_elem, @{$new_item_elems} ; | |
379 | ||
380 | redo; | |
381 | } | |
382 | ||
383 | warn "pushing " . @item_elem . " elems " if $p{debug} ; | |
384 | ||
385 | $p{splice}->($container, @item_elem); | |
386 | ||
387 | } | |
388 | ||
389 | sub HTML::Element::dual_iter { | |
390 | my ($parent, $data) = @_; | |
391 | ||
392 | my ($prototype_a, $prototype_b) = $parent->content_list; | |
393 | ||
394 | # my $id_incr = make_counter; | |
395 | ||
396 | my $i; | |
397 | ||
398 | @$data %2 == 0 or | |
399 | confess 'dataset does not contain an even number of members'; | |
400 | ||
401 | my @iterable_data = ngroup 2 => @$data; | |
402 | ||
403 | my @item = map { | |
404 | my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ; | |
405 | $new_a->splice_content(0,1, $_->[0]); | |
406 | $new_b->splice_content(0,1, $_->[1]); | |
407 | #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ; | |
408 | ($new_a, $new_b) | |
409 | } @iterable_data; | |
410 | ||
411 | $parent->splice_content(0, 2, @item); | |
412 | ||
413 | } | |
414 | ||
415 | ||
416 | sub HTML::Element::set_child_content { | |
417 | my $tree = shift; | |
418 | my $content = pop; | |
419 | my @look_down = @_; | |
420 | ||
421 | my $content_tag = $tree->look_down(@look_down); | |
422 | ||
423 | unless ($content_tag) { | |
424 | warn "criteria [@look_down] not found"; | |
425 | return; | |
426 | } | |
427 | ||
428 | $content_tag->replace_content($content); | |
429 | ||
430 | } | |
431 | ||
432 | sub HTML::Element::highlander { | |
433 | my ($tree, $local_root_id, $aref, @arg) = @_; | |
434 | ||
435 | ref $aref eq 'ARRAY' or confess | |
436 | "must supply array reference"; | |
437 | ||
438 | my @aref = @$aref; | |
439 | @aref % 2 == 0 or confess | |
440 | "supplied array ref must have an even number of entries"; | |
441 | ||
442 | warn __PACKAGE__ if $DEBUG; | |
443 | ||
444 | my $survivor; | |
445 | while (my ($id, $test) = splice @aref, 0, 2) { | |
446 | warn $id if $DEBUG; | |
447 | if ($test->(@arg)) { | |
448 | $survivor = $id; | |
449 | last; | |
450 | } | |
451 | } | |
452 | ||
453 | ||
454 | my @id_survivor = (id => $survivor); | |
455 | my $survivor_node = $tree->look_down(@id_survivor); | |
456 | # warn $survivor; | |
457 | # warn $local_root_id; | |
458 | # warn $node; | |
459 | ||
460 | warn "survivor: $survivor" if $DEBUG; | |
461 | warn "tree: " . $tree->as_HTML if $DEBUG; | |
462 | ||
463 | $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML; | |
464 | ||
465 | my $survivor_node_parent = $survivor_node->parent; | |
466 | $survivor_node = $survivor_node->clone; | |
467 | $survivor_node_parent->replace_content($survivor_node); | |
468 | ||
469 | warn "new tree: " . $tree->as_HTML if $DEBUG; | |
470 | ||
471 | $survivor_node; | |
472 | } | |
473 | ||
474 | ||
475 | sub HTML::Element::highlander2 { | |
476 | my $tree = shift; | |
477 | ||
478 | my %p = validate(@_, { | |
479 | cond => { type => ARRAYREF }, | |
480 | cond_arg => { type => ARRAYREF, | |
481 | default => [] | |
482 | }, | |
483 | debug => { default => 0 } | |
484 | } | |
485 | ); | |
486 | ||
487 | ||
488 | my @cond = @{$p{cond}}; | |
489 | @cond % 2 == 0 or confess | |
490 | "supplied array ref must have an even number of entries"; | |
491 | ||
492 | warn __PACKAGE__ if $p{debug}; | |
493 | ||
494 | my @cond_arg = @{$p{cond_arg}}; | |
495 | ||
496 | my $survivor; my $then; | |
497 | while (my ($id, $if_then) = splice @cond, 0, 2) { | |
498 | ||
499 | warn $id if $p{debug}; | |
500 | my ($if, $_then); | |
501 | ||
502 | if (ref $if_then eq 'ARRAY') { | |
503 | ($if, $_then) = @$if_then; | |
504 | } else { | |
505 | ($if, $_then) = ($if_then, sub {}); | |
506 | } | |
507 | ||
508 | if ($if->(@cond_arg)) { | |
509 | $survivor = $id; | |
510 | $then = $_then; | |
511 | last; | |
512 | } | |
513 | ||
514 | } | |
515 | ||
516 | my @ld = (ref $survivor eq 'ARRAY') | |
517 | ? @$survivor | |
518 | : (id => $survivor) | |
519 | ; | |
520 | ||
521 | warn "survivor: ", $survivor if $p{debug}; | |
522 | warn "survivor_ld: ", Dumper \@ld if $p{debug}; | |
523 | ||
524 | ||
525 | my $survivor_node = $tree->look_down(@ld); | |
526 | ||
527 | $survivor_node or confess | |
528 | "search for @ld failed in tree($tree): " . $tree->as_HTML; | |
529 | ||
530 | my $survivor_node_parent = $survivor_node->parent; | |
531 | $survivor_node = $survivor_node->clone; | |
532 | $survivor_node_parent->replace_content($survivor_node); | |
533 | ||
534 | ||
535 | # **************** NEW FUNCTIONALITY ******************* | |
536 | ||
537 | # apply transforms on survivor node | |
538 | ||
539 | ||
540 | warn "SURV::pre_trans " . $survivor_node->as_HTML if $p{debug}; | |
541 | $then->($survivor_node, @cond_arg); | |
542 | warn "SURV::post_trans " . $survivor_node->as_HTML if $p{debug}; | |
543 | ||
544 | # **************** NEW FUNCTIONALITY ******************* | |
545 | ||
546 | ||
547 | ||
548 | ||
549 | $survivor_node; | |
550 | } | |
551 | ||
552 | ||
553 | sub overwrite_action { | |
554 | my ($mute_node, %X) = @_; | |
555 | ||
556 | $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new}); | |
557 | } | |
558 | ||
559 | ||
560 | sub HTML::Element::overwrite_attr { | |
561 | my $tree = shift; | |
562 | ||
563 | $tree->mute_elem(@_, \&overwrite_action); | |
564 | } | |
565 | ||
566 | ||
567 | ||
568 | sub HTML::Element::mute_elem { | |
569 | my ($tree, $mute_attr, $closures, $post_hook) = @_; | |
570 | ||
571 | warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;"; | |
572 | my @mute_node = $tree->look_down($mute_attr => qr/.*/) ; | |
573 | ||
574 | for my $mute_node (@mute_node) { | |
575 | my ($local_attr,$mute_key) = split /\s+/, $mute_node->attr($mute_attr); | |
576 | my $local_attr_value_current = $mute_node->attr($local_attr); | |
577 | my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current); | |
578 | $post_hook->( | |
579 | $mute_node, | |
580 | tree => $tree, | |
581 | local_attr => { | |
582 | name => $local_attr, | |
583 | value => { | |
584 | current => $local_attr_value_current, | |
585 | new => $local_attr_value_new | |
586 | } | |
587 | } | |
588 | ) if ($post_hook) ; | |
589 | } | |
590 | } | |
591 | ||
592 | ||
593 | ||
594 | sub HTML::Element::table { | |
595 | ||
596 | my ($s, %table) = @_; | |
597 | ||
598 | my $table = {}; | |
599 | ||
600 | # use Data::Dumper; warn Dumper \%table; | |
601 | ||
602 | # ++$DEBUG if $table{debug} ; | |
603 | ||
604 | ||
605 | # Get the table element | |
606 | $table->{table_node} = $s->look_down(id => $table{gi_table}); | |
607 | $table->{table_node} or confess | |
608 | "table tag not found via (id => $table{gi_table}"; | |
609 | ||
610 | # Get the prototype tr element(s) | |
611 | my @table_gi_tr = listify $table{gi_tr} ; | |
612 | my @iter_node = map | |
613 | { | |
614 | my $tr = $table->{table_node}->look_down(id => $_); | |
615 | $tr or confess "tr with id => $_ not found"; | |
616 | $tr; | |
617 | } @table_gi_tr; | |
618 | ||
619 | warn "found " . @iter_node . " iter nodes " if $DEBUG; | |
620 | # tie my $iter_node, 'Tie::Cycle', \@iter_node; | |
621 | my $iter_node = List::Rotation::Cycle->new(@iter_node); | |
622 | ||
623 | # warn $iter_node; | |
624 | warn Dumper ($iter_node, \@iter_node) if $DEBUG; | |
625 | ||
626 | # $table->{content} = $table{content}; | |
627 | #$table->{parent} = $table->{table_node}->parent; | |
628 | ||
629 | ||
630 | # $table->{table_node}->detach; | |
631 | # $_->detach for @iter_node; | |
632 | ||
633 | my @table_rows; | |
634 | ||
635 | { | |
636 | my $row = $table{tr_data}->($table, $table{table_data}); | |
637 | last unless defined $row; | |
638 | ||
639 | # get a sample table row and clone it. | |
640 | my $I = $iter_node->next; | |
641 | warn "I: $I" if $DEBUG; | |
642 | my $new_iter_node = $I->clone; | |
643 | ||
644 | ||
645 | $table{td_data}->($new_iter_node, $row); | |
646 | push @table_rows, $new_iter_node; | |
647 | ||
648 | redo; | |
649 | } | |
650 | ||
651 | if (@table_rows) { | |
652 | ||
653 | my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ; | |
654 | for (@table_gi_tr) { | |
655 | $s->look_down(id => $_)->detach; | |
656 | } | |
657 | ||
658 | $replace_with_elem->replace_with(@table_rows); | |
659 | ||
660 | } | |
661 | ||
662 | } | |
663 | ||
664 | sub ref_or_ld { | |
665 | ||
666 | my ($tree, $slot) = @_; | |
667 | ||
668 | if (ref($slot) eq 'CODE') { | |
669 | $slot->($tree); | |
670 | } else { | |
671 | $tree->look_down(@$slot); | |
672 | } | |
673 | } | |
674 | ||
675 | ||
676 | ||
677 | sub HTML::Element::table2 { | |
678 | ||
679 | my $tree = shift; | |
680 | ||
681 | ||
682 | ||
683 | my %p = validate( | |
684 | @_, { | |
685 | table_ld => { default => ['_tag' => 'table'] }, | |
686 | table_data => 1, | |
687 | table_proc => { default => undef }, | |
688 | ||
689 | tr_ld => { default => ['_tag' => 'tr'] }, | |
690 | tr_data => { default => sub { my ($self, $data) = @_; | |
691 | shift(@{$data}) ; | |
692 | }}, | |
693 | tr_base_id => { default => undef }, | |
694 | tr_proc => { default => sub {} }, | |
695 | td_proc => 1, | |
696 | debug => {default => 0} | |
697 | } | |
698 | ); | |
699 | ||
700 | warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug}; | |
701 | ||
702 | warn "table_data: " . Dumper $p{table_data} if $p{debug} ; | |
703 | ||
704 | my $table = {}; | |
705 | ||
706 | # use Data::Dumper; warn Dumper \%table; | |
707 | ||
708 | # ++$DEBUG if $table{debug} ; | |
709 | ||
710 | # Get the table element | |
5f53bf21 | 711 | #warn 1; |
67e78ff2 | 712 | $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ; |
5f53bf21 | 713 | #warn 2; |
67e78ff2 | 714 | $table->{table_node} or confess |
715 | "table tag not found via " . Dumper($p{table_ld}) ; | |
716 | ||
717 | warn "table: " . $table->{table_node}->as_HTML if $p{debug}; | |
718 | ||
719 | ||
720 | # Get the prototype tr element(s) | |
721 | my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ; | |
722 | ||
723 | warn "found " . @proto_tr . " iter nodes " if $p{debug}; | |
724 | ||
725 | @proto_tr or return ; | |
726 | ||
727 | if ($p{debug}) { | |
728 | warn $_->as_HTML for @proto_tr; | |
729 | } | |
730 | my $proto_tr = List::Rotation::Cycle->new(@proto_tr); | |
731 | ||
732 | my $tr_parent = $proto_tr[0]->parent; | |
733 | warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug}; | |
734 | ||
735 | my $row_count; | |
736 | ||
737 | my @table_rows; | |
738 | ||
739 | { | |
740 | my $row = $p{tr_data}->($table, $p{table_data}, $row_count); | |
741 | warn "data row: " . Dumper $row if $p{debug}; | |
742 | last unless defined $row; | |
743 | ||
744 | # wont work: my $new_iter_node = $table->{iter_node}->clone; | |
745 | my $new_tr_node = $proto_tr->next->clone; | |
746 | warn "new_tr_node: $new_tr_node" if $p{debug}; | |
747 | ||
748 | $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count) | |
749 | if defined $p{tr_proc}; | |
750 | ||
751 | warn "data row redux: " . Dumper $row if $p{debug}; | |
5f53bf21 | 752 | #warn 3.3; |
67e78ff2 | 753 | |
754 | $p{td_proc}->($new_tr_node, $row); | |
755 | push @table_rows, $new_tr_node; | |
756 | ||
5f53bf21 | 757 | #warn 4.4; |
67e78ff2 | 758 | |
759 | redo; | |
760 | } | |
761 | ||
762 | $_->detach for @proto_tr; | |
763 | ||
764 | $tr_parent->push_content(@table_rows) if (@table_rows) ; | |
765 | ||
766 | } | |
767 | ||
768 | ||
769 | sub HTML::Element::unroll_select { | |
770 | ||
771 | my ($s, %select) = @_; | |
772 | ||
773 | my $select = {}; | |
774 | ||
f25dca7f TB |
775 | warn "Select Hash: " . Dumper(\%select) if $select{debug}; |
776 | ||
67e78ff2 | 777 | my $select_node = $s->look_down(id => $select{select_label}); |
3caedb5b | 778 | warn "Select Node: " . $select_node if $select{debug}; |
67e78ff2 | 779 | |
3caedb5b TB |
780 | unless ($select{append}) { |
781 | for my $option ($select_node->look_down('_tag' => 'option')) { | |
782 | $option->delete; | |
783 | } | |
784 | } | |
67e78ff2 | 785 | |
67e78ff2 | 786 | |
3caedb5b TB |
787 | my $option = HTML::Element->new('option'); |
788 | warn "Option Node: " . $option if $select{debug}; | |
67e78ff2 | 789 | |
790 | $option->detach; | |
791 | ||
792 | while (my $row = $select{data_iter}->($select{data})) | |
793 | { | |
3caedb5b TB |
794 | warn "Data Row:" . Dumper($row) if $select{debug}; |
795 | my $o = $option->clone; | |
796 | $o->attr('value', $select{option_value}->($row)); | |
797 | $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)) ; | |
798 | ||
799 | $o->replace_content($select{option_content}->($row)); | |
800 | $select_node->push_content($o); | |
801 | warn $o->as_HTML if $select{debug}; | |
67e78ff2 | 802 | } |
803 | ||
804 | ||
805 | } | |
806 | ||
807 | ||
808 | ||
809 | sub HTML::Element::set_sibling_content { | |
810 | my ($elt, $content) = @_; | |
811 | ||
812 | $elt->parent->splice_content($elt->pindex + 1, 1, $content); | |
813 | ||
814 | } | |
815 | ||
816 | sub HTML::TreeBuilder::parse_string { | |
817 | my ($package, $string) = @_; | |
818 | ||
819 | my $h = HTML::TreeBuilder->new; | |
820 | HTML::TreeBuilder->parse($string); | |
821 | ||
822 | } | |
823 | ||
824 | ||
825 | ||
826 | 1; | |
827 | __END__ |