line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
=head1 NAME |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
HTML::Tested - Provides HTML widgets with the built-in means of testing. |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 SYNOPSIS |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package MyPage; |
8
|
|
|
|
|
|
|
use base 'HTML::Tested'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
__PACKAGE__->make_tested_value('x'); |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# Register my own widget |
13
|
|
|
|
|
|
|
__PACKAGE__->register_tested_widget('my_widget', 'My::App::Widget'); |
14
|
|
|
|
|
|
|
__PACKAGE__->make_tested_my_widget('w'); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# Later, in the test for example |
18
|
|
|
|
|
|
|
package main; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
my $p = MyPage->construct_somehow; |
21
|
|
|
|
|
|
|
$p->x('Hi'); |
22
|
|
|
|
|
|
|
my $stash = {}; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
$p->ht_render($stash); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# stash contains x => 'Hi' |
27
|
|
|
|
|
|
|
# We can pass it to templating mechanism |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# Stash checking function |
30
|
|
|
|
|
|
|
my @errors = HTML::Tested::Test->check_stash( |
31
|
|
|
|
|
|
|
'MyPage', $stash, { x => 'Hi' }); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Stash checking function |
34
|
|
|
|
|
|
|
my @errors = HTML::Tested::Test->check_text( |
35
|
|
|
|
|
|
|
'MyPage', 'x', { x => 'Hi' }); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 DISCLAIMER |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
This is pre-alpha quality software. Please use it on your own risk. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 INTRODUCTION |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Imagine common web programming scenario - you have HTML page packed with |
44
|
|
|
|
|
|
|
checkboxes, edit boxes, labels etc. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
You are probably using some kind of templating mechanism for this page already. |
47
|
|
|
|
|
|
|
However, your generating routine still has quite a lot of complex code. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
Now, being an experienced XP programmer, you face the task of writing test |
50
|
|
|
|
|
|
|
code for the routine. Note, that your test code can deal with the results on |
51
|
|
|
|
|
|
|
two levels: we can check the stash that we are going to pass to the templating module |
52
|
|
|
|
|
|
|
or we can crawl our site and check the resulting text. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
As you can imagine both of those scenarios require quite a lot of effort to |
55
|
|
|
|
|
|
|
get right. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
HTML::Tested can help here. It does this by generating stash data from the |
58
|
|
|
|
|
|
|
widgets that you declare. Its testing code can check the existence of those |
59
|
|
|
|
|
|
|
widgets both in the stash and in the text of the page. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=cut |
62
|
|
|
|
|
|
|
|
63
|
20
|
|
|
20
|
|
795679
|
use strict; |
|
20
|
|
|
|
|
46
|
|
|
20
|
|
|
|
|
1092
|
|
64
|
20
|
|
|
20
|
|
222
|
use warnings FATAL => 'all'; |
|
20
|
|
|
|
|
41
|
|
|
20
|
|
|
|
|
1734
|
|
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
package HTML::Tested; |
67
|
20
|
|
|
20
|
|
185
|
use base 'Exporter', 'Class::Accessor', 'Class::Data::Inheritable'; |
|
20
|
|
|
|
|
48
|
|
|
20
|
|
|
|
|
47241
|
|
68
|
20
|
|
|
20
|
|
105711
|
use Carp; |
|
20
|
|
|
|
|
56
|
|
|
20
|
|
|
|
|
2109
|
|
69
|
|
|
|
|
|
|
our $VERSION = '0.58'; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
our @EXPORT_OK = qw(HT HTV); |
72
|
|
|
|
|
|
|
|
73
|
20
|
|
|
20
|
|
123
|
use constant HT => 'HTML::Tested'; |
|
20
|
|
|
|
|
40
|
|
|
20
|
|
|
|
|
2029
|
|
74
|
20
|
|
|
20
|
|
130
|
use constant HTV => 'HTML::Tested::Value'; |
|
20
|
|
|
|
|
54
|
|
|
20
|
|
|
|
|
31303
|
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('Widgets_List', []); |
77
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_Widgets_Hash', {}); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=head1 METHODS |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=head2 $class->ht_add_widget($widget_class, $widget_name, @widget_args) |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
Adds widget implemented by C<$widget_class> to C<$class> as C<$widget_name>. |
84
|
|
|
|
|
|
|
C<@widget_args> are passed as is into $widget_class->new function. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
For example, A->ht_add_widget("HTML::Tested::Value", "a", default_value => "b"); |
87
|
|
|
|
|
|
|
will create value widget (and corresponding C accessor) in A class which |
88
|
|
|
|
|
|
|
will have default value "b". |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
See widget C function documentation for relevant C<@widget_args> values |
91
|
|
|
|
|
|
|
(most of them are documented in L class). |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=cut |
94
|
|
|
|
|
|
|
sub ht_add_widget { |
95
|
129
|
|
|
129
|
1
|
68851
|
my ($class, $widget_class, $name, @args) = @_; |
96
|
129
|
100
|
|
|
|
1305
|
confess sprintf('Widget "%s" already exists', $name) |
97
|
|
|
|
|
|
|
if $class->ht_find_widget($name); |
98
|
128
|
|
|
|
|
3316
|
$class->mk_accessors($name); |
99
|
128
|
|
|
|
|
12492
|
my $res = $widget_class->new($class, $name, @args); |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# to avoid inheritance troubles... |
102
|
127
|
50
|
|
|
|
240
|
my @wl = @{ $class->Widgets_List || [] }; |
|
127
|
|
|
|
|
910
|
|
103
|
127
|
|
|
|
|
1810
|
push @wl, $res; |
104
|
127
|
|
|
|
|
465
|
$class->Widgets_List(\@wl); |
105
|
|
|
|
|
|
|
|
106
|
127
|
50
|
|
|
|
4914
|
my %wh = %{ $class->_Widgets_Hash || {} }; |
|
127
|
|
|
|
|
435
|
|
107
|
127
|
|
|
|
|
1668
|
$wh{ $res->name } = $res; |
108
|
127
|
|
|
|
|
473
|
$class->_Widgets_Hash(\%wh); |
109
|
127
|
100
|
|
|
|
5384
|
$res->compile($class) if $res->can('compile'); |
110
|
127
|
|
|
|
|
1139
|
return $res; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _ht_render_i { |
114
|
233
|
|
|
233
|
|
557
|
my ($self, $stash, $parent_name) = @_; |
115
|
233
|
|
|
|
|
335
|
for my $v (@{ $self->Widgets_List }) { |
|
233
|
|
|
|
|
739
|
|
116
|
280
|
|
|
|
|
2942
|
my $n = $v->name; |
117
|
280
|
100
|
|
|
|
824
|
my $id = $parent_name ? $parent_name . "__$n" : $n; |
118
|
280
|
|
|
|
|
1175
|
$v->render($self, $stash, $id, $n); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
=head2 ht_render(stash) |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
Renders all of the contained controls into the stash. |
125
|
|
|
|
|
|
|
C should be hash reference. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
=cut |
128
|
99
|
|
|
99
|
1
|
103106
|
sub ht_render { shift()->_ht_render_i(shift); } |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=head2 ht_find_widget($widget_name) |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
Finds widget named C<$widget_name>. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=cut |
135
|
|
|
|
|
|
|
sub ht_find_widget { |
136
|
1026
|
|
|
1026
|
1
|
6018
|
my ($self, $wn) = @_; |
137
|
1026
|
|
|
|
|
4149
|
return $self->_Widgets_Hash->{$wn}; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head2 ht_bless_from_tree(class, tree) |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Creates blessed instance of the class from tree. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
sub ht_bless_from_tree { |
146
|
8
|
|
|
8
|
1
|
3627
|
my ($class, $tree) = @_; |
147
|
8
|
|
|
|
|
15
|
my $res = {}; |
148
|
8
|
|
|
|
|
31
|
while (my ($n, $v) = each %$tree) { |
149
|
9
|
|
|
|
|
29
|
my $wc = $class->ht_find_widget($n); |
150
|
9
|
100
|
|
|
|
95
|
$res->{$n} = $wc ? $wc->bless_from_tree($v) : $v; |
151
|
|
|
|
|
|
|
} |
152
|
8
|
|
|
|
|
37
|
return bless($res, $class); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub _ht_set_one { |
156
|
260
|
|
|
260
|
|
743
|
my ($self, $func, $val, @path) = @_; |
157
|
260
|
50
|
|
|
|
645
|
my $p = shift(@path) or return; |
158
|
260
|
100
|
|
|
|
623
|
my $wc = $self->ht_find_widget($p) or return; |
159
|
259
|
|
|
|
|
2785
|
$wc->$func($self, $val, @path); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub _call_finish_load { |
163
|
141
|
|
|
141
|
|
202
|
my $self = shift; |
164
|
141
|
|
|
|
|
443
|
my $wl = $self->Widgets_List; |
165
|
141
|
|
|
|
|
973
|
$_->finish_load($self) for grep { $_->can('finish_load') } @$wl; |
|
163
|
|
|
|
|
1164
|
|
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub _for_each_arg_set_one { |
169
|
25
|
|
|
25
|
|
131
|
my ($self, $func, %args) = @_; |
170
|
25
|
|
|
|
|
290
|
$self->_ht_set_one($func, $args{$_}, split('__', $_)) for keys %args; |
171
|
25
|
|
|
|
|
230
|
$self->_call_finish_load; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub ht_load_from_params { |
175
|
20
|
|
|
20
|
0
|
10248
|
my ($class, %args) = @_; |
176
|
20
|
|
|
|
|
138
|
my $self = $class->new; |
177
|
20
|
|
|
|
|
438
|
$self->_for_each_arg_set_one("absorb_one_value", %args); |
178
|
20
|
|
|
|
|
140
|
return $self; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=head2 ht_get_widget_option($widget_name, $option_name) |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
Gets option C<$option_name> for widget named C<$widget_name>. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=cut |
186
|
|
|
|
|
|
|
sub ht_get_widget_option { |
187
|
479
|
|
|
479
|
1
|
10918
|
my ($self, $wn, $opname) = @_; |
188
|
479
|
100
|
|
|
|
1033
|
my $w = $self->ht_find_widget($wn) or confess "Unknown widget $wn"; |
189
|
478
|
|
|
|
|
5156
|
return $w->_get_option($self, $wn, $opname); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=head2 ht_set_widget_option($widget_name, $option_name, $value) |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
Sets option C<$option_name> to C<$value> for widget named C<$widget_name>. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=cut |
197
|
|
|
|
|
|
|
sub ht_set_widget_option { |
198
|
13
|
|
|
13
|
1
|
15435
|
my ($self, $wname, $opname, $val) = @_; |
199
|
13
|
100
|
|
|
|
59
|
my $w = $self->ht_find_widget($wname) |
200
|
|
|
|
|
|
|
or confess "Unknown widget $wname"; |
201
|
12
|
100
|
|
|
|
162
|
if (ref($self)) { |
202
|
8
|
|
|
|
|
45
|
$self->{"__ht__$wname\_$opname"} = $val; |
203
|
|
|
|
|
|
|
} else { |
204
|
4
|
|
|
|
|
26
|
$w->options->{$opname} = $val; |
205
|
|
|
|
|
|
|
} |
206
|
12
|
|
|
|
|
166
|
$w->compile($self); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=head2 $root->ht_validate |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Recursively validates all contained widgets. See C for |
212
|
|
|
|
|
|
|
C<$widget->validate> method description. |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
Prepends the names of the widgets which failed validation into result arrays. |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=cut |
217
|
|
|
|
|
|
|
sub ht_validate { |
218
|
22
|
|
|
22
|
1
|
1611
|
my $self = shift; |
219
|
22
|
|
|
|
|
29
|
return map { $_->validate($self) } @{ $self->Widgets_List }; |
|
28
|
|
|
|
|
222
|
|
|
22
|
|
|
|
|
58
|
|
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=head2 $root->ht_make_query_string($uri, @widget_names) |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
Makes query string from $uri and widget values. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=cut |
227
|
|
|
|
|
|
|
sub ht_make_query_string { |
228
|
0
|
|
|
0
|
1
|
0
|
my ($self, $uri, @widget_names) = @_; |
229
|
0
|
0
|
|
|
|
0
|
return $uri unless @widget_names; |
230
|
0
|
0
|
|
|
|
0
|
$uri .= ($uri =~ /\?/) ? "&" : "?"; |
231
|
0
|
|
|
|
|
0
|
return $uri . join("&", map { |
232
|
0
|
|
|
|
|
0
|
"$_=" . $self->ht_find_widget($_)->prepare_value($self, $_, $_) |
233
|
|
|
|
|
|
|
} @widget_names); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=head2 $root->ht_merge_params(@params) |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
Merges parameters with current values. Tries to reconstruct the state of the |
239
|
|
|
|
|
|
|
controls to user set values. |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
E.g. for EditBox it means setting its value to one in params. For checkbox - |
242
|
|
|
|
|
|
|
setting its C state. |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=cut |
245
|
|
|
|
|
|
|
sub ht_merge_params { |
246
|
5
|
|
|
5
|
1
|
9346
|
my ($self, %params) = @_; |
247
|
5
|
|
|
|
|
43
|
$self->_for_each_arg_set_one("merge_one_value", %params); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub ht_encode_errors { |
251
|
2
|
|
|
2
|
0
|
2524
|
my ($class, @errs) = @_; |
252
|
2
|
|
|
|
|
6
|
return join(",", map { $_->[0] . ":" . $_->[1] } @errs); |
|
3
|
|
|
|
|
25
|
|
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub _error_one { |
256
|
3
|
|
|
3
|
|
8
|
my ($self, $stash, $var_name, $n, $v) = @_; |
257
|
3
|
|
|
|
|
12
|
my @ns = split('__', $n); |
258
|
3
|
|
|
|
|
12
|
while (@ns > 1) { |
259
|
1
|
|
|
|
|
3
|
my $ln = shift @ns; |
260
|
1
|
|
|
|
|
3
|
my $lidx = shift @ns; |
261
|
|
|
|
|
|
|
|
262
|
1
|
|
|
|
|
13
|
$stash = $stash->{$ln}->[ $lidx - 1 ]; |
263
|
|
|
|
|
|
|
} |
264
|
3
|
|
|
|
|
21
|
$stash->{$var_name}->{ $ns[0] } = $v; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
sub ht_error_render { |
268
|
2
|
|
|
2
|
0
|
741
|
my ($self, $stash, $var_name, $err) = @_; |
269
|
2
|
|
|
|
|
25
|
$self->_error_one($stash, $var_name, split(':')) for split(',', $err); |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
1; |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=head1 BUGS |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Documentation is too sparse to be taken seriously. |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
=head1 AUTHOR |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
Boris Sukholitko |
281
|
|
|
|
|
|
|
CPAN ID: BOSU |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
boriss@gmail.com |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
=head1 COPYRIGHT |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
This program is free software; you can redistribute |
289
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself. |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
The full text of the license can be found in the |
292
|
|
|
|
|
|
|
LICENSE file included with this module. |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
=head1 SEE ALSO |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
HTML::Tested::Test for writing tests using HTML::Tested. |
298
|
|
|
|
|
|
|
See HTML::Tested::Value::* for the documentation on the specific |
299
|
|
|
|
|
|
|
widgets. |
300
|
|
|
|
|
|
|
See HTML::Tested::List for documentation on list container. |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=cut |
303
|
|
|
|
|
|
|
|