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