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