File Coverage

blib/lib/SOAP/Packager.pm
Criterion Covered Total %
statement 70 199 35.1
branch 5 60 8.3
condition 0 19 0.0
subroutine 22 36 61.1
pod 5 7 71.4
total 102 321 31.7


line stmt bran cond sub pod time code
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             # ======================================================================
8              
9             package SOAP::Packager;
10              
11 25     25   144 use strict;
  25         55  
  25         840  
12 25     25   142 use vars;
  25         62  
  25         1563  
13              
14             our $VERSION = 1.11;
15             our $SUPPORTED_TYPES = { };
16              
17             sub BEGIN {
18 25     25   123 no strict 'refs';
  25         56  
  25         2408  
19 25     25   84 for my $method ( qw(parser headers_http persist_parts) ) {
20 75         174 my $field = '_' . $method;
21             *$method = sub {
22 2     2   3 my $self = shift;
23 2 50       7 if (@_) { $self->{$field} = shift; return $self }
  0         0  
  0         0  
24 2         12 return $self->{$field};
25             }
26 75         7623 }
27             }
28              
29             sub new {
30 18     18 1 49 my($class) = shift;
31 18         51 my(%params) = @_;
32 18         134 bless {
33             "_parts" => [ ],
34             "_parser" => undef,
35             "_persist_parts" => 0,
36             }, $class;
37             }
38              
39             sub is_supported_part {
40 1     1 0 2 my $self = shift;
41 1         6 return $SUPPORTED_TYPES->{ref $_[0]};
42             }
43              
44             sub parts {
45 25     25 1 50 my $self = shift;
46 25 50       76 if (@_) {
47 0         0 $self->{'_parts'} = shift;
48             }
49 25         339 return $self->{'_parts'};
50             }
51              
52             # This is a static method that helps find the right Packager
53 0     0 0 0 sub find_packager {
54             # TODO - Input:
55             # * the mimetype of the data to be decoded raw data that needs
56             # * the data to be decoded
57             # Returns:
58             # * the proper SOAP::Packager instance
59             }
60              
61             sub push_part {
62 0     0 1 0 my $self = shift;
63 0         0 my ($part) = @_;
64 0         0 push @{$self->{'_parts'}}, $part;
  0         0  
65             }
66              
67             sub package {
68             # do nothing
69 0     0 1 0 die "SOAP::Packager::package() must be implemented";
70             }
71              
72             sub unpackage {
73 1     1 1 2 my $self = shift;
74 1 50       8 $self->{'_parts'} = [] if !$self->persist_parts; # experimental
75             }
76              
77             # ======================================================================
78              
79             package SOAP::Packager::MIME;
80              
81 25     25   153 use strict;
  25         61  
  25         906  
82 25     25   129 use vars qw(@ISA);
  25         67  
  25         1618  
83             @ISA = qw(SOAP::Packager);
84              
85             sub BEGIN {
86 25     25   131 no strict 'refs';
  25         57  
  25         3799  
87 25     25   156 for my $method ( qw(transfer_encoding env_id env_location) ) {
88 75         188 my $field = '_' . $method;
89             *$method = sub {
90 0     0   0 my $self = shift;
91 0 0       0 if (@_) { $self->{$field} = shift; return $self }
  0         0  
  0         0  
92 0         0 return $self->{$field};
93             }
94 75         15369 }
95             }
96              
97             sub new {
98 18     18   140 my ($classname) = @_;
99 18         84 my $self = SOAP::Packager::new(@_);
100 18         159 $self->{'_content_encoding'} = '8bit';
101 18         58 $self->{'_env_id'} = '';
102 18         47 $self->{'_env_location'} = '/main_envelope';
103 18         55 bless $self, $classname;
104 18         71 $SOAP::Packager::SUPPORTED_TYPES->{"MIME::Entity"} = 1;
105 18         265 return $self;
106             }
107              
108             sub initialize_parser {
109 4     4   10 my $self = shift;
110 4         258 eval "require MIME::Parser;";
111 4 50       58 die "Could not find MIME::Parser - is MIME::Tools installed? Aborting." if $@;
112 0         0 $self->{'_parser'} = MIME::Parser->new;
113 0         0 $self->{'_parser'}->output_to_core('ALL');
114 0         0 $self->{'_parser'}->tmp_to_core(1);
115 0         0 $self->{'_parser'}->ignore_errors(1);
116 0         0 $self->{'_parser'}->extract_nested_messages(0);
117             }
118              
119             sub generate_random_string {
120 0     0   0 my ($self,$len) = @_;
121 0         0 my @chars=('a'..'z','A'..'Z','0'..'9','_');
122 0         0 my $random_string;
123 0         0 foreach (1..$len) {
124 0         0 $random_string .= $chars[rand @chars];
125             }
126 0         0 return $random_string;
127             }
128              
129             sub get_multipart_id {
130 0     0   0 my ($id) = shift;
131 0 0 0     0 ($id || '') =~ /^]+)>?$/; $1 || '';
  0         0  
132             }
133              
134             sub package {
135 0     0   0 my $self = shift;
136 0         0 my ($envelope,$context) = @_;
137 0 0       0 return $envelope if (!$self->parts); # if there are no parts,
138             # then there is nothing to do
139 0         0 require MIME::Entity;
140 0         0 local $MIME::Entity::BOUNDARY_DELIMITER = "\r\n";
141 0         0 my $top = MIME::Entity->build('Type' => "Multipart/Related");
142 0 0       0 my $soapversion = defined($context) ? $context->soapversion : '1.1';
143 0 0       0 $top->attach('Type' => $soapversion == 1.1 ? "text/xml" : "application/soap+xml",
144             'Content-Transfer-Encoding' => $self->transfer_encoding(),
145             'Content-Location' => $self->env_location(),
146             'Content-ID' => $self->env_id(),
147             'Data' => $envelope );
148             # consume the attachments that come in as input by 'shift'ing
149 25     25   265 no strict 'refs';
  25         132  
  25         27956  
150 0         0 while (my $part = shift(@{$self->parts})) {
  0         0  
151 0         0 $top->add_part($part);
152             }
153             # determine MIME boundary
154 0         0 my $boundary = $top->head->multipart_boundary;
155 0         0 $self->headers_http({ 'Content-Type' => 'Multipart/Related; type="text/xml"; start=""; boundary="'.$boundary.'"'});
156 0         0 return $top->stringify_body;
157             }
158              
159             sub unpackage {
160 1     1   2 my $self = shift;
161 1         2 my ($raw_input,$context) = @_;
162 1         10 $self->SUPER::unpackage();
163              
164             # Parse the raw input into a MIME::Entity structure.
165             # - fail if the raw_input is not MIME formatted
166 1 50       8 $self->initialize_parser() if !defined($self->parser);
167 0 0         my $entity = eval { $self->parser->parse_data($raw_input) }
  0            
168 0   0       or die "Something wrong with MIME message: @{[$@ || $self->parser->last_error]}\n";
169              
170 0           my $env = undef;
171             # major memory bloat below! TODO - fix!
172 0 0         if (lc($entity->head->mime_type) eq 'multipart/form-data') {
    0          
    0          
173 0           $env = $self->process_form_data($entity);
174             } elsif (lc($entity->head->mime_type) eq 'multipart/related') {
175 0           $env = $self->process_related($entity);
176             } elsif (lc($entity->head->mime_type) eq 'text/xml') {
177             # I don't think this ever gets called.
178             # warn "I am somewhere in the SOAP::Packager::MIME code I didn't know I would be in!";
179 0           $env = $entity->bodyhandle->as_string;
180             } else {
181 0           die "Can't handle MIME messsage with specified type (@{[$entity->head->mime_type]})\n";
  0            
182             }
183              
184             # return the envelope
185 0 0         if ($env) {
    0          
186 0           return $env;
187             } elsif ($entity->bodyhandle->as_string) {
188 0           return $entity->bodyhandle->as_string;
189             } else {
190 0           die "No content in MIME message\n";
191             }
192             }
193              
194             sub process_form_data {
195 0     0     my ($self, $entity) = @_;
196 0           my $env = undef;
197 0           foreach my $part ($entity->parts) {
198 0           my $name = $part->head->mime_attr('content-disposition.name');
199 0 0         $name eq 'payload' ?
200             $env = $part->bodyhandle->as_string
201             : $self->push_part($part);
202             }
203 0           return $env;
204             }
205              
206             sub process_related {
207 0     0     my $self = shift;
208 0           my ($entity) = @_;
209 0 0         die "Multipart MIME messages MUST declare Multipart/Related content-type"
210             if ($entity->head->mime_attr('content-type') !~ /^multipart\/related/i);
211             # As it turns out, the Content-ID and start parameters are optional
212             # according to the MIME and SOAP specs. In the event that the head cannot
213             # be found, the head/root entity is used as a starting point.
214             # [19 Mar 2008] Modified by Feng Li
215             # Check optional start parameter, then optional Content-ID, then create/add
216             # Content-ID (the same approach as in SOAP::Lite 0.66)
217              
218             #my $start = get_multipart_id($entity->head->mime_attr('content-type.start'));
219 0   0       my $start = get_multipart_id($entity->head->mime_attr('content-type.start'))
220             || get_multipart_id($entity->parts(0)->head->mime_attr('content-id'));
221              
222 0 0 0       if (!defined($start) || $start eq "") {
223 0           $start = $self->generate_random_string(10);
224 0           $entity->parts(0)->head->add('content-id',$start);
225             }
226 0   0       my $location = $entity->head->mime_attr('content-location') ||
227             'thismessage:/';
228 0           my $env;
229 0           foreach my $part ($entity->parts) {
230 0 0         next if !UNIVERSAL::isa($part => "MIME::Entity");
231              
232             # Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as
233             # expected. Work around is to eliminate the INDEX.
234 0           my $pid = get_multipart_id($part->head->mime_attr('content-id'));
235              
236             # If Content-ID is not supplied, then generate a random one (HACK - because
237             # MIME::Entity does not do this as it should... content-id is required
238             # according to MIME specification)
239 0 0         $pid = $self->generate_random_string(10) if $pid eq '';
240 0           my $type = $part->head->mime_type;
241              
242             # If a Content-Location header cannot be found, this will look for an
243             # alternative in the following MIME Header attributes
244 0   0       my $plocation = $part->head->get('content-location') ||
245             $part->head->mime_attr('Content-Disposition.filename') ||
246             $part->head->mime_attr('Content-Type.name');
247 0 0 0       if ($start && $pid eq $start) {
248 0           $env = $part->bodyhandle->as_string;
249             } else {
250 0           $self->push_part($part);
251             }
252             }
253             # die "Can't find 'start' parameter in multipart MIME message\n"
254             # if @{$self->parts} > 1 && !$start;
255 0           return $env;
256             }
257              
258             # ======================================================================
259              
260             package SOAP::Packager::DIME;
261              
262 25     25   173 use strict;
  25         208  
  25         904  
263 25     25   131 use vars qw(@ISA);
  25         50  
  25         1546  
264             @ISA = qw(SOAP::Packager);
265              
266             sub BEGIN {
267 25     25   138 no strict 'refs';
  25         52  
  25         2480  
268 25     25   81 for my $method ( qw(foo) ) {
269 25         90 my $field = '_' . $method;
270             *$method = sub {
271 0     0   0 my $self = shift;
272 0 0       0 if (@_) { $self->{$field} = shift; return $self }
  0         0  
  0         0  
273 0         0 return $self->{$field};
274             }
275 25         7514 }
276             }
277              
278             sub new {
279 0     0     my ($classname) = @_;
280 0           my $self = SOAP::Packager::new(@_);
281 0           bless $self, $classname;
282 0           $SOAP::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1;
283 0           return $self;
284             }
285              
286             sub initialize_parser {
287 0     0     my $self = shift;
288 0           print STDERR "Initializing parser\n";
289 0           eval "require DIME::Parser;";
290 0 0         die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@;
291 0           $self->{'_parser'} = DIME::Parser->new;
292             }
293              
294             sub package {
295 0     0     my $self = shift;
296 0           my ($envelope,$context) = @_;
297 0 0         return $envelope if (!$self->parts); # if there are no parts,
298             # then there is nothing to do
299 0           require DIME::Message;
300 0           require DIME::Payload;
301 0           my $message = DIME::Message->new;
302 0           my $top = DIME::Payload->new;
303 0 0         my $soapversion = defined($context) ? $context->soapversion : '1.1';
304 0 0         $top->attach('MIMEType' => $soapversion == 1.1 ?
305             "http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml",
306             'Data' => \$envelope );
307 0           $message->add_payload($top);
308             # consume the attachments that come in as input by 'shift'ing
309 25     25   151 no strict 'refs';
  25         57  
  25         9419  
310 0           while (my $part = shift(@{$self->parts})) {
  0            
311 0 0         die "You are only allowed to add parts of type DIME::Payload to a DIME::Message"
312             if (!$part->isa('DIME::Payload'));
313             # print STDERR "Adding payload to DIME message: ".ref($part)."\n";
314 0           $message->add_payload($part);
315             # print STDERR "Payload's payload is: ".${$part->print_content_data}."\n";
316             }
317 0           $self->headers_http({ 'Content-Type' => 'application/dime' });
318 0           return $message->print_data;
319             }
320              
321             sub unpackage {
322 0     0     my $self = shift;
323 0           my ($raw_input,$context) = @_;
324 0           $self->SUPER::unpackage();
325              
326             # Parse the raw input into a DIME::Message structure.
327             # - fail if the raw_input is not DIME formatted
328 0           print STDERR "raw_data: $raw_input\n";
329 0 0         $self->initialize_parser() if !defined($self->parser);
330 0 0         my $message = eval { $self->parser->parse_data(\$raw_input) }
  0            
331 0           or die "Something wrong with DIME message: @{[$@]}\n";
332              
333             # The first payload is always the SOAP Message
334             # TODO - Error check
335 0           my @payloads = @{$message->{'_PAYLOADS'}};
  0            
336 0           my $env = shift(@payloads);
337 0           my $env_str = $env->print_content_data;
338 0           print STDERR "Received this envelope: ".$env_str."\n";
339 0           while (my $p = shift(@payloads)) {
340 0           print STDERR "Adding part to Packager\n";
341 0           $self->push_part($p);
342             }
343 0           return $env_str;
344             }
345              
346             1;
347             __END__