[html-element-library.git] / lib / HTML / Element / Library.pm

package HTML::Element::Library;


use strict;
use warnings;


our $DEBUG = 0;
#our $DEBUG = 1;

use Array::Group qw(:all);
use Carp qw(confess);
use Data::Dumper;
use HTML::Element;
use List::Util qw(first);
use List::MoreUtils qw/:all/;
use Params::Validate qw(:all);
use Scalar::Listify;
#use Tie::Cycle;
use List::Rotation::Cycle;

our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT      = qw();


our $VERSION = '4.3';


# Preloaded methods go here.

# https://rt.cpan.org/Ticket/Display.html?id=44105
sub HTML::Element::fillinform {

    my ($tree, $hashref, $return_tree, $guts)=@_;

    (ref $hashref) eq 'HASH' or die 'hashref not supplied as argument' ;

    use HTML::FillInForm;
    my $html = $tree->as_HTML;
    my $new_html = HTML::FillInForm->fill(\$html, $hashref);

    if ($return_tree) {
	my $tree = HTML::TreeBuilder->new_from_content($new_html);
        $tree = $guts ? $tree->guts : $tree ;
    } else {
	$new_html;
    }

}

sub HTML::Element::siblings {
  my $element = shift;
  my $p = $element->parent;
  return () unless $p;
  $p->content_list;
}

sub HTML::Element::defmap {
    my($tree,$attr,$hashref,$debug)=@_;

    while (my ($k, $v) = (each %$hashref)) {
	warn "defmap looks for ($attr => $k)" if $debug;
	my $found = $tree->look_down($attr => $k);
	if ($found) {
	    warn "($attr => $k) was found.. replacing with '$v'" if $debug;
	    $found->replace_content( $v );
	}
    }

}

sub HTML::Element::crunch {
    my $container = shift;

    my %p = validate(@_, {
			  look_down => { type => ARRAYREF },
			  leave => { default => 1 },
			 });

    my @look_down = @{$p{look_down}} ;
    my @elem = $container->look_down( @look_down ) ;
    
    my $left;
    
    for my $elem (@elem) {
	$elem->detach if $left++ >= $p{leave} ;
    }

}

sub HTML::Element::hash_map {
    my $container = shift;

    my %p = validate(@_, {
			  hash => { type => HASHREF },
			  to_attr => 1,
			  excluding => { type => ARRAYREF , default => [] },
			  debug => { default => 0 },
			 });

    warn 'The container tag is ', $container->tag if $p{debug} ;
    warn 'hash' . Dumper($p{hash}) if $p{debug} ;
    #warn 'at_under' . Dumper(\@_) if $p{debug} ;

    my @same_as = $container->look_down( $p{to_attr} => qr/.+/ ) ;

    warn 'Found ' . scalar(@same_as) . ' nodes' if $p{debug} ;


    for my $same_as (@same_as) {
	my $attr_val = $same_as->attr($p{to_attr}) ;
	if (first { $attr_val eq $_ } @{$p{excluding}}) {
	    warn "excluding $attr_val" if $p{debug} ;
	    next;
	}
	warn "processing $attr_val" if $p{debug} ;
	$same_as->replace_content( $p{hash}->{$attr_val} ) ;
    }

}

sub HTML::Element::hashmap {
    my ($container, $attr_name, $hashref, $excluding, $debug) = @_;

    $excluding ||= [] ;

    $container->hash_map(hash => $hashref, 
                          to_attr => $attr_name,
                          excluding => $excluding,
                          debug => $debug);

}


sub HTML::Element::passover {
  my ($tree, @to_preserve) = @_;
  
  warn "ARGS:   my ($tree, @to_preserve)" if $DEBUG;
  warn $tree->as_HTML(undef, ' ') if $DEBUG;

  my $exodus = $tree->look_down(id => $to_preserve[0]);

  warn "E: $exodus" if $DEBUG;

  my @s = HTML::Element::siblings($exodus);

  for my $s (@s) {
    next unless ref $s;
    if (first { $s->attr('id') eq $_ } @to_preserve) {
      ;
    } else {
      $s->delete;
    }
  }

  return $exodus; # Goodbye Egypt! http://en.wikipedia.org/wiki/Passover

}

sub HTML::Element::sibdex {

  my $element = shift;
  firstidx { $_ eq $element } $element->siblings

}

sub HTML::Element::addr { goto &HTML::Element::sibdex }

sub HTML::Element::replace_content {
  my $elem = shift;
  $elem->delete_content;
  $elem->push_content(@_);
}

sub HTML::Element::wrap_content {
  my($self, $wrap) = @_;
  my $content = $self->content;
  if (ref $content) {
    $wrap->push_content(@$content);
    @$content = ($wrap);
  }
  else {
    $self->push_content($wrap);
  }
  $wrap;
}

sub HTML::Element::Library::super_literal {
  my($text) = @_;

  HTML::Element->new('~literal', text => $text);
}


sub HTML::Element::position {
  # Report coordinates by chasing addr's up the
  # HTML::ElementSuper tree.  We know we've reached
  # the top when a) there is no parent, or b) the
  # parent is some HTML::Element unable to report
  # it's position.
  my $p = shift;
  my @pos;
  while ($p) {
    my $a = $p->addr;
    unshift(@pos, $a) if defined $a;
    $p = $p->parent;
  }
  @pos;
}


sub HTML::Element::content_handler {
  my ($tree, %content_hash) = @_;

  for my $k (keys %content_hash) {
      $tree->set_child_content(id => $k, $content_hash{$k});      
  }


}

sub HTML::Element::assign {
    goto &HTML::Element::content_handler;
}


sub make_counter {
  my $i = 1;
  sub {
    shift() . ':' . $i++
  }
}


sub HTML::Element::iter {
  my ($tree, $p, @data) = @_;

  #  warn 'P: ' , $p->attr('id') ;
  #  warn 'H: ' , $p->as_HTML;

  #  my $id_incr = make_counter;
  my @item = map {
    my $new_item = clone $p;
    $new_item->replace_content($_);
    $new_item;
  } @data;

  $p->replace_with(@item);

}


sub HTML::Element::iter2 {

  my $tree = shift;

  #warn "INPUT TO TABLE2: ", Dumper \@_;

  my %p = validate(
    @_, {
      wrapper_ld    => { default => ['_tag' => 'dl'] },
      wrapper_data  => 1,
      wrapper_proc  => { default => undef },
      item_ld       => { default => sub { 
			   my $tree = shift;
			   [
			     $tree->look_down('_tag' => 'dt'),
			     $tree->look_down('_tag' => 'dd')
			    ];
			 }
			},
      item_data     => { default => sub { my ($wrapper_data) = @_;
					  shift(@{$wrapper_data}) ;
					}},
      item_proc     => {
	default => sub {
	  my ($item_elems, $item_data, $row_count) = @_;
	  $item_elems->[$_]->replace_content($item_data->[$_]) for (0,1) ;
	  $item_elems;
	}},
      splice        => { default => sub {
			   my ($container, @item_elems) = @_;
			   $container->splice_content(0, 2, @item_elems);
			 }
			},
      debug => {default => 0}
     }
   );

  warn "wrapper_data: " . Dumper $p{wrapper_data} if $p{debug} ;

  my $container = ref_or_ld($tree, $p{wrapper_ld});
  warn "container: " . $container if $p{debug} ;
  warn "wrapper_(preproc): " . $container->as_HTML if $p{debug} ;
  $p{wrapper_proc}->($container) if defined $p{wrapper_proc} ;
  warn "wrapper_(postproc): " . $container->as_HTML if $p{debug} ;

  my $_item_elems = $p{item_ld}->($container);
  

  my $row_count;
  my @item_elem;
  {
    my $item_data  = $p{item_data}->($p{wrapper_data});
    last unless defined $item_data;

    warn Dumper("item_data", $item_data);


    my $item_elems = [ map { $_->clone } @{$_item_elems} ] ;

    if ($p{debug}) {
      for (@{$item_elems}) {
	warn "ITEM_ELEMS ", $_->as_HTML;
      }
    }

    my $new_item_elems = $p{item_proc}->($item_elems, $item_data, ++$row_count);

    if ($p{debug}) {
      for (@{$new_item_elems}) {
	warn "NEWITEM_ELEMS ", $_->as_HTML;
      }
    }


    push @item_elem, @{$new_item_elems} ;

    redo;
  }

  warn "pushing " . @item_elem . " elems " if $p{debug} ;

  $p{splice}->($container, @item_elem);

}

sub HTML::Element::dual_iter {
  my ($parent, $data) = @_;

  my ($prototype_a, $prototype_b) = $parent->content_list;

  #  my $id_incr = make_counter;

  my $i;

  @$data %2 == 0 or 
    confess 'dataset does not contain an even number of members';

  my @iterable_data = ngroup 2 => @$data;

  my @item = map {
    my ($new_a, $new_b) = map { clone $_ } ($prototype_a, $prototype_b) ;
    $new_a->splice_content(0,1, $_->[0]);
    $new_b->splice_content(0,1, $_->[1]);
    #$_->attr('id', $id_incr->($_->attr('id'))) for ($new_a, $new_b) ;
    ($new_a, $new_b)
  } @iterable_data;

  $parent->splice_content(0, 2, @item);

}


sub HTML::Element::set_child_content {
  my $tree      = shift;
  my $content   = pop;
  my @look_down = @_;

  my $content_tag = $tree->look_down(@look_down);

  unless ($content_tag) {
    warn "criteria [@look_down] not found";
    return;
  }

  $content_tag->replace_content($content);

}

sub HTML::Element::highlander {
  my ($tree, $local_root_id, $aref, @arg) = @_;

  ref $aref eq 'ARRAY' or confess 
    "must supply array reference";
    
  my @aref = @$aref;
  @aref % 2 == 0 or confess 
    "supplied array ref must have an even number of entries";

  warn __PACKAGE__ if $DEBUG;

  my $survivor;
  while (my ($id, $test) = splice @aref, 0, 2) {
    warn $id if $DEBUG;
    if ($test->(@arg)) {
      $survivor = $id;
      last;
    }
  }


  my @id_survivor = (id => $survivor);
  my $survivor_node = $tree->look_down(@id_survivor);
#  warn $survivor;
#  warn $local_root_id;
#  warn $node;

  warn "survivor: $survivor" if $DEBUG;
  warn "tree: "  . $tree->as_HTML if $DEBUG;

  $survivor_node or die "search for @id_survivor failed in tree($tree): " . $tree->as_HTML;

  my $survivor_node_parent = $survivor_node->parent;
  $survivor_node = $survivor_node->clone;
  $survivor_node_parent->replace_content($survivor_node);

  warn "new tree: " . $tree->as_HTML if $DEBUG;

  $survivor_node;
}


sub HTML::Element::highlander2 {
  my $tree = shift;

  my %p = validate(@_, {
    cond => { type => ARRAYREF },
    cond_arg => { type => ARRAYREF,
		  default => []
		 },
    debug => { default => 0 }
   }
		  );


  my @cond = @{$p{cond}};
  @cond % 2 == 0 or confess 
    "supplied array ref must have an even number of entries";

  warn __PACKAGE__ if $p{debug};

  my @cond_arg = @{$p{cond_arg}};

  my $survivor; my $then;
  while (my ($id, $if_then) = splice @cond, 0, 2) {

    warn $id if $p{debug};
    my ($if, $_then);

    if (ref $if_then eq 'ARRAY') {
      ($if, $_then) = @$if_then;
    } else {
      ($if, $_then) = ($if_then, sub {});
    }

    if ($if->(@cond_arg)) {
      $survivor = $id;
      $then = $_then;
      last;
    }

  }

  my @ld = (ref $survivor eq 'ARRAY')
      ? @$survivor
	  : (id => $survivor)
	      ;

  warn "survivor:    ", $survivor if $p{debug};
  warn "survivor_ld: ", Dumper \@ld if $p{debug};


  my $survivor_node = $tree->look_down(@ld);

  $survivor_node or confess
      "search for @ld failed in tree($tree): " . $tree->as_HTML;

  my $survivor_node_parent = $survivor_node->parent;
  $survivor_node = $survivor_node->clone;
  $survivor_node_parent->replace_content($survivor_node);


  # **************** NEW FUNCTIONALITY *******************

  # apply transforms on survivor node


  warn "SURV::pre_trans "  . $survivor_node->as_HTML if $p{debug};
  $then->($survivor_node, @cond_arg);
  warn "SURV::post_trans "  . $survivor_node->as_HTML if $p{debug};

  # **************** NEW FUNCTIONALITY *******************


  $survivor_node;
}


sub overwrite_action {
  my ($mute_node, %X) = @_;

  $mute_node->attr($X{local_attr}{name} => $X{local_attr}{value}{new});
}


sub HTML::Element::overwrite_attr {
  my $tree = shift;
  
  $tree->mute_elem(@_, \&overwrite_action);
}


sub HTML::Element::mute_elem {
  my ($tree, $mute_attr, $closures, $post_hook) = @_;

  warn "my mute_node = $tree->look_down($mute_attr => qr/.*/) ;";
  my @mute_node = $tree->look_down($mute_attr => qr/.*/) ;

  for my $mute_node (@mute_node) {
    my ($local_attr,$mute_key)        = split /\s+/, $mute_node->attr($mute_attr);
    my $local_attr_value_current      = $mute_node->attr($local_attr);
    my $local_attr_value_new          = $closures->{$mute_key}->($tree, $mute_node, $local_attr_value_current);
    $post_hook->(
      $mute_node,
      tree => $tree,
      local_attr => {
	name => $local_attr,
	value => {
	  current => $local_attr_value_current,
	  new     => $local_attr_value_new
	 }
       }
     ) if ($post_hook) ;
  }
}


sub HTML::Element::table {

  my ($s, %table) = @_;

  my $table = {};

  #  use Data::Dumper; warn Dumper \%table;

  #  ++$DEBUG if $table{debug} ;


  # Get the table element
  $table->{table_node} = $s->look_down(id => $table{gi_table});
  $table->{table_node} or confess
    "table tag not found via (id => $table{gi_table}";

  # Get the prototype tr element(s) 
  my @table_gi_tr = listify $table{gi_tr} ;
  my @iter_node = map 
    {
      my $tr = $table->{table_node}->look_down(id => $_);
      $tr or confess "tr with id => $_ not found";
      $tr;
    } @table_gi_tr;

  warn "found " . @iter_node . " iter nodes " if $DEBUG;
  #  tie my $iter_node, 'Tie::Cycle', \@iter_node;
  my $iter_node =  List::Rotation::Cycle->new(@iter_node);

  #  warn $iter_node;
  warn Dumper ($iter_node, \@iter_node) if $DEBUG;

  # $table->{content}    = $table{content};
  #$table->{parent}     = $table->{table_node}->parent;


  #  $table->{table_node}->detach;
  #  $_->detach for @iter_node;

  my @table_rows;

  {
    my $row = $table{tr_data}->($table, $table{table_data});
    last unless defined $row;

    # get a sample table row and clone it.
    my $I = $iter_node->next;
    warn  "I: $I" if $DEBUG;
    my $new_iter_node = $I->clone;


      $table{td_data}->($new_iter_node, $row);
      push @table_rows, $new_iter_node;

    redo;
  }

  if (@table_rows) {

    my $replace_with_elem = $s->look_down(id => shift @table_gi_tr) ;
    for (@table_gi_tr) {
      $s->look_down(id => $_)->detach;
    }

    $replace_with_elem->replace_with(@table_rows);

  }

}

sub ref_or_ld {

  my ($tree, $slot) = @_;

  if (ref($slot) eq 'CODE') {
    $slot->($tree);
  } else {
    $tree->look_down(@$slot);
  }
}


sub HTML::Element::table2 {

  my $tree = shift;


  my %p = validate(
    @_, {
      table_ld    => { default => ['_tag' => 'table'] },
      table_data  => 1,
      table_proc  => { default => undef },
      
      tr_ld       => { default => ['_tag' => 'tr']    },
      tr_data     => { default => sub { my ($self, $data) = @_;
				      shift(@{$data}) ;
				    }},
      tr_base_id  => { default => undef },
      tr_proc     => { default => sub {} },
      td_proc     => 1,
      debug => {default => 0}
     }
   );

  warn "INPUT TO TABLE2: ", Dumper \@_ if $p{debug};

  warn "table_data: " . Dumper $p{table_data} if $p{debug} ;

  my $table = {};

  #  use Data::Dumper; warn Dumper \%table;

  #  ++$DEBUG if $table{debug} ;

  # Get the table element
  #warn 1;
  $table->{table_node} = ref_or_ld( $tree, $p{table_ld} ) ;
  #warn 2;
  $table->{table_node} or confess
    "table tag not found via " . Dumper($p{table_ld}) ;

  warn "table: " . $table->{table_node}->as_HTML if $p{debug};


  # Get the prototype tr element(s) 
  my @proto_tr = ref_or_ld( $table->{table_node},  $p{tr_ld} ) ;

  warn "found " . @proto_tr . " iter nodes " if $p{debug};

  @proto_tr or return ;

  if ($p{debug}) {
    warn $_->as_HTML for @proto_tr;
  }
  my $proto_tr =  List::Rotation::Cycle->new(@proto_tr);

  my $tr_parent = $proto_tr[0]->parent;
  warn "parent element of trs: " . $tr_parent->as_HTML if $p{debug};

  my $row_count;

  my @table_rows;

  {
    my $row = $p{tr_data}->($table, $p{table_data}, $row_count);
    warn  "data row: " . Dumper $row if $p{debug};
    last unless defined $row;

    # wont work:      my $new_iter_node = $table->{iter_node}->clone;
    my $new_tr_node = $proto_tr->next->clone;
    warn  "new_tr_node: $new_tr_node" if $p{debug};

    $p{tr_proc}->($tree, $new_tr_node, $row, $p{tr_base_id}, ++$row_count)
	if defined $p{tr_proc};

    warn  "data row redux: " . Dumper $row if $p{debug};
    #warn 3.3;

    $p{td_proc}->($new_tr_node, $row);
    push @table_rows, $new_tr_node;

    #warn 4.4;

    redo;
  }

  $_->detach for @proto_tr;

  $tr_parent->push_content(@table_rows) if (@table_rows) ;

}


sub HTML::Element::unroll_select {

  my ($s, %select) = @_;

  my $select = {};

  warn "Select Hash: " . Dumper(\%select) if $select{debug};

  my $select_node = $s->look_down(id => $select{select_label});
  warn "Select Node: " . $select_node if $select{debug};

  unless ($select{append}) {
      for my $option ($select_node->look_down('_tag' => 'option')) {
	  $option->delete;
      }
  }


  my $option = HTML::Element->new('option');
  warn "Option Node: " . $option if $select{debug};

  $option->detach;

  while (my $row = $select{data_iter}->($select{data}))
    {
	warn "Data Row:" . Dumper($row) if $select{debug};
	my $o = $option->clone;
	$o->attr('value', $select{option_value}->($row));
	$o->attr('SELECTED', 1) if (exists $select{option_selected} and $select{option_selected}->($row)) ;

	$o->replace_content($select{option_content}->($row));
	$select_node->push_content($o);
	warn $o->as_HTML if $select{debug};
    }


}


sub HTML::Element::set_sibling_content {
  my ($elt, $content) = @_;

  $elt->parent->splice_content($elt->pindex + 1, 1, $content);

}

sub HTML::TreeBuilder::parse_string {
  my ($package, $string) = @_;

  my $h = HTML::TreeBuilder->new;
  HTML::TreeBuilder->parse($string);

}


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