File Coverage

blib/lib/Net/UPS.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 Net::UPS;
$Net::UPS::VERSION = '0.14';
{
  $Net::UPS::DIST = 'Net-UPS';
}
use strict;
use warnings;
use Carp ('croak');
use XML::Simple;
use Encode;
use LWP::UserAgent;
use Net::UPS::ErrorHandler;
use Net::UPS::Rate;
use Net::UPS::Service;
use Net::UPS::Address;
use Net::UPS::Package;
use Scalar::Util 'weaken';

@Net::UPS::ISA          = ( "Net::UPS::ErrorHandler" );
$Net::UPS::LIVE         = 0;

sub RATE_TEST_PROXY () { 'https://wwwcie.ups.com/ups.app/xml/Rate'      }
sub RATE_LIVE_PROXY () { 'https://onlinetools.ups.com/ups.app/xml/Rate' }
sub AV_TEST_PROXY   () { 'https://wwwcie.ups.com/ups.app/xml/AV'        }
sub AV_LIVE_PROXY   () { 'https://onlinetools.ups.com/ups.app/xml/AV'   }
sub XAV_TEST_PROXY  () { 'https://wwwcie.ups.com/ups.app/xml/XAV'       }
sub XAV_LIVE_PROXY  () { 'https://onlinetools.ups.com/ups.app/xml/XAV'  }

sub PICKUP_TYPES () {
    return {
        DAILY_PICKUP            => '01',
        DAILY                   => '01',
        CUSTOMER_COUNTER        => '03',
        ONE_TIME_PICKUP         => '06',
        ONE_TIME                => '06',
        ON_CALL_AIR             => '07',
        SUGGESTED_RETAIL        => '11',
        SUGGESTED_RETAIL_RATES  => '11',
        LETTER_CENTER           => '19',
        AIR_SERVICE_CENTER      => '20'
    };
}

sub CUSTOMER_CLASSIFICATION () {
    return {
        WHOLESALE               => '01',
        OCCASIONAL              => '03',
        RETAIL                  => '04'
    };
}


sub import {
    my $class = shift;
    @_ or return;
    if ( @_ % 2 ) {
        croak "import(): argument list has tobe in key=>value format";
    }
    my $args = { @_ };
    $Net::UPS::LIVE = $args->{live} || 0;
}


sub live {
    my $class = shift;
    unless ( @_ ) {
        croak "$class->live(): usage error";
    }
    $Net::UPS::LIVE = shift;
}



my $ups = undef;
sub new {
    my $class = shift;
    croak "new(): usage error" if ref($class);

    unless ( (@_ >= 1) || (@_ <= 4) ) {
        croak "new(): invalid number of arguments";
    }
    $ups = bless({
        __userid      => $_[0] || undef,
        __password    => $_[1] || undef,
        __access_key  => $_[2] || undef,
        __args        => $_[3] || {},
        __last_service=> undef
    }, $class);

    if ( @_ < 3 ) {
        $ups->_read_args_from_file(@_) or return undef;
    }

    unless ( $ups->userid && $ups->password && $ups->access_key ) {
        croak "new(): usage error. Required arguments missing";
    }
    if ( my $cache_life = $ups->{__args}->{cache_life} ) {
        eval "require Cache::File";
        if (my $errstr = $@ ) {
            croak "'cache_life' requires Cache::File module";
        }
        unless ( $ups->{__args}->{cache_root} ) {
            require File::Spec;
            $ups->{__args}->{cache_root} = File::Spec->catdir(File::Spec->tmpdir, 'net_ups');
        }
        $ups->{__cache} = Cache::File->new( cache_root      => $ups->{__args}->{cache_root},
                                            default_expires => "$cache_life m",
                                            cache_depth     => 5,
                                            lock_level      => Cache::File::LOCK_LOCAL()
                                            );
    }
    $ups->init();
    return $ups;
}





sub instance {
    return $ups if defined($ups);
    croak "instance(): no object instance found";
}




sub _read_args_from_file {
    my $self = shift;
    my ($path, $args) = @_;
    $args ||= {};

    unless ( defined $path ) {
        croak "_read_args_from_file(): required arguments are missing";
    }

    require IO::File;
    my $fh = IO::File->new($path, '<') or return $self->set_error("couldn't open $path: $!");
    my %config = ();
    while (local $_ = $fh->getline) {
        next if /^\s*\#/;
        next if /^\n/;
        next unless /^UPS/;
        chomp();
        my ($key, $value) = m/^\s*UPS(\w+)\s+(\S+)$/;
        $config{ $key } = $value;
    }
    unless ( $config{UserID} && $config{Password} && $config{AccessKey} ) {
        return $self->set_error( "_read_args_from_file(): required arguments are missing" );
    }
    $self->{__userid}       = $config{UserID};
    $self->{__password}     = $config{Password};
    $self->{__access_key}   = $config{AccessKey};


    $self->{__args}->{customer_classification} = $args->{customer_classification} || $config{CustomerClassification};
    $self->{__args}->{ups_account_number}      = $args->{ups_account_number}      || $config{AccountNumber};
    $self->{__args}->{rate_proxy} = $args->{rate_proxy} || $config{RateProxy};
    $self->{__args}->{av_proxy} = $args->{av_proxy} || $config{AVProxy};
    $self->cache_life( $args->{cache_life} || $config{CacheLife} );
    $self->cache_root( $args->{cache_root} || $config{CacheRoot} );

    return $self;
}

sub init        {                                                       }
sub rate_proxy  { return $_[0]->{__args}->{rate_proxy} || ($Net::UPS::LIVE ? RATE_LIVE_PROXY : RATE_TEST_PROXY) }
sub av_proxy    { return $_[0]->{__args}->{av_proxy} || ($Net::UPS::LIVE ? AV_LIVE_PROXY   : AV_TEST_PROXY) }
sub xav_proxy   { return $_[0]->{__args}->{xav_proxy} || ($Net::UPS::LIVE ? XAV_LIVE_PROXY   : XAV_TEST_PROXY) }

sub cache_life  { return $_[0]->{__args}->{cache_life} = $_[1]          }
sub cache_root  { return $_[0]->{__args}->{cache_root} = $_[1]          }
sub userid      { return $_[0]->{__userid}                              }
sub password    { return $_[0]->{__password}                            }
sub access_key  { return $_[0]->{__access_key}                          }
sub account_number{return $_[0]->{__args}->{ups_account_number}         }
sub customer_classification { return $_[0]->{__args}->{customer_classification} }
sub dump        { return Dumper($_[0])                                  }

sub ssl_options {
    my ($self) = @_;

    unless ($self->{__args}{ssl_options}) {
        require IO::Socket::SSL;
        require IO::Socket::SSL::Utils;
        my $cert = IO::Socket::SSL::Utils::PEM_string2cert(<<'PEM');
-----BEGIN CERTIFICATE-----
MIICPDCCAaUCEHC65B0Q2Sk0tjjKewPMur8wDQYJKoZIhvcNAQECBQAwXzELMAkGA1UEBhMCVVMx
FzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMTcwNQYDVQQLEy5DbGFzcyAzIFB1YmxpYyBQcmltYXJ5
IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MB4XDTk2MDEyOTAwMDAwMFoXDTI4MDgwMTIzNTk1OVow
XzELMAkGA1UEBhMCVVMxFzAVBgNVBAoTDlZlcmlTaWduLCBJbmMuMTcwNQYDVQQLEy5DbGFzcyAz
IFB1YmxpYyBQcmltYXJ5IENlcnRpZmljYXRpb24gQXV0aG9yaXR5MIGfMA0GCSqGSIb3DQEBAQUA
A4GNADCBiQKBgQDJXFme8huKARS0EN8EQNvjV69qRUCPhAwL0TPZ2RHP7gJYHyX3KqhEBarsAx94
f56TuZoAqiN91qyFomNFx3InzPRMxnVx0jnvT0Lwdd8KkMaOIG+YD/isI19wKTakyYbnsZogy1Ol
hec9vn2a/iRFM9x2Fe0PonFkTGUugWhFpwIDAQABMA0GCSqGSIb3DQEBAgUAA4GBALtMEivPLCYA
TxQT3ab7/AoRhIzzKBxnki98tsX63/Dolbwdj2wsqFHMc9ikwFPwTtYmwHYBV4GSXiHx0bH/59Ah
WM1pF+NEHJwZRDmJXNycAA9WjQKZ7aKQRUzkuxCkPfAyAw7xzvjoyVGM5mKf5p/AfbdynMk2Omuf
Tqj/ZA1k
-----END CERTIFICATE-----
PEM
        require Mozilla::CA;
        $self->{__args}{ssl_options} = {
            SSL_verify_mode => 1,
            SSL_verifycn_scheme => 'www',
            SSL_ca => [ $cert ],
            SSL_ca_file => Mozilla::CA::SSL_ca_file(),
        };
    }
    return $self->{__args}{ssl_options};
}


sub user_agent  {
    my ($self) = @_;

    unless ($self->{__args}{user_agent}) {
        my $user_agent  = LWP::UserAgent->new(
            ssl_opts => $self->ssl_options,
        );
        $user_agent->env_proxy;
        $self->{__args}{user_agent} = $user_agent;
    }
    return $self->{__args}{user_agent}
}

sub access_as_xml {
    my $self = shift;
    return XMLout({
        AccessRequest => {
            AccessLicenseNumber  => $self->access_key,
            Password            => $self->password,
            UserId              => $self->userid
        }
    }, NoAttr=>1, KeepRoot=>1, XMLDecl=>1);
}

sub transaction_reference {
    return {
        CustomerContext => "Net::UPS",
        XpciVersion     => '1.0001'
    };
}

sub rate {
    my $self = shift;
    my ($from, $to, $packages, $args) = @_;
    croak "rate(): usage error" unless ($from && $to && $packages);

    unless ( ref $from ) {
        $from = Net::UPS::Address->new(postal_code=>$from);
    }
    unless ( ref $to ) {
        $to   = Net::UPS::Address->new(postal_code=>$to);
    }
    unless ( ref $packages eq 'ARRAY' ) {
        $packages = [$packages];
    }
    $args                   ||= {};
    $args->{mode}             = "rate";
    $args->{service}        ||= "GROUND";

    my $services = $self->request_rate($from, $to, $packages, $args);
    return if !defined $services;

    # we need to replace the rate->service ref with a non-weak one,
    # but we also need to avoid the circular reference problem. Hence
    # all this mess

    my $service = $services->[0];
    my @rates = @{$service->rates()};
    $service->rates([]); # now the service no longer references the rates
    $_->service($service) for @rates; # and each rate has a non-weak service ref

    if ( @$packages == 1 ) {
        return $rates[0];
    }

    return \@rates;
}


sub shop_for_rates {
    my $self = shift;
    my ($from, $to, $packages, $args) = @_;

    unless ( $from && $to && $packages ) {
        croak "shop_for_rates(): usage error";
    }
    unless ( ref $from ) {
        $from = Net::UPS::Address->new(postal_code=>$from);
    }
    unless ( ref $to ) {
        $to =  Net::UPS::Address->new(postal_code=>$to);
    }
    unless ( ref $packages eq 'ARRAY' ) {
        $packages = [$packages];
    }
    $args           ||= {};
    $args->{mode}     = "shop";
    $args->{service}||= "GROUND";

    # Scoob correction Aug 19th 2006 / [e-mail]
    # There was a Perl run time error when no rates were found
    # (empty package list, bad zip code etc...)
    # request_rate() can now return undef in case of errors.
    ####
    my $services_aref = $self->request_rate($from, $to, $packages, $args);
    if (defined $services_aref) {
        return [sort {$a->total_charges <=>$b->total_charges} @$services_aref];
    } else {
        return undef;  # No services were
    }
}

sub request_rate {
    my $self = shift;
    my ($from, $to, $packages, $args) = @_;

    croak "request_rate(): usage error" unless ($from && $to && $packages && $args);
    unless (ref($from) && $from->isa("Net::UPS::Address")&&
            ref($to) && $to->isa("Net::UPS::Address") &&
            ref($packages) && (ref $packages eq 'ARRAY') &&
            ref($args) && (ref $args eq 'HASH')) {
        croak "request_rate(): usage error";
    }
    if ( defined($args->{limit_to}) ) {
        unless ( ref($args->{limit_to}) && ref($args->{limit_to}) eq 'ARRAY' ) {
            croak "request_rate(): usage error. 'limit_to' should be of type ARRAY";
        }
    }
    if ( defined $args->{exclude} ) {
        unless ( ref($args->{exclude}) && ref($args->{exclude}) eq 'ARRAY' ) {
            croak "request_rate(): usage error. 'exclude' has to be of type 'ARRAY'";
        }
    }
    if ( $args->{exclude} && $args->{limit_to} ) {
        croak "request_rate(): usage error. You cannot use both 'limit_to' and 'exclude' at the same time";
    }
    unless (scalar(@$packages)) {
        return $self->set_error( "request_rate() was given an empty list of packages!" );
    }

    for (my $i=0; $i < @$packages; $i++ ) {
        $packages->[$i]->id( $i + 1 );
    }
    my $cache_key = undef;
    my $cache     = undef;
    if ( defined($cache = $self->{__cache}) ) {
        $cache_key = $self->generate_cache_key($from, $to, $packages, $args);
        if ( my $services = $cache->thaw($cache_key) ) {
            return $services;
        }
    }
    my %data = (
        RatingServiceSelectionRequest => {
            Request => {
                RequestAction   => 'Rate',
                RequestOption   =>  $args->{mode},
                TransactionReference => $self->transaction_reference,
            },
            PickupType  => {
                Code    => PICKUP_TYPES->{$self->{__args}->{pickup_type}||"ONE_TIME"}
            },
            Shipment    => {
                Service     => { Code   => Net::UPS::Service->new_from_label( $args->{service} )->code },
                Package     => [map { $_->as_hash()->{Package} } @$packages],
                Shipper     => $from->as_hash('AV'),
                ShipTo      => $to->as_hash('AV')
            }
    });
    if ( my $shipper_number = $self->{__args}->{ups_account_number} ) {
        $data{RatingServiceSelectionRequest}->{Shipment}->{Shipper}->{ShipperNumber} = $shipper_number;
    }
    if (my $classification_code = $self->{__args}->{customer_classification} ) {
        $data{RatingServiceSelectionRequest}->{CustomerClassification}->{Code} = CUSTOMER_CLASSIFICATION->{$classification_code};
    }
    my $xml         = $self->access_as_xml . XMLout(\%data, KeepRoot=>1, NoAttr=>1, KeyAttr=>[], XMLDecl=>1);
    my $response    = XMLin( $self->post( $self->rate_proxy, $xml ),
                                            KeepRoot => 0,
                                            NoAttr => 1,
                                            KeyAttr => [],
                                            ForceArray => ['RatedPackage', 'RatedShipment']);

    ##############################################################################
    # Scoob correction Jan 2nd 2007 / cpan AT pickledbrain.com
    #
    # Changes to handle latest UPS xml service.  See this document for details:
    #
    # This new release of the document:
    #    "UPS online tools
    #     Rates and Service Selection - XML Programming Invormation
    #     version 1.0,  Volume 7, number 1   rev date Dec 17th 2006"
    #
    #  Get it at:  http://www.ups.com/onlinetools  (registration required)
    #
    #  UPS just introduced two new errors codes (warning level):
    #    ErrorCode:        110971
    #    ErrorSeverity:    Warning
    #    ErrorDescription: 'Your invoice may vary from the displayed reference rates'
    #            AND
    #    ErrorCode:        110920
    #    ErrorSeverity:    Warning
    #    ErrorDescription: 'Ship To address has been changed from (residential/commercial)
    #                                    to (commercial/residential)'
    #
    #    The original code here did not handle any "warning" level
    #    (there were no other cases of warning level errors prior to this)
    #    and simply returned an error w/o the shipping rates.
    #
    #    The code change below simply ignore those two warnings as they are
    #    essentially legal cover-your-ass and not all that useful here.
    #
    #####
    # Ignore "Warning" level error
    if ( my $error  =  $response->{Response}->{Error} ) {
        unless ($error->{'ErrorSeverity'} eq 'Warning') {
            return $self->set_error( $error->{ErrorDescription} );
        }
    }

    my @services;
    for (my $i=0; $i < @{$response->{RatedShipment}}; $i++ ) {
        my $ref = $response->{RatedShipment}->[$i] or die;
        my $service = Net::UPS::Service->new_from_code($ref->{Service}->{Code});
        $service->total_charges( $ref->{TotalCharges}->{MonetaryValue} );
        $service->guaranteed_days(ref($ref->{GuaranteedDaysToDelivery}) ?
                                                undef : $ref->{GuaranteedDaysToDelivery});
        $service->rated_packages( $packages );
        my @rates = ();
        for (my $j=0; $j < @{$ref->{RatedPackage}}; $j++ ) {
            push @rates, Net::UPS::Rate->new(
                billing_weight  => $ref->{RatedPackage}->[$j]->{BillingWeight}->{Weight},
                total_charges   => $ref->{RatedPackage}->[$j]->{TotalCharges}->{MonetaryValue},
                rated_package   => $packages->[$j],
                service         => $service,
                from            => $from,
                to              => $to
            );
            # bad hack! we have to do it this way because:
            #
            # 1) Class::Struct has no support for weak references
            #
            # 2) weakening the result of the accessor would not change
            #    the actual value inside the object
            #
            # 3) the objects created by Class::Struct by default are
            #    array-based
            #
            # we are clearly breaking encapsulation, and this may stop
            # working if the internals of Class::Struct change. I
            # can't see any better way, though.
            weaken($rates[-1]->[3]);
        }
        $service->rates(\@rates);
        if ( (lc($args->{mode}) eq 'shop') && defined($cache) ) {
            local ($args->{mode}, $args->{service});
            $args->{mode} = 'rate';
            $args->{service} = $service->label;
            my $cache_key = $self->generate_cache_key($from, $to, $packages, $args);
            $cache->freeze($cache_key, [$service]);
        }
        if ( $args->{limit_to} ) {
            my $limit_ok = 0;
            for ( @{$args->{limit_to}} ) {
                ($_ eq $service->label) && $limit_ok++;
            }
            $limit_ok or next;
        }
        if ( $args->{exclude} ) {
            my $exclude_ok = 0;
            for ( @{$args->{exclude}} ) {
                ($_ eq $service->label) && $exclude_ok++;
            }
            $exclude_ok and next;
        }
        push @services, $service;
        $self->{__last_service} = $service;

    }
    if ( defined $cache ) {
        $cache->freeze($cache_key, \@services);
    }
    return \@services;
}




sub service {
    return $_[0]->{__last_service};
}


sub post {
    my $self = shift;
    my ($url, $content) = @_;

    unless ( $url && $content ) {
        croak "post(): usage error";
    }

    my $request     = HTTP::Request->new('POST', $url);
    $request->content( encode('utf-8',$content) );
    my $response    = $self->user_agent->request( $request );
    if ( $response->is_error ) {
        die $response->status_line();
    }
    return $response->content;
}




sub validate_address {
    my $self    = shift;
    my ($address, $args) = @_;

    croak "verify_address(): usage error" unless defined($address);

    unless ( ref $address ) {
        $address = {postal_code => $address};
    }
    if ( ref $address eq 'HASH' ) {
        $address = Net::UPS::Address->new(%$address);
    }
    $args ||= {};
    unless ( defined $args->{tolerance} ) {
        $args->{tolerance} = 0.05;
    }
    unless ( ($args->{tolerance} >= 0) && ($args->{tolerance} <= 1) ) {
        croak "validate_address(): invalid tolerance threshold";
    }
    my %data = (
        AddressValidationRequest    => {
            Request => {
                RequestAction   => "AV",
                TransactionReference => $self->transaction_reference(),
            },
            %{$address->as_hash('AV')},
        }
    );

    my $xml = $self->access_as_xml . XMLout(\%data, KeepRoot=>1, NoAttr=>1, KeyAttr=>[], XMLDecl=>1);
    my $response = XMLin($self->post($self->av_proxy, $xml),
                                                KeepRoot=>0, NoAttr=>1,
                                                KeyAttr=>[], ForceArray=>["AddressValidationResult"]);

    if ( my $error = $response->{Response}->{Error} ) {
        unless ($error->{'ErrorSeverity'} eq 'Warning') {
            return $self->set_error( $error->{ErrorDescription} );
        }
    }
    my @addresses = ();
    for (my $i=0; $i < @{$response->{AddressValidationResult}}; $i++ ) {
        my $ref = $response->{AddressValidationResult}->[$i];
        next if $ref->{Quality} < (1 - $args->{tolerance});
        while ( $ref->{PostalCodeLowEnd} <= $ref->{PostalCodeHighEnd} ) {
            my $address = Net::UPS::Address->new(
                quality         => $ref->{Quality},
                postal_code     => $ref->{PostalCodeLowEnd},
                city            => $ref->{Address}->{City},
                state           => $ref->{Address}->{StateProvinceCode},
                country_code    => "US"
            );
            push @addresses, $address;
            $ref->{PostalCodeLowEnd}++;
        }
    }
    return \@addresses;
}

sub validate_street_address {
    my $self = shift;
    my ($address, $args) = @_;

    croak "validate_street_address(): usage error" unless defined($address);

    unless ( ref $address ) {
        $address = {postal_code => $address};
    }
    if ( ref $address eq 'HASH' ) {
        $address = Net::UPS::StreetAddress->new(%$address);
    }
    $args ||= {};

    my %data = (
        AddressValidationRequest => {
            Request => {
                RequestAction => "XAV",
                RequestOption => "3",
                TransactionReference => $self->transaction_reference(),
            },
            %{$address->as_hash('XAV')},
        },
    );

    my $xml = $self->access_as_xml . XMLout(\%data, KeepRoot=>1, NoAttr=>1, KeyAttr=>[], XMLDecl=>1);
    my $response = XMLin($self->post($self->xav_proxy, $xml),
                         KeepRoot=>0, NoAttr=>1,
                         KeyAttr=>[], ForceArray=>["AddressValidationResponse", "AddressLine"]);

    if ( my $error = $response->{Response}->{Error} ) {
        unless ($error->{'ErrorSeverity'} eq 'Warning') {
            return $self->set_error( $error->{ErrorDescription} );
        }
    }
    if ( $response->{NoCandidatesIndicator} )
    {
        return $self->set_error("The Address Matching System is not able to match an address from any other one in the database.");
    }
    my $quality = 0;
    if ( $response->{AmbiguousAddressIndicator} )
    {
        $self->set_error("The Address Matching System is not able to explicitly differentiate an address from any other one in the database.");
    }
    elsif ( $response->{ValidAddressIndicator} )
    {
        $quality = 1;
    }

    my $response_address;
    if ($response->{AddressKeyFormat}) {
        my $akf = $response->{AddressKeyFormat};
        if (ref($akf) eq 'ARRAY') {
            $akf = $akf->[0];
        }
        $response_address = Net::UPS::Address->new(
            quality => $quality,
            building_name => $akf->{BuildingName},
            address => $akf->{AddressLine}->[0],
            address2 => $akf->{AddressLine}->[1],
            address3 => $akf->{AddressLine}->[2],
            postal_code => $akf->{PostcodePrimaryLow},
            postal_code_extended => $akf->{PostcodeExtendedLow},
            city => $akf->{PoliticalDivision2},
            state => $akf->{PoliticalDivision1},
            country_code => $akf->{CountryCode},
            is_commercial => ( $response->{AddressClassification}->{Code} eq "1" ) ? 1 : 0,
            is_residential => ( $response->{AddressClassification}->{Code} eq "2" ) ? 1 : 0,
        );
    }

    return $response_address;
}

sub generate_cache_key {
    my $self = shift;
    my ($from, $to, $packages, $args) = @_;
    unless ( $from && $to && $packages && ref($from) && ref($to) && ref($packages) ) {
        croak "generate_cache_key(): usage error";
    }
    my @keys = ($from->cache_id, $to->cache_id);
    for my $package ( @$packages ) {
        push @keys, $package->cache_id;
    }
    for my $key ( sort keys %{$self->{__args}} ) {
        push @keys, sprintf("%s:%s", lc $key, lc $self->{__args}->{$key} );
    }
    for my $key (sort keys %$args ) {
        next if $key eq 'limit_to';
        next if $key eq 'exclude';
        push @keys, sprintf("%s:%s", lc $key, lc $args->{$key});
    }
    return join(":", @keys);
}




1;
__END__