home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _503306cca3922fe4ff916ff58a8a1b88 < prev    next >
Text File  |  2000-03-15  |  13KB  |  444 lines
  1. package SOAP::Envelope;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. $VERSION = '0.23';
  6.  
  7. use SOAP::Defs;
  8. use SOAP::OutputStream;
  9. use SOAP::Packager;
  10. use SOAP::TypeMapper;
  11.  
  12. ########################################################################
  13. # constructor
  14. ########################################################################
  15. sub new {
  16.     my ($class, $print_fcn, $namespace_uris_to_preload, $type_mapper) = @_;
  17.  
  18.     $type_mapper ||= SOAP::TypeMapper->defaultMapper();
  19.  
  20.     my $self = {
  21.         print_fcn       => $print_fcn || \&__default_print_fcn,
  22.         use_namespaces  => 1,
  23.         header_count    => 0,
  24.         soap_prefix     => '',
  25.         cur_id          => 0,
  26.         packager        => undef,
  27.         type_mapper     => $type_mapper,
  28.     };
  29.     bless $self, $class;
  30.  
  31.     #
  32.     # calculating $self->{soap_prefix} should be done VERY EARLY
  33.     # because lots of objects (like the packager I create below)
  34.     # copies this value for their own use...
  35.     #
  36.     my $attrs = '';
  37.     if ($self->{use_namespaces}) {
  38.         $self->{soap_prefix} = 's:';
  39.  
  40.         $attrs .= $self->_preload_ns($soap_namespace, 's');
  41.         $attrs .= $self->_preload_ns($xsd_namespace, 'xsi');
  42.     }
  43.  
  44.     $self->{packager} = $self->_create_new_packager();
  45.  
  46.     if ($namespace_uris_to_preload) {
  47.         foreach my $uri (@$namespace_uris_to_preload) {
  48.             $attrs .= $self->_preload_ns($uri);
  49.         }
  50.     }
  51.     my $sp = $self->{soap_prefix};
  52.  
  53.     $self->_print(qq[<$sp$soap_envelope$attrs>]);
  54.  
  55.     $self;
  56. }
  57.  
  58. sub header {
  59.     my ($self, $accessor_uri, $accessor_name,
  60.                $typeuri, $typename,
  61.                $must_understand, $is_package, $object) = @_;
  62.  
  63.     my $sp = $self->{soap_prefix};
  64.  
  65.     my $header_number = ++$self->{header_count};
  66.     if (1 == $header_number) {
  67.         #
  68.         # this is the first header, so print the SOAP::Header tag to
  69.         # delimit the headers
  70.         #
  71.         $self->_print(qq[<$sp$soap_header>]);
  72.     }
  73.     my $tag;
  74.     my $attrs = '';
  75.     if (defined $accessor_name) {
  76.         my $nsprefix = '';
  77.         if (defined $accessor_uri) {
  78.             (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($accessor_uri);
  79.             $attrs .= $nsdecl if $nsdecl;
  80.         }
  81.         $tag = qq[$nsprefix$accessor_name];
  82.     }
  83.     else {
  84.         $tag = qq[header$header_number];
  85.     }
  86.  
  87.     if (defined $typename) {
  88.         my $nsprefix = '';
  89.         if (defined $typeuri) {
  90.             (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($typeuri);
  91.             $attrs .= $nsdecl if $nsdecl;
  92.         }
  93.         $attrs .= qq[ xsi:type="${nsprefix}$typename"];
  94.     }
  95.  
  96.     if ($must_understand) {
  97.         $attrs .= qq[ $sp$soap_must_understand="1"];
  98.     }
  99.  
  100.     my $already_marshaled = 0;
  101.     my $packager = $self->{packager};
  102.     if ($object) {
  103.         #
  104.         # by passing in this optional parameter,
  105.         # the header may be used as a multi-reference root
  106.         #
  107.         my $id = $packager->is_registered($object);
  108.         if ($id) {
  109.             $attrs .= qq[ $sp$soap_href="#$id"];
  110.             $already_marshaled = 1;
  111.         }
  112.         else {
  113.             $id = $packager->register($self, $object, 1);
  114.             $attrs .= qq[ $sp$soap_id="$id"];
  115.         }
  116.         $attrs .= qq[ $sp$soap_root_with_id="1"];
  117.     }
  118.  
  119.     if (!$already_marshaled && $is_package) {
  120.         $attrs .= qq[ $sp$soap_package="1"];
  121.     }
  122.  
  123.     $self->_print(qq[<$tag$attrs>]);
  124.  
  125.     my $stream = undef;
  126.     if ($already_marshaled) {
  127.         $self->_print(qq[</$tag>]);
  128.     }
  129.     else {
  130.         my $child_packager = $is_package ? $self->_create_new_packager() : $packager;
  131.  
  132.         $stream = SOAP::OutputStream->new();
  133.         $stream->{tag}            = $tag;    
  134.         $stream->{packager}       = $child_packager;
  135.         $stream->{soap_prefix}    = $self->{soap_prefix};
  136.         $stream->{envelope}       = $self;    
  137.         $stream->{print_fcn}      = $self->{print_fcn};
  138.         $stream->{seal_package}   = $is_package;
  139.     }
  140.     $stream;
  141. }
  142.  
  143. sub body {
  144.     my ($self, $accessor_uri, $accessor_name,
  145.                $typeuri, $typename, $is_package, $object) = @_;
  146.  
  147.     my $sp = $self->{soap_prefix};
  148.  
  149.     if ($self->{header_count}) {
  150.         # delimit any headers
  151.         $self->{packager}->seal($self);
  152.         $self->_print(qq[</$sp$soap_header>]);
  153.     }
  154.  
  155.     $self->_print(qq[<$sp$soap_body>]);
  156.  
  157.     my $tag;
  158.     my $attrs = '';
  159.     if (defined $accessor_name) {
  160.         my $nsprefix = '';
  161.         if (defined $accessor_uri) {
  162.             (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($accessor_uri);
  163.             $attrs .= $nsdecl if $nsdecl;
  164.         }
  165.         $tag = qq[$nsprefix$accessor_name];
  166.     }
  167.  
  168.     if (defined $typename) {
  169.         my $nsprefix = '';
  170.         if (defined $typeuri) {
  171.             (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($typeuri);
  172.             $attrs .= $nsdecl if $nsdecl;
  173.         }
  174.     if (defined $accessor_name) {
  175.         $attrs .= qq[ xsi:type="$nsprefix$typename"];
  176.     }
  177.     else {
  178.         # if no accessor name defined, pick it up from the type name
  179.         $tag = qq[$nsprefix$typename];
  180.     }
  181.     }
  182.  
  183.     my $already_marshaled = 0;
  184.     my $packager = $self->{packager};
  185.     if ($object) {
  186.         #
  187.         # by passing in this optional parameter,
  188.         # the body may be used as a multi-reference root
  189.         #
  190.         my $id = $packager->is_registered($object);
  191.         if ($id) {
  192.             $attrs .= qq[ $sp$soap_href="#$id"];
  193.             $already_marshaled = 1;
  194.         }
  195.         else {
  196.             $id = $packager->register($self, $object, 1);
  197.             $attrs .= qq[ $sp$soap_id="$id"];
  198.         }
  199.         $attrs .= qq[ $sp$soap_root_with_id="1"];
  200.     }
  201.  
  202.     if (!$already_marshaled && $is_package) {
  203.         $attrs .= qq[ $sp$soap_package="1"];
  204.     }
  205.  
  206.     $self->_print(qq[<$tag$attrs>]);
  207.  
  208.     my $stream = undef;
  209.     if ($already_marshaled) {
  210.         $self->_print(qq[</$tag>]);
  211.     }
  212.     else {
  213.         my $child_packager = $is_package ? $self->_create_new_packager() : $packager;
  214.  
  215.         $stream = SOAP::OutputStream->new();
  216.         $stream->{tag}            = $tag;    
  217.         $stream->{packager}       = $child_packager;
  218.         $stream->{soap_prefix}    = $self->{soap_prefix};
  219.         $stream->{envelope}       = $self;    
  220.         $stream->{print_fcn}      = $self->{print_fcn};
  221.         $stream->{seal_package}   = $is_package;
  222.     }
  223.     $stream;
  224. }
  225.  
  226. sub term {
  227.     my ($self) = @_;
  228.     
  229.     $self->{packager}->seal($self);
  230.  
  231.     my $sp = $self->{soap_prefix};
  232.     $self->_print(qq[</$sp$soap_body></$sp$soap_envelope>]);
  233. }
  234.  
  235. ########################################################################
  236. # misc
  237. ########################################################################
  238. sub _get_type_mapper {
  239.     my ($self) = @_;
  240.     $self->{type_mapper};
  241. }
  242.  
  243. sub _create_new_packager {
  244.     my ($self, $depth) = @_;
  245.     
  246.     $depth ||= 1;
  247.     
  248.     SOAP::Packager->new($self->{soap_prefix},
  249.                         $depth,
  250.                         $self->{print_fcn});
  251. }
  252.  
  253. sub _get_ns_decl_and_prefix {
  254.     #
  255.     # if the uri is already in use, just use the existing prefix,
  256.     # otherwise, declare a new, temporary one, but don't bother caching it
  257.     #
  258.     my ($self, $uri) = @_;
  259.  
  260.     my $nsdecl = '';
  261.     my $ns_prefix;
  262.     if (exists $self->{uri_to_prefix}{$uri}) {
  263.         $ns_prefix = $self->{uri_to_prefix}{$uri};
  264.     }
  265.     else {
  266.         $ns_prefix = ('n' . ++$self->{cur_ns_prefix});
  267.         $nsdecl = qq[ xmlns:${ns_prefix}="$uri"];
  268.     }
  269.  
  270.     ($nsdecl, qq[${ns_prefix}:]);
  271. }
  272.  
  273. sub _push_ns_decl_and_prefix {
  274.     #
  275.     # if the uri is already in use, just use the existing prefix,
  276.     # otherwise, declare a new one, and save it for child scopes to use also
  277.     #
  278.     my ($self, $uri, $depth) = @_;
  279.  
  280.     my $nsdecl = '';
  281.     my $ns_prefix;
  282.  
  283.     if (exists $self->{uri_to_prefix}{$uri}) {
  284.         $ns_prefix = $self->{uri_to_prefix}{$uri};
  285.     }
  286.     else {
  287.         #
  288.         # add this uri to our namespace dictionary with an auto-generated prefix
  289.         # and remember the depth at which we registered it, so we can remove it
  290.         # during termination
  291.         #
  292.         $ns_prefix = $self->{uri_to_prefix}{$uri} = ('n' . ++$self->{cur_ns_prefix});
  293.         push @{$self->{depth_to_uri_list}{$depth}}, $uri;
  294.  
  295.         $nsdecl = qq[ xmlns:${ns_prefix}="$uri"];
  296.     }
  297.  
  298.     ($nsdecl, qq[${ns_prefix}:]);
  299. }
  300.  
  301. sub _preload_ns {
  302.     my ($self, $uri, $ns_prefix) = @_;
  303.  
  304.     my $nsdecl = '';
  305.     unless (exists $self->{uri_to_prefix}{$uri}) {
  306.         $ns_prefix ||= 'n' . ++$self->{cur_ns_prefix};
  307.         $self->{uri_to_prefix}{$uri} = $ns_prefix;
  308.         $nsdecl = qq[ xmlns:${ns_prefix}="$uri"];
  309.     }
  310.     $nsdecl;
  311. }
  312.  
  313. sub _clean_up_namespace_dictionary {
  314.     my ($self, $depth) = @_;
  315.  
  316.     if (exists $self->{depth_to_uri_list}{$depth}) {
  317.         my $uri_to_prefix = $self->{uri_to_prefix};
  318.         foreach my $uri (@{$self->{depth_to_uri_list}{$depth}}) {
  319.             delete $uri_to_prefix->{$uri};
  320.         }
  321.         delete $self->{depth_to_uri_list}{$depth};
  322.     }
  323. }
  324.  
  325. sub _alloc_id {
  326.     my ($self) = @_;
  327.  
  328.     my $id = ++$self->{cur_id};
  329.  
  330.     qq[ref-$id];  # follow SOAP examples (for clarity only)
  331. }
  332.  
  333. sub _print {
  334.     my ($self, $s) = @_;
  335.     
  336.     $self->{print_fcn}->($s);
  337. }
  338.  
  339. sub __default_print_fcn {
  340.     my ($s) = @_;
  341.     print $s;
  342. }
  343.  
  344. 1;
  345. __END__
  346.  
  347. =head1 NAME
  348.  
  349. SOAP::Envelope - Creates SOAP streams
  350.  
  351. =head1 SYNOPSIS
  352.  
  353.     use SOAP::Envelope;
  354.  
  355.     sub output_fcn {
  356.         my $string = shift;
  357.         print $string;
  358.     }
  359.  
  360.     my $namespaces_to_preload = ["urn:foo", "urn:bar"];
  361.     my $env = SOAP::Envelope->new(\&output_fcn,
  362.                                   $namespaces_to_preload);
  363.     my $header = $env->header("urn:a", "MyHeaderA",
  364.                               undef, undef,
  365.                               0, 0);
  366.     ...
  367.     $header->term();
  368.  
  369.     $header = $env->header("urn:b", "MyHeaderB",
  370.                            undef, undef,
  371.                            0, 0);
  372.     ...
  373.     $header->term();
  374.  
  375.     my $body = $env->body("urn:c", "MyCall",
  376.                           undef, undef);
  377.     ...
  378.     $body->term();
  379.  
  380.     $env->term();
  381.  
  382.  
  383. =head1 DESCRIPTION
  384.  
  385. This class bootstraps and manages the serialization of an object graph
  386. into a SOAP stream. It is used by the SOAP::Transport classes, but may
  387. be used directly as well.
  388.  
  389. =head2 The new function
  390.  
  391. Creates a new envelope. If you know you'll be using certain namespaces
  392. a lot, you can save some space by preloading those namespaces (pass the
  393. set of URI strings as an array when creating a new envelope, as in the example
  394. above).
  395.  
  396. =head2 The header function
  397.  
  398. Creates a new header in the specified namespace URI (which is required).
  399. You can call this function multiple times to create several different headers,
  400. but don't call the body function until you've created all the headers.
  401. If omitted, the typename and typeuri will be taken from the accessor name
  402. and accessor uri, but the accessor name and uri are required.
  403. Be sure to term() the current header before creating a new one.
  404. For a discussion of the $object optional parameter, please see body(), below.
  405.  
  406. =head2 The body function
  407.  
  408. Creates the body. You can only call this function once per envelope,
  409. and you must call it after you're done creating all the headers you need
  410. to create. If omitted, the typename and typeuri will be taken from the accessor
  411. name and accessor uri, but the accessor name is required.
  412. The $object parameter is optional, but must be passed if headers (or subelements
  413. in the body) may point to the body itself. SOAP::Envelope adds this object
  414. reference into its identity dictionary to correctly deal with these cases
  415. (a doubly-linked list is a simple example of this case).
  416. If you pass $object, you have to be prepared for body() to return undef,
  417. which indicates that the object was already marshaled into the header area
  418. (because it was referred to by a header element). In this case, the body
  419. element will simply be a reference to the previously marshaled body.
  420. If body() returns a value, don't forget to call term() through it when you're done
  421. serializing the body, because this forces the output of any outstanding multi-ref
  422. items.
  423.  
  424. =head2 The term function
  425.  
  426. This writes an end tag, terminating the SOAP envelope.
  427.  
  428. =head1 DEPENDENCIES
  429.  
  430. SOAP::OutputStream
  431. SOAP::Packager
  432. SOAP::Defs
  433.  
  434. =head1 AUTHOR
  435.  
  436. Keith Brown
  437.  
  438. =head1 SEE ALSO
  439.  
  440. SOAP::OutputStream
  441. SOAP::Transport::HTTP
  442.  
  443. =cut
  444.