File Coverage

lib/Test/WWW/Mechanize/Driver.pm
Criterion Covered Total %
statement 188 193 97.4
branch 65 78 83.3
condition 35 49 71.4
subroutine 29 29 100.0
pod 6 6 100.0
total 323 355 90.9


line stmt bran cond sub pod time code
1             package Test::WWW::Mechanize::Driver;
2 9     9   2291533 use Carp; use strict; use warnings;
  9     9   23  
  9     9   550  
  9         56  
  9         21  
  9         191  
  9         45  
  9         20  
  9         239  
3 9     9   4369 use Test::WWW::Mechanize::Driver::YAMLLoader;
  9         27  
  9         383  
4 9     9   63 use Test::WWW::Mechanize::Driver::Util qw/ :all /;
  9         18  
  9         1384  
5             require Test::WWW::Mechanize::Driver::MagicValues;
6 9     9   66 use Test::Builder;
  9         16  
  9         254  
7             require URI;
8 9     9   51 use Storable qw/dclone/;
  9         18  
  9         28765  
9              
10             my $Test = Test::Builder->new;
11             our $VERSION = '1.0';
12             our $TODO;
13             our $CURRENT_GROUP;
14              
15             =pod
16              
17             =head1 NAME
18              
19             Test::WWW::Mechanize::Driver - Drive Test::WWW::Mechanize Object Using YAML Configuration Files
20              
21             =head1 SYNOPSIS
22              
23             use strict; use warnings;
24             use Test::WWW::Mechanize::Driver;
25             Test::WWW::Mechanize::Driver->new(
26             load => [ glob( "t/*.yaml" ) ]
27             )->run;
28              
29              
30             use strict; use warnings;
31             use Test::WWW::Mechanize::Driver;
32             Test::WWW::Mechanize::Driver->new->run; # runs basename($0)*.{yaml.yml,dat}
33              
34             =head1 DESCRIPTION
35              
36             Write Test::WWW::Mechanize tests in YAML. This module will load the tests
37             make a plan and run the tests. Supports every-page tests, SKIP, TODO, and
38             any object supporting the Test::WWW::Mechanize interface.
39              
40             This document focuses on the Test::WWW::Mechanize::Driver object and the
41             options it can take. See the L<Manual|Test::WWW::Mechanize::Driver::Manual>
42             for a full description of the test data file format.
43              
44             =head1 USAGE
45              
46             =head3 new
47              
48             Test::WWW::Mechanize::Driver->new( [ OPTIONS ] )
49              
50             =over 4
51              
52             =item add_to_plan
53              
54             Number of tests running outside of Driver control. Use this option if your
55             test script perfoirms other tests such as build-up of mock objects.
56              
57             =item after_response
58              
59             =item after_response_tests
60              
61             C<after_response> is a callback sub triggered once per test group (is not
62             triggered by submit_form_ok or other actions) immediately after the initial
63             response is received. If any tests are run in the callback, the
64             C<after_response_tests> option must be set to the number of tests to be run
65             each time so that the driver may make the proper plan.
66              
67             =item base
68              
69             Base URL for any test uris which are not absolute. If not defined, all test
70             uris must be absolute.
71              
72             =item load
73              
74             Array ref of file names which should be loaded by the Driver. These tests
75             are loaded at object creation time.
76              
77             =item loader
78              
79             Name of loader package or object with C<package-E<gt>load( $file )> method.
80             Defaults to C<Test::WWW::Mechanize::Driver::YAMLLoader>.
81              
82             =item mechanize
83              
84             Override default mechanize object. The default object is:
85              
86             Test::WWW::Mechanize->new(cookie_jar => {})
87              
88             =item no_plan
89              
90             When true, calling C<-E<gt>run> will not print a test plan.
91              
92             =back
93              
94             =cut
95              
96             our %valid_params = map +($_,1),
97             qw/
98             add_to_plan after_response after_response_tests base load loader mechanize no_plan
99             /;
100             sub new {
101 10     10 1 345216 my $class = shift;
102 10         66 my %x = @_;
103 10         75 my ($invalid) = grep !$valid_params{$_}, keys %x;
104 10 50       52 croak "Invalid Parameter '$invalid'" if defined($invalid);
105              
106             # Create loader so that "require YAML" happens early on
107 10   33     124 $x{loader} ||= Test::WWW::Mechanize::Driver::YAMLLoader->new;
108              
109 10         35 my $x = bless \%x, $class;
110 10         47 $x->load;
111 10         105 return $x;
112             }
113              
114             =head3 load
115              
116             num tests loaded = $tester->load( test filenames )
117              
118             Load tests.
119              
120             =cut
121              
122             sub load {
123 18     18 1 44 my $x = shift;
124              
125 18 100 100     161 $$x{load} = [ $$x{load} ] if HAS($x, 'load') and !ref($$x{load});
126              
127 18         47 push @{$$x{load}}, @_;
  18         70  
128              
129 18         78 my $t = $x->tests;
130 18         85 $x->_load;
131 18         65 $x->tests - $t;
132             }
133              
134             =head3 tests
135              
136             num tests = $tester->tests()
137              
138             Calculate number of tests currently loaded
139              
140             =cut
141              
142             sub tests {
143 46     46 1 2012 my $x = shift;
144 46   100     186 my $tests = $$x{add_to_plan} || 0;
145 46 100       152 return $tests unless $$x{groups};
146 18         38 $tests += $x->_tests_in_group($_) for @{$$x{groups}};
  18         85  
147 18         81 return $tests;
148             }
149              
150             =head3 test_groups
151              
152             num groups = $tester->test_groups()
153              
154             Return number of test groups currently loaded
155              
156             =cut
157              
158             sub test_groups {
159 3     3 1 7 my $x = shift;
160 3 100       17 return 0 unless $$x{groups};
161 2         5 return 0 + @{$$x{groups}};
  2         11  
162             }
163              
164             =head3 run
165              
166             $tester->run()
167              
168             Run each group of tests
169              
170             =cut
171              
172             sub run {
173 10     10 1 37 my $x = shift;
174 10 100       76 $x->_autoload unless $$x{_loaded};
175 10 100       52 die "No test groups!" unless $$x{groups};
176 9         60 $x->_ensure_plan;
177 9         6080 $x->_run_group( $_ ) for @{$$x{groups}};
  9         58  
178             }
179              
180             =head3 mechanize
181              
182             mech = $tester->mechanize()
183              
184             Return or construct mechanize object
185              
186             =cut
187              
188             sub mechanize {
189 88     88 1 204 my $x = shift;
190 88 50       2402 return $$x{mechanize} if $$x{mechanize};
191 0         0 require Test::WWW::Mechanize;
192 0         0 $$x{mechanize} = Test::WWW::Mechanize->new(cookie_jar => {});
193             }
194              
195             =head1 INTERNAL METHODS
196              
197             =head3 _ensure_plan
198              
199             $tester->_ensure_plan()
200              
201             Feed a plan (expected_tests) to Test::Builder if a plan has not yet been given.
202              
203             =cut
204              
205             sub _ensure_plan {
206 9     9   19 my $x = shift;
207 9 100       76 $Test->expected_tests($x->tests) unless $Test->expected_tests;
208             }
209              
210             =head3 _run_group
211              
212             $tester->_run_group( group hash )
213              
214             Run a group of tests. Performs group-level actions (SKIP, TODO) and tests
215             initial request.
216              
217             =cut
218              
219             sub _run_group {
220 21     21   65490 my ($x, $group) = @_;
221 21         53 $CURRENT_GROUP = $group;
222              
223 21 100       101 if ($$group{SKIP}) {
224 3         9 local $TODO = undef;
225 3         21 $Test->skip($$group{SKIP}) for 1..$x->_tests_in_group($group);
226 3         4129 return;
227             }
228              
229 18         47 local $TODO = $$group{TODO};
230 18         69 $x->_make_initial_request( $group );
231 18         40 $x->_run_test( $group, $_ ) for @{$$group{_actions}};
  18         116  
232             }
233              
234             =head3 _make_initial_request
235              
236             $tester->_make_initial_request( group hash )
237              
238             Perform initial GET, POST, ... request. Makes after_response callback if
239             present.
240              
241             =cut
242              
243             sub _make_initial_request {
244 18     18   47 my ($x, $group) = @_;
245 18   100     148 my $method = ($$group{method} ||= 'GET');
246 18 100       75 my @params = ($$group{parameters} ? $$group{parameters} : ());
247 18         79 my $label = $x->_test_label($group, "$method $$group{uri}", @{$$group{_id}});
  18         81  
248              
249 18 100       93 if (uc($method) eq 'GET') {
    50          
250 16         91 my $uri = build_uri( $$group{uri}, @params );
251 16         63 $x->mechanize->get_ok( $uri, $label );
252             }
253             elsif (uc($method) eq 'POST') {
254 2         8 $x->mechanize->post_ok( $$group{uri}, @params, $label );
255             }
256 0         0 else { die "Unimplemented request method: '$method'" }
257              
258 18 100       232491 $$x{after_response}->($x->mechanize, $group) if $$x{after_response};
259 18         2903 return 1;
260             }
261              
262             =head3 _run_test
263              
264             $tester->_run_test( group hash, test hash )
265              
266             Run an individual test. Tests (an action) at theis stage should be in one
267             of the following forms:
268              
269             { sub => sub { ... do stuff },
270             }
271              
272             { name => "mechanize method name",
273             args => [ array of method arguments ],
274             }
275              
276             =cut
277              
278             sub _run_test {
279 49     49   44324 my ($x, $group, $test) = @_;
280              
281 49 100       170 if ($$test{sub}) {
282 1         6 return $$test{sub}->();
283             }
284              
285 48         121 my $t = $$test{name};
286 48         119 $x->mechanize->$t( @{$$test{args}} );
  48         354  
287             }
288              
289             =head3 _load
290              
291             $tester->_load()
292              
293             Open test files (listed in C<@{$$x{load}}>) and attempt to load each
294             contained document. Each testfile is loaded only once.
295              
296             =cut
297              
298             sub _load {
299 18     18   36 my $x = shift;
300 18 50 33     71 return unless HAS($x, 'load') and 'ARRAY' eq ref($$x{load});
301              
302 18         51 for my $file (@{$$x{load}}) {
  18         57  
303 10 50       73 next if $$x{_loaded}{$file}++;
304              
305 10         35 my @docs = eval { $$x{loader}->load( $file ) };
  10         97  
306 10 50 33     100404 die "While parsing test file '$file':\n$@" if $@ or !@docs;
307              
308 10         41 my $document = 1;
309 10         97 $x->_load_doc( $_, [$file, $document++] ) for @docs;
310              
311             # local configs last only until end of file
312 10         49 $x->_clear_local_config;
313             }
314             }
315              
316             =head3 _load_doc
317              
318             $tester->_load_doc( any doc, id array )
319              
320             Determine document type and hand off to appropriate loaders.
321              
322             =cut
323              
324             sub _load_doc {
325 17     17   61 my ($x, $doc, $id) = @_;
326              
327 17 100       113 if (!ref($doc)) {
    100          
    50          
328 3         13 return 1;
329             }
330              
331             elsif ('HASH' eq ref($doc)) {
332 4         25 $x->_push_local_config($doc);
333             }
334              
335             elsif ('ARRAY' eq ref($doc)) {
336 10         25 my $test = 1;
337 10         73 $x->_load_group($_, [@$id, $test++]) for @$doc;
338             }
339              
340             else {
341 0         0 die "Unknown document type ".ref($doc);
342             }
343             }
344              
345             =head3 _load_group
346              
347             $tester->_load_group( non-canonical group hash, id array )
348              
349             Actually perform test "loading". As test groups are loaded the they are:
350              
351             * canonicalized:
352             - all tests moved to actions array with one test per entry
353             - url misspelling -> uri
354             - uri -> $$x{base}/uri if necessary
355             * tagged: the test's location in the file is inserted into the test hash
356              
357             =cut
358              
359             our %config_options = map +($_,1),
360             qw/
361             uri parameters method description SKIP TODO
362             /;
363             our %config_aliases =
364             qw/
365             url uri
366             parms parameters
367             params parameters
368             /;
369              
370             # mech methods
371             our %scalar_tests = map +($_,1),
372             qw/
373             title_is title_like title_unlike
374             base_is base_like base_unlike
375             content_is content_contains content_lacks content_like content_unlike
376             page_links_content_like page_links_content_unlike
377             links_ok click_ok
378             /;
379              
380             # values are mech methods
381             our %aliases =
382             qw/
383             is content_is
384             contains content_contains
385             lacks content_lacks
386             like content_like
387             unlike content_unlike
388             /;
389              
390             # mech methods
391             our %bool_tests = map +($_,1), qw/ page_links_ok html_lint_ok /;
392             our %kv_tests = map +($_,1),
393             qw/
394             has_tag has_tag_like
395             link_status_is link_status_isnt
396             link_content_like link_content_unlike
397             /;
398             our %hash_tests = map +($_,1), qw/ submit_form_ok follow_link_ok /;
399             our %mech_action = map +($_,1),
400             qw/
401             get put reload back follow_link form_number form_name
402             form_with_fields field select set_fields set_visible tick untick
403             click click_button submit submit_form add_header delete_header
404             save_content dump_links dump_images dump_forms dump_all redirect_ok
405             request credentials stuff_inputs
406             /;
407              
408             sub _load_group {
409 21     21   58 my ($x, $group, $id) = @_;
410 21         83 $x->_apply_local_config( $group );
411              
412             # We're all about convenience here, For example, I want to be able to
413             # perform simple contains tests without setting up an "_actions" sequence.
414             # To do that, we need to munge the group hash a bit.
415 21         132 my @keys = keys %$group;
416 21         46 my @actions;
417 21         59 for (@keys) {
418             # the actual "actions" element, pushed to end of actions array so it
419             # happens after the toplevel actions.
420 85 100 100     410 if ($_ eq 'actions') {
    100 100        
    100 100        
      66        
      66        
      66        
      66        
421 3         4 for (@{delete $$group{actions}}) {
  3         10  
422 9         35 while (my ($k, $v) = each %$_) {
423 9         42 push @actions, { name => $k, args => $v };
424             }
425             }
426             }
427              
428             # leave internal configuration options where they are
429             elsif (TRUE( \%config_options, $_ )
430             or TRUE( \%config_aliases, $_ )
431             ) {
432 35 100 66     101 $$group{$config_aliases{$_}} = $$group{$_} if TRUE( \%config_aliases, $_ ) and !HAS( $group, $config_aliases{$_} );
433 35         94 next;
434             }
435              
436             # Put anything that looks like a test action on the front of the action
437             # list (again, so that explicit action sequences occur after transplanted
438             # initial load actions).
439             elsif (TRUE( \%scalar_tests, $_ )
440             or TRUE( \%bool_tests, $_ )
441             or TRUE( \%kv_tests, $_ )
442             or TRUE( \%hash_tests, $_ )
443             or TRUE( \%mech_action, $_ )
444             or TRUE( \%aliases, $_ )
445             or $x->mechanize->can($_)
446 35         267 ) { unshift @actions, { name => $_, args => $$group{$_}, _transplant => 1 } }
447              
448             # anything else is considered a custom config value and will be
449             # preserved in the top level group hash.
450             }
451              
452 21 100       128 $$group{uri} = URI->new_abs($$group{uri}, $$x{base})->as_string if $$x{base};
453              
454 21         35937 $$group{_id} = $id;
455 21         82 $$group{_actions} = $x->_prepare_actions( $group, \@actions, $id );
456 21         43 push @{$$x{groups}}, $group;
  21         156  
457             }
458              
459             =head3 _prepare_actions
460              
461             canon-test (actions) array = $x->_prepare_actions( canon-group hash, actions array, group id array )
462              
463             Prepare array of actions by:
464              
465             * expanding aliases
466             * expanding tests
467              
468             =cut
469              
470             sub _prepare_actions {
471 21     21   61 my ($x, $group, $actions, $id) = @_;
472 21         36 my @expanded;
473              
474 21         34 my $action = 1;
475 21         60 for my $a (@$actions) {
476 44 100       151 $$a{name} = $aliases{$$a{name}} if HAS( \%aliases, $$a{name} );
477              
478 44         187 push @expanded, $x->_expand_tests($group, $a, [@$id, $action++])
479             }
480              
481 21         78 return \@expanded;
482             }
483              
484              
485             =head3 _expand_tests
486              
487             list of canon-tests = $tester->_expand_tests( canon-group hash, non-canon action item, id array )
488              
489             Expand a logical action item into possibly many explicit test items. When
490             executed, each test item will increment the test count be exactly 1.
491              
492             * prepares argument list
493              
494             =cut
495              
496             sub _expand_tests {
497 44     44   100 my ($x, $group, $action, $id) = @_;
498 44         86 my $name = $$action{name};
499 44         78 my $args = $$action{args};
500 44         65 my $test = 'a';
501              
502             # SCALAR TESTS
503 44 100       120 if (TRUE( \%scalar_tests, $name )) {
504 34 50       286 return map
    100          
505             +{ %$action, args => [(($name =~ /_like$/) ? qr/$_/ : $_), $x->_test_label($group, $name, @$id, $test)], id => [@$id, $test++] },
506             ('ARRAY' eq ref($args)) ? @$args : $args;
507             }
508              
509             # KV TESTS
510 10 100       35 if (TRUE( \%kv_tests, $name )) {
511 6         10 my @tests;
512 6         27 while (my ($k, $v) = each %$args) {
513 6 50       66 push @tests,
514             { %$action, id => [@$id, $test++],
515             args => [$k, (($name =~ /(?:_|_un)like$/) ? qr/$v/ : $v),
516             $x->_test_label($group, $name, @$id, $test)],
517             };
518             }
519 6         26 return @tests;
520             }
521              
522             # HASH TESTS
523 4 100       13 if (TRUE( \%hash_tests, $name )) {
524 2         6 my @tests;
525 2         8 $$action{id} = [@$id, $test++];
526 2         5 $$action{args} = [$$action{args}, $x->_test_label($group, $name, @{$$action{id}})];
  2         7  
527 2         5 push @tests, $action;
528 2         7 return @tests;
529             }
530              
531             # BOOLEAN TESTS
532 2 100       7 if (TRUE( \%bool_tests, $name )) {
533 1         3 $$action{id} = $id;
534 1         5 $$action{args} = [ $x->_test_label($group, $name, @$id) ];
535 1         3 return $action;
536             }
537              
538             # MECHANIZE ACTIONS
539 1 50       5 if (TRUE( \%mech_action, $name )) {
540 1         3 $$action{id} = $id;
541             $$action{sub} = sub {
542 1     1   3 my $res = eval {
543 1 50       5 $x->mechanize->$name( ('ARRAY' eq ref($args)) ? @$args
    50          
544             : ('HASH' eq ref($args)) ? %$args
545             : $args
546             );
547 1         7232 1;
548             };
549             # plain mechanize actions don't report "ok". Force a test based on
550             # just evaluation fatality since we take an action spot.
551 1         4 local $Test::Builder::Level = $Test::Builder::Level + 1;
552 1 50       4 $Test->diag( "$name: $@" ) if $@;
553 1   33     12 $Test->ok(($res and !$@), "$name mechanize action");
554 1         8 };
555 1         4 return $action;
556             }
557              
558 0         0 die "Invalid action: '$name'";
559             }
560              
561             =head3 _test_label
562              
563             label = $tester->_test_label( group, name, id list )
564              
565             Convert id components into something human-readable. For example:
566              
567             "[description] content_contains: file basic.yml, doc 3, group 5, test 2.b"
568              
569             =cut
570              
571             sub _test_label {
572 69     69   225 my ($x, $group, $name, $file, $doc, $group_no, @id) = @_;
573 69         139 local $" = '.';
574              
575 69         112 my $desc = "";
576 69 100       196 $desc = "[$$group{description}] " if defined($$group{description});
577              
578 69         121 my $test = "";
579 69 100       222 $test = ", test @id" if @id;
580              
581 69         718 "$desc$name: file $file, doc $doc, group $group_no$test"
582             }
583              
584             =head3 _tests_in_group
585              
586             $tester->_tests_in_group($group)
587              
588             Calculates number of tests attributable to the given group. Accounts for
589             initial requerst, explicit actions, and tests in any callbacks.
590              
591             =cut
592              
593             sub _tests_in_group {
594 45     45   109 my ($x, $group) = @_;
595 45         66 my $tests = 0;
596              
597             # 1 test for the initial request
598 45         75 $tests += 1;
599              
600             # tests performed in callbacks
601 45         91 for (qw/after_response_tests before_request_tests/) {
602 90   100     286 $tests += $$x{$_} || 0;
603             }
604              
605             # 1 test for each action in the group
606 45         107 $tests += 0+@{$$group{_actions}};
  45         95  
607              
608 45         126 return $tests;
609             }
610              
611             =head3 _autoload
612              
613             $tester->_autoload()
614              
615             Attempt to load test files based on current script name. removes .t or .pl
616             from C<$0> and globs C<base*.{yaml,yml,dat}>
617              
618             =cut
619              
620             sub _autoload {
621 7     7   18 my $x = shift;
622 7         26 my $glob = $0;
623 7         65 $glob =~ s/\.(?:t|pl)$//;
624 7         1805 my @autoload = grep +(-r $_), glob("$glob*.{yaml,yml,dat}");
625 7         57 $x->load( @autoload );
626             }
627              
628             =head3 _clear_local_config
629              
630             $tester->_clear_local_config()
631              
632             Configs local to a series of test documents should be cleared after each
633             file is loaded.
634              
635             =cut
636              
637             sub _clear_local_config {
638 10     10   28 my $x = shift;
639 10         66 $$x{_local_config} = {};
640             }
641              
642             =head3 _push_local_config
643              
644             Merge a new configuration into the local configuration. called for each
645             hash document in a test configuration file.
646              
647             =cut
648              
649             sub _push_local_config {
650 4     4   16 my ($x, $config) = @_;
651 4   50     42 $$x{_local_config} ||= {};
652 4         36 %{$$x{_local_config}} = (%{$$x{_local_config}}, %$config);
  4         40  
  4         27  
653             }
654              
655             =head3 _apply_local_config
656              
657             Merge a new configuration into the local configuration. called for each
658             hash document in a test configuration file.
659              
660             =cut
661              
662             sub _apply_local_config {
663 21     21   86 my ($x, $group) = @_;
664 21   100     133 $$x{_local_config} ||= {};
665 21         50 %$group = (%{dclone($$x{_local_config})}, %$group);
  21         1525  
666             }
667              
668              
669              
670              
671             1;
672              
673             =head1 TODO
674              
675             =over 4
676              
677             =item test and perhaps implement proper enctype="multipart/form-data" file uploads
678              
679             =item HEAD, PUT, DELETE requests
680              
681             =item Custom Request headers (probably as a "headers" top level hash item so avoid using that as a custom field)
682              
683             =back
684              
685             =cut
686              
687             =head1 AUTHOR
688              
689             The original version of this code written by Dean Serenevy while under
690             contract with National Financial Management who graciously allowed me to
691             release it to the public.
692              
693             Dean Serenevy
694             dean@serenevy.net
695             https://serenevy.net/
696              
697             =head1 LICENSE
698              
699             This software is hereby placed into the public domain. If you use this
700             code, a simple comment in your code giving credit and an email letting
701             me know that you find it useful would be courteous but is not required.
702              
703             The software is provided "as is" without warranty of any kind, either
704             expressed or implied including, but not limited to, the implied warranties
705             of merchantability and fitness for a particular purpose. In no event shall
706             the authors or copyright holders be liable for any claim, damages or other
707             liability, whether in an action of contract, tort or otherwise, arising
708             from, out of or in connection with the software or the use or other
709             dealings in the software.
710              
711             =head1 SEE ALSO
712              
713             L<WWW::Mechanize>, L<Test::WWW::Mechanize>
714              
715             =cut