File Coverage

blib/lib/HTML/Tested.pm
Criterion Covered Total %
statement 89 94 94.6
branch 19 26 73.0
condition n/a
subroutine 22 23 95.6
pod 9 12 75.0
total 139 155 89.6


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