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