File Coverage

blib/lib/Gallery/Remote/API.pm

Criterion	Covered	Total	%
statement	140	153	91.5
branch	39	54	72.2
condition	11	18	61.1
subroutine	25	35	71.4
pod	13	13	100.0
total	228	273	83.5

package Gallery::Remote::API;

use strict;
use warnings;

use version 0.77; our $VERSION = qv('v0.1.4');

use base qw(Class::Accessor);
Gallery::Remote::API->mk_ro_accessors(qw(
	url username password version _remoteurl _cookiejar _useragent
));
Gallery::Remote::API->mk_accessors(qw(response result));

use Carp;
use URI;
use URI::QueryParam;
use LWP::UserAgent;
use HTTP::Cookies;
use File::Temp;
use Config::Properties;
use Data::Diver qw(Dive);
use Sub::Name;
use Scalar::Util qw(blessed);
use Fcntl qw(:seek);


#constants

use constant PROTOCOL_VERSION => 2.9;

use constant ACCESSPAGE => {
	1 => 'gallery_remote2.php',
	2 => 'main.php'
};

## actions

## we auto-build methods for each known Protocol command

BEGIN {

    no strict 'refs';

	foreach (qw(
		fetch_albums
		fetch_albums_prune
		add_item
		album_properties
		new_album
		fetch_album_images
		move_album
		increment_view_count
		image_properties
		no_op
	)) {
		my $cmd = $_; $cmd =~ s/\_/\-/g;
		my $method = sub {
			my ($self,$params) = @_;
			return $self->execute_command("$cmd",$params);
		};
		my $methname = "Gallery::Remote::API::$_";
		subname($methname,$method);
		*{$methname} = $method;
	}
};

#except for login, for which we want the user/pass goodness

sub login {
	my $self = shift;

	croak "Must define username during object construction to login"
		unless my $u = $self->username;
	croak "Must define password during object construction to login"
		unless my $p = $self->password;

	return $self->execute_command('login', {
			uname    => $u, password => $p
	});
}

# the big boy

sub execute_command {
	my ($self,$command,$params) = @_;

	#clear any previous response and result
	$self->response(undef);
	$self->result(undef);

	croak "Must pass a command" unless $command;
	$params = {} unless defined $params;

	$params->{protocol_version} ||= PROTOCOL_VERSION;
	#if you try and send this, I'm just going to overwrite
	$params->{cmd} = $command;

	my $useparams = {};
	if ($self->version == 2) {
		foreach (keys %$params) {
			next if $_ =~ /^userfile/;
			$useparams->{"g2_form[$_]"} = $params->{$_};
		}

		#hack these goofy exceptions
		# see: http://codex.gallery2.org/Gallery_Remote:Protocol#G2_support
		if (my $uf = $params->{userfile}) {
			#also do the arrayref bit here so lwp knows to read the file
			$useparams->{g2_userfile} = [$uf];
		}
		if (my $ufn = $params->{userfile_name}) {
			$useparams->{g2_userfile_name} = $ufn;
		}
	}
	else {
		$useparams = $params;
	}

	#do it!
	my $res = $self->_useragent->post(
		$self->_remoteurl,
		Content_Type => $command eq 'add-item' ?
			'multipart/form-data' : 'application/x-www-form-urlencoded',
		Content => $useparams
	);

	if ($res->is_success) {
		$self->response($res->content);
		return $self->_parse_response;
	}

	#carp "Server Error: ".$res->status_line."\n";
	# fake an error in the same style as those returned by the protocol
	# throw in the response object itself in case anyone finds it useful
	$self->result({status => 'server_error', status_text => $res->message, response => $res});
	return;
}

sub _parse_response {
	my $self = shift;
	if (my $response = $self->response) {

		#drop anything before the proto tag
		$response =~ s/^(.*)#__GR2PROTO/#__GR2PROTO/;

		#this is stupid. They return a Java Properties stream. We
		#want Config::Properties to deserialize it for us, but that
		#module wants to load from a filehandle, it doesn't look like
		#you can just pass it data. Hence...
		my $virtualfile = '';
		open(my $fh, '+>', \$virtualfile)
			|| croak "Failed to open virtual file: $!";
		print $fh $response;
		seek($fh,0,SEEK_SET);

		my $cp = new Config::Properties;
		$cp->load($fh);

		my $result = $cp->splitToTree;

		#now let's improve deserialization on a few things where we get a csv
		#list that ought to be an array (does Properties not serialize
		#on the "value" side? I don't see any way to differentiate a csv from
		#ordinary data with a comma in it)

			# use DataDiver so as not to autovivify if not there

		#from fetch-albums & fetch-abums-prune
		if (my $ef = Dive($result, qw( album info extrafields ))) {
			foreach (keys %$ef) {
				$result->{album}->{info}->{extrafields}->{$_} = [
					split(',',$result->{album}->{info}->{extrafields}->{$_})
				];
			}
		}
		#from album-properties
		if (my $ef = Dive($result, qw(extrafields))) {
			$result->{extrafields} = [ split(',',$ef) ];
		}

		$self->result($result);
		unless (exists $result->{status}) {
			$result->{status} = 'unknown_error';
			$result->{status_text} = $result->{Error} || 'unknown error';
		}

		unless ($result->{status}) { #success is 0, don't do on fail
			#add/replace the security token, if present
			if (my $newtoken = $result->{auth_token}) {
				$self->_remoteurl->query_param(g2_authToken => $newtoken);
			}
			return $result
		};
	}
	return;
}


#constructor

# Override parent C:A's new method to do some validation and default
# as needed before passing arguments into the RO accessors

sub new {
	my ($class,$args) = @_;
	$class = ref $class || $class;

	my $cleanargs = $class->_parse_constructor_args($args);
	my $self = $class->SUPER::new($cleanargs);
	bless $self,$class;

	return $self;
}

sub _parse_constructor_args {
	my ($self,$args) = @_;

	unless (ref $args eq 'HASH') {
		croak "Must pass arguments as a hashref; 'url' required at minimum";
	}

	my %cleanargs;
	$args->{version} ||= 2;
	foreach (keys %$args) {
		if (($_ eq 'url') && (my $u = $args->{url})) {

			if (ref $u && blessed $u && $u->isa('URI')) {
				$cleanargs{$_} = $u;
			}
			elsif (ref $u) {
				croak "url must be a URI object, or a string";
			}
			else {
				$u  = "http://$u" unless (substr($u,0,7) eq 'http://');
				$cleanargs{$_} = URI->new($u);
			}
		}
		elsif ($_ eq 'version') {
			if ($args->{$_} =~ /^[12]$/) {
				$cleanargs{$_} = $args->{$_};
			}
			else {
				croak "Accepted values for Gallery version are '1' or '2'";
			}
		}
		elsif ($self->can($_)) {
			$cleanargs{$_} = $args->{$_};
		}
		else {
			carp "Unkown argument '$_'";
		}
	}

	if (my $u = $cleanargs{url}) {
		my $v = $cleanargs{version};
		$cleanargs{_remoteurl} = URI->new($u->canonical . ACCESSPAGE->{$v});
		if ($v == 2) {
			$cleanargs{_remoteurl}->query_param(g2_controller => 'remote:GalleryRemote');
		}
	}
	else {
		croak "'url' to the gallery installation is a required argument";
	}

	my $cj = File::Temp->new->filename;
	$cleanargs{_cookiejar} = $cj;

	my $ua = new LWP::UserAgent;
    $ua->cookie_jar(HTTP::Cookies->new(file => $cj, autosave => 1));
	$cleanargs{_useragent} = $ua;

	return \%cleanargs;
}


1; # Magic true value required at end of module
__END__