Commit | Line | Data |
---|---|---|
67e78ff2 | 1 | package HTML::Element::Library; |
67e78ff2 | 2 | use strict; |
3 | use warnings; | |
4 | ||
6c20681a | 5 | our $VERSION = '5.120100'; |
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 | ||
e87db89a | 249 | sub HTML::Element::iter2 { ## no critic (RequireArgUnpacking) |
6c20681a MG |
250 | my $tree = shift; |
251 | ||
252 | #warn "INPUT TO TABLE2: ", Dumper \@_; | |
253 | ||
254 | my %p = validate( | |
255 | @_, { | |
256 | wrapper_ld => { default => ['_tag' => 'dl'] }, | |
257 | wrapper_data => 1, | |
258 | wrapper_proc => { default => undef }, | |
259 | item_ld => { | |
260 | default => sub { | |
e87db89a | 261 | my $tr = shift; |
6c20681a | 262 | [ |
e87db89a MG |
263 | $tr->look_down('_tag' => 'dt'), |
264 | $tr->look_down('_tag' => 'dd') | |
6c20681a MG |
265 | ]; |
266 | }}, | |
267 | item_data => { | |
268 | default => sub { | |
269 | my ($wrapper_data) = @_; | |
e87db89a | 270 | shift @{$wrapper_data}; |
6c20681a MG |
271 | }}, |
272 | item_proc => { | |
273 | default => sub { | |
274 | my ($item_elems, $item_data, $row_count) = @_; | |
275 | $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ; | |
276 | $item_elems; | |
277 | }}, | |
278 | splice => { | |
279 | default => sub { | |
280 | my ($container, @item_elems) = @_; | |
281 | $container->splice_content(0, 2, @item_elems); | |
282 | } | |
67e78ff2 | 283 | }, |
6c20681a MG |
284 | debug => {default => 0} |
285 | } | |
286 | ); | |
67e78ff2 | 287 | |
e87db89a | 288 | warn 'wrapper_data: ' . Dumper $p{wrapper_data} if $p{debug} ; |
67e78ff2 | 289 | |
6c20681a | 290 | my $container = ref_or_ld($tree, $p{wrapper_ld}); |
e87db89a MG |
291 | warn 'container: ' . $container if $p{debug} ; |
292 | warn 'wrapper_(preproc): ' . $container->as_HTML if $p{debug} ; | |
6c20681a | 293 | $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ; |
e87db89a | 294 | warn 'wrapper_(postproc): ' . $container->as_HTML if $p{debug} ; |
67e78ff2 | 295 | |
6c20681a | 296 | my $_item_elems = $p{item_ld}->($container); |
67e78ff2 | 297 | |
6c20681a MG |
298 | my $row_count; |
299 | my @item_elem; | |
300 | while(1){ | |
301 | my $item_data = $p{item_data}->($p{wrapper_data}); | |
302 | last unless defined $item_data; | |
67e78ff2 | 303 | |
aa016126 | 304 | warn Dumper('item_data', $item_data) if $p{debug}; |
67e78ff2 | 305 | |
6c20681a | 306 | my $item_elems = [ map { $_->clone } @{$_item_elems} ] ; |
67e78ff2 | 307 | |
6c20681a MG |
308 | if ($p{debug}) { |
309 | for (@{$item_elems}) { | |
aa016126 | 310 | warn 'ITEM_ELEMS ', $_->as_HTML if $p{debug}; |
6c20681a MG |
311 | } |
312 | } | |
67e78ff2 | 313 | |
6c20681a | 314 | my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count); |
67e78ff2 | 315 | |
6c20681a MG |
316 | if ($p{debug}) { |
317 | for (@{$new_item_elems}) { | |
aa016126 | 318 | warn 'NEWITEM_ELEMS ', $_->as_HTML if $p{debug}; |
6c20681a MG |
319 | } |
320 | } | |
67e78ff2 | 321 | |
6c20681a MG |
322 | push @item_elem, @{$new_item_elems} ; |
323 | } | |
67e78ff2 | 324 | |
e87db89a | 325 | warn 'pushing ' . @item_elem . ' elems' if $p{debug} ; |
67e78ff2 | 326 | |
6c20681a | 327 | $p{splice}->($container, @item_elem); |
67e78ff2 | 328 | } |
329 | ||
330 | sub HTML::Element::dual_iter { | |
6c20681a | 331 | my ($parent, $data) = @_; |
67e78ff2 | 332 | |
6c20681a | 333 | my ($prototype_a, $prototype_b) = $parent->content_list; |
67e78ff2 | 334 | |
6c20681a | 335 | # my $id_incr = make_counter; |
67e78ff2 | 336 | |
6c20681a | 337 | my $i; |
67e78ff2 | 338 | |
6c20681a | 339 | @$data %2 == 0 or confess 'dataset does not contain an even number of members'; |
67e78ff2 | 340 | |
6c20681a | 341 | my @iterable_data = ngroup 2 => @$data; |
67e78ff2 | 342 | |
6c20681a MG |
343 | my @item = map { |
344 | my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ; | |
345 | $new_a->splice_content(0,1, $_->[0]); | |
346 | $new_b->splice_content(0,1, $_->[1]); | |
347 | #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ; | |
348 | ($new_a, $new_b) | |
349 | } @iterable_data; | |
67e78ff2 | 350 | |
6c20681a | 351 | $parent->splice_content(0, 2, @item); |
67e78ff2 | 352 | } |
353 | ||
e87db89a | 354 | sub HTML::Element::set_child_content { ## no critic (RequireArgUnpacking) |
6c20681a MG |
355 | my $tree = shift; |
356 | my $content = pop; | |
357 | my @look_down = @_; | |
67e78ff2 | 358 | |
6c20681a | 359 | my $content_tag = $tree->look_down(@look_down); |
67e78ff2 | 360 | |
6c20681a MG |
361 | unless ($content_tag) { |
362 | warn "criteria [@look_down] not found"; | |
363 | return; | |
364 | } | |
67e78ff2 | 365 | |
6c20681a | 366 | $content_tag->replace_content($content); |
67e78ff2 | 367 | } |
368 | ||
369 | sub HTML::Element::highlander { | |
6c20681a | 370 | my ($tree, $local_root_id, $aref, @arg) = @_; |
67e78ff2 | 371 | |
e87db89a | 372 | ref $aref eq 'ARRAY' or confess 'must supply array reference'; |
67e78ff2 | 373 | |
6c20681a | 374 | my @aref = @$aref; |
e87db89a | 375 | @aref % 2 == 0 or confess 'supplied array ref must have an even number of entries'; |
67e78ff2 | 376 | |
6c20681a | 377 | warn __PACKAGE__ if $DEBUG; |
67e78ff2 | 378 | |
6c20681a MG |
379 | my $survivor; |
380 | while (my ($id, $test) = splice @aref, 0, 2) { | |
381 | warn $id if $DEBUG; | |
382 | if ($test->(@arg)) { | |
383 | $survivor = $id; | |
384 | last; | |
385 | } | |
386 | } | |
67e78ff2 | 387 | |
6c20681a MG |
388 | my @id_survivor = (id => $survivor); |
389 | my $survivor_node = $tree->look_down(@id_survivor); | |
390 | # warn $survivor; | |
391 | # warn $local_root_id; | |
392 | # warn $node; | |
67e78ff2 | 393 | |
6c20681a | 394 | warn "survivor: $survivor" if $DEBUG; |
e87db89a | 395 | warn 'tree: ' . $tree->as_HTML if $DEBUG; |
67e78ff2 | 396 | |
6c20681a | 397 | $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML; |
67e78ff2 | 398 | |
6c20681a MG |
399 | my $survivor_node_parent = $survivor_node->parent; |
400 | $survivor_node = $survivor_node->clone; | |
401 | $survivor_node_parent->replace_content($survivor_node); | |
67e78ff2 | 402 | |
e87db89a | 403 | warn 'new tree: ' . $tree->as_HTML if $DEBUG; |
67e78ff2 | 404 | |
6c20681a | 405 | $survivor_node; |
67e78ff2 | 406 | } |
407 | ||
e87db89a | 408 | sub HTML::Element::highlander2 { ## no critic (RequireArgUnpacking) |
6c20681a MG |
409 | my $tree = shift; |
410 | ||
411 | my %p = validate(@_, { | |
412 | cond => { type => ARRAYREF }, | |
413 | cond_arg => { | |
414 | type => ARRAYREF, | |
415 | default => [] | |
416 | }, | |
417 | debug => { default => 0 } | |
418 | }); | |
419 | ||
420 | my @cond = @{$p{cond}}; | |
e87db89a | 421 | @cond % 2 == 0 or confess 'supplied array ref must have an even number of entries'; |
6c20681a MG |
422 | |
423 | warn __PACKAGE__ if $p{debug}; | |
424 | ||
425 | my @cond_arg = @{$p{cond_arg}}; | |
426 | ||
427 | my $survivor; my $then; | |
428 | while (my ($id, $if_then) = splice @cond, 0, 2) { | |
429 | warn $id if $p{debug}; | |
430 | my ($if, $_then); | |
431 | ||
432 | if (ref $if_then eq 'ARRAY') { | |
433 | ($if, $_then) = @$if_then; | |
434 | } else { | |
435 | ($if, $_then) = ($if_then, sub {}); | |
436 | } | |
437 | ||
438 | if ($if->(@cond_arg)) { | |
439 | $survivor = $id; | |
440 | $then = $_then; | |
441 | last; | |
442 | } | |
443 | } | |
67e78ff2 | 444 | |
6c20681a | 445 | my @ld = (ref $survivor eq 'ARRAY') ? @$survivor : (id => $survivor); |
67e78ff2 | 446 | |
e87db89a MG |
447 | warn 'survivor: ', $survivor if $p{debug}; |
448 | warn 'survivor_ld: ', Dumper \@ld if $p{debug}; | |
67e78ff2 | 449 | |
6c20681a | 450 | my $survivor_node = $tree->look_down(@ld); |
67e78ff2 | 451 | |
6c20681a | 452 | $survivor_node or confess "search for @ld failed in tree($tree): " . $tree->as_HTML; |
67e78ff2 | 453 | |
6c20681a MG |
454 | my $survivor_node_parent = $survivor_node->parent; |
455 | $survivor_node = $survivor_node->clone; | |
456 | $survivor_node_parent->replace_content($survivor_node); | |
67e78ff2 | 457 | |
6c20681a MG |
458 | # **************** NEW FUNCTIONALITY ******************* |
459 | # apply transforms on survivor node | |
67e78ff2 | 460 | |
e87db89a | 461 | warn 'SURV::pre_trans ' . $survivor_node->as_HTML if $p{debug}; |
6c20681a | 462 | $then->($survivor_node, @cond_arg); |
e87db89a | 463 | warn 'SURV::post_trans ' . $survivor_node->as_HTML if $p{debug}; |
6c20681a | 464 | # **************** NEW FUNCTIONALITY ******************* |
67e78ff2 | 465 | |
6c20681a | 466 | $survivor_node; |
67e78ff2 | 467 | } |
468 | ||
67e78ff2 | 469 | sub overwrite_action { |
6c20681a | 470 | my ($mute_node, %X) = @_; |
67e78ff2 | 471 | |
6c20681a | 472 | $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new}); |
67e78ff2 | 473 | } |
474 | ||
67e78ff2 | 475 | sub HTML::Element::overwrite_attr { |
6c20681a | 476 | my $tree = shift; |
67e78ff2 | 477 | |
6c20681a MG |
478 | $tree->mute_elem(@_, \&overwrite_action); |
479 | } | |
67e78ff2 | 480 | |
481 | sub HTML::Element::mute_elem { | |
6c20681a MG |
482 | my ($tree, $mute_attr, $closures, $post_hook) = @_; |
483 | ||
e87db89a | 484 | my @mute_node = $tree->look_down($mute_attr => qr/.*/s) ; |
6c20681a MG |
485 | |
486 | for my $mute_node (@mute_node) { | |
e87db89a | 487 | my ($local_attr,$mute_key) = split /\s+/s, $mute_node->attr($mute_attr); |
6c20681a MG |
488 | my $local_attr_value_current = $mute_node->attr($local_attr); |
489 | my $local_attr_value_new = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current); | |
490 | $post_hook->( | |
491 | $mute_node, | |
492 | tree => $tree, | |
493 | local_attr => { | |
494 | name => $local_attr, | |
495 | value => { | |
496 | current => $local_attr_value_current, | |
497 | new => $local_attr_value_new | |
498 | } | |
499 | } | |
500 | ) if ($post_hook) ; | |
501 | } | |
67e78ff2 | 502 | } |
503 | ||
504 | ||
505 | ||
506 | sub HTML::Element::table { | |
6c20681a MG |
507 | my ($s, %table) = @_; |
508 | my $table = {}; | |
67e78ff2 | 509 | |
6c20681a MG |
510 | # Get the table element |
511 | $table->{table_node} = $s->look_down(id => $table{gi_table}); | |
512 | $table->{table_node} or confess "table tag not found via (id => $table{gi_table}"; | |
67e78ff2 | 513 | |
6c20681a MG |
514 | # Get the prototype tr element(s) |
515 | my @table_gi_tr = listify $table{gi_tr} ; | |
516 | my @iter_node = map { | |
517 | my $tr = $table->{table_node}->look_down(id => $_); | |
518 | $tr or confess "tr with id => $_ not found"; | |
519 | $tr; | |
520 | } @table_gi_tr; | |
67e78ff2 | 521 | |
e87db89a | 522 | warn 'found ' . @iter_node . ' iter nodes ' if $DEBUG; |
6c20681a | 523 | my $iter_node = List::Rotation::Cycle->new(@iter_node); |
67e78ff2 | 524 | |
6c20681a MG |
525 | # warn $iter_node; |
526 | warn Dumper ($iter_node, \@iter_node) if $DEBUG; | |
67e78ff2 | 527 | |
6c20681a MG |
528 | # $table->{content} = $table{content}; |
529 | # $table->{parent} = $table->{table_node}->parent; | |
67e78ff2 | 530 | |
6c20681a MG |
531 | # $table->{table_node}->detach; |
532 | # $_->detach for @iter_node; | |
67e78ff2 | 533 | |
6c20681a | 534 | my @table_rows; |
67e78ff2 | 535 | |
6c20681a MG |
536 | while (1) { |
537 | my $row = $table{tr_data}->($table, $table{table_data}); | |
538 | last unless defined $row; | |
67e78ff2 | 539 | |
6c20681a MG |
540 | # get a sample table row and clone it. |
541 | my $I = $iter_node->next; | |
542 | warn "I: $I" if $DEBUG; | |
543 | my $new_iter_node = $I->clone; | |
67e78ff2 | 544 | |
6c20681a MG |
545 | $table{td_data}->($new_iter_node, $row); |
546 | push @table_rows, $new_iter_node; | |
547 | } | |
67e78ff2 | 548 | |
6c20681a MG |
549 | if (@table_rows) { |
550 | my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ; | |
551 | $s->look_down(id => $_)->detach for @table_gi_tr; | |
552 | $replace_with_elem->replace_with(@table_rows); | |
553 | } | |
67e78ff2 | 554 | } |
555 | ||
556 | sub ref_or_ld { | |
6c20681a | 557 | my ($tree, $slot) = @_; |
67e78ff2 | 558 | |
6c20681a MG |
559 | if (ref($slot) eq 'CODE') { |
560 | $slot->($tree); | |
561 | } else { | |
562 | $tree->look_down(@$slot); | |
563 | } | |
67e78ff2 | 564 | } |
565 | ||
e87db89a | 566 | sub HTML::Element::table2 { ## no critic (RequireArgUnpacking) |
6c20681a MG |
567 | my $tree = shift; |
568 | ||
569 | my %p = validate( | |
570 | @_, { | |
571 | table_ld => { default => ['_tag' => 'table'] }, | |
572 | table_data => 1, | |
573 | table_proc => { default => undef }, | |
574 | tr_ld => { default => ['_tag' => 'tr'] }, | |
575 | tr_data => { | |
576 | default => sub { | |
577 | my ($self, $data) = @_; | |
e87db89a | 578 | shift @{$data}; |
6c20681a MG |
579 | }}, |
580 | tr_base_id => { default => undef }, | |
581 | tr_proc => { default => sub {} }, | |
582 | td_proc => 1, | |
583 | debug => {default => 0} | |
584 | } | |
585 | ); | |
586 | ||
e87db89a MG |
587 | warn 'INPUT TO TABLE2: ', Dumper \@_ if $p{debug}; |
588 | warn 'table_data: ' . Dumper $p{table_data} if $p{debug} ; | |
6c20681a MG |
589 | |
590 | my $table = {}; | |
591 | ||
592 | # Get the table element | |
593 | $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ; | |
e87db89a | 594 | $table->{table_node} or confess 'table tag not found via ' . Dumper($p{table_ld}) ; |
6c20681a | 595 | |
e87db89a | 596 | warn 'table: ' . $table->{table_node}->as_HTML if $p{debug}; |
6c20681a MG |
597 | |
598 | # Get the prototype tr element(s) | |
599 | my @proto_tr = ref_or_ld( $table->{table_node}, $p{tr_ld} ) ; | |
600 | ||
e87db89a | 601 | warn 'found ' . @proto_tr . ' iter nodes' if $p{debug}; |
6c20681a MG |
602 | |
603 | return unless @proto_tr; | |
604 | ||
605 | if ($p{debug}) { | |
606 | warn $_->as_HTML for @proto_tr; | |
607 | } | |
608 | my $proto_tr = List::Rotation::Cycle->new(@proto_tr); | |
67e78ff2 | 609 | |
6c20681a | 610 | my $tr_parent = $proto_tr[0]->parent; |
e87db89a | 611 | warn 'parent element of trs: ' . $tr_parent->as_HTML if $p{debug}; |
67e78ff2 | 612 | |
6c20681a | 613 | my $row_count; |
67e78ff2 | 614 | |
6c20681a | 615 | my @table_rows; |
67e78ff2 | 616 | |
6c20681a MG |
617 | while(1) { |
618 | my $row = $p{tr_data}->($table, $p{table_data}, $row_count); | |
e87db89a | 619 | warn 'data row: ' . Dumper $row if $p{debug}; |
6c20681a | 620 | last unless defined $row; |
67e78ff2 | 621 | |
6c20681a MG |
622 | # wont work: my $new_iter_node = $table->{iter_node}->clone; |
623 | my $new_tr_node = $proto_tr->next->clone; | |
e87db89a | 624 | warn "new_tr_node: $new_tr_node" if $p{debug}; |
67e78ff2 | 625 | |
6c20681a | 626 | $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count) if defined $p{tr_proc}; |
67e78ff2 | 627 | |
e87db89a | 628 | warn 'data row redux: ' . Dumper $row if $p{debug}; |
67e78ff2 | 629 | |
6c20681a MG |
630 | $p{td_proc}->($new_tr_node, $row); |
631 | push @table_rows, $new_tr_node; | |
632 | } | |
67e78ff2 | 633 | |
6c20681a | 634 | $_->detach for @proto_tr; |
67e78ff2 | 635 | |
6c20681a | 636 | $tr_parent->push_content(@table_rows) if (@table_rows) ; |
67e78ff2 | 637 | } |
638 | ||
67e78ff2 | 639 | sub HTML::Element::unroll_select { |
6c20681a | 640 | my ($s, %select) = @_; |
67e78ff2 | 641 | |
6c20681a | 642 | my $select = {}; |
e87db89a | 643 | warn 'Select Hash: ' . Dumper(\%select) if $select{debug}; |
67e78ff2 | 644 | |
6c20681a | 645 | my $select_node = $s->look_down(id => $select{select_label}); |
e87db89a | 646 | warn "Select Node: $select_node" if $select{debug}; |
67e78ff2 | 647 | |
6c20681a MG |
648 | unless ($select{append}) { |
649 | for my $option ($select_node->look_down('_tag' => 'option')) { | |
650 | $option->delete; | |
651 | } | |
652 | } | |
67e78ff2 | 653 | |
6c20681a | 654 | my $option = HTML::Element->new('option'); |
e87db89a | 655 | warn "Option Node: $option" if $select{debug}; |
3caedb5b | 656 | |
6c20681a | 657 | $option->detach; |
67e78ff2 | 658 | |
6c20681a | 659 | while (my $row = $select{data_iter}->($select{data})) { |
e87db89a | 660 | warn 'Data Row: ' . Dumper($row) if $select{debug}; |
6c20681a MG |
661 | my $o = $option->clone; |
662 | $o->attr('value', $select{option_value}->($row)); | |
663 | $o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)); | |
67e78ff2 | 664 | |
6c20681a MG |
665 | $o->replace_content($select{option_content}->($row)); |
666 | $select_node->push_content($o); | |
667 | warn $o->as_HTML if $select{debug}; | |
668 | } | |
67e78ff2 | 669 | } |
670 | ||
67e78ff2 | 671 | sub HTML::Element::set_sibling_content { |
6c20681a | 672 | my ($elt, $content) = @_; |
67e78ff2 | 673 | |
6c20681a | 674 | $elt->parent->splice_content($elt->pindex + 1, 1, $content); |
67e78ff2 | 675 | } |
676 | ||
677 | sub HTML::TreeBuilder::parse_string { | |
6c20681a | 678 | my ($package, $string) = @_; |
67e78ff2 | 679 | |
6c20681a MG |
680 | my $h = HTML::TreeBuilder->new; |
681 | HTML::TreeBuilder->parse($string); | |
67e78ff2 | 682 | } |
683 | ||
67e78ff2 | 684 | 1; |
685 | __END__ |