libjifty-perl 1.10518+dfsg-1ubuntu2 / usr / share / perl5 / Jifty / Client.pm

use strict;
use warnings;

package Jifty::Client;
use base qw/WWW::Mechanize/;

delete $ENV{'http_proxy'}; # Otherwise WWW::Mechanize tries to go through your HTTP proxy

use Jifty::YAML;
use HTTP::Cookies;
use HTML::TreeBuilder::XPath;
use List::Util qw(first);
use Carp;

=head1 NAME

Jifty::Client - Subclass of L<WWW::Mechanize> with extra Jifty features

=head1 DESCRIPTION

This module is a base for building robots to interact with Jifty applications.
It currently contains much overlapping code with C<Jifty::Test::WWW::Mechanize>,
except that it does not inherit from C<Test::WWW::Mechanize>.

Expect this code to be refactored in the near future.

=head1 METHODS

=head2 new

Overrides L<WWW::Mechanize>'s C<new> to automatically give the
bot a cookie jar.

=cut

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->cookie_jar(HTTP::Cookies->new);
    return $self;
} 

=head2 moniker_for ACTION, FIELD1 => VALUE1, FIELD2 => VALUE2

Finds the moniker of the first action of type I<ACTION> whose
"constructor" field I<FIELD1> is I<VALUE1>, and so on.

=cut

sub moniker_for {
  my $self = shift;
  my $action = Jifty->api->qualify(shift);
  my %args = @_;

  # Search through all the inputs of all the forms
  for my $f ($self->forms) {
  INPUT: 
    for my $input ($f->inputs) {

      # Look for the matching action
      if ($input->type eq "hidden" and $input->name =~ /^J:A-(?:\d+-)?(.*)/ and $input->value eq $action) {

        # We have a potential moniker
        my $moniker = $1;

        # Make sure that this action actually has the field values we're
        # looking for, if not keep looking
        for my $id (keys %args) {
          my $idfield = $f->find_input("J:A:F:F-$id-$moniker");
          next INPUT unless $idfield and $idfield->value eq $args{$id};
        }

        # It does! Return it...
        return $1;
      }
    }
  }
  return undef;
}

=head2 fill_in_action MONIKER, FIELD1 => VALUE1, FIELD2 => VALUE2, ...

Finds the fields on the current page with the names FIELD1, FIELD2,
etc in the MONIKER action, and fills them in.  Returns the
L<HTML::Form> object of the form that the action is in, or undef if it
can't find all the fields.

=cut

sub fill_in_action {
    my $self = shift;
    my $moniker = shift;
    my %args = @_;

    # Load the form object containing the given moniker or quit
    my $action_form = $self->action_form($moniker, keys %args);
    return unless $action_form;

    # For each field name given, set the field's value
    for my $arg (keys %args) {
        my $input = $action_form->find_input("J:A:F-$arg-$moniker");
        return unless $input;
        $input->value($args{$arg});
    } 

    # Return the form in case they want to do something with it
    return $action_form;
}

=head2 action_form MONIKER [ARGUMENTNAMES]

Returns the form (as an L<HTML::Form> object) corresponding to the
given moniker (which also contains inputs for the given
argumentnames), and also selects it as the current form.  Returns
undef if it can't be found.

=cut

sub action_form {
    my $self = shift;
    my $moniker = shift;
    my @fields = @_;
    Carp::confess("No moniker") unless $moniker;

    # Go through all the forms looking for the moniker
    my $i;
    for my $form ($self->forms) {
        no warnings 'uninitialized';

        # Keep looking unless the right kind of input is found
        $i++;
        next unless first {   $_->name =~ /J:A-(?:\d+-)?$moniker/
                           && $_->type eq "hidden" }
                        $form->inputs;

        # Keep looking if the suggested field's don't match up
        next if grep {not $form->find_input("J:A:F-$_-$moniker")} @fields;

        $self->form_number($i); #select it, for $mech->submit etc
        return $form;
    } 
    return;
} 

=head2 action_field_value MONIKER, FIELD

Finds the fields on the current page with the names FIELD in the
action MONIKER, and returns its value, or undef if it can't be found.

=cut

sub action_field_value {
    my $self = shift;
    my $moniker = shift;
    my $field = shift;

    # Find the form containing the moniker requested
    my $action_form = $self->action_form($moniker, $field);
    return unless $action_form;
    
    # Find the input containing the field requested and fetch the value
    my $input = $action_form->find_input("J:A:F-$field-$moniker");
    return unless $input;
    return $input->value;
}

=head2 send_action CLASS ARGUMENT => VALUE, [ ... ]

Sends a request to the server via the webservices API, and returns the
L<Jifty::Result> of the action.  C<CLASS> specifies the class of the
action, and all parameters thereafter supply argument keys and values.

The URI of the page is unchanged after this; this is accomplished by
using the "back button" after making the webservice request.

=cut

sub send_action {
    my $self = shift;
    my $class = shift;
    my %args = @_;

    # Setup the URL of the request we're about to make
    my $uri = $self->uri->clone;
    $uri->path("__jifty/webservices/yaml");

    # Setup the action request we're going to send
    my $request = HTTP::Request->new(
        POST => $uri,
        [ 'Content-Type' => 'text/x-yaml' ],
        Jifty::YAML::Dump(
            {   path => $uri->path,
                actions => {
                    action => {
                        moniker => 'action',
                        class   => $class,
                        fields  => \%args
                    }
                }
            }
        )
    );

    # Fire off the request, evaluate the result, and return it
    my $result = $self->request( $request );
    my $content = eval { Jifty::YAML::Load($result->content)->{action} } || undef;
    $self->back;
    return $content;
}

=head2 fragment_request PATH ARGUMENT => VALUE, [ ... ]

Makes a request for the fragment at PATH, using the webservices API,
and returns the string of the result.

=cut

sub fragment_request {
    my $self = shift;
    my $path = shift;
    my %args = @_;

    # Setup the URL we're going to use
    my $uri = $self->uri->clone;
    $uri->path("__jifty/webservices/xml");

    # Setup the request we're going to use
    my $request = HTTP::Request->new(
        POST => $uri,
        [ 'Content-Type' => 'text/x-yaml' ],
        Jifty::YAML::Dump(
            {   path => $uri->path,
                fragments => {
                    fragment => {
                        name  => 'fragment',
                        path  => $path,
                        args  => \%args
                    }
                }
            }
        )
    );

    # Fire the request, evaluate the result, and return it
    my $result = $self->request( $request );
    use XML::Simple;
    my $content = eval { XML::Simple::XMLin($result->content, SuppressEmpty => '')->{fragment}{content} } || '';
    $self->back;
    return $content;
}

=head2 field_error_text MONIKER, FIELD

Finds the error span on the current page for the name FIELD in the
action MONIKER, and returns the text (tags stripped) from it.  (If the
field can't be found, return undef).

=cut

sub field_error_text {
    my $self = shift;
    my $moniker = shift;
    my $field = shift;

    # Setup the XPath processor and the ID we're looking for
    my $tree = HTML::TreeBuilder::XPath->new;
    $tree->parse($self->content);
    $tree->eof;

    my $id = "errors-J:A:F-$field-$moniker";

    # Search for the span containing that error
    return $tree->findvalue(qq{//span[\@id = "$id"]});
}

=head2 uri

L<WWW::Mechanize> has a bug where it returns the wrong value for
C<uri> after redirect.  This fixes that.  See
http://rt.cpan.org/NoAuth/Bug.html?id=9059

=cut

sub uri { shift->response->request->uri }

=head2 session

Returns the server-side L<Jifty::Web::Session> object associated with
this Mechanize object.

=cut

sub session {
    my $self = shift;

    # We don't have a session!
    return undef unless $self->cookie_jar->as_string =~ /JIFTY_SID_\d+=([^;]+)/;

    # Load the data stored in the session cookie
    my $session = Jifty::Web::Session->new;
    $session->load($1);
    return $session;
}

=head2 continuation [ID]

Returns the current continuation of the Mechanize object, if any.  Or,
given an ID, returns the continuation with that ID.

=cut

sub continuation {
    my $self = shift;

    # If we don't have a session, we don't have a continuation
    my $session = $self->session;
    return undef unless $session;
    
    # Look for the continuation info in the URL
    my $id = shift;
    ($id) = $self->uri =~ /J:(?:C|CALL|RETURN)=([^&;]+)/ unless $id;

    # Return information about the continuation
    return $session->get_continuation($id);
}

=head2 current_user

Returns the L<Jifty::CurrentUser> object or descendant, if any.

=cut

sub current_user {
    my $self = shift;

    # We don't have a current user if we don't have a session
    my $session = $self->session;
    return undef unless $session;

    # Fetch information about user from the session
    my $id = $session->get('user_id');
    my $object = Jifty->app_class("CurrentUser")->new();
    my $user = $session->get('user_ref')->new( current_user => $object );
    $user->load_by_cols( id => $id );
    $object->user_object($user);

    return $object;
}

=head1 SEE ALSO

L<Jifty::Test::WWW::Mechanize>

=head1 LICENSE

Jifty is Copyright 2005-2010 Best Practical Solutions, LLC.
Jifty is distributed under the same terms as Perl itself.

=cut

1;