view release on metacpan or  search on metacpan

DirectConnect.pm  view on Meta::CPAN

# modify it under the same terms as Perl itself

package Business::FedEx::DirectConnect; #must be in Business/FedEx

require 5.006_000;

use Business::FedEx::Constants qw(
    %FE_RE %FE_SE %FE_TT %FE_RQ
    field_name_to_tag
    field_tag_to_name
);

use Carp qw(confess croak);
use LWP::UserAgent;

our $VERSION = '1.01';

use strict;


#Please register with FedEx to receive the addresses to their DirectConnect API.
use constant FEDEX_API_URI => '';

# Use Tie::IxHash so that fields are output in the order they're set,
# which makes reading the list of fields easier if you set them in a
# useful order.
#
# XXX only use IxHash when a debug flag is set?

{ my $have_ix_hash;
sub _init_ix_hash {
    my ($rhash, $rdata) = @_;

    $have_ix_hash = !!eval { local $SIG{__DIE__}; require Tie::IxHash }
    if !defined $have_ix_hash;

    if ($have_ix_hash) {
    tie %$rhash, 'Tie::IxHash', @$rdata;
    }
    else {
        %$rhash = @$rdata;
    }
} }

sub new {
    my $name = shift;
    my $class = ref($name) || $name;
    my $self  = {
                 uri=>FEDEX_API_URI
                ,acc => ''
                ,meter => ''
                ,referer => ''
                ,Debug=>0
                ,sdata => {}
                ,@_ };
    $self->{UA} = LWP::UserAgent->new(
                          exists $self->{timeout}
                              ? (timeout => $self->{timeout})
                              : ()
                    );
    $self->{REQ} = HTTP::Request->new(POST => $self->{uri}); # Create a request
    bless ($self, $class);
}

sub get_data {
    my $self = shift;
    my @key = @_;

    if (!@key) {
        return $self->{sdata};
    }

    if (@key > 1 && !wantarray) {
        croak "scalar context but asked for ", 0+@key, " items";
    }

    my $r = $self->{sdata};
    my @ret;
    for my $key (@key) {
        # This sucks, but the key might be present as either a number
        # or a name (or both, there's nothing which prevents that
        # currently).
        #
        # Check first as they passed it (in case it's there both ways):

        #print "key=$key\n";
        if (exists $r->{$key}) {
            push @ret, $r->{$key};
            next;
        }

        # Then as a number:

        my $tag = field_name_to_tag $key;
        #print "tag=$tag\n";
        if (exists $r->{$tag}) {
            push @ret, $r->{$tag};
            next;
        }        

        # Then as a name:

        my $name = field_tag_to_name $key;
        #print "name=$name\n";
        if (exists $r->{$name}) {
            push @ret, $r->{$name};
            next;
        }        

        # It isn't there.

        print "undef\n";
        push @ret, undef;
    }

    return wantarray ? @ret : $ret[0];
}

sub set_data {
    my $self = shift;
    $self->{UTI} = shift;