t/misc.t

   1 #!/usr/bin/perl -T
   2 use lib '.';
   3 use t::lib tests => 27;
   4
   5 ##################################################
   6 # Short tests based on mklol
   7
   8 sub mklol {
   9         HTML::Element->new_from_lol(
  10                 ['html',
  11                  ['head',
  12                   [ 'title', 'I like stuff!' ]],
  13                  ['body', {id => 'corpus'}, {'lang', 'en-JP'},
  14                   'stuff',
  15                   ['p', 'um, p < 4!', {'class' => 'par123'}],
  16                   ['div', {foo => 'bar'}, '123'],
  17                   ['div', {jack => 'olantern'}, '456']]]);
  18 }
  19
  20 my $tree_replaced = \'<html><head><title>I like stuff!</title></head><body id="corpus" lang="en-JP">all gone!</body></html>';
  21 my $tree;
  22
  23 $tree = mklol;
  24 $tree->content_handler(corpus => 'all gone!');
  25 isxml $tree, $tree_replaced, 'content_handler';
  26
  27 $tree = mklol;
  28 $tree->set_child_content(id => 'corpus', 'all gone!');
  29 isxml $tree, $tree_replaced, 'set_child_content';
  30
  31 $tree = mklol;
  32 $tree->look_down('_tag' => 'body')->replace_content('all gone!');
  33 isxml $tree, $tree_replaced, 'replace_content';
  34
  35 $tree = mklol;
  36 my $p = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
  37 is $p->sibdex, 1, 'p tag has 1 as its index';
  38
  39 $tree = mklol;
  40 my $div = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
  41 my @sibs = $div->siblings;
  42 is $sibs[0], 'stuff', "first sibling is simple text";
  43 is $sibs[2]->tag, 'div', "3rd tag is a div tag";
  44 is scalar @sibs, 4, "4 siblings total";
  45
  46 $tree = mklol;
  47 my $bold = HTML::Element->new('b', id => 'wrapper');
  48 my $w = $tree->look_down(_tag => 'p');
  49 $w->wrap_content($bold);
  50 isxml $w, \'<p class="par123"><b id="wrapper">um, p &lt; 4!</b></p>', 'wrap_content';
  51
  52 ##################################################
  53 # Short tests
  54
  55 $tree = mktree 't/html/crunch.html';
  56 $tree->crunch(look_down => [ class => 'imageElement' ], leave => 1);
  57 isxml $tree, 't/html/crunch-exp.html', 'crunch';
  58
  59 $tree = mktree 't/html/defmap.html';
  60 $tree->defmap(smap => {pause => 'arsenal rules'}, $ENV{TEST_VERBOSE});
  61 isxml $tree, 't/html/defmap-exp.html', 'defmap';
  62
  63 $tree = mktree 't/html/fillinform.html';
  64 isxml \($tree->fillinform({state => 'catatonic'})), 't/html/fillinform-exp.html', 'fillinform';
  65
  66 $tree = mktree 't/html/hashmap.html';
  67 $tree->hash_map(
  68         hash      => {people_id => 888, phone => '444-4444', email => 'm@xml.com'},
  69         to_attr   => 'sid',
  70         excluding => ['email']
  71 );
  72 isxml $tree, 't/html/hashmap-exp.html', 'hash_map';
  73
  74 $tree = mktree 't/html/iter.html';
  75 my $li = $tree->look_down(class => 'store_items');
  76 $tree->iter($li, qw/bread butter vodka/);
  77 isxml $tree, 't/html/iter-exp.html', 'iter';
  78
  79 my @list = map { [item => $_] } qw/bread butter beans/;
  80 my $initial_lol = [ note => [ list => [ item => 'sample' ] ] ];
  81 my ($new_lol) = HTML::Element::newchild($initial_lol, list => @list);
  82 my $expected = [note => [list => [item => 'bread'], [item => 'butter'], [item => 'beans']]];
  83 is_deeply $new_lol, $expected, 'newchild unrolling';
  84
  85 $tree = mktree 't/html/highlander2.html';
  86 $tree->passover('under18');
  87 isxml $tree, 't/html/highlander2-passover-exp.html', 'passover';
  88
  89 $tree = mktree 't/html/position.html';
  90 my $found = $tree->look_down(id => 'findme');
  91 my $pos = join ' ', $found->position;
  92 is $pos, '-1 1 0 1 2', 'position';
  93
  94 $tree = mktree 't/html/prune.html';
  95 $tree->prune;
  96 isxml $tree, 't/html/prune-exp.html', 'prune';
  97
  98 ##################################################
  99 # Longer tests
 100
 101 $tree = mktree 't/html/dual_iter.html';
 102
 103 $tree->iter2(
 104         wrapper_data => [
 105                 ['the pros' => 'never have to worry about service again'],
 106                 ['the cons' => 'upfront extra charge on purchase'],
 107                 ['our choice' => 'go with the extended service plan']
 108         ],
 109         wrapper_proc => sub {
 110                 my ($container) = @_;
 111                 # only keep the last 2 dts and dds
 112                 my @content_list = $container->content_list;
 113                 $container->splice_content(0, @content_list - 2);
 114         },
 115         splice       => sub {
 116                 my ($container, @item_elems) = @_;
 117                 $container->unshift_content(@item_elems);
 118         },
 119         debug        => $ENV{TEST_VERBOSE},
 120 );
 121
 122 isxml $tree, 't/html/dual_iter-exp.html', 'dual_iter';
 123
 124 ###
 125
 126 sub cb {
 127         my ($data, $tr) = @_;
 128         $tr->look_down(class => 'first')->replace_content($data->{first});
 129         $tr->look_down(class => 'last')->replace_content($data->{last});
 130         $tr->look_down(class => 'option')->replace_content($data->{option});
 131 }
 132
 133 my @cbdata = (
 134         {first => 'Foo', last => 'Bar', option => 2},
 135         {first => 'Bar', last => 'Bar', option => 3},
 136         {first => 'Baz', last => 'Bar', option => 4},
 137 );
 138
 139 $tree = mktree 't/html/itercb.html';
 140 $tree->find('table')->find('tbody')->find('tr')->itercb(\@cbdata, \&cb);
 141 isxml $tree, 't/html/itercb-exp.html', 'itercb';
 142
 143 ###
 144
 145 for my $age (qw/5 15 50/) {
 146         $tree = mktree 't/html/highlander.html';
 147         $tree->highlander(
 148                 age_dialog => [
 149                         under10 => sub { $_[0] < 10 },
 150                         under18 => sub { $_[0] < 18 },
 151                         welcome => sub { 1 }
 152                 ],
 153                 $age
 154         );
 155         isxml $tree, "t/html/highlander-$age-exp.html", "highlander for $age";
 156 }
 157
 158 ###
 159
 160 sub replace_age {
 161         my ($branch, $age) = @_;
 162         $branch->look_down(id => 'age')->replace_content($age);
 163 }
 164
 165 for my $age (qw/5 15 27/) {
 166         $tree = mktree 't/html/highlander2.html';
 167         my $if_then = $tree->look_down(id => 'age_dialog')->highlander2(
 168                 cond => [
 169                         under10 => [ sub { $_[0] < 10 }, \&replace_age ],
 170                         under18 => [ sub { $_[0] < 18 }, \&replace_age ],
 171                         welcome => [ sub { 1          }, \&replace_age ]
 172                 ],
 173                 cond_arg => [ $age ]
 174         );
 175
 176         isxml ($tree, "t/html/highlander2-$age-exp.html", "highlander2 for age $age");
 177 }
 178
 179 ###
 180
 181 $tree = mktree 't/html/iter2.html';
 182
 183 $tree->iter2(
 184         # default wrapper_ld ok
 185         wrapper_data => [
 186                 [ Programmer => 'one who likes Perl and Seamstress' ],
 187                 [ DBA        => 'one who does business as' ],
 188                 [ Admin      => 'one who plays Tetris all day' ]
 189         ],
 190         wrapper_proc => sub {
 191                 my ($container) = @_;
 192
 193                 # only keep the last 2 dts and dds
 194                 my @content_list = $container->content_list;
 195                 $container->splice_content(0, @content_list - 2);
 196         },
 197         # default item_ld is k00l
 198         # default item_data is phrEsh
 199         # default item_proc will do w0rk
 200         splice       => sub {
 201                 my ($container, @item_elems) = @_;
 202                 $container->unshift_content(@item_elems);
 203         },
 204
 205         debug => $ENV{TEST_VERBOSE},
 206 );
 207
 208 isxml $tree, 't/html/iter2-exp.html', 'iter2';
 209
 210 ###
 211
 212 my @data = (
 213         { clan_name => 'janglers',    clan_id => 12, selected => 1 },
 214         { clan_name => 'thugknights', clan_id => 14 },
 215         { clan_name => 'cavaliers' ,  clan_id => 13 }
 216 );
 217 $tree = mktree 't/html/unroll_select.html';
 218
 219 $tree->unroll_select(
 220         select_label     => 'clan_list',
 221         option_value     => sub { my $row = shift; $row->{clan_id} },
 222         option_content   => sub { my $row = shift; $row->{clan_name} },
 223         option_selected  => sub { my $row = shift; $row->{selected} },
 224         data             => \@data,
 225         data_iter        => sub { my $data = shift; shift @$data });
 226
 227 isxml $tree, 't/html/unroll_select-exp.html', 'unroll_select';