File Coverage

blib/lib/Jifty/Test/WWW/Mechanize.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1 1     1   43275 use strict;
  1         2  
  1         40  
2 1     1   6 use warnings;
  1         1  
  1         48  
3              
4             package Jifty::Test::WWW::Mechanize;
5 1     1   5 use base qw/Test::WWW::Mechanize/;
  1         2  
  1         2477  
6              
7             delete $ENV{'http_proxy'}; # Otherwise Test::WWW::Mechanize tries to go through your HTTP proxy
8              
9             use Test::More;
10             use Jifty::YAML;
11             use HTML::Lint;
12             use Test::HTML::Lint qw();
13             use HTTP::Cookies;
14             use HTML::TreeBuilder::XPath;
15             use List::Util qw(first);
16             use Plack::Test;
17             use Carp;
18              
19             # XXX TODO: We're leaving out FLUFF errors because it complains about non-standard
20             # attributes such as "autocomplete" on
elements. There should be a better
21             # way to fix this.
22             my $lint = HTML::Lint->new( only_types => [HTML::Lint::Error::STRUCTURE,
23             HTML::Lint::Error::HELPER] );
24              
25             =head1 NAME
26              
27             Jifty::Test::WWW::Mechanize - Subclass of L with
28             extra Jifty features
29              
30             =head1 METHODS
31              
32             =head2 new
33              
34             Overrides L's C to automatically give the
35             bot a cookie jar.
36              
37             =cut
38              
39             my $plack_server_pid;
40              
41             sub new {
42             my ($class, @args) = @_;
43              
44             push @args, app => Jifty->handler->psgi_app
45             if $class->isa('Test::WWW::Mechanize::PSGI');
46              
47             my $self = $class->SUPER::new(@args);
48             $self->cookie_jar(HTTP::Cookies->new);
49              
50             return $self;
51             }
52              
53             =head2 request
54              
55             We override L's default request method so accept-encoding is
56             not set to gzip by default.
57              
58             =cut
59              
60             sub _modify_request {
61             my ($self, $req) = @_;
62             $req->header( 'Accept-Encoding', 'identity' )
63             unless $req->header( 'Accept-Encoding' );
64             return $self->SUPER::_modify_request($req);
65             }
66              
67             =head2 moniker_for ACTION, FIELD1 => VALUE1, FIELD2 => VALUE2
68              
69             Finds the moniker of the first action of type I whose
70             "constructor" field I is I, and so on.
71              
72             my $mon = $mech->moniker_for('MyApp::Action::UpdateInfo');
73              
74             If there is only one action of type ACTION, be sure not to pass
75             any more arguments to this method, or the method will return undef.
76              
77             NOTE that if you're using this in a series of different pages or forms,
78             you'll need to run it again for each new form:
79              
80             $mech->fill_in_action_ok($mech->moniker_for('MyApp::Action::UpdateInfo'),
81             owner_id => 'someone');
82             $mech->submit_html_ok();
83              
84             is($mech->action_field_value($mech->moniker_for("MyApp::Action::UpdateInfo"),
85             'owner_id'),
86             'someone',
87             "Owner was reassigned properly to owner 'someone'");
88              
89             =cut
90              
91             sub moniker_for {
92             my $self = shift;
93             my $action = Jifty->api->qualify(shift);
94             my %args = @_;
95              
96             for my $f ($self->forms) {
97             INPUT:
98             for my $input ($f->inputs) {
99             if ($input->type eq "hidden" and $input->name =~ /^J:A-(?:\d+-)?(.*)/ and $input->value eq $action) {
100              
101             my $moniker = $1;
102              
103             for my $id (keys %args) {
104             my $idfield = $f->find_input("J:A:F:F-$id-$moniker")
105             || $f->find_input("J:A:F-$id-$moniker");
106             next INPUT unless $idfield and $idfield->value eq $args{$id};
107             }
108              
109             return $1;
110             }
111             }
112             # if we've gotten to this point, there were no hidden fields with a moniker,
113             # possibly a form with only its continuation-marking hidden field.
114             # Fall back to a submit field with similar attributes.
115             for my $input ($f->inputs) {
116             my $name = $input->name || '';
117              
118             next unless $input->type eq "submit";
119             next unless $name =~ /\Q$action\E/;
120             my ($moniker) = $name =~ /J:ACTIONS=([^|]+)\|/
121             or next;
122             return $moniker;
123             }
124             }
125             return undef;
126             }
127              
128             =head2 fill_in_action MONIKER, FIELD1 => VALUE1, FIELD2 => VALUE2, ...
129              
130             Finds the fields on the current page with the names FIELD1, FIELD2,
131             etc in the MONIKER action, and fills them in. Returns the
132             L object of the form that the action is in, or undef if it
133             can't find all the fields.
134              
135             =cut
136              
137             sub fill_in_action {
138             my $self = shift;
139             my $moniker = shift;
140             my %args = @_;
141              
142             my $action_form = $self->action_form($moniker, keys %args);
143             return unless $action_form;
144              
145             for my $arg (keys %args) {
146             my $input = $action_form->find_input("J:A:F-$arg-$moniker");
147             unless ($input) {
148             return;
149             }
150              
151             # not $input->value($args{$arg}), because it doesn't handle arrayref
152             $action_form->param( $input->name, $args{$arg} );
153             }
154              
155             return $action_form;
156             }
157              
158             =head2 fill_in_action_ok MONIKER, FIELD1 => VALUE1, FIELD2 => VALUE2, ...
159              
160             Finds the fields on the current page with the names FIELD1, FIELD2,
161             etc in the MONIKER action, and fills them in. Returns the
162             L object of the form that the action is in, or undef if it
163             can't find all the fields.
164              
165             Also, passes if it finds all of the fields and fails if any of the
166             fields are missing.
167              
168             =cut
169              
170             sub fill_in_action_ok {
171             my $self = shift;
172             my $moniker = shift;
173              
174             my $ret = $self->fill_in_action($moniker, @_);
175             my $Test = Test::Builder->new;
176             $Test->ok($ret, "Filled in action $moniker");
177             }
178              
179             =head2 action_form MONIKER [ARGUMENTNAMES]
180              
181             Returns the form (as an L object) corresponding to the
182             given moniker (which also contains inputs for the given
183             argumentnames), and also selects it as the current form. Returns
184             undef if it can't be found.
185              
186             =cut
187              
188             sub action_form {
189             my $self = shift;
190             my $moniker = shift;
191             my @fields = @_;
192             Carp::confess("No moniker") unless $moniker;
193              
194             my $i;
195             for my $form ($self->forms) {
196             no warnings 'uninitialized';
197              
198             $i++;
199             next unless first { $_->name =~ /J:A-(?:\d+-)?$moniker/
200             && $_->type eq "hidden" }
201             $form->inputs;
202             next if grep {not $form->find_input("J:A:F-$_-$moniker")} @fields;
203              
204             $self->form_number($i); #select it, for $mech->submit etc
205             return $form;
206             }
207              
208             # A fallback for forms that don't have any named fields except their
209             # submit button. Could stand to be refactored.
210             $i = 0;
211             for my $form ($self->forms) {
212             no warnings 'uninitialized';
213              
214             $i++;
215             next unless first { $_->name =~ /J:A-(?:\d+-)?$moniker/
216             && $_->type eq "submit" }
217             $form->inputs;
218             next if grep {not $form->find_input("J:A:F-$_-$moniker")} @fields;
219              
220             $self->form_number($i); #select it, for $mech->submit etc
221             return $form;
222             }
223             return;
224             }
225              
226             =head2 action_field_input MONIKER, FIELD
227              
228             Finds the field on the current page with the names FIELD in the
229             action MONIKER, and returns its L, or undef if it can't be
230             found.
231              
232             =cut
233              
234             sub action_field_input {
235             my $self = shift;
236             my $moniker = shift;
237             my $field = shift;
238              
239             my $action_form = $self->action_form($moniker, $field);
240             return unless $action_form;
241              
242             my $input = $action_form->find_input("J:A:F-$field-$moniker");
243             return $input;
244             }
245              
246             =head2 action_field_value MONIKER, FIELD
247              
248             Finds the field on the current page with the names FIELD in the
249             action MONIKER, and returns its value, or undef if it can't be found.
250              
251             =cut
252              
253             sub action_field_value {
254             my $self = shift;
255             my $input = $self->action_field_input(@_);
256             return $input ? $input->value : undef;
257             }
258              
259             =head2 send_action CLASS ARGUMENT => VALUE, [ ... ]
260              
261             Sends a request to the server via the webservices API, and returns the
262             L of the action. C specifies the class of the
263             action, and all parameters thereafter supply argument keys and values.
264              
265             The URI of the page is unchanged after this; this is accomplished by
266             using the "back button" after making the webservice request.
267              
268             =cut
269              
270             sub _build_webservices_request {
271             my ($self, $endpoint, $data) = @_;
272              
273             my $uri = $self->uri->clone;
274             $uri->path($endpoint);
275             $uri->query('');
276              
277             my $body = Jifty::YAML::Dump({ path => $endpoint, %$data});
278              
279             HTTP::Request->new(
280             POST => $uri,
281             [ 'Content-Type' => 'text/x-yaml',
282             'Content-Length' => length($body) ],
283             $body
284             );
285             }
286              
287             sub send_action {
288             my $self = shift;
289             my $class = shift;
290             my %args = @_;
291              
292             my $request = $self->_build_webservices_request
293             ( "__jifty/webservices/yaml",
294             { actions => {
295             action => {
296             moniker => 'action',
297             class => $class,
298             fields => \%args
299             }
300             }
301             });
302              
303             my $result = $self->request( $request );
304             my $content = eval { Jifty::YAML::Load($result->content)->{action} } || undef;
305             $self->back;
306             return $content;
307             }
308              
309             =head2 fragment_request PATH ARGUMENT => VALUE, [ ... ]
310              
311             Makes a request for the fragment at PATH, using the webservices API,
312             and returns the string of the result.
313              
314             =cut
315              
316             sub fragment_request {
317             my $self = shift;
318             my $path = shift;
319             my %args = @_;
320              
321             my $request = $self->_build_webservices_request
322             ( "__jifty/webservices/xml",
323             { fragments => {
324             fragment => {
325             name => 'fragment',
326             path => $path,
327             args => \%args
328             }
329             }
330             });
331              
332             my $result = $self->request( $request );
333              
334             use XML::Simple;
335             my $content = eval { XML::Simple::XMLin($result->content, SuppressEmpty => '')->{fragment}{content} } || '';
336             $self->back;
337             return $content;
338             }
339              
340             =head2 field_error_text MONIKER, FIELD
341              
342             Finds the error span on the current page for the name FIELD in the
343             action MONIKER, and returns the text (tags stripped) from it. (If the
344             field can't be found, return undef).
345              
346             =cut
347              
348             sub field_error_text {
349             my $self = shift;
350             my $moniker = shift;
351             my $field = shift;
352              
353             # Setup the XPath processor and the ID we're looking for
354             my $tree = HTML::TreeBuilder::XPath->new;
355             $tree->parse($self->content);
356             $tree->eof;
357              
358             my $id = "errors-J:A:F-$field-$moniker";
359              
360             # Search for the span containing that error
361             return $tree->findvalue(qq{//span[\@id = "$id"]});
362             }
363              
364             =head2 uri
365              
366             L has a bug where it returns the wrong value for
367             C after redirect. This fixes that. See
368             http://rt.cpan.org/NoAuth/Bug.html?id=9059
369              
370             =cut
371              
372             sub uri { shift->response->request->uri }
373              
374             =head2 get_html_ok URL
375              
376             Calls C URL, followed by testing the HTML using
377             L.
378              
379             =cut
380              
381             sub get_html_ok {
382             my $self = shift;
383             $self->get(@_);
384             {
385             local $Test::Builder::Level = $Test::Builder::Level;
386             $Test::Builder::Level++;
387             Test::HTML::Lint::html_ok( $lint, $self->content, "html_ok for ".$self->uri );
388             }
389             }
390              
391             =head2 html_ok [STRING]
392              
393             Tests the current C using L. If passed a string,
394             tests against that instead of the current content.
395              
396             =cut
397              
398             sub html_ok {
399             my $self = shift;
400             my $content = shift || $self->content;
401             {
402             local $Test::Builder::Level = $Test::Builder::Level;
403             $Test::Builder::Level++;
404             Test::HTML::Lint::html_ok( $lint, $content );
405             }
406             }
407              
408             =head2 submit_html_ok
409              
410             Calls C, followed by testing the HTML using
411             L.
412              
413             =cut
414              
415             sub submit_html_ok {
416             my $self = shift;
417             $self->submit(@_);
418             {
419             local $Test::Builder::Level = $Test::Builder::Level;
420             $Test::Builder::Level++;
421             Test::HTML::Lint::html_ok( $lint, $self->content );
422             }
423             }
424              
425             =head2 follow_link_ok
426              
427             Calls C, followed by testing the HTML using
428             L. Warns if it cannot find the specified link (you
429             should use C on C first to check its existence).
430              
431             =cut
432              
433             sub follow_link_ok {
434             my $self = shift;
435              
436              
437             my $desc;
438              
439             # Test::WWW::Mechanize allows passing in a hashref of arguments, so we should to
440             if ( ref($_[0]) eq 'HASH') {
441             # if the user is pashing in { text => 'foo' } ...
442             $desc = $_[1] if $_[1];
443             @_ = %{$_[0]};
444             } elsif (@_ % 2 ) {
445             # IF the user is passing in text => 'foo' ,"Cicked the right thing"
446             # Remove reason from end if it's there
447             $desc = pop @_ ;
448             }
449              
450             carp("Couldn't find link") unless $self->follow_link(@_);
451             {
452             local $Test::Builder::Level = $Test::Builder::Level;
453             $Test::Builder::Level++;
454             Test::HTML::Lint::html_ok( $lint, $self->content, $desc );
455             }
456             }
457              
458             =head2 warnings_like WARNING, [REASON]
459              
460             Tests that the warnings generated by the server (since the last such
461             check) match the given C, which should be a regular
462             expression. If an array reference of regular expressions is passed as
463             C, checks that one warning per element was received.
464              
465             =cut
466              
467             sub warnings_like {
468             my $self = shift;
469             my @args = shift;
470             @args = @{$args[0]} if ref $args[0] eq "ARRAY";
471             my $reason = pop || "Server warnings matched";
472              
473             local $Test::Builder::Level = $Test::Builder::Level;
474             $Test::Builder::Level++;
475              
476             my $plugin = Jifty->find_plugin("Jifty::Plugin::TestServerWarnings");
477             my @warnings = $plugin->decoded_warnings($self->uri);
478             my $max = @warnings > @args ? $#warnings : $#args;
479             for (0 .. $max) {
480             like($warnings[$_], $_ <= $#args ? qr/$args[$_]/ : qr/(?!unexpected)unexpected warning/, $reason);
481             }
482             }
483              
484             =head2 no_warnings_ok [REASON]
485              
486             Checks that no warnings were generated by the server (since the last
487             such check).
488              
489             =cut
490              
491             sub no_warnings_ok {
492             my $self = shift;
493             my $reason = shift || "no warnings emitted";
494              
495             local $Test::Builder::Level = $Test::Builder::Level;
496             $Test::Builder::Level++;
497              
498             my $plugin = Jifty->find_plugin("Jifty::Plugin::TestServerWarnings");
499             my @warnings = $plugin->decoded_warnings( $self->uri );
500              
501             is( @warnings, 0, $reason );
502             for (@warnings) {
503             diag("got warning: $_");
504             }
505             }
506              
507             =head2 session
508              
509             Returns the server-side L object associated with
510             this Mechanize object.
511              
512             =cut
513              
514             sub session {
515             my $self = shift;
516              
517             my $cookie = Jifty->config->framework('Web')->{'SessionCookieName'};
518             $cookie =~ s/\$PORT/(?:\\d+|NOPORT)/g;
519              
520             return undef unless $self->cookie_jar->as_string =~ /$cookie=([^;]+)/;
521              
522             my $session = Jifty::Web::Session->new;
523             $session->load($1);
524             return $session;
525             }
526              
527             =head2 continuation [ID]
528              
529             Returns the current continuation of the Mechanize object, if any. Or,
530             given an ID, returns the continuation with that ID.
531              
532             =cut
533              
534             sub continuation {
535             my $self = shift;
536              
537             my $session = $self->session;
538             return undef unless $session;
539            
540             my $id = shift;
541             ($id) = $self->uri =~ /J:(?:C|CALL|RETURN)=([^&;]+)/ unless $id;
542              
543             return $session->get_continuation($id);
544             }
545              
546             =head2 current_user
547              
548             Returns the L object or descendant, if any.
549              
550             =cut
551              
552             sub current_user {
553             my $self = shift;
554              
555             my $session = $self->session;
556             return undef unless $session;
557              
558             my $id = $session->get('user_id');
559              
560             return undef unless ($id);
561              
562             my $object = Jifty->app_class("CurrentUser")->new(id => $id);
563             return $object;
564             }
565              
566              
567             1;