view release on metacpan or  search on metacpan

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

    my $boundary = $top->head->multipart_boundary;
    $self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
    return $top->stringify_body;
}

sub unpackage {
    my $self = shift;
    my ($raw_input,$context) = @_;
    $self->SUPER::unpackage();

    # Parse the raw input into a MIME::Entity structure.
    #   - fail if the raw_input is not MIME formatted
    $self->initialize_parser() if !defined($self->parser);
    my $entity = eval { $self->parser->parse_data($raw_input) }
        or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";

    my $env = undef;
    # major memory bloat below! TODO - fix!
    if (lc($entity->head->mime_type) eq 'multipart/form-data') {
        $env = $self->process_form_data($entity);
    }
    elsif (lc($entity->head->mime_type) eq 'multipart/related') {
        $env = $self->process_related($entity);
    }
    elsif (lc($entity->head->mime_type) eq 'text/xml') {
        # I don't think this ever gets called.
        # warn "I am somewhere in the SOAP::Lite::Packager::MIME code I didn't know I would be in!";
        $env = $entity->bodyhandle->as_string;
    }
    else {
        die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
    }

    # return the envelope
    if ($env) {
        return $env;
    }
    elsif ($entity->bodyhandle->as_string) {
        return $entity->bodyhandle->as_string;
    }
    else {
        die "No content in MIME message\n";
    }
}

sub process_form_data {
    my ($self, $entity) = @_;
    my $env = undef;
    foreach my $part ($entity->parts()) {
        my $name = $part->head()->mime_attr('content-disposition.name');
        $name eq 'payload' ?
        $env = $part->bodyhandle()->as_string()
            : $self->push_part($part);
    }
    return $env;
}

sub process_related {
    my $self = shift;
    my ($entity) = @_;
    die "Multipart MIME messages MUST declare Multipart/Related content-type"
        if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
    # As it turns out, the Content-ID and start parameters are optional
    # according to the MIME and SOAP specs. In the event that the head cannot
    # be found, the head/root entity is used as a starting point.
    my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
    if (!defined($start) || $start eq "") {
        $start = $self->generate_random_string(10);
        $entity->parts(0)->head->add('content-id',$start);
    }
    my $location = $entity->head->mime_attr('content-location')
        || 'thismessage:/';
    my $env;
    foreach my $part ($entity->parts) {
        next if !UNIVERSAL::isa($part => "MIME::Entity");

        # Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
        # expected. Work around is to eliminate the INDEX.
        my $pid = get_multipart_id($part->head->mime_attr('content-id'));

        # If Content-ID is not supplied, then generate a random one (HACK - because
        # MIME::Entity does not do this as it should... content-id is required
        # according to MIME specification)
        $pid = $self->generate_random_string(10) if $pid eq '';
        my $type = $part->head->mime_type;

        # If a Content-Location header cannot be found, this will look for an
        # alternative in the following MIME Header attributes
        my $plocation = $part->head->get('content-location')
            || $part->head->mime_attr('Content-Disposition.filename')
            || $part->head->mime_attr('Content-Type.name');
        if ($start && $pid eq $start) {
            $env = $part->bodyhandle->as_string;
        }
        else {
            $self->push_part($part) if (defined($part->bodyhandle));
        }
    }

    return $env;
}

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

package SOAP::Lite::Packager::DIME;

use strict;
use vars qw(@ISA);
@ISA = qw(SOAP::Lite::Packager);

sub BEGIN {
    no strict 'refs';
    for my $method ( qw(foo) ) {
        my $field = '_' . $method;
        *$method = sub {
            my $self = shift;
            if (@_) { $self->{$field} = shift; return $self }
            return $self->{$field};
        }
    }
}

sub new {
    my ($classname) = @_;
    my $self = SOAP::Lite::Packager::new(@_);
    bless $self, $classname;