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 |
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; |