]> iEval git - html-element-library.git/blob - t/misc.t
Bump version and update Changes
[html-element-library.git] / 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';
This page took 0.067008 seconds and 4 git commands to generate.