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