view release on metacpan or  search on metacpan

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

}

sub new {
    my($class)  = shift;
    my(%params) = @_;
    bless {
        "_parts"         => [ ],
        "_parser"        => undef,
        "_persist_parts" => 0,
    }, $class;
}

sub is_supported_part {
  my $self = shift;
  return $SUPPORTED_TYPES->{ref $_[0]};
}

sub parts {
  my $self = shift;
  if (@_) {
    $self->{'_parts'} = shift;
  }
  return $self->{'_parts'};
}

# This is a static method that helps find the right Packager
sub find_packager {
   # TODO - Input:
   #        * the mimetype of the data to be decoded raw data that needs
   #        * the data to be decoded
   #        Returns:
   #        * the proper SOAP::Packager instance
}

sub push_part {
   my $self = shift;
   my ($part) = @_;
   push @{$self->{'_parts'}}, $part;
}

sub package {
    # do nothing
    die "SOAP::Packager::package() must be implemented";
}

sub unpackage {
   my $self = shift;
   $self->{'_parts'} = [] if !$self->persist_parts; # experimental
}

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

package SOAP::Packager::MIME;

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

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

sub new {
    my ($classname) = @_;
    my $self = SOAP::Packager::new(@_);
    $self->{'_content_encoding'} = '8bit';
    $self->{'_env_id'}           = '<main_envelope>';
    $self->{'_env_location'}     = '/main_envelope';
    bless $self, $classname;
    $SOAP::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
    return $self;
}

sub initialize_parser {
  my $self = shift;
  eval "require MIME::Parser;";
  die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
  $self->{'_parser'} = MIME::Parser->new;
  $self->{'_parser'}->output_to_core('ALL');
  $self->{'_parser'}->tmp_to_core(1);
  $self->{'_parser'}->ignore_errors(1);
  $self->{'_parser'}->extract_nested_messages(0);
}

sub generate_random_string {
  my ($self,$len) = @_;
  my @chars=('a'..'z','A'..'Z','0'..'9','_');
  my $random_string;
  foreach (1..$len) {
    $random_string .= $chars[rand @chars];
  }
  return $random_string;
}

sub get_multipart_id {
  my ($id) = shift;
  ($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
}

sub package {
   my $self = shift;
   my ($envelope,$context) = @_;
   return $envelope if (!$self->parts); # if there are no parts,
                                        # then there is nothing to do
   require MIME::Entity;
   local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
   my $top = MIME::Entity->build('Type'     => "Multipart/Related");
   my $soapversion = defined($context) ? $context->soapversion : '1.1';
   $top->attach('Type'                      => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
                'Content-Transfer-Encoding' => $self->transfer_encoding(),
                'Content-Location'          => $self->env_location(),
                'Content-ID'                => $self->env_id(),
                'Data'                      => $envelope );
   # consume the attachments that come in as input by 'shift'ing
   no strict 'refs';
   while (my $part = shift(@{$self->parts})) {
      $top->add_part($part);
   }
   # determine MIME boundary
   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::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;
}