1 package HTML
::Element
::Library
;
5 our $VERSION = '5.120100';
8 use Array
::Group
':all';
11 use Data
::Rmap
'rmap_array';
14 use List
::MoreUtils
':all';
15 use List
::Rotation
::Cycle
;
16 use List
::Util
'first';
17 use Params
::Validate
':all';
20 # https://rt.cpan.org/Ticket/Display.html?id=44105
21 sub HTML
::Element
::fillinform
{
22 my ($tree, $hashref, $return_tree, $guts) = @_;
23 (ref $hashref) eq 'HASH' or confess
'hashref not supplied as argument' ;
25 my $html = $tree->as_HTML;
26 my $new_html = HTML
::FillInForm
->fill(\
$html, $hashref);
29 $tree = HTML
::TreeBuilder
->new_from_content($new_html);
30 $tree = $guts ?
$tree->guts : $tree ;
36 sub HTML
::Element
::siblings
{
38 my $p = $element->parent;
43 sub HTML
::Element
::defmap
{
44 my($tree, $attr, $hashref, $debug) = @_;
46 while (my ($k, $v) = (each %$hashref)) {
47 warn "defmap looks for ($attr => $k)" if $debug;
48 my $found = $tree->look_down($attr => $k);
50 warn "($attr => $k) was found.. replacing with '$v'" if $debug;
51 $found->replace_content( $v );
56 sub HTML
::Element
::_only_empty_content
{
58 my @c = $self->content_list;
59 my $length = scalar @c;
61 scalar @c == 1 and not length $c[0];
64 sub HTML
::Element
::prune
{
67 for my $c ($self->content_list) {
73 $self->delete if ($self->is_empty or $self->_only_empty_content);
77 sub HTML
::Element
::newchild
{
78 my ($lol, $parent_label, @newchild) = @_;
80 if ($_->[0] eq $parent_label) {
81 $_ = [ $parent_label => @newchild ];
89 sub HTML
::Element
::crunch
{ ## no critic (RequireArgUnpacking)
90 my $container = shift;
92 my %p = validate
(@_, {
93 look_down
=> { type
=> ARRAYREF
},
94 leave
=> { default => 1 },
97 my @look_down = @
{$p{look_down
}} ;
98 my @elem = $container->look_down(@look_down) ;
102 for my $elem (@elem) {
103 $elem->detach if $detached++ >= $p{leave
};
107 sub HTML
::Element
::hash_map
{ ## no critic (RequireArgUnpacking)
108 my $container = shift;
110 my %p = validate
(@_, {
111 hash
=> { type
=> HASHREF
},
113 excluding
=> { type
=> ARRAYREF
, default => [] },
114 debug
=> { default => 0 },
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} ;
121 my @same_as = $container->look_down( $p{to_attr
} => qr/.+/s ) ;
123 warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug
} ;
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
} ;
131 warn "processing $attr_val" if $p{debug
} ;
132 $same_as->replace_content($p{hash
}->{$attr_val});
136 sub HTML
::Element
::hashmap
{
137 my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
141 $container->hash_map(
143 to_attr
=> $attr_name,
144 excluding
=> $excluding,
149 sub HTML
::Element
::passover
{
150 my ($tree, @to_preserve) = @_;
152 warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
153 warn $tree->as_HTML(undef, ' ') if $DEBUG;
155 my $exodus = $tree->look_down(id
=> $to_preserve[0]);
157 warn "E: $exodus" if $DEBUG;
159 my @s = HTML
::Element
::siblings
($exodus);
163 $s->delete unless first
{ $s->attr('id') eq $_ } @to_preserve;
166 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
169 sub HTML
::Element
::sibdex
{
171 firstidx
{ $_ eq $element } $element->siblings
174 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
176 sub HTML
::Element
::replace_content
{
178 $elem->delete_content;
179 $elem->push_content(@_);
182 sub HTML
::Element
::wrap_content
{
183 my($self, $wrap) = @_;
184 my $content = $self->content;
186 $wrap->push_content(@
$content);
190 $self->push_content($wrap);
195 sub HTML
::Element
::Library
::super_literal
{
197 HTML
::Element
->new('~literal', text
=> $text);
200 sub HTML
::Element
::position
{
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
210 unshift @pos, $a if defined $a;
216 sub HTML
::Element
::content_handler
{
217 my ($tree, %content_hash) = @_;
219 for my $k (keys %content_hash) {
220 $tree->set_child_content(id
=> $k, $content_hash{$k});
224 sub HTML
::Element
::assign
{ goto &HTML
::Element
::content_handler
}
233 sub HTML
::Element
::iter
{
234 my ($tree, $p, @data) = @_;
236 # warn 'P: ' , $p->attr('id') ;
237 # warn 'H: ' , $p->as_HTML;
239 # my $id_incr = make_counter;
241 my $new_item = clone
$p;
242 $new_item->replace_content($_);
246 $p->replace_with(@item);
249 sub HTML
::Element
::iter2
{ ## no critic (RequireArgUnpacking)
252 #warn "INPUT TO TABLE2: ", Dumper \@_;
256 wrapper_ld
=> { default => ['_tag' => 'dl'] },
258 wrapper_proc
=> { default => undef },
263 $tr->look_down('_tag' => 'dt'),
264 $tr->look_down('_tag' => 'dd')
269 my ($wrapper_data) = @_;
270 shift @
{$wrapper_data};
274 my ($item_elems, $item_data, $row_count) = @_;
275 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
280 my ($container, @item_elems) = @_;
281 $container->splice_content(0, 2, @item_elems);
284 debug
=> {default => 0}
288 warn 'wrapper_data: ' . Dumper
$p{wrapper_data
} if $p{debug
} ;
290 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
291 warn 'container: ' . $container if $p{debug
} ;
292 warn 'wrapper_(preproc): ' . $container->as_HTML if $p{debug
} ;
293 $p{wrapper_proc
}->($container) if defined $p{wrapper_proc
} ;
294 warn 'wrapper_(postproc): ' . $container->as_HTML if $p{debug
} ;
296 my $_item_elems = $p{item_ld
}->($container);
301 my $item_data = $p{item_data
}->($p{wrapper_data
});
302 last unless defined $item_data;
304 warn Dumper
('item_data', $item_data) if $p{debug
};
306 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
309 for (@
{$item_elems}) {
310 warn 'ITEM_ELEMS ', $_->as_HTML if $p{debug
};
314 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
317 for (@
{$new_item_elems}) {
318 warn 'NEWITEM_ELEMS ', $_->as_HTML if $p{debug
};
322 push @item_elem, @
{$new_item_elems} ;
325 warn 'pushing ' . @item_elem . ' elems' if $p{debug
} ;
327 $p{splice}->($container, @item_elem);
330 sub HTML
::Element
::dual_iter
{
331 my ($parent, $data) = @_;
333 my ($prototype_a, $prototype_b) = $parent->content_list;
335 # my $id_incr = make_counter;
339 @
$data %2 == 0 or confess
'dataset does not contain an even number of members';
341 my @iterable_data = ngroup
2 => @
$data;
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) ;
351 $parent->splice_content(0, 2, @item);
354 sub HTML
::Element
::set_child_content
{ ## no critic (RequireArgUnpacking)
359 my $content_tag = $tree->look_down(@look_down);
361 unless ($content_tag) {
362 warn "criteria [@look_down] not found";
366 $content_tag->replace_content($content);
369 sub HTML
::Element
::highlander
{
370 my ($tree, $local_root_id, $aref, @arg) = @_;
372 ref $aref eq 'ARRAY' or confess
'must supply array reference';
375 @aref % 2 == 0 or confess
'supplied array ref must have an even number of entries';
377 warn __PACKAGE__
if $DEBUG;
380 while (my ($id, $test) = splice @aref, 0, 2) {
388 my @id_survivor = (id
=> $survivor);
389 my $survivor_node = $tree->look_down(@id_survivor);
391 # warn $local_root_id;
394 warn "survivor: $survivor" if $DEBUG;
395 warn 'tree: ' . $tree->as_HTML if $DEBUG;
397 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
399 my $survivor_node_parent = $survivor_node->parent;
400 $survivor_node = $survivor_node->clone;
401 $survivor_node_parent->replace_content($survivor_node);
403 warn 'new tree: ' . $tree->as_HTML if $DEBUG;
408 sub HTML
::Element
::highlander2
{ ## no critic (RequireArgUnpacking)
411 my %p = validate
(@_, {
412 cond
=> { type
=> ARRAYREF
},
417 debug
=> { default => 0 }
420 my @cond = @
{$p{cond
}};
421 @cond % 2 == 0 or confess
'supplied array ref must have an even number of entries';
423 warn __PACKAGE__
if $p{debug
};
425 my @cond_arg = @
{$p{cond_arg
}};
427 my $survivor; my $then;
428 while (my ($id, $if_then) = splice @cond, 0, 2) {
429 warn $id if $p{debug
};
432 if (ref $if_then eq 'ARRAY') {
433 ($if, $_then) = @
$if_then;
435 ($if, $_then) = ($if_then, sub {});
438 if ($if->(@cond_arg)) {
445 my @ld = (ref $survivor eq 'ARRAY') ? @
$survivor : (id
=> $survivor);
447 warn 'survivor: ', $survivor if $p{debug
};
448 warn 'survivor_ld: ', Dumper \
@ld if $p{debug
};
450 my $survivor_node = $tree->look_down(@ld);
452 $survivor_node or confess
"search for @ld failed in tree($tree): " . $tree->as_HTML;
454 my $survivor_node_parent = $survivor_node->parent;
455 $survivor_node = $survivor_node->clone;
456 $survivor_node_parent->replace_content($survivor_node);
458 # **************** NEW FUNCTIONALITY *******************
459 # apply transforms on survivor node
461 warn 'SURV::pre_trans ' . $survivor_node->as_HTML if $p{debug
};
462 $then->($survivor_node, @cond_arg);
463 warn 'SURV::post_trans ' . $survivor_node->as_HTML if $p{debug
};
464 # **************** NEW FUNCTIONALITY *******************
469 sub overwrite_action
{
470 my ($mute_node, %X) = @_;
472 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
475 sub HTML
::Element
::overwrite_attr
{
478 $tree->mute_elem(@_, \
&overwrite_action
);
481 sub HTML
::Element
::mute_elem
{
482 my ($tree, $mute_attr, $closures, $post_hook) = @_;
484 my @mute_node = $tree->look_down($mute_attr => qr/.*/s) ;
486 for my $mute_node (@mute_node) {
487 my ($local_attr,$mute_key) = split /\s+/s, $mute_node->attr($mute_attr);
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);
496 current
=> $local_attr_value_current,
497 new
=> $local_attr_value_new
506 sub HTML
::Element
::table
{
507 my ($s, %table) = @_;
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}";
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";
522 warn 'found ' . @iter_node . ' iter nodes ' if $DEBUG;
523 my $iter_node = List
::Rotation
::Cycle
->new(@iter_node);
526 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
528 # $table->{content} = $table{content};
529 # $table->{parent} = $table->{table_node}->parent;
531 # $table->{table_node}->detach;
532 # $_->detach for @iter_node;
537 my $row = $table{tr_data
}->($table, $table{table_data
});
538 last unless defined $row;
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;
545 $table{td_data
}->($new_iter_node, $row);
546 push @table_rows, $new_iter_node;
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);
557 my ($tree, $slot) = @_;
559 if (ref($slot) eq 'CODE') {
562 $tree->look_down(@
$slot);
566 sub HTML
::Element
::table2
{ ## no critic (RequireArgUnpacking)
571 table_ld
=> { default => ['_tag' => 'table'] },
573 table_proc
=> { default => undef },
574 tr_ld
=> { default => ['_tag' => 'tr'] },
577 my ($self, $data) = @_;
580 tr_base_id
=> { default => undef },
581 tr_proc
=> { default => sub {} },
583 debug
=> {default => 0}
587 warn 'INPUT TO TABLE2: ', Dumper \
@_ if $p{debug
};
588 warn 'table_data: ' . Dumper
$p{table_data
} if $p{debug
} ;
592 # Get the table element
593 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
594 $table->{table_node
} or confess
'table tag not found via ' . Dumper
($p{table_ld
}) ;
596 warn 'table: ' . $table->{table_node
}->as_HTML if $p{debug
};
598 # Get the prototype tr element(s)
599 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
601 warn 'found ' . @proto_tr . ' iter nodes' if $p{debug
};
603 return unless @proto_tr;
606 warn $_->as_HTML for @proto_tr;
608 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
610 my $tr_parent = $proto_tr[0]->parent;
611 warn 'parent element of trs: ' . $tr_parent->as_HTML if $p{debug
};
618 my $row = $p{tr_data
}->($table, $p{table_data
}, $row_count);
619 warn 'data row: ' . Dumper
$row if $p{debug
};
620 last unless defined $row;
622 # wont work: my $new_iter_node = $table->{iter_node}->clone;
623 my $new_tr_node = $proto_tr->next->clone;
624 warn "new_tr_node: $new_tr_node" if $p{debug
};
626 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count) if defined $p{tr_proc
};
628 warn 'data row redux: ' . Dumper
$row if $p{debug
};
630 $p{td_proc
}->($new_tr_node, $row);
631 push @table_rows, $new_tr_node;
634 $_->detach for @proto_tr;
636 $tr_parent->push_content(@table_rows) if (@table_rows) ;
639 sub HTML
::Element
::unroll_select
{
640 my ($s, %select) = @_;
643 warn 'Select Hash: ' . Dumper
(\
%select) if $select{debug
};
645 my $select_node = $s->look_down(id
=> $select{select_label
});
646 warn "Select Node: $select_node" if $select{debug
};
648 unless ($select{append
}) {
649 for my $option ($select_node->look_down('_tag' => 'option')) {
654 my $option = HTML
::Element
->new('option');
655 warn "Option Node: $option" if $select{debug
};
659 while (my $row = $select{data_iter
}->($select{data
})) {
660 warn 'Data Row: ' . Dumper
($row) if $select{debug
};
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));
665 $o->replace_content($select{option_content
}->($row));
666 $select_node->push_content($o);
667 warn $o->as_HTML if $select{debug
};
671 sub HTML
::Element
::set_sibling_content
{
672 my ($elt, $content) = @_;
674 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
677 sub HTML
::TreeBuilder
::parse_string
{
678 my ($package, $string) = @_;
680 my $h = HTML
::TreeBuilder
->new;
681 HTML
::TreeBuilder
->parse($string);
This page took 0.057875 seconds and 4 git commands to generate.