view release on metacpan or  search on metacpan

lib/SOAP/Lite.pm  view on Meta::CPAN

sub o_qname { $_[0]->[0] }
sub o_attr  { $_[0]->[1] }
sub o_child { ref $_[0]->[2] ? $_[0]->[2] : undef }
sub o_chars { ref $_[0]->[2] ? undef : $_[0]->[2] }
            # $_[0]->[3] is not used. Serializer stores object ID there
sub o_value { $_[0]->[4] }
sub o_lname { $_[0]->[5] }
sub o_lattr { $_[0]->[6] }

sub format_datetime {
    my ($s,$m,$h,$D,$M,$Y) = (@_)[0,1,2,3,4,5];
    my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d",($Y+1900),($M+1),$D,$h,$m,$s);
    return $time;
}

# make bytelength that calculates length in bytes regardless of utf/byte settings
# either we can do 'use bytes' or length will count bytes already
BEGIN {
    sub bytelength;
    *bytelength = eval('use bytes; 1') # 5.6.0 and later?
        ? sub { use bytes; length(@_ ? $_[0] : $_) }
        : sub { length(@_ ? $_[0] : $_) };
}

# ======================================================================

package SOAP::Cloneable;

sub clone {
    my $self = shift;

    return unless ref $self && UNIVERSAL::isa($self => __PACKAGE__);

    my $clone = bless {} => ref($self) || $self;
    for (keys %$self) {
        my $value = $self->{$_};
        $clone->{$_} = ref $value && UNIVERSAL::isa($value => __PACKAGE__) ? $value->clone : $value;
    }
    return $clone;
}

# ======================================================================

package SOAP::Transport;

use vars qw($AUTOLOAD @ISA);
@ISA = qw(SOAP::Cloneable);

use Class::Inspector;


sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;
    return $self if ref $self;
    my $class = ref($self) || $self;

    SOAP::Trace::objects('()');
    return bless {} => $class;
}

sub proxy {
    my $self = shift;
    $self = $self->new() if not ref $self;

    my $class = ref $self;

    return $self->{_proxy} unless @_;

    $_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
    my $protocol = uc "$1"; # untainted now

    # HTTPS is handled by HTTP class
    $protocol =~s/^HTTPS$/HTTP/;

    (my $protocol_class = "${class}::$protocol") =~ s/-/_/g;

    no strict 'refs';
    unless (Class::Inspector->loaded("$protocol_class\::Client")
        && UNIVERSAL::can("$protocol_class\::Client" => 'new')
    ) {
        eval "require $protocol_class";
        die "Unsupported protocol '$protocol'\n"
            if $@ =~ m!^Can\'t locate SOAP/Transport/!;
        die if $@;
    }

    $protocol_class .= "::Client";
    return $self->{_proxy} = $protocol_class->new(endpoint => shift, @_);
}

sub AUTOLOAD {
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
    return if $method eq 'DESTROY';

    no strict 'refs';
    *$AUTOLOAD = sub { shift->proxy->$method(@_) };
    goto &$AUTOLOAD;
}

# ======================================================================

package SOAP::Fault;

use Carp ();

use overload fallback => 1, '""' => "stringify";

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = $self;
        $self = bless {} => $class;
        SOAP::Trace::objects('()');
    }

    Carp::carp "Odd (wrong?) number of parameters in new()"
        if $^W && (@_ & 1);

    no strict qw(refs);
    while (@_) {
        my $method = shift;
        $self->$method(shift)
            if $self->can($method)
    }

    return $self;
}

sub stringify {
    my $self = shift;
    return join ': ', $self->faultcode, $self->faultstring;
}

sub BEGIN {
    no strict 'refs';
    for my $method (qw(faultcode faultstring faultactor faultdetail)) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
                ? shift->new
                : __PACKAGE__->new;
            if (@_) {
                $self->{$field} = shift;
                return $self
            }
            return $self->{$field};
        }
    }
    *detail = \&faultdetail;
}

# ======================================================================

package SOAP::Data;

use vars qw(@ISA @EXPORT_OK);
use Exporter;
use Carp ();
use SOAP::Lite::Deserializer::XMLSchemaSOAP1_2;

@ISA = qw(Exporter);
@EXPORT_OK = qw(name type attr value uri);

sub DESTROY { SOAP::Trace::objects('()') }

sub new {
    my $self = shift;

    unless (ref $self) {
        my $class = $self;
        $self = bless {_attr => {}, _value => [], _signature => []} => $class;
        SOAP::Trace::objects('()');
    }
    no strict qw(refs);
    Carp::carp "Odd (wrong?) number of parameters in new()" if $^W && (@_ & 1);
    while (@_) {
        my $method = shift;
        $self->$method(shift) if $self->can($method)
    }

    return $self;
}

sub name {
    my $self = ref $_[0] ? shift : UNIVERSAL::isa($_[0] => __PACKAGE__) ? shift->new : __PACKAGE__->new;
    if (@_) {
        my $name = shift;
        my ($uri, $prefix);    # predeclare, because can't declare in assign
        if ($name) {
            ($uri, $name) = SOAP::Utils::splitlongname($name);
            unless (defined $uri) {
                ($prefix, $name) = SOAP::Utils::splitqname($name);
                $self->prefix($prefix) if defined $prefix;
            } else {
                $self->uri($uri);
            }
        }
        $self->{_name} = $name;

        $self->value(@_) if @_;
        return $self;
    }
    return $self->{_name};
}

sub attr {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    if (@_) {
        $self->{_attr} = shift;
        return $self->value(@_) if @_;
        return $self
    }
    return $self->{_attr};
}

sub type {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    if (@_) {
        $self->{_type} = shift;
        $self->value(@_) if @_;
        return $self;
    }
    if (!defined $self->{_type} && (my @types = grep {/^\{$SOAP::Constants::NS_XSI_ALL}type$/o} keys %{$self->{_attr}})) {