SOAP::Header results from the CPAN

SOAP::Header

SOAP-Lite

view release on metacpan or search on metacpan

    return $self->{_prefix} unless @_;
    $self->{_prefix} = shift;
    if (scalar @_) {
        return $self->value(@_);
    }
    return $self;
}

sub uri {
    my $self = ref $_[0]
        ? shift
        : UNIVERSAL::isa($_[0] => __PACKAGE__)
            ? shift->new()
            : __PACKAGE__->new();
    return $self->{_uri} unless @_;
    my $uri = $self->{_uri} = shift;
    warn "Usage of '::' in URI ($uri) deprecated. Use '/' instead\n"
        if defined $uri && $^W && $uri =~ /::/;
    if (scalar @_) {
         return $self->value(@_);
    }
    return $self;
}

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

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

sub signature {
    my $self = UNIVERSAL::isa($_[0] => __PACKAGE__)
        ? shift->new()
        : __PACKAGE__->new();
    (@_)
        ? ($self->{_signature} = shift, return $self)
        : (return $self->{_signature});
}

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

package SOAP::Header;

use vars qw(@ISA);
@ISA = qw(SOAP::Data);

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

package SOAP::Serializer;
use SOAP::Lite::Utils;
use Carp ();
use vars qw(@ISA);

@ISA = qw(SOAP::Cloneable SOAP::XMLSchema::Serializer);

BEGIN {
    # namespaces and anonymous data structures
    my $ns   = 0;
    my $name = 0;
    my $prefix = 'c-';
    sub gen_ns { 'namesp' . ++$ns }
    sub gen_name { join '', $prefix, 'gensym', ++$name }
    sub prefix { $prefix =~ s/^[^\-]+-/$_[1]-/; $_[0]; }
}

sub BEGIN {
    no strict 'refs';

    __PACKAGE__->__mk_accessors(qw(readable level seen autotype attr maptype
        namespaces multirefinplace encoding signature on_nonserialized context
        ns_uri ns_prefix use_default_ns));

    for my $method (qw(method fault freeform)) { # aliases for envelope
        *$method = sub { shift->envelope($method => @_) }
    }

    # Is this necessary? Seems like work for nothing when a user could just use
    # SOAP::Utils directly.
    # for my $method (qw(qualify overqualify disqualify)) { # import from SOAP::Utils
    #   *$method = \&{'SOAP::Utils::'.$method};
    # }
}

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

sub new {
    my $self = shift;
    return $self if ref $self;

    my $class = $self;
    $self = bless {
        _level => 0,
        _autotype => 1,
        _readable => 0,
        _ns_uri => '',
        _ns_prefix => '',
        _use_default_ns => 1,
        _multirefinplace => 0,
        _seen => {},
        _encoding => 'UTF-8',
        _objectstack => {},
        _signature => [],

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

}

sub uriformethod {
    my $self = shift;

    my $method_is_data = ref $_[0] && UNIVERSAL::isa($_[0] => 'SOAP::Data');

    # drop prefix from method that could be string or SOAP::Data object
    my($prefix, $method) = $method_is_data
        ? ($_[0]->prefix, $_[0]->name)
        : SOAP::Utils::splitqname($_[0]);

    my $attr = {reverse %{$self->namespaces}};
    # try to define namespace that could be stored as
    #   a) method is SOAP::Data
    #        ? attribute in method's element as xmlns= or xmlns:${prefix}=
    #        : uri
    #   b) attribute in Envelope element as xmlns= or xmlns:${prefix}=
    #   c) no prefix or prefix equal serializer->envprefix
    #        ? '', but see comment below
    #        : die with error message
    my $uri = $method_is_data
        ? ref $_[0]->attr && ($_[0]->attr->{$prefix ? "xmlns:$prefix" : 'xmlns'} || $_[0]->uri)
        : $self->uri;

    defined $uri or $uri = $attr->{$prefix || ''};

    defined $uri or $uri = !$prefix || $prefix eq $self->envprefix
    # still in doubts what should namespace be in this case
    # but will keep it like this for now and be compatible with our server
        ? ( $method_is_data
            && $^W
            && warn("URI is not provided as an attribute for method ($method)\n"),
            ''
            )
        : die "Can't find namespace for method ($prefix:$method)\n";

    return ($uri, $method);
}

sub serialize { SOAP::Trace::trace('()');
    my $self = shift->new;
    @_ == 1 or Carp::croak "serialize() method accepts one parameter";

    $self->seen({}); # reinitialize multiref table
    my($encoded) = $self->encode_object($_[0]);

    # now encode multirefs if any
    #                 v -------------- subelements of Envelope
    push(@{$encoded->[2]}, $self->encode_multirefs) if ref $encoded->[2];
    return $self->xmlize($encoded);
}

sub envelope {
    SOAP::Trace::trace('()');
    my $self = shift->new;
    my $type = shift;
    my(@parameters, @header);
    for (@_) {
        # Find all the SOAP Headers
        if (defined($_) && ref($_) && UNIVERSAL::isa($_ => 'SOAP::Header')) {
            push(@header, $_);
        }
        # Find all the SOAP Message Parts (attachments)
        elsif (defined($_) && ref($_) && $self->context
            && $self->context->packager->is_supported_part($_)
        ) {
            $self->context->packager->push_part($_);
        }
        # Find all the SOAP Body elements
        else {
            # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
            push(@parameters, $_);
            # push (@parameters, SOAP::Utils::encode_data($_));
        }
    }
    my $header = @header ? SOAP::Data->set_value(@header) : undef;
    my($body,$parameters);
    if ($type eq 'method' || $type eq 'response') {
        SOAP::Trace::method(@parameters);

        my $method = shift(@parameters);
        #  or die "Unspecified method for SOAP call\n";

        $parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
        if (!defined($method)) {}
        elsif (UNIVERSAL::isa($method => 'SOAP::Data')) {
            $body = $method;
        }
        elsif ($self->use_default_ns) {
            if ($self->{'_ns_uri'}) {
                $body = SOAP::Data->name($method)
                    ->attr({'xmlns' => $self->{'_ns_uri'} } );
            }
            else {
                $body = SOAP::Data->name($method);
            }
        }
        else {
            # Commented out by Byrne on 1/4/2006 - to address default namespace problems
            #      $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'});
            #      $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'});

            # Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new
            # namespace
            # Begin New Code (replaces code commented out above)
            $body = SOAP::Data->name($method);
            my $pre = $self->find_prefix($self->{'_ns_uri'});
            $body = $body->prefix($pre) if ($self->{'_ns_prefix'});
            # End new code
        }

        # This is breaking a unit test right now...
        # proposed resolution for [ 1700326 ] encode_data called incorrectly in envelope
        #    $body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ()))
        #      if $body;
        # must call encode_data on nothing to enforce xsi:nil="true" to be set.
        $body->set_value($parameters ? \$parameters : SOAP::Utils::encode_data()) if $body;
    }
    elsif ($type eq 'fault') {
        SOAP::Trace::fault(@parameters);

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

            my $self = shift;
            ref $self or return $results{$method};
            Carp::croak "Method '$method' is readonly and doesn't accept any parameters" if @_;
            defined $self->fault ? return : return $self->valueof($results{$method});
        };
    }

    for my $method (qw(o_child o_value o_lname o_lattr o_qname)) { # import from SOAP::Utils
        *$method = \&{'SOAP::Utils::'.$method};
    }

    __PACKAGE__->__mk_accessors('context');

}

# use object in boolean context return true/false on last match
# Ex.: $som->match('//Fault') ? 'SOAP call failed' : 'success';
use overload fallback => 1, 'bool'  => sub { @{shift->{_current}} > 0 };

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

sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    my $content = shift;
    SOAP::Trace::objects('()');
    return bless { _content => $content, _current => [$content] } => $class;
}

sub parts {
    my $self = shift;
    if (@_) {
        $self->context->packager->parts(@_);
        return $self;
    }
    else {
        return $self->context->packager->parts;
    }
}

sub is_multipart {
    my $self = shift;
    return defined($self->parts);
}

sub current {
    my $self = shift;
    $self->{_current} = [@_], return $self if @_;
    return wantarray ? @{$self->{_current}} : $self->{_current}->[0];
}

sub valueof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {o_value($_)} @{$self->{_current}}
        : @{$self->{_current}} ? o_value($self->{_current}->[0]) : undef;
}

sub headerof { # SOAP::Header is the same as SOAP::Data, so just rebless it
    wantarray
        ? map { bless $_ => 'SOAP::Header' } shift->dataof(@_)
        : do { # header returned by ->dataof can be undef in scalar context
            my $header = shift->dataof(@_);
            ref $header ? bless($header => 'SOAP::Header') : undef;
        };
}

sub dataof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {$self->_as_data($_)} @{$self->{_current}}
        : @{$self->{_current}}
            ? $self->_as_data($self->{_current}->[0])
            : undef;
}

sub namespaceuriof {
    my $self = shift;
    local $self->{_current} = $self->{_current};
    $self->match(shift) if @_;
    return wantarray
        ? map {(SOAP::Utils::splitlongname(o_lname($_)))[0]} @{$self->{_current}}
        : @{$self->{_current}} ? (SOAP::Utils::splitlongname(o_lname($self->{_current}->[0])))[0] : undef;
}

#sub _as_data {
#    my $self = shift;
#    my $pointer = shift;
#
#    SOAP::Data
#        -> new(prefix => '', name => o_qname($pointer), name => o_lname($pointer), attr => o_lattr($pointer))
#        -> set_value(o_value($pointer));
#}

sub _as_data {
    my $self = shift;
    my $node = shift;

    my $data = SOAP::Data->new( prefix => '',
        # name => o_qname has side effect: sets namespace !
        name => o_qname($node),
        name => o_lname($node),
        attr => o_lattr($node) );

    if ( defined o_child($node) ) {
        my @children;
        foreach my $child ( @{ o_child($node) } ) {
            push( @children, $self->_as_data($child) );
        }
        $data->set_value( \SOAP::Data->value(@children) );
    }
    else {
        $data->set_value( o_value($node) );
    }

    return $data;
}


sub match {
    my $self = shift;
    my $path = shift;

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

    # is it problem?

    my $result = eval {
        local $SIG{__DIE__};
        # why is this here:
        $self->serializer->soapversion(1.1);
        my $request = eval { $self->deserializer->deserialize($_[0]) };

        die SOAP::Fault
            ->faultcode($SOAP::Constants::FAULT_VERSION_MISMATCH)
            ->faultstring($@)
                if $@ && $@ =~ /^$SOAP::Constants::WRONG_VERSION/;

        die "Application failed during request deserialization: $@" if $@;
        my $som = ref $request;
        die "Can't find root element in the message"
            unless $request->match($som->envelope);
        $self->serializer->soapversion(SOAP::Lite->soapversion);
        $self->serializer->xmlschema($SOAP::Constants::DEFAULT_XML_SCHEMA
            = $self->deserializer->xmlschema)
                if $self->deserializer->xmlschema;

        die SOAP::Fault
            ->faultcode($SOAP::Constants::FAULT_MUST_UNDERSTAND)
            ->faultstring("Unrecognized header has mustUnderstand attribute set to 'true'")
            if !$SOAP::Constants::DO_NOT_CHECK_MUSTUNDERSTAND &&
                grep {
                    $_->mustUnderstand
                    && (!$_->actor || $_->actor eq $SOAP::Constants::NEXT_ACTOR)
                } $request->dataof($som->headers);

        die "Can't find method element in the message"
            unless $request->match($som->method);
        # TODO - SOAP::Dispatcher plugs in here
        # my $handler = $self->dispatcher->find_handler($request);
        my($class, $method_uri, $method_name) = $self->find_target($request);
        my @results = eval {
            local $^W;
            my @parameters = $request->paramsin;

            # SOAP::Trace::dispatch($fullname);
            SOAP::Trace::parameters(@parameters);

            push @parameters, $request
                if UNIVERSAL::isa($class => 'SOAP::Server::Parameters');

            no strict qw(refs);
            SOAP::Server::Object->references(
                defined $parameters[0]
                && ref $parameters[0]
                && UNIVERSAL::isa($parameters[0] => $class)
                    ? do {
                        my $object = shift @parameters;
                        SOAP::Server::Object->object(ref $class
                            ? $class
                            : $object
                        )->$method_name(SOAP::Server::Object->objects(@parameters)),

                        # send object back as a header
                        # preserve name, specify URI
                        SOAP::Header
                            ->uri($SOAP::Constants::NS_SL_HEADER => $object)
                            ->name($request->dataof($som->method.'/[1]')->name)
                    } # end do block

                    # SOAP::Dispatcher will plug-in here as well
                    # $handler->dispatch(SOAP::Server::Object->objects(@parameters)
                    : $class->$method_name(SOAP::Server::Object->objects(@parameters)) );
        }; # end eval block
        SOAP::Trace::result(@results);

        # let application errors pass through with 'Server' code
        die ref $@
            ? $@
            : $@ =~ /^Can\'t locate object method "$method_name"/
                ? "Failed to locate method ($method_name) in class ($class)"
                : SOAP::Fault->faultcode($SOAP::Constants::FAULT_SERVER)->faultstring($@)
                    if $@;

        my $result = $self->serializer
            ->prefix('s') # distinguish generated element names between client and server
            ->uri($method_uri)
            ->envelope(response => $method_name . 'Response', @results);
        return $result;
    };

    # void context
    return unless defined wantarray;

    # normal result
    return $result unless $@;

    # check fails, something wrong with message
    return $self->make_fault($SOAP::Constants::FAULT_CLIENT, $@) unless ref $@;

    # died with SOAP::Fault
    return $self->make_fault($@->faultcode   || $SOAP::Constants::FAULT_SERVER,
        $@->faultstring || 'Application error',
        $@->faultdetail, $@->faultactor)
    if UNIVERSAL::isa($@ => 'SOAP::Fault');

    # died with complex detail
    return $self->make_fault($SOAP::Constants::FAULT_SERVER, 'Application error' => $@);

} # end of handle()

sub make_fault {
    my $self = shift;
    my($code, $string, $detail, $actor) = @_;
    $self->serializer->fault($code, $string, $detail, $actor || $self->myuri);
}

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

package SOAP::Trace;

use Carp ();

my @list = qw(
    transport   dispatch    result
    parameters  headers     objects

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

                my $param = $signatures{$signature};
                my($value) = $_->value; # take first value

                # fillup parameters
                if ( reftype( $_[$param] ) ) {
                    if ( reftype( $_[$param] ) eq 'SCALAR' ) {
                        ${ $_[$param] } = $$value;
                    }
                    elsif ( reftype( $_[$param] ) eq 'ARRAY' ) {
                        @{ $_[$param] } = @$value;
                    }
                    elsif ( reftype( $_[$param] ) eq 'HASH' ) {
                        if ( eval { $_[$param]->isa('SOAP::Data') } ) {
                            $_[$param]->SOAP::Data::value($value);
                        }
                        elsif ( reftype($value) eq 'REF' ) {
                            %{ $_[$param] } = %$$value;
                        }
                        else { %{ $_[$param] } = %$value; }
                    }
                    else { $_[$param] = $value; }
                }
                else {
                    $_[$param] = $value;
                }
            }
        }
    }
    return $result;
} # end of call()

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

package SOAP::Lite::COM;

require SOAP::Lite;

sub required {
  foreach (qw(
    URI::_foreign URI::http URI::https
    LWP::Protocol::http LWP::Protocol::https LWP::Authen::Basic LWP::Authen::Digest
    HTTP::Daemon Compress::Zlib SOAP::Transport::HTTP
    XMLRPC::Lite XMLRPC::Transport::HTTP
  )) {
    eval join ';', 'local $SIG{__DIE__}', "require $_";
  }
}

sub new    { required; SOAP::Lite->new(@_) }

sub create; *create = \&new; # make alias. Somewhere 'new' is registered keyword

sub soap; *soap = \&new;     # also alias. Just to be consistent with .xmlrpc call

sub xmlrpc { required; XMLRPC::Lite->new(@_) }

sub server { required; shift->new(@_) }

sub data   { SOAP::Data->new(@_) }

sub header { SOAP::Header->new(@_) }

sub hash   { +{@_} }

sub instanceof {
  my $class = shift;
  die "Incorrect class name" unless $class =~ /^(\w[\w:]*)$/;
  eval "require $class";
  $class->new(@_);
}

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

1;

__END__

=pod

=head1 NAME

SOAP::Lite - Perl's Web Services Toolkit

=head1 DESCRIPTION

SOAP::Lite is a collection of Perl modules which provides a simple and
lightweight interface to the Simple Object Access Protocol (SOAP) both on
client and server side.

=head1 PERL VERSION WARNING

As of version SOAP::Lite version 1.05, no perl versions before 5.8 will be supported.

SOAP::Lite 0.71 will be the last version of SOAP::Lite running on perl 5.005

Future versions of SOAP::Lite will require at least perl 5.6.0

If you have not had the time to upgrade your perl, you should consider this now.

=head1 OVERVIEW OF CLASSES AND PACKAGES

=over

=item F<lib/SOAP/Lite.pm>

L<SOAP::Lite> - Main class provides all logic

L<SOAP::Transport> - Transport backend

L<SOAP::Data> - Data objects

L<SOAP::Header> - Header Data Objects

L<SOAP::Serializer> - Serializes data structures to SOAP messages

L<SOAP::Deserializer> - Deserializes SOAP messages into SOAP::SOM objects

L<SOAP::SOM> - SOAP Message objects

L<SOAP::Constants> - Provides access to common constants and defaults

L<SOAP::Trace> - Tracing facilities

L<SOAP::Schema> - Provides access and stub(s) for schema(s)

L<SOAP::Schema::WSDL|SOAP::Schema/SOAP::Schema::WSDL> - WSDL implementation for SOAP::Schema

L<SOAP::Server> - Handles requests on server side

SOAP::Server::Object - Handles objects-by-reference

L<SOAP::Fault> - Provides support for Faults on server side

L<SOAP::Utils> - A set of private and public utility subroutines

=item F<lib/SOAP/Packager.pm>

L<SOAP::Packager> - Provides an abstract class for implementing custom packagers.

L<SOAP::Packager::MIME|SOAP::Packager/SOAP::Packager::MIME> - Provides MIME support to SOAP::Lite

L<SOAP::Packager::DIME|SOAP::Packager/SOAP::Packager::DIME> - Provides DIME support to SOAP::Lite

=item F<lib/SOAP/Transport/HTTP.pm>

L<SOAP::Transport::HTTP::Client|SOAP::Transport/SOAP::Transport::HTTP::Client> - Client interface to HTTP transport

L<SOAP::Transport::HTTP::Server|SOAP::Transport/SOAP::Transport::HTTP::Server> - Server interface to HTTP transport

L<SOAP::Transport::HTTP::CGI|SOAP::Transport/SOAP::Transport::HTTP::CGI> - CGI implementation of server interface

L<SOAP::Transport::HTTP::Daemon|SOAP::Transport/SOAP::Transport::HTTP::Daemon> - Daemon implementation of server interface

L<SOAP::Transport::HTTP::Apache|SOAP::Transport/SOAP::Transport::HTTP::Apache> - mod_perl implementation of server interface

=item F<lib/SOAP/Transport/POP3.pm>

L<SOAP::Transport::POP3::Server|SOAP::Transport/SOAP::Transport::POP3::Server> - Server interface to POP3 protocol

=item F<lib/SOAP/Transport/MAILTO.pm>

L<SOAP::Transport::MAILTO::Client|SOAP::Transport/SOAP::Transport::MAILTO::Client> - Client interface to SMTP/sendmail

=item F<lib/SOAP/Transport/LOCAL.pm>

L<SOAP::Transport::LOCAL::Client|SOAP::Transport/SOAP::Transport::LOCAL::Client> - Client interface to local transport

=item F<lib/SOAP/Transport/TCP.pm>

L<SOAP::Transport::TCP::Server|SOAP::Transport/SOAP::Transport::TCP::Server> - Server interface to TCP protocol

L<SOAP::Transport::TCP::Client|SOAP::Transport/SOAP::Transport::TCP::Client> - Client interface to TCP protocol

( run in 1.586 second using v1.01-cache-2.11-cpan-39bf76dae61 )