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,v 1.7 2006/08/16 14:07:38 byrnereese Exp $ 8# 9# ====================================================================== 10 11package SOAP::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 (@_) { $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 my $start = get_multipart_id($entity->head->mime_attr('content-type.start')); 216 if (!defined($start) || $start eq "") { 217 $start = $self->generate_random_string(10); 218 $entity->parts(0)->head->add('content-id',$start); 219 } 220 my $location = $entity->head->mime_attr('content-location') || 221 'thismessage:/'; 222 my $env; 223 foreach my $part ($entity->parts) { 224 next if !UNIVERSAL::isa($part => "MIME::Entity"); 225 226 # Weird, the following use of head->get(SCALAR[,INDEX]) doesn't work as 227 # expected. Work around is to eliminate the INDEX. 228 my $pid = get_multipart_id($part->head->mime_attr('content-id')); 229 230 # If Content-ID is not supplied, then generate a random one (HACK - because 231 # MIME::Entity does not do this as it should... content-id is required 232 # according to MIME specification) 233 $pid = $self->generate_random_string(10) if $pid eq ''; 234 my $type = $part->head->mime_type; 235 236 # If a Content-Location header cannot be found, this will look for an 237 # alternative in the following MIME Header attributes 238 my $plocation = $part->head->get('content-location') || 239 $part->head->mime_attr('Content-Disposition.filename') || 240 $part->head->mime_attr('Content-Type.name'); 241 if ($start && $pid eq $start) { 242 $env = $part->bodyhandle->as_string; 243 } else { 244 $self->push_part($part) if (defined($part->bodyhandle)); 245 } 246 } 247# die "Can't find 'start' parameter in multipart MIME message\n" 248# if @{$self->parts} > 1 && !$start; 249 return $env; 250} 251 252# ====================================================================== 253 254package SOAP::Packager::DIME; 255 256use strict; 257use vars qw(@ISA); 258@ISA = qw(SOAP::Packager); 259 260sub BEGIN { 261 no strict 'refs'; 262 for my $method ( qw(foo) ) { 263 my $field = '_' . $method; 264 *$method = sub { 265 my $self = shift; 266 if (@_) { $self->{$field} = shift; return $self } 267 return $self->{$field}; 268 } 269 } 270} 271 272sub new { 273 my ($classname) = @_; 274 my $self = SOAP::Packager::new(@_); 275 bless $self, $classname; 276 $SOAP::Packager::SUPPORTED_TYPES->{"DIME::Payload"} = 1; 277 return $self; 278} 279 280sub initialize_parser { 281 my $self = shift; 282 print STDERR "Initializing parser\n"; 283 eval "require DIME::Parser;"; 284 die "Could not find DIME::Parser - is DIME::Tools installed? Aborting." if $@; 285 $self->{'_parser'} = DIME::Parser->new; 286} 287 288sub package { 289 my $self = shift; 290 my ($envelope,$context) = @_; 291 return $envelope if (!$self->parts); # if there are no parts, 292 # then there is nothing to do 293 require DIME::Message; 294 require DIME::Payload; 295 my $message = DIME::Message->new; 296 my $top = DIME::Payload->new; 297 my $soapversion = defined($context) ? $context->soapversion : '1.1'; 298 $top->attach('MIMEType' => $soapversion == 1.1 ? 299 "http://schemas.xmlsoap.org/soap/envelope/" : "application/soap+xml", 300 'Data' => $envelope ); 301 $message->add_payload($top); 302 # consume the attachments that come in as input by 'shift'ing 303 no strict 'refs'; 304 while (my $part = shift(@{$self->parts})) { 305 die "You are only allowed to add parts of type DIME::Payload to a DIME::Message" 306 if (!$part->isa('DIME::Payload')); 307# print STDERR "Adding payload to DIME message: ".ref($part)."\n"; 308 $message->add_payload($part); 309# print STDERR "Payload's payload is: ".${$part->print_content_data}."\n"; 310 } 311 $self->headers_http({ 'Content-Type' => 'application/dime' }); 312 return $message->print_data; 313} 314 315sub unpackage { 316 my $self = shift; 317 my ($raw_input,$context) = @_; 318 $self->SUPER::unpackage(); 319 320 # Parse the raw input into a DIME::Message structure. 321 # - fail if the raw_input is not DIME formatted 322 print STDERR "raw_data: $raw_input\n"; 323 $self->initialize_parser() if !defined($self->parser); 324 my $message = eval { $self->parser->parse_data(\$raw_input) } 325 or die "Something wrong with DIME message: @{[$@]}\n"; 326 327 # The first payload is always the SOAP Message 328 # TODO - Error check 329 my @payloads = @{$message->{'_PAYLOADS'}}; 330 my $env = shift(@payloads); 331 my $env_str = $env->print_content_data; 332 print STDERR "Received this envelope: ".$env_str."\n"; 333 while (my $p = shift(@payloads)) { 334 print STDERR "Adding part to Packager\n"; 335 $self->push_part($p); 336 } 337 return $env_str; 338} 339 3401; 341__END__ 342 343=pod 344 345=head1 NAME 346 347SOAP::Packager - this class is an abstract class which allows for multiple types of packaging agents such as MIME and DIME. 348 349=head1 DESCRIPTION 350 351The SOAP::Packager class is responsible for managing a set of "parts." Parts are 352additional pieces of information, additional documents, or virtually anything that 353needs to be associated with the SOAP Envelope/payload. The packager then will take 354these parts and encode/decode or "package"/"unpackage" them as they come and go 355over the wire. 356 357=head1 METHODS 358 359=over 360 361=item new 362 363Instantiates a new instance of a SOAP::Packager. 364 365=item parts 366 367Contains an array of parts. The contents of this array and their types are completely 368dependant upon the Packager being used. For example, when using MIME, the content 369of this array is MIME::Entity's. 370 371=item push_part 372 373Adds a part to set of parts managed by the current instance of SOAP::Packager. 374 375=item parser 376 377Returns the parser used to parse attachments out of a data stream. 378 379=item headers_http 380 381This is a hook into the HTTP layer. It provides a way for a packager to add and/or modify 382HTTP headers in a request/response. For example, most packaging layers will need to 383override the Content-Type (e.g. multipart/related, or application/dime). 384 385=back 386 387=head1 ABSTRACT METHODS 388 389If you wish to implement your own SOAP::Packager, then the methods below must be 390implemented by you according to the prescribed input and output requirements. 391 392=over 393 394=item package() 395 396The C<package> subroutine takes as input the SOAP envelope in string/SCALAR form. 397This will serve as the content of the root part. The packager then encapsulates the 398envelope with the parts contained within C<parts> and returns the properly 399encapsulated envelope in string/SCALAR form. 400 401=item unpackage() 402 403The C<unpackage> subroutines takes as input raw data that needs to be parsed into 404a set of parts. It is responsible for extracting the envelope from the input, and 405populating C<parts> with an ARRAY of parts extracted from the input. It then returns 406the SOAP Envelope in string/SCALAR form so that SOAP::Lite can parse it. 407 408=back 409 410=head1 SUPPORTED PACKAGING FORMATS 411 412=head2 SOAP::Packager::MIME 413 414C<SOAP::Packager::MIME> utilizes L<MIME::Tools> to provides the ability to send 415and receive Multipart/Related and Multipart/Form-Data formatted requests and 416responses. 417 418=head3 MIME METHODS 419 420The following methods are used when composing a MIME formatted message. 421 422=over 423 424=item transfer_encoding 425 426The value of the root part's Content-Transfer-Encoding MIME Header. Default is: 8bit. 427 428=item env_id 429 430The value of the root part's Content-Id MIME Header. Default is: <main_envelope>. 431 432=item env_location 433 434The value of the root part's Content-Location MIME Header. Default is: /main_envelope. 435 436=item env_type 437 438The value of the root part's Content-Type MIME Header. Default is: text/xml. 439 440=back 441 442=head3 OPTIMIZING THE MIME PARSER 443 444The use of attachments can often result in a heavy drain on system resources depending 445upon how your MIME parser is configured. For example, you can instruct the parser to 446store attachments in memory, or to use temp files. Using one of the other can affect 447performance, disk utilization, and/or reliability. Therefore you should consult the 448following URL for optimization techniques and trade-offs: 449 450http://search.cpan.org/dist/MIME-tools/lib/MIME/Parser.pm#OPTIMIZING_YOUR_PARSER 451 452To modify the parser's configuration options consult the following code sample, 453which incidentally shows how to minimize memory utilization: 454 455 my $packager = SOAP::Packager::MIME->new; 456 # $packager->parser->decode_headers(1); # no difference 457 # $packager->parser->extract_nested_messages(1); # no difference 458 $packager->parser->output_to_core(0); # much less memory 459 $packager->parser->tmp_to_core(0); # much less memory 460 $packager->parser->tmp_recycling(0); # promotes faster garbage collection 461 $packager->parser->use_inner_files(1); # no difference 462 my $client = SOAP::Lite->uri($NS)->proxy($URL)->packager($packager); 463 $client->someMethod(); 464 465=head3 CLIENT SIDE EXAMPLE 466 467The following code sample shows how to use attachments within the context of a 468SOAP::Lite client. 469 470 #!/usr/bin/perl 471 use SOAP::Lite; 472 use MIME::Entity; 473 my $ent = build MIME::Entity 474 Type => "text/plain", 475 Path => "attachment.txt", 476 Filename => "attachment.txt", 477 Disposition => "attachment"; 478 $NS = "urn:Majordojo:TemperatureService"; 479 $HOST = "http://localhost/cgi-bin/soaplite.cgi"; 480 my $client = SOAP::Lite 481 ->packager(SOAP::Packager::MIME->new) 482 ->parts([ $ent ]) 483 ->uri($NS) 484 ->proxy($HOST); 485 $response = $client->c2f(SOAP::Data->name("temperature" => '100')); 486 print $response->valueof('//c2fResponse/foo'); 487 488=head3 SERVER SIDE EXAMPLE 489 490The following code shows how to use attachments within the context of a CGI 491script. It shows how to read incoming attachments, and to return attachments to 492the client. 493 494 #!/usr/bin/perl -w 495 use SOAP::Transport::HTTP; 496 use MIME::Entity; 497 SOAP::Transport::HTTP::CGI 498 ->packager(SOAP::Packager::MIME->new) 499 ->dispatch_with({'urn:Majordojo:TemperatureService' => 'TemperatureService'}) 500 ->handle; 501 502 BEGIN { 503 package TemperatureService; 504 use vars qw(@ISA); 505 @ISA = qw(Exporter SOAP::Server::Parameters); 506 use SOAP::Lite; 507 sub c2f { 508 my $self = shift; 509 my $envelope = pop; 510 my $temp = $envelope->dataof("//c2f/temperature"); 511 use MIME::Entity; 512 my $ent = build MIME::Entity 513 Type => "text/plain", 514 Path => "printenv", 515 Filename => "printenv", 516 Disposition => "attachment"; 517 # read attachments 518 foreach my $part (@{$envelope->parts}) { 519 print STDERR "soaplite.cgi: attachment found! (".ref($part).")\n"; 520 print STDERR "soaplite.cgi: contents => ".$part->stringify."\n"; 521 } 522 # send attachments 523 return SOAP::Data->name('convertedTemp' => (((9/5)*($temp->value)) + 32)), 524 $ent; 525 } 526 } 527 528=head2 SOAP::Packager::DIME 529 530TODO 531 532=head1 SEE ALSO 533 534L<MIME::Tools>, L<DIME::Tools> 535 536=head1 COPYRIGHT 537 538Copyright (C) 2000-2004 Paul Kulchenko. All rights reserved. 539 540This library is free software; you can redistribute it and/or modify 541it under the same terms as Perl itself. 542 543=head1 AUTHORS 544 545Byrne Reese (byrne@majordojo.com) 546 547=cut 548