]>
iEval git - html-element-library.git/blob - lib/HTML/Element/Library.pm
cb9cec3e5d423454e19e29c82f24e38ef3bbe48e
1 package HTML
::Element
::Library
;
2 # ABSTRACT: Convenience methods for HTML::TreeBuilder and HTML::Element
11 use Array
::Group
qw(:all);
15 use List
::Util
qw(first);
16 use List
::MoreUtils qw
/:all/;
17 use Params
::Validate
qw(:all);
20 use List
::Rotation
::Cycle
;
22 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
23 our @EXPORT_OK = ( @
{ $EXPORT_TAGS{'all'} } );
32 # Preloaded methods go here.
34 # https://rt.cpan.org/Ticket/Display.html?id=44105
35 sub HTML
::Element
::fillinform
{
37 my ($tree, $hashref, $return_tree, $guts)=@_;
39 (ref $hashref) eq 'HASH' or die 'hashref not supplied as argument' ;
42 my $html = $tree->as_HTML;
43 my $new_html = HTML
::FillInForm
->fill(\
$html, $hashref);
46 my $tree = HTML
::TreeBuilder
->new_from_content($new_html);
47 $tree = $guts ?
$tree->guts : $tree ;
54 sub HTML
::Element
::siblings
{
56 my $p = $element->parent;
61 sub HTML
::Element
::defmap
{
62 my($tree,$attr,$hashref,$debug)=@_;
64 while (my ($k, $v) = (each %$hashref)) {
65 warn "defmap looks for ($attr => $k)" if $debug;
66 my $found = $tree->look_down($attr => $k);
68 warn "($attr => $k) was found.. replacing with '$v'" if $debug;
69 $found->replace_content( $v );
75 sub HTML
::Element
::_only_empty_content
{
77 my @c = $self->content_list;
78 my $length = scalar @c;
81 #warn sprintf 'Testing %s (%s)' , $self->starttag, Dumper(\@c);
82 #warn sprintf "\t\tlength of content: %d ", $length;
84 scalar @c == 1 and not length($c[0]);
87 sub HTML
::Element
::prune
{
90 for my $c ($self->content_list) {
92 #warn "C: " . Dumper($c);
97 $self->delete if ($self->is_empty or $self->_only_empty_content);
101 sub HTML
::Element
::newnode
{
102 my ($lol, $node_label, $new_node)=@_;
104 use Data
::Rmap
qw(rmap_array);
106 my ($mapresult) = rmap_array
{
109 if ($_->[0] eq $node_label) {
122 sub HTML
::Element
::crunch
{
123 my $container = shift;
125 my %p = validate
(@_, {
126 look_down
=> { type
=> ARRAYREF
},
127 leave
=> { default => 1 },
130 my @look_down = @
{$p{look_down
}} ;
131 my @elem = $container->look_down( @look_down ) ;
135 for my $elem (@elem) {
136 $elem->detach if $left++ >= $p{leave
} ;
141 sub HTML
::Element
::hash_map
{
142 my $container = shift;
144 my %p = validate
(@_, {
145 hash
=> { type
=> HASHREF
},
147 excluding
=> { type
=> ARRAYREF
, default => [] },
148 debug
=> { default => 0 },
151 warn 'The container tag is ', $container->tag if $p{debug
} ;
152 warn 'hash' . Dumper
($p{hash
}) if $p{debug
} ;
153 #warn 'at_under' . Dumper(\@_) if $p{debug} ;
155 my @same_as = $container->look_down( $p{to_attr
} => qr/.+/ ) ;
157 warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug
} ;
160 for my $same_as (@same_as) {
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
} ;
166 warn "processing $attr_val" if $p{debug
} ;
167 $same_as->replace_content( $p{hash
}->{$attr_val} ) ;
172 sub HTML
::Element
::hashmap
{
173 my ($container, $attr_name, $hashref, $excluding, $debug) = @_;
177 $container->hash_map(hash
=> $hashref,
178 to_attr
=> $attr_name,
179 excluding
=> $excluding,
185 sub HTML
::Element
::passover
{
186 my ($tree, @to_preserve) = @_;
188 warn "ARGS: my ($tree, @to_preserve)" if $DEBUG;
189 warn $tree->as_HTML(undef, ' ') if $DEBUG;
191 my $exodus = $tree->look_down(id
=> $to_preserve[0]);
193 warn "E: $exodus" if $DEBUG;
195 my @s = HTML
::Element
::siblings
($exodus);
199 if (first
{ $s->attr('id') eq $_ } @to_preserve) {
206 return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover
210 sub HTML
::Element
::sibdex
{
213 firstidx
{ $_ eq $element } $element->siblings
217 sub HTML
::Element
::addr
{ goto &HTML
::Element
::sibdex
}
219 sub HTML
::Element
::replace_content
{
221 $elem->delete_content;
222 $elem->push_content(@_);
225 sub HTML
::Element
::wrap_content
{
226 my($self, $wrap) = @_;
227 my $content = $self->content;
229 $wrap->push_content(@
$content);
233 $self->push_content($wrap);
238 sub HTML
::Element
::Library
::super_literal
{
241 HTML
::Element
->new('~literal', text
=> $text);
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
255 unshift(@pos, $a) if defined $a;
262 sub HTML
::Element
::content_handler
{
263 my ($tree, %content_hash) = @_;
265 for my $k (keys %content_hash) {
266 $tree->set_child_content(id
=> $k, $content_hash{$k});
272 sub HTML
::Element
::assign
{
273 goto &HTML
::Element
::content_handler
;
285 sub HTML
::Element
::iter
{
286 my ($tree, $p, @data) = @_;
288 # warn 'P: ' , $p->attr('id') ;
289 # warn 'H: ' , $p->as_HTML;
291 # my $id_incr = make_counter;
293 my $new_item = clone
$p;
294 $new_item->replace_content($_);
298 $p->replace_with(@item);
303 sub HTML
::Element
::iter2
{
307 #warn "INPUT TO TABLE2: ", Dumper \@_;
311 wrapper_ld
=> { default => ['_tag' => 'dl'] },
313 wrapper_proc
=> { default => undef },
314 item_ld
=> { default => sub {
317 $tree->look_down('_tag' => 'dt'),
318 $tree->look_down('_tag' => 'dd')
322 item_data
=> { default => sub { my ($wrapper_data) = @_;
323 shift(@
{$wrapper_data}) ;
327 my ($item_elems, $item_data, $row_count) = @_;
328 $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
331 splice => { default => sub {
332 my ($container, @item_elems) = @_;
333 $container->splice_content(0, 2, @item_elems);
336 debug
=> {default => 0}
340 warn "wrapper_data: " . Dumper
$p{wrapper_data
} if $p{debug
} ;
342 my $container = ref_or_ld
($tree, $p{wrapper_ld
});
343 warn "container: " . $container if $p{debug
} ;
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
} ;
348 my $_item_elems = $p{item_ld
}->($container);
355 my $item_data = $p{item_data
}->($p{wrapper_data
});
356 last unless defined $item_data;
358 warn Dumper
("item_data", $item_data);
361 my $item_elems = [ map { $_->clone } @
{$_item_elems} ] ;
364 for (@
{$item_elems}) {
365 warn "ITEM_ELEMS ", $_->as_HTML;
369 my $new_item_elems = $p{item_proc
}->($item_elems, $item_data, ++$row_count);
372 for (@
{$new_item_elems}) {
373 warn "NEWITEM_ELEMS ", $_->as_HTML;
378 push @item_elem, @
{$new_item_elems} ;
383 warn "pushing " . @item_elem . " elems " if $p{debug
} ;
385 $p{splice}->($container, @item_elem);
389 sub HTML
::Element
::dual_iter
{
390 my ($parent, $data) = @_;
392 my ($prototype_a, $prototype_b) = $parent->content_list;
394 # my $id_incr = make_counter;
399 confess
'dataset does not contain an even number of members';
401 my @iterable_data = ngroup
2 => @
$data;
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) ;
411 $parent->splice_content(0, 2, @item);
416 sub HTML
::Element
::set_child_content
{
421 my $content_tag = $tree->look_down(@look_down);
423 unless ($content_tag) {
424 warn "criteria [@look_down] not found";
428 $content_tag->replace_content($content);
432 sub HTML
::Element
::highlander
{
433 my ($tree, $local_root_id, $aref, @arg) = @_;
435 ref $aref eq 'ARRAY' or confess
436 "must supply array reference";
439 @aref % 2 == 0 or confess
440 "supplied array ref must have an even number of entries";
442 warn __PACKAGE__
if $DEBUG;
445 while (my ($id, $test) = splice @aref, 0, 2) {
454 my @id_survivor = (id
=> $survivor);
455 my $survivor_node = $tree->look_down(@id_survivor);
457 # warn $local_root_id;
460 warn "survivor: $survivor" if $DEBUG;
461 warn "tree: " . $tree->as_HTML if $DEBUG;
463 $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;
465 my $survivor_node_parent = $survivor_node->parent;
466 $survivor_node = $survivor_node->clone;
467 $survivor_node_parent->replace_content($survivor_node);
469 warn "new tree: " . $tree->as_HTML if $DEBUG;
475 sub HTML
::Element
::highlander2
{
478 my %p = validate
(@_, {
479 cond
=> { type
=> ARRAYREF
},
480 cond_arg
=> { type
=> ARRAYREF
,
483 debug
=> { default => 0 }
488 my @cond = @
{$p{cond
}};
489 @cond % 2 == 0 or confess
490 "supplied array ref must have an even number of entries";
492 warn __PACKAGE__
if $p{debug
};
494 my @cond_arg = @
{$p{cond_arg
}};
496 my $survivor; my $then;
497 while (my ($id, $if_then) = splice @cond, 0, 2) {
499 warn $id if $p{debug
};
502 if (ref $if_then eq 'ARRAY') {
503 ($if, $_then) = @
$if_then;
505 ($if, $_then) = ($if_then, sub {});
508 if ($if->(@cond_arg)) {
516 my @ld = (ref $survivor eq 'ARRAY')
521 warn "survivor: ", $survivor if $p{debug
};
522 warn "survivor_ld: ", Dumper \
@ld if $p{debug
};
525 my $survivor_node = $tree->look_down(@ld);
527 $survivor_node or confess
528 "search for @ld failed in tree($tree): " . $tree->as_HTML;
530 my $survivor_node_parent = $survivor_node->parent;
531 $survivor_node = $survivor_node->clone;
532 $survivor_node_parent->replace_content($survivor_node);
535 # **************** NEW FUNCTIONALITY *******************
537 # apply transforms on survivor node
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
};
544 # **************** NEW FUNCTIONALITY *******************
553 sub overwrite_action
{
554 my ($mute_node, %X) = @_;
556 $mute_node->attr($X{local_attr
}{name
} => $X{local_attr
}{value
}{new
});
560 sub HTML
::Element
::overwrite_attr
{
563 $tree->mute_elem(@_, \
&overwrite_action
);
568 sub HTML
::Element
::mute_elem
{
569 my ($tree, $mute_attr, $closures, $post_hook) = @_;
571 warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
572 my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;
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);
584 current
=> $local_attr_value_current,
585 new
=> $local_attr_value_new
594 sub HTML
::Element
::table
{
596 my ($s, %table) = @_;
600 # use Data::Dumper; warn Dumper \%table;
602 # ++$DEBUG if $table{debug} ;
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}";
610 # Get the prototype tr element(s)
611 my @table_gi_tr = listify
$table{gi_tr
} ;
614 my $tr = $table->{table_node
}->look_down(id
=> $_);
615 $tr or confess
"tr with id => $_ not found";
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);
624 warn Dumper
($iter_node, \
@iter_node) if $DEBUG;
626 # $table->{content} = $table{content};
627 #$table->{parent} = $table->{table_node}->parent;
630 # $table->{table_node}->detach;
631 # $_->detach for @iter_node;
636 my $row = $table{tr_data
}->($table, $table{table_data
});
637 last unless defined $row;
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;
645 $table{td_data
}->($new_iter_node, $row);
646 push @table_rows, $new_iter_node;
653 my $replace_with_elem = $s->look_down(id
=> shift @table_gi_tr) ;
655 $s->look_down(id
=> $_)->detach;
658 $replace_with_elem->replace_with(@table_rows);
666 my ($tree, $slot) = @_;
668 if (ref($slot) eq 'CODE') {
671 $tree->look_down(@
$slot);
677 sub HTML
::Element
::table2
{
685 table_ld
=> { default => ['_tag' => 'table'] },
687 table_proc
=> { default => undef },
689 tr_ld
=> { default => ['_tag' => 'tr'] },
690 tr_data
=> { default => sub { my ($self, $data) = @_;
693 tr_base_id
=> { default => undef },
694 tr_proc
=> { default => sub {} },
696 debug
=> {default => 0}
700 warn "INPUT TO TABLE2: ", Dumper \
@_ if $p{debug
};
702 warn "table_data: " . Dumper
$p{table_data
} if $p{debug
} ;
706 # use Data::Dumper; warn Dumper \%table;
708 # ++$DEBUG if $table{debug} ;
710 # Get the table element
712 $table->{table_node
} = ref_or_ld
( $tree, $p{table_ld
} ) ;
714 $table->{table_node
} or confess
715 "table tag not found via " . Dumper
($p{table_ld
}) ;
717 warn "table: " . $table->{table_node
}->as_HTML if $p{debug
};
720 # Get the prototype tr element(s)
721 my @proto_tr = ref_or_ld
( $table->{table_node
}, $p{tr_ld
} ) ;
723 warn "found " . @proto_tr . " iter nodes " if $p{debug
};
725 @proto_tr or return ;
728 warn $_->as_HTML for @proto_tr;
730 my $proto_tr = List
::Rotation
::Cycle
->new(@proto_tr);
732 my $tr_parent = $proto_tr[0]->parent;
733 warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug
};
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;
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
};
748 $p{tr_proc
}->($tree, $new_tr_node, $row, $p{tr_base_id
}, ++$row_count)
749 if defined $p{tr_proc
};
751 warn "data row redux: " . Dumper
$row if $p{debug
};
754 $p{td_proc
}->($new_tr_node, $row);
755 push @table_rows, $new_tr_node;
762 $_->detach for @proto_tr;
764 $tr_parent->push_content(@table_rows) if (@table_rows) ;
769 sub HTML
::Element
::unroll_select
{
771 my ($s, %select) = @_;
775 warn "Select Hash: " . Dumper
(\
%select) if $select{debug
};
777 my $select_node = $s->look_down(id
=> $select{select_label
});
778 warn "Select Node: " . $select_node if $select{debug
};
780 unless ($select{append
}) {
781 for my $option ($select_node->look_down('_tag' => 'option')) {
787 my $option = HTML
::Element
->new('option');
788 warn "Option Node: " . $option if $select{debug
};
792 while (my $row = $select{data_iter
}->($select{data
}))
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)) ;
799 $o->replace_content($select{option_content
}->($row));
800 $select_node->push_content($o);
801 warn $o->as_HTML if $select{debug
};
809 sub HTML
::Element
::set_sibling_content
{
810 my ($elt, $content) = @_;
812 $elt->parent->splice_content($elt->pindex + 1, 1, $content);
816 sub HTML
::TreeBuilder
::parse_string
{
817 my ($package, $string) = @_;
819 my $h = HTML
::TreeBuilder
->new;
820 HTML
::TreeBuilder
->parse($string);
This page took 0.14474 seconds and 3 git commands to generate.