lib/HTML/Element/Library.pm

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