1# ======================================================================
2#
3# Copyright (C) 2000-2004 Paul Kulchenko (paulclinger@yahoo.com)
4# SOAP::Lite is free software; you can redistribute it
5# and/or modify it under the same terms as Perl itself.
6#
7# $Id: Packager.pm 180 2008-02-25 20:11:28Z kutterma $
8#
9# ======================================================================
10
11package SOAP::Lite::Packager;
12
13use strict;
14use vars;
15
16use vars qw($SUPPORTED_TYPES);
17$SUPPORTED_TYPES = { };
18
19sub BEGIN {
20    no strict 'refs';
21    for my $method ( qw(parser headers_http persist_parts) ) {
22        my $field = '_' . $method;
23        *$method = sub {
24            my $self = shift;
25            if (@_) {
26                $self->{$field} = shift;
27                return $self
28            }
29            return $self->{$field};
30        }
31    }
32}
33
34sub new {
35    my($class)  = shift;
36    my(%params) = @_;
37    bless {
38        "_parts"         => [ ],
39        "_parser"        => undef,
40        "_persist_parts" => 0,
41    }, $class;
42}
43
44sub is_supported_part {
45    my $self = shift;
46    return $SUPPORTED_TYPES->{ref $_[0]};
47}
48
49sub parts {
50    my $self = shift;
51    if (@_) {
52        $self->{'_parts'} = shift;
53    }
54    return $self->{'_parts'};
55}
56
57# This is a static method that helps find the right Packager
58sub find_packager {
59    # TODO - Input:
60    #        * the mimetype of the data to be decoded raw data that needs
61    #        * the data to be decoded
62    #        Returns:
63    #        * the proper SOAP::Lite::Packager instance
64}
65
66sub push_part {
67    my $self = shift;
68    my ($part) = @_;
69    push @{$self->{'_parts'}}, $part;
70}
71
72sub package {
73    # do nothing
74    die "SOAP::Lite::Packager::package() must be implemented";
75}
76
77sub unpackage {
78    my $self = shift;
79    $self->{'_parts'} = [] if !$self->persist_parts; # experimental
80}
81
82# ======================================================================
83
84package SOAP::Lite::Packager::MIME;
85
86use strict;
87use vars qw(@ISA);
88@ISA = qw(SOAP::Lite::Packager);
89
90sub BEGIN {
91    no strict 'refs';
92    for my $method ( qw(transfer_encoding env_id env_location) ) {
93        my $field = '_' . $method;
94        *$method = sub {
95            my $self = shift;
96            if (@_) {
97                $self->{$field} = shift;
98                return $self
99            }
100            return $self->{$field};
101        }
102    }
103}
104
105sub new {
106    my ($classname) = @_;
107    my $self = SOAP::Lite::Packager::new(@_);
108    $self->{'_content_encoding'} = '8bit';
109    $self->{'_env_id'}           = '<main_envelope>';
110    $self->{'_env_location'}     = '/main_envelope';
111    bless $self, $classname;
112    $SOAP::Lite::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
113    return $self;
114}
115
116sub initialize_parser {
117    my $self = shift;
118    eval "require MIME::Parser;";
119    die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
120    $self->{'_parser'} = MIME::Parser->new;
121    $self->{'_parser'}->output_to_core('ALL');
122    $self->{'_parser'}->tmp_to_core(1);
123    $self->{'_parser'}->ignore_errors(1);
124}
125
126sub generate_random_string {
127    my ($self,$len) = @_;
128    my @chars=('a'..'z','A'..'Z','0'..'9','_');
129    my $random_string;
130    foreach (1..$len) {
131        $random_string .= $chars[rand @chars];
132    }
133    return $random_string;
134}
135
136sub get_multipart_id {
137    my ($id) = shift;
138    ($id || '') =~ /^<?([^>]+)>?$/; $1 || '';
139}
140
141sub package {
142    my $self = shift;
143    my ($envelope,$context) = @_;
144    return $envelope if (!$self->parts); # if there are no parts,
145                                        # then there is nothing to do
146    require MIME::Entity;
147    local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
148    my $top = MIME::Entity->build('Type'     => "Multipart/Related");
149    my $soapversion = defined($context) ? $context->soapversion : '1.1';
150    $top->attach('Type'                      => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
151                 'Content-Transfer-Encoding' => $self->transfer_encoding(),
152                 'Content-Location'          => $self->env_location(),
153                 'Content-ID'                => $self->env_id(),
154                 'Data'                      => $envelope );
155    # consume the attachments that come in as input by 'shift'ing
156    no strict 'refs';
157    while (my $part = shift(@{$self->parts})) {
158        $top->add_part($part);
159    }
160    # determine MIME boundary
161    my $boundary = $top->head->multipart_boundary;
162    $self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start="<main_envelope>"; boundary="'.$boundary.'"'});
163    return $top->stringify_body;
164}
165
166sub unpackage {
167    my $self = shift;
168    my ($raw_input,$context) = @_;
169    $self->SUPER::unpackage();
170
171    # Parse the raw input into a MIME::Entity structure.
172    #   - fail if the raw_input is not MIME formatted
173    $self->initialize_parser() if !defined($self->parser);
174    my $entity = eval { $self->parser->parse_data($raw_input) }
175        or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
176
177    my $env = undef;
178    # major memory bloat below! TODO - fix!
179    if (lc($entity->head->mime_type) eq 'multipart/form-data') {
180        $env = $self->process_form_data($entity);
181    }
182    elsif (lc($entity->head->mime_type) eq 'multipart/related') {
183        $env = $self->process_related($entity);
184    }
185    elsif (lc($entity->head->mime_type) eq 'text/xml') {
186        # I don't think this ever gets called.
187        # warn "I am somewhere in the SOAP::Lite::Packager::MIME code I didn't know I would be in!";
188        $env = $entity->bodyhandle->as_string;
189    }
190    else {
191        die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
192    }
193
194    # return the envelope
195    if ($env) {
196        return $env;
197    }
198    elsif ($entity->bodyhandle->as_string) {
199        return $entity->bodyhandle->as_string;
200    }
201    else {
202        die "No content in MIME message\n";
203    }
204}
205
206sub process_form_data {
207    my ($self, $entity) = @_;
208    my $env = undef;
209    foreach my $part ($entity->parts()) {
210        my $name = $part->head()->mime_attr('content-disposition.name');
211        $name eq 'payload' ?
212        $env = $part->bodyhandle()->as_string()
213            : $self->push_part($part);
214    }
215    return $env;
216}
217
218sub process_related {
219    my $self = shift;
220    my ($entity) = @_;
221    die "Multipart MIME messages MUST declare Multipart/Related content-type"
222        if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
223    # As it turns out, the Content-ID and start parameters are optional
224    # according to the MIME and SOAP specs. In the event that the head cannot
225    # be found, the head/root entity is used as a starting point.
226    my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
227    if (!defined($start) || $start eq "") {
228        $start = $self->generate_random_string(10);
229        $entity->parts(0)->head->add('content-id',$start);
230    }
231    my $location = $entity->head->mime_attr('content-location')
232        || 'thismessage:/';
233    my $env;
234    foreach my $part ($entity->parts) {
235        next if !UNIVERSAL::isa($part => "MIME::Entity");
236
237        # Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
238        # expected. Work around is to eliminate the INDEX.
239        my $pid = get_multipart_id($part->head->mime_attr('content-id'));
240
241        # If Content-ID is not supplied, then generate a random one (HACK - because
242        # MIME::Entity does not do this as it should... content-id is required
243        # according to MIME specification)
244        $pid = $self->generate_random_string(10) if $pid eq '';
245        my $type = $part->head->mime_type;
246
247        # If a Content-Location header cannot be found, this will look for an
248        # alternative in the following MIME Header attributes
249        my $plocation = $part->head->get('content-location')
250            || $part->head->mime_attr('Content-Disposition.filename')
251            || $part->head->mime_attr('Content-Type.name');
252        if ($start && $pid eq $start) {
253            $env = $part->bodyhandle->as_string;
254        }
255        else {
256            $self->push_part($part) if (defined($part->bodyhandle));
257        }
258    }
259
260    return $env;
261}
262
263# ======================================================================
264
265package SOAP::Lite::Packager::DIME;
266
267use strict;
268use vars qw(@ISA);
269@ISA = qw(SOAP::Lite::Packager);
270
271sub BEGIN {
272    no strict 'refs';
273    for my $method ( qw(foo) ) {
274        my $field = '_' . $method;
275        *$method = sub {
276            my $self = shift;
277            if (@_) { $self->{$field} = shift; return $self }
278            return $self->{$field};
279        }
280    }
281}
282
283sub new {
284    my ($classname) = @_;
285    my $self = SOAP::Lite::Packager::new(@_);
286    bless $self, $classname;
287    $SOAP::Lite::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
288    return $self;
289}
290
291sub initialize_parser {
292    my $self = shift;
293    print STDERR "Initializing parser\n";
294    eval "require DIME::Parser;";
295    die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
296    $self->{'_parser'} = DIME::Parser->new;
297}
298
299sub package {
300   my $self = shift;
301   my ($envelope,$context) = @_;
302   return $envelope if (!$self->parts); # if there are no parts,
303                                        # then there is nothing to do
304   require DIME::Message;
305   require DIME::Payload;
306   my $message = DIME::Message->new;
307   my $top = DIME::Payload->new;
308   my $soapversion = defined($context) ? $context->soapversion : '1.1';
309   $top->attach('MIMEType' => $soapversion == 1.1 ?
310                  "http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
311                'Data'     => $envelope );
312   $message->add_payload($top);
313   # consume the attachments that come in as input by 'shift'ing
314   no strict 'refs';
315   while (my $part = shift(@{$self->parts})) {
316      die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
317        if (!$part->isa('DIME::Payload'));
318#      print STDERR "Adding payload to DIME message: ".ref($part)."\n";
319      $message->add_payload($part);
320#      print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
321   }
322   $self->headers_http({ 'Content-Type' => 'application/dime' });
323   return $message->print_data;
324}
325
326sub unpackage {
327    my $self = shift;
328    my ($raw_input,$context) = @_;
329    $self->SUPER::unpackage();
330
331    # Parse the raw input into a DIME::Message structure.
332    #   - fail if the raw_input is not DIME formatted
333    print STDERR "raw_data: $raw_input\n";
334    $self->initialize_parser() if !defined($self->parser);
335    my $message = eval { $self->parser->parse_data(\$raw_input) }
336        or die "Something wrong with DIME message: @{[$@]}\n";
337
338    # The first payload is always the SOAP Message
339    # TODO - Error check
340    my @payloads = @{$message->{'_PAYLOADS'}};
341    my $env = shift(@payloads);
342    my $env_str = $env->print_content_data;
343    print STDERR "Received this envelope: ".$env_str."\n";
344    while (my $p = shift(@payloads)) {
345        print STDERR "Adding part to Packager\n";
346        $self->push_part($p);
347    }
348    return $env_str;
349}
350
3511;
352__END__
353
354=pod
355
356=head1 NAME
357
358SOAP::Lite::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME.
359
360=head1 DESCRIPTION
361
362The SOAP::Lite::Packager class is responsible for managing a set of "parts." Parts are
363additional pieces of information, additional documents, or virtually anything that
364needs to be associated with the SOAP Envelope/payload. The packager then will take
365these parts and encode/decode or "package"/"unpackage" them as they come and go
366over the wire.
367
368=head1 METHODS
369
370=over
371
372=item new
373
374Instantiates a new instance of a SOAP::Lite::Packager.
375
376=item parts
377
378Contains an array of parts. The contents of this array and their types are completely
379dependant upon the Packager being used. For example, when using MIME, the content
380of this array is MIME::Entity's.
381
382=item push_part
383
384Adds a part to set of parts managed by the current instance of SOAP::Lite::Packager.
385
386=item parser
387
388Returns the parser used to parse attachments out of a data stream.
389
390=item headers_http
391
392This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify
393HTTP headers in a request/response. For example, most packaging layers will need to
394override the Content-Type (e.g. multipart/related, or application/dime).
395
396=back
397
398=head1 ABSTRACT METHODS
399
400If you wish to implement your own SOAP::Lite::Packager, then the methods below must be
401implemented by you according to the prescribed input and output requirements.
402
403=over
404
405=item package()
406
407The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form.
408This will serve as the content of the root part. The packager then encapsulates the
409envelope with the parts contained within C<parts> and returns the properly
410encapsulated envelope in string/SCALAR form.
411
412=item unpackage()
413
414The C<unpackage> subroutines takes as input raw data that needs to be parsed into
415a set of parts. It is responsible for extracting the envelope from the input, and
416populating C<parts> with an ARRAY of parts extracted from the input. It then returns
417the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it.
418
419=back
420
421=head1 SUPPORTED PACKAGING FORMATS
422
423=head2 SOAP::Lite::Packager::MIME
424
425C<SOAP::Lite::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send
426and receive Multipart/Related and Multipart/Form-Data formatted requests and
427responses.
428
429=head3 MIME METHODS
430
431The following methods are used when composing a MIME formatted message.
432
433=over
434
435=item transfer_encoding
436
437The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit.
438
439=item env_id
440
441The value of the root part's Content-Id MIME Header. Default is: <main_envelope>.
442
443=item env_location
444
445The value of the root part's Content-Location MIME Header. Default is: /main_envelope.
446
447=item env_type
448
449The value of the root part's Content-Type MIME Header. Default is: text/xml.
450
451=back
452
453=head3 OPTIMIZING THE MIME PARSER
454
455The use of attachments can often result in a heavy drain on system resources depending
456upon how your MIME parser is configured. For example, you can instruct the parser to
457store attachments in memory, or to use temp files. Using one of the other can affect
458performance, disk utilization, and/or reliability. Therefore you should consult the
459following URL for optimization techniques and trade-offs:
460
461http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER
462
463To modify the parser's configuration options consult the following code sample,
464which incidentally shows how to minimize memory utilization:
465
466  my $packager = SOAP::Lite::Packager::MIME->new;
467  # $packager->parser->decode_headers(1); # no difference
468  # $packager->parser->extract_nested_messages(1); # no difference
469  $packager->parser->output_to_core(0); # much less memory
470  $packager->parser->tmp_to_core(0); # much less memory
471  $packager->parser->tmp_recycling(0); # promotes faster garbage collection
472  $packager->parser->use_inner_files(1); # no difference
473  my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager);
474  $client->someMethod();
475
476=head3 CLIENT SIDE EXAMPLE
477
478The following code sample shows how to use attachments within the context of a
479SOAP::Lite client.
480
481  #!/usr/bin/perl
482  use SOAP::Lite;
483  use MIME::Entity;
484  my $ent = build MIME::Entity
485    Type        => "text/plain",
486    Path        => "attachment.txt",
487    Filename    => "attachment.txt",
488    Disposition => "attachment";
489  $NS = "urn:Majordojo:TemperatureService";
490  $HOST = "http://localhost/cgi-bin/soaplite.cgi";
491  my $client = SOAP::Lite
492    ->packager(SOAP::Lite::Packager::MIME->new)
493    ->parts([ $ent ])
494    ->uri($NS)
495    ->proxy($HOST);
496  $response = $client->c2f(SOAP::Data->name("temperature" => '100'));
497  print $response->valueof('//c2fResponse/foo');
498
499=head3 SERVER SIDE EXAMPLE
500
501The following code shows how to use attachments within the context of a CGI
502script. It shows how to read incoming attachments, and to return attachments to
503the client.
504
505  #!/usr/bin/perl -w
506  use SOAP::Transport::HTTP;
507  use MIME::Entity;
508  SOAP::Transport::HTTP::CGI
509    ->packager(SOAP::Lite::Packager::MIME->new)
510    ->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'})
511    ->handle;
512
513  BEGIN {
514    package TemperatureService;
515    use vars qw(@ISA);
516    @ISA = qw(Exporter SOAP::Server::Parameters);
517    use SOAP::Lite;
518    sub c2f {
519      my $self = shift;
520      my $envelope = pop;
521      my $temp = $envelope->dataof("//c2f/temperature");
522      use MIME::Entity;
523      my $ent = build MIME::Entity
524        Type        => "text/plain",
525        Path        => "printenv",
526        Filename    => "printenv",
527        Disposition => "attachment";
528      # read attachments
529      foreach my $part (@{$envelope->parts}) {
530        print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n";
531        print STDERR "soaplite.cgi: contents => ".$part->stringify."\n";
532      }
533      # send attachments
534      return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)),
535        $ent;
536    }
537  }
538
539=head2 SOAP::Lite::Packager::DIME
540
541TODO
542
543=head1 SEE ALSO
544
545L<MIME::Tools>, L<DIME::Tools>
546
547=head1 COPYRIGHT
548
549Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved.
550
551This library is free software; you can redistribute it and/or modify
552it under the same terms as Perl itself.
553
554=head1 AUTHORS
555
556Byrne Reese
557
558Martin Kutter E<lt>martin.kutter fen-net.deE<gt>
559
560=cut
561