1use strict;
2use warnings;
3
4package Jifty::Client;
5use base qw/WWW::Mechanize/;
6
7delete $ENV{'http_proxy'}; # Otherwise WWW::Mechanize tries to go through your HTTP proxy
8
9use Jifty::YAML;
10use HTTP::Cookies;
11use HTML::TreeBuilder::XPath;
12use List::Util qw(first);
13use Carp;
14
15=head1 NAME
16
17Jifty::Client - Subclass of L<WWW::Mechanize> with extra Jifty features
18
19=head1 DESCRIPTION
20
21This module is a base for building robots to interact with Jifty applications.
22It currently contains much overlapping code with C<Jifty::Test::WWW::Mechanize>,
23except that it does not inherit from C<Test::WWW::Mechanize>.
24
25Expect this code to be refactored in the near future.
26
27=head1 METHODS
28
29=head2 new
30
31Overrides L<WWW::Mechanize>'s C<new> to automatically give the
32bot a cookie jar.
33
34=cut
35
36sub new {
37    my $class = shift;
38    my $self = $class->SUPER::new(@_);
39    $self->cookie_jar(HTTP::Cookies->new);
40    return $self;
41}
42
43=head2 moniker_for ACTION, FIELD1 => VALUE1, FIELD2 => VALUE2
44
45Finds the moniker of the first action of type I<ACTION> whose
46"constructor" field I<FIELD1> is I<VALUE1>, and so on.
47
48=cut
49
50sub moniker_for {
51  my $self = shift;
52  my $action = Jifty->api->qualify(shift);
53  my %args = @_;
54
55  # Search through all the inputs of all the forms
56  for my $f ($self->forms) {
57  INPUT:
58    for my $input ($f->inputs) {
59
60      # Look for the matching action
61      if ($input->type eq "hidden" and $input->name =~ /^J:A-(?:\d+-)?(.*)/ and $input->value eq $action) {
62
63        # We have a potential moniker
64        my $moniker = $1;
65
66        # Make sure that this action actually has the field values we're
67        # looking for, if not keep looking
68        for my $id (keys %args) {
69          my $idfield = $f->find_input("J:A:F:F-$id-$moniker");
70          next INPUT unless $idfield and $idfield->value eq $args{$id};
71        }
72
73        # It does! Return it...
74        return $1;
75      }
76    }
77  }
78  return undef;
79}
80
81=head2 fill_in_action MONIKER, FIELD1 => VALUE1, FIELD2 => VALUE2, ...
82
83Finds the fields on the current page with the names FIELD1, FIELD2,
84etc in the MONIKER action, and fills them in.  Returns the
85L<HTML::Form> object of the form that the action is in, or undef if it
86can't find all the fields.
87
88=cut
89
90sub fill_in_action {
91    my $self = shift;
92    my $moniker = shift;
93    my %args = @_;
94
95    # Load the form object containing the given moniker or quit
96    my $action_form = $self->action_form($moniker, keys %args);
97    return unless $action_form;
98
99    # For each field name given, set the field's value
100    for my $arg (keys %args) {
101        my $input = $action_form->find_input("J:A:F-$arg-$moniker");
102        return unless $input;
103        $input->value($args{$arg});
104    }
105
106    # Return the form in case they want to do something with it
107    return $action_form;
108}
109
110=head2 action_form MONIKER [ARGUMENTNAMES]
111
112Returns the form (as an L<HTML::Form> object) corresponding to the
113given moniker (which also contains inputs for the given
114argumentnames), and also selects it as the current form.  Returns
115undef if it can't be found.
116
117=cut
118
119sub action_form {
120    my $self = shift;
121    my $moniker = shift;
122    my @fields = @_;
123    Carp::confess("No moniker") unless $moniker;
124
125    # Go through all the forms looking for the moniker
126    my $i;
127    for my $form ($self->forms) {
128        no warnings 'uninitialized';
129
130        # Keep looking unless the right kind of input is found
131        $i++;
132        next unless first {   $_->name =~ /J:A-(?:\d+-)?$moniker/
133                           && $_->type eq "hidden" }
134                        $form->inputs;
135
136        # Keep looking if the suggested field's don't match up
137        next if grep {not $form->find_input("J:A:F-$_-$moniker")} @fields;
138
139        $self->form_number($i); #select it, for $mech->submit etc
140        return $form;
141    }
142    return;
143}
144
145=head2 action_field_value MONIKER, FIELD
146
147Finds the fields on the current page with the names FIELD in the
148action MONIKER, and returns its value, or undef if it can't be found.
149
150=cut
151
152sub action_field_value {
153    my $self = shift;
154    my $moniker = shift;
155    my $field = shift;
156
157    # Find the form containing the moniker requested
158    my $action_form = $self->action_form($moniker, $field);
159    return unless $action_form;
160
161    # Find the input containing the field requested and fetch the value
162    my $input = $action_form->find_input("J:A:F-$field-$moniker");
163    return unless $input;
164    return $input->value;
165}
166
167=head2 send_action CLASS ARGUMENT => VALUE, [ ... ]
168
169Sends a request to the server via the webservices API, and returns the
170L<Jifty::Result> of the action.  C<CLASS> specifies the class of the
171action, and all parameters thereafter supply argument keys and values.
172
173The URI of the page is unchanged after this; this is accomplished by
174using the "back button" after making the webservice request.
175
176=cut
177
178sub send_action {
179    my $self = shift;
180    my $class = shift;
181    my %args = @_;
182
183    # Setup the URL of the request we're about to make
184    my $uri = $self->uri->clone;
185    $uri->path("__jifty/webservices/yaml");
186
187    # Setup the action request we're going to send
188    my $request = HTTP::Request->new(
189        POST => $uri,
190        [ 'Content-Type' => 'text/x-yaml' ],
191        Jifty::YAML::Dump(
192            {   path => $uri->path,
193                actions => {
194                    action => {
195                        moniker => 'action',
196                        class   => $class,
197                        fields  => \%args
198                    }
199                }
200            }
201        )
202    );
203
204    # Fire off the request, evaluate the result, and return it
205    my $result = $self->request( $request );
206    my $content = eval { Jifty::YAML::Load($result->content)->{action} } || undef;
207    $self->back;
208    return $content;
209}
210
211=head2 fragment_request PATH ARGUMENT => VALUE, [ ... ]
212
213Makes a request for the fragment at PATH, using the webservices API,
214and returns the string of the result.
215
216=cut
217
218sub fragment_request {
219    my $self = shift;
220    my $path = shift;
221    my %args = @_;
222
223    # Setup the URL we're going to use
224    my $uri = $self->uri->clone;
225    $uri->path("__jifty/webservices/xml");
226
227    # Setup the request we're going to use
228    my $request = HTTP::Request->new(
229        POST => $uri,
230        [ 'Content-Type' => 'text/x-yaml' ],
231        Jifty::YAML::Dump(
232            {   path => $uri->path,
233                fragments => {
234                    fragment => {
235                        name  => 'fragment',
236                        path  => $path,
237                        args  => \%args
238                    }
239                }
240            }
241        )
242    );
243
244    # Fire the request, evaluate the result, and return it
245    my $result = $self->request( $request );
246    use XML::Simple;
247    my $content = eval { XML::Simple::XMLin($result->content, SuppressEmpty => '')->{fragment}{content} } || '';
248    $self->back;
249    return $content;
250}
251
252=head2 field_error_text MONIKER, FIELD
253
254Finds the error span on the current page for the name FIELD in the
255action MONIKER, and returns the text (tags stripped) from it.  (If the
256field can't be found, return undef).
257
258=cut
259
260sub field_error_text {
261    my $self = shift;
262    my $moniker = shift;
263    my $field = shift;
264
265    # Setup the XPath processor and the ID we're looking for
266    my $tree = HTML::TreeBuilder::XPath->new;
267    $tree->parse($self->content);
268    $tree->eof;
269
270    my $id = "errors-J:A:F-$field-$moniker";
271
272    # Search for the span containing that error
273    return $tree->findvalue(qq{//span[\@id = "$id"]});
274}
275
276=head2 uri
277
278L<WWW::Mechanize> has a bug where it returns the wrong value for
279C<uri> after redirect.  This fixes that.  See
280http://rt.cpan.org/NoAuth/Bug.html?id=9059
281
282=cut
283
284sub uri { shift->response->request->uri }
285
286=head2 session
287
288Returns the server-side L<Jifty::Web::Session> object associated with
289this Mechanize object.
290
291=cut
292
293sub session {
294    my $self = shift;
295
296    # We don't have a session!
297    return undef unless $self->cookie_jar->as_string =~ /JIFTY_SID_\d+=([^;]+)/;
298
299    # Load the data stored in the session cookie
300    my $session = Jifty::Web::Session->new;
301    $session->load($1);
302    return $session;
303}
304
305=head2 continuation [ID]
306
307Returns the current continuation of the Mechanize object, if any.  Or,
308given an ID, returns the continuation with that ID.
309
310=cut
311
312sub continuation {
313    my $self = shift;
314
315    # If we don't have a session, we don't have a continuation
316    my $session = $self->session;
317    return undef unless $session;
318
319    # Look for the continuation info in the URL
320    my $id = shift;
321    ($id) = $self->uri =~ /J:(?:C|CALL|RETURN)=([^&;]+)/ unless $id;
322
323    # Return information about the continuation
324    return $session->get_continuation($id);
325}
326
327=head2 current_user
328
329Returns the L<Jifty::CurrentUser> object or descendant, if any.
330
331=cut
332
333sub current_user {
334    my $self = shift;
335
336    # We don't have a current user if we don't have a session
337    my $session = $self->session;
338    return undef unless $session;
339
340    # Fetch information about user from the session
341    my $id = $session->get('user_id');
342    my $object = Jifty->app_class("CurrentUser")->new();
343    my $user = $session->get('user_ref')->new( current_user => $object );
344    $user->load_by_cols( id => $id );
345    $object->user_object($user);
346
347    return $object;
348}
349
350=head1 SEE ALSO
351
352L<Jifty::Test::WWW::Mechanize>
353
354=head1 LICENSE
355
356Jifty is Copyright 2005-2010 Best Practical Solutions, LLC.
357Jifty is distributed under the same terms as Perl itself.
358
359=cut
360
3611;
362