File Coverage

blib/lib/Business/PayPal/API.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Business::PayPal::API;

use 5.008001;
use strict;
use warnings;

use SOAP::Lite 0.67; # +trace => 'all';
use Carp qw(carp);

our $VERSION = '0.70';
our $CVS_VERSION = '$Id: API.pm,v 1.24 2009/07/28 18:00:58 scott Exp $';
our $Debug = 0;

## NOTE: This package exists only until I can figure out how to use
## NOTE: SOAP::Lite's WSDL support for complex types and importing
## NOTE: type definitions, at which point this module will become much
## NOTE: smaller (or non-existent).

sub C_api_sandbox    () { 'https://api.sandbox.paypal.com/2.0/' }
sub C_api_sandbox_3t () { 'https://api-3t.sandbox.paypal.com/2.0/' }
sub C_api_live    () { 'https://api.paypal.com/2.0/' }
sub C_api_live_3t () { 'https://api-3t.paypal.com/2.0/' }
sub C_xmlns_pp    () { 'urn:ebay:api:PayPalAPI' }
sub C_xmlns_ebay  () { 'urn:ebay:apis:eBLBaseComponents' }
sub C_version     () { '3.0' }  ## 3.0 adds RecurringPayments

## this is an inside-out object. Make sure you 'delete' additional
## members in DESTROY() as you add them.
my %Soap;
my %Header;

my %H_PKCS12File;     ## path to certificate file (pkc12)
my %H_PKCS12Password; ## password for certificate file (pkc12)
my %H_CertFile;       ## PEM certificate
my %H_KeyFile;        ## PEM private key

sub import {
    my $self    = shift;
    my @modules = @_;

    for my $module ( @modules ) {
        eval( "use Business::PayPal::API::$module;" );
        if( $@ ) {
            warn $@;
            next;
        }

        ## import 'exported' subroutines into our namespace
        no strict 'refs';
        for my $sub ( @{"Business::PayPal::API::" . $module . "::EXPORT_OK"} ) {
            *{"Business::PayPal::API::" . $sub} = *{"Business::PayPal::API::" . $module . "::" . $sub};
        }
    }
}

sub new {
    my $class = shift;
    my %args = @_;
    my $self = bless \(my $fake), $class;

    ## if you add new args, be sure to update the test file's @variables array
    $args{Username}  ||= '';
    $args{Password}  ||= '';
    $args{Signature} ||= '';
    $args{Subject}   ||= '';
    $args{sandbox} = 1 unless exists $args{sandbox};
    $args{timeout}   ||= 0;

    $H_PKCS12File{$self}     = $args{PKCS12File}     || '';
    $H_PKCS12Password{$self} = $args{PKCS12Password} || '';
    $H_CertFile{$self}       = $args{CertFile}       || '';
    $H_KeyFile{$self}        = $args{KeyFile}        || '';

    my $proxy = ($args{sandbox}
		 ? ($args{Signature}
                    ? C_api_sandbox_3t
                    : C_api_sandbox)
		 : ($args{Signature}
		    ? C_api_live_3t
		    : C_api_live)
		);

    $Soap{$self} = SOAP::Lite->proxy( $proxy, timeout => $args{timeout} )->uri( C_xmlns_pp );

    $Header{$self} = SOAP::Header
      ->name( RequesterCredentials => \SOAP::Header->value
	      ( SOAP::Data->name( Credentials => \SOAP::Data->value
				  ( SOAP::Data->name( Username  => $args{Username} )->type(''),
				    SOAP::Data->name( Password  => $args{Password} )->type(''),
				    SOAP::Data->name( Signature => $args{Signature} )->type(''),
				    SOAP::Data->name( Subject   => $args{Subject} )->type(''),
				  ),
				)->attr( {xmlns => C_xmlns_ebay} )
	      )
	    )->attr( {xmlns => C_xmlns_pp} )->mustUnderstand(1);

    return $self;
}

sub DESTROY {
    my $self = $_[0];

    delete $Soap{$self};
    delete $Header{$self};

    delete $H_PKCS12File{$self};
    delete $H_PKCS12Password{$self};
    delete $H_CertFile{$self};
    delete $H_KeyFile{$self};

    my $super = $self->can("SUPER::DESTROY");
    goto &$super if $super;
}

sub version_req {
    return SOAP::Data->name( Version => C_version )
      ->type('xs:string')->attr( {xmlns => C_xmlns_ebay} );
}

sub doCall {
    my $self = shift;
    my $method_name = shift;
    my $request = shift;
    my $method = SOAP::Data->name( $method_name )->attr( {xmlns => C_xmlns_pp} );

    my $som;
    {
        $H_PKCS12File{$self}     and local $ENV{HTTPS_PKCS12_FILE}     = $H_PKCS12File{$self};
        $H_PKCS12Password{$self} and local $ENV{HTTPS_PKCS12_PASSWORD} = $H_PKCS12Password{$self};
        $H_CertFile{$self}       and local $ENV{HTTPS_CERT_FILE}       = $H_CertFile{$self};
        $H_KeyFile{$self}        and local $ENV{HTTPS_KEY_FILE}        = $H_KeyFile{$self};

	if( $Debug ) {
	    print STDERR SOAP::Serializer->envelope(method => $method,
                                                    $Header{$self}, $request), "\n";
	}

#	$Soap{$self}->readable( $Debug );
#	$Soap{$self}->outputxml( $Debug );

	no warnings 'redefine';
	local *SOAP::Deserializer::typecast = sub {shift; return shift};
        eval {
          $som = $Soap{$self}->call( $Header{$self}, $method => $request );
        };

        if( $@ ) {
          carp $@;
          return;
        }
    }

    if( $Debug ) {
        ## FIXME: would be nicer to dump a SOM to XML, but how to do that?
        require Data::Dumper;
        print STDERR Data::Dumper::Dumper($som->envelope);
    }

    if( ref($som) && $som->fault ) {
        carp "Fault: " . $som->faultstring
          . ( $som->faultdetail ? " (" . $som->faultdetail . ")" : '' )
            . "\n";
        return;
    }

    return $som;
}

sub getFieldsList {
    my $self = shift;
    my $som  = shift;
    my $path = shift;
    my $fields = shift;

    return unless $som;

    my %trans_id = ();
    my @records = ();
    for my $rec ( $som->valueof($path) ) {
        my %response = ();
        @response{keys %$fields} = @{$rec}{keys %$fields};

        ## avoid duplicates
	if( defined $response{TransactionID}) {
	    if( $trans_id{$response{TransactionID}}) {
		next;
	    } else {
		$trans_id{$response{TransactionID}} = 1;
	    }
	}
        push @records, \%response;
    }

    return \@records;
}

sub getFields {
    my $self = shift;
    my $som  = shift;
    my $path = shift;
    my $response = shift;
    my $fields = shift;

    return unless $som;

    ## kudos to Erik Aronesty via email, Drew Simpson via rt.cpan.org (#28596)

    ## Erik wrote:
    ##
    ## If you want me to write the code for the "flagged" version, i
    ## can .. i think the '/@' flag is a pretty safe, and obvious flag.
    ##
    ## the advantage of the flagged version would be that the caller
    ## doesn't have to check the returned value ... in the case of a
    ## field where multiple values are expected.
    ##
    ##
    ## I agree with this on principle and would prefer it, but I voted
    ## against a special flag, now forcing the caller to check the
    ## return value, but only for the sake of keeping everything
    ## consistent with the rest of the API. If Danny Hembree wants to
    ## go through and implement Erik's suggestion, I'd be in favor of
    ## it.

    for my $field ( keys %$fields ) {
        my @vals = grep { defined } $som->valueof("$path/$fields->{$field}");
        next unless @vals;

        if( scalar(@vals) == 1 ) {
            $response->{$field} = $vals[0];
        }
        else {
            $response->{$field} = \@vals;
        }
    }
}

sub getBasic {
    my $self = shift;
    my $som  = shift;
    my $path = shift;
    my $details = shift;

    return unless $som;

    for my $field ( qw( Ack Timestamp CorrelationID Version Build ) ) {
        $details->{$field} = $som->valueof("$path/$field") || '';
    }

    return $details->{Ack} =~ /Success/;
}

sub getErrors {
    my $self = shift;
    my $som  = shift;
    my $path = shift;
    my $details = shift;

    return unless $som;

    my @errors = ();

    for my $enode ( $som->valueof("$path/Errors") ) {
        push @errors, { LongMessage => $enode->{LongMessage},
                        ErrorCode   => $enode->{ErrorCode}, };
    }
    $details->{Errors} = \@errors;

    return;
}

1;
__END__