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