]>
Commit | Line | Data |
---|---|---|
c337c404 MG |
1 | #!/usr/bin/perl -T |
2 | use lib '.'; | |
3 | use t::lib tests => 26; | |
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 < 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); | |
7c5af9fc | 57 | isxml $tree, 't/html/crunch-exp.html', 'crunch'; |
c337c404 MG |
58 | |
59 | $tree = mktree 't/html/defmap.html'; | |
60 | $tree->defmap(smap => {pause => 'arsenal rules'}, $ENV{TEST_VERBOSE}); | |
7c5af9fc | 61 | isxml $tree, 't/html/defmap-exp.html', 'defmap'; |
c337c404 MG |
62 | |
63 | $tree = mktree 't/html/fillinform.html'; | |
7c5af9fc | 64 | isxml \($tree->fillinform({state => 'catatonic'})), 't/html/fillinform-exp.html', 'fillinform'; |
c337c404 MG |
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 | ); | |
7c5af9fc | 72 | isxml $tree, 't/html/hashmap-exp.html', 'hash_map'; |
c337c404 MG |
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/); | |
7c5af9fc | 77 | isxml $tree, 't/html/iter-exp.html', 'iter'; |
c337c404 MG |
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'); | |
7c5af9fc | 87 | isxml $tree, 't/html/highlander2-passover-exp.html', 'passover'; |
c337c404 MG |
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; | |
7c5af9fc | 96 | isxml $tree, 't/html/prune-exp.html', 'prune'; |
c337c404 MG |
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 | ||
7c5af9fc | 122 | isxml $tree, 't/html/dual_iter-exp.html', 'dual_iter'; |
c337c404 MG |
123 | |
124 | ### | |
125 | ||
126 | for my $age (qw/5 15 50/) { | |
127 | $tree = mktree 't/html/highlander.html'; | |
128 | $tree->highlander( | |
129 | age_dialog => [ | |
130 | under10 => sub { $_[0] < 10 }, | |
131 | under18 => sub { $_[0] < 18 }, | |
132 | welcome => sub { 1 } | |
133 | ], | |
134 | $age | |
135 | ); | |
7c5af9fc | 136 | isxml $tree, "t/html/highlander-$age-exp.html", "highlander for $age"; |
c337c404 MG |
137 | } |
138 | ||
139 | ### | |
140 | ||
141 | sub replace_age { | |
142 | my ($branch, $age) = @_; | |
143 | $branch->look_down(id => 'age')->replace_content($age); | |
144 | } | |
145 | ||
146 | for my $age (qw/5 15 27/) { | |
147 | $tree = mktree 't/html/highlander2.html'; | |
148 | my $if_then = $tree->look_down(id => 'age_dialog')->highlander2( | |
149 | cond => [ | |
150 | under10 => [ sub { $_[0] < 10 }, \&replace_age ], | |
151 | under18 => [ sub { $_[0] < 18 }, \&replace_age ], | |
152 | welcome => [ sub { 1 }, \&replace_age ] | |
153 | ], | |
154 | cond_arg => [ $age ] | |
155 | ); | |
156 | ||
7c5af9fc | 157 | isxml ($tree, "t/html/highlander2-$age-exp.html", "highlander2 for age $age"); |
c337c404 MG |
158 | } |
159 | ||
160 | ### | |
161 | ||
162 | $tree = mktree 't/html/iter2.html'; | |
163 | ||
164 | $tree->iter2( | |
165 | # default wrapper_ld ok | |
166 | wrapper_data => [ | |
167 | [ Programmer => 'one who likes Perl and Seamstress' ], | |
168 | [ DBA => 'one who does business as' ], | |
169 | [ Admin => 'one who plays Tetris all day' ] | |
170 | ], | |
171 | wrapper_proc => sub { | |
172 | my ($container) = @_; | |
173 | ||
174 | # only keep the last 2 dts and dds | |
175 | my @content_list = $container->content_list; | |
176 | $container->splice_content(0, @content_list - 2); | |
177 | }, | |
178 | # default item_ld is k00l | |
179 | # default item_data is phrEsh | |
180 | # default item_proc will do w0rk | |
181 | splice => sub { | |
182 | my ($container, @item_elems) = @_; | |
183 | $container->unshift_content(@item_elems); | |
184 | }, | |
185 | ||
186 | debug => $ENV{TEST_VERBOSE}, | |
187 | ); | |
188 | ||
7c5af9fc | 189 | isxml $tree, 't/html/iter2-exp.html', 'iter2'; |
c337c404 MG |
190 | |
191 | ### | |
192 | ||
193 | my @data = ( | |
194 | { clan_name => 'janglers', clan_id => 12, selected => 1 }, | |
195 | { clan_name => 'thugknights', clan_id => 14 }, | |
196 | { clan_name => 'cavaliers' , clan_id => 13 } | |
197 | ); | |
198 | $tree = mktree 't/html/unroll_select.html'; | |
199 | ||
200 | $tree->unroll_select( | |
201 | select_label => 'clan_list', | |
202 | option_value => sub { my $row = shift; $row->{clan_id} }, | |
203 | option_content => sub { my $row = shift; $row->{clan_name} }, | |
204 | option_selected => sub { my $row = shift; $row->{selected} }, | |
205 | data => \@data, | |
206 | data_iter => sub { my $data = shift; shift @$data }); | |
207 | ||
7c5af9fc | 208 | isxml $tree, 't/html/unroll_select-exp.html', 'unroll_select'; |