home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _7723bb5d5fbc843ad0971040065d3589 < prev    next >
Text File  |  2000-03-15  |  8KB  |  244 lines
  1. package SOAP::Packager;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. use SOAP::Defs;
  6.  
  7. $VERSION = '0.23';
  8.  
  9. sub new {
  10.     my ($class, $soap_prefix, $depth, $print_fcn) = @_;
  11.     my $self = {
  12.         soap_prefix => $soap_prefix, # this allows us to turn on/off namespace support
  13.         depth       => $depth,
  14.         print_fcn   => $print_fcn,
  15.     };
  16.     bless $self, $class;
  17. }
  18.  
  19. sub is_registered {
  20.     my ($self, $object) = @_;
  21.  
  22.               $self->{objref_dictionary}{$object}[0]
  23.     if exists $self->{objref_dictionary}{$object};
  24. }
  25.  
  26. sub register {
  27.     my ($self, $envelope, $object, $already_serialized) = @_;
  28.  
  29.     #
  30.     # $already_serialized is an optional parameter that you can pass as nonzero
  31.     # to indicate that the object has been serialized into the stream, but might
  32.     # be referred to by other objects. This is used to deal with the special
  33.     # cases where roots (body root, and headers) may be referenced, and *could*
  34.     # be used to implement the special case of strings/bytearrays, if we can figure
  35.     # out a reasonable way of automating string/bytearray matching. I don't expect
  36.     # to implement this feature in my serializing (as opposed to deserializing) code
  37.     # anytime soon though.
  38.     #
  39.  
  40.     #
  41.     # my dictionaries spring into life the first time we use them,
  42.     # so be careful always to use them via hash references here!
  43.     #
  44.     if (exists $self->{objref_dictionary}{$object}) {
  45.         return $self->{objref_dictionary}{$object}[0];
  46.     }
  47.     elsif (exists $self->{objref_dictionary_while_sealing}) {
  48.         if (exists $self->{objref_dictionary_while_sealing}{$object}) {
  49.             return $self->{objref_dictionary_while_sealing}{$object}[0];
  50.         }
  51.         else {
  52.             my $id = $envelope->_alloc_id();
  53.             $self->{objref_dictionary_while_sealing}{$object} = 
  54.                 $already_serialized ? [$id] : [$id, $object];
  55.             return $id;
  56.         }
  57.     }
  58.     else {
  59.         my $id = $envelope->_alloc_id();
  60.         $self->{objref_dictionary}{$object} =
  61.             $already_serialized ? [$id] : [$id, $object];
  62.         return $id;
  63.     }
  64. }
  65.  
  66. sub seal {
  67.     my ($self, $envelope) = @_;
  68.  
  69.     #
  70.     # NOTE: seal() explicitly supports sealing off multiple times
  71.     #       to deal with the Envelope/Header/Body special case, where Header
  72.     #       mustn't have any "external pointers", but may have "internal pointers"
  73.     #       coming from Body.
  74.     #       whenever an object is sealed, it is popped from the packager's
  75.     #       dictionary (the hashed objref-->id mapping is left intact though)
  76.     #       so that on a reseal, we won't end up reserializing any objects
  77.     #
  78.  
  79.     # quit if there's nothing to do
  80.     return unless exists $self->{objref_dictionary};
  81.  
  82.     #
  83.     # the presence of this member variable indicates that we are sealing
  84.     #
  85.     my $objref_dictionary_while_sealing      =
  86.     $self->{objref_dictionary_while_sealing} = {};
  87.  
  88.     my $objref_dictionary = $self->{objref_dictionary};
  89.     while (my ($key, $id_and_object) = each %$objref_dictionary) {
  90.         if (2 == @$id_and_object) {
  91.             $self->seal_object($envelope, @$id_and_object);
  92.             pop @{$id_and_object};
  93.         }
  94.     }
  95.  
  96.     while (%$objref_dictionary_while_sealing) {
  97.         #
  98.         # first merge newly added items into our main identity table
  99.         #
  100.         while (my ($key, $id_and_object) = each %$objref_dictionary_while_sealing) {
  101.             $self->{objref_dictionary}{$id_and_object->[1]} = $id_and_object;
  102.         }
  103.  
  104.         my $prev_dict = $objref_dictionary_while_sealing;
  105.         $objref_dictionary_while_sealing         =
  106.         $self->{objref_dictionary_while_sealing} = {};
  107.  
  108.         #
  109.         # finally serialize the items added during the previous pass
  110.         #
  111.         while (my ($key, $id_and_object) = each %$prev_dict) {
  112.             if (2 == @$id_and_object) {
  113.                 $self->seal_object($envelope, @$id_and_object);
  114.                 pop @{$id_and_object};
  115.             }
  116.         }
  117.     }
  118.     delete $self->{objref_dictionary_while_sealing};
  119. }
  120.  
  121. sub seal_object {
  122.     my ($self, $envelope, $id, $object) = @_;
  123.  
  124.     my $serializer = $envelope->_get_type_mapper()->get_serializer($object);
  125.  
  126.     my ($accessor_uri, $accessor_name) = $serializer->get_typeinfo();
  127.  
  128.     $accessor_name ||= 'item';
  129.  
  130.     my $sp = $self->{soap_prefix};
  131.  
  132.     my $attrs = qq[ ${sp}id="$id"];
  133.  
  134.     my $accessor_type = $serializer->get_accessor_type();
  135.     if ($soapperl_accessor_type_simple == $accessor_type) {
  136.  
  137.         my $content = $serializer->serialize_as_string();
  138.  
  139.         my $nsprefix = '';
  140.         if (defined $accessor_uri) {
  141.             (my $nsdecl, $nsprefix) = $envelope->_get_ns_decl_and_prefix($accessor_uri);
  142.             $attrs .= $nsdecl if $nsdecl;
  143.         }
  144.         my $tag = $nsprefix . $accessor_name;
  145.  
  146.         $self->_print(qq[<$tag$attrs>$content</$tag>]);
  147.  
  148.         return;
  149.     }
  150.  
  151.     my $new_depth = $self->{depth} + 1;
  152.  
  153.     my $nsprefix = '';
  154.     if (defined $accessor_uri) {
  155.         (my $nsdecl, $nsprefix) = $envelope->_push_ns_decl_and_prefix($accessor_uri, $new_depth);
  156.         $attrs .= $nsdecl if $nsdecl;
  157.     }
  158.     my $tag = $nsprefix . $accessor_name;
  159.  
  160.     $self->_print(qq[<$tag$attrs>]);
  161.  
  162.     my $packager = $serializer->is_package() ?
  163.         $envelope->_create_new_package($new_depth) : $self;
  164.     
  165.     my $stream = SOAP::OutputStream->new();
  166.     $stream->{tag}          = $tag;
  167.     $stream->{packager}     = $packager;
  168.     $stream->{envelope}     = $envelope;
  169.     $stream->{print_fcn}    = $self->{print_fcn};
  170.     $stream->{soap_prefix}  = $self->{soap_prefix};
  171.     $stream->{depth}        = $new_depth;
  172.  
  173.     $serializer->serialize($stream);
  174.     $stream->term();
  175. }
  176.  
  177. sub _print {
  178.     my ($self, $s) = @_;
  179.     
  180.     $self->{print_fcn}->($s);
  181. }
  182.  
  183.  
  184.  
  185. 1;
  186. __END__
  187.  
  188.  
  189. =head1 NAME
  190.  
  191. SOAP::Packager - SOAP internal helper class
  192.  
  193. =head1 SYNOPSIS
  194.  
  195.     use SOAP::Packager;
  196.     my $packager = SOAP::Packager->new('s:', 1, sub { print shift } );
  197.  
  198.     # some object used as a reference
  199.     my $object = SOAP::Object->new();
  200.  
  201.     # on a given packager, register() always returns the same id for a given object
  202.     my $id = $packager->register($env, $object);
  203.     unless($id == $packager->register($env, $object)) { die "internal error" }
  204.  
  205.     # this serializes objectA
  206.     $packager->seal($envelope);
  207.  
  208.     # note that the package is still valid
  209.     unless($id == $packager->register($env, $object)) { die "internal error" }
  210.  
  211.     my $objectB = SOAP::Object->new();
  212.     my $idB = $packager->register($env, $objectB);
  213.     unless($idB == $packager->register($env, $objectB)) { die "internal error" }
  214.  
  215.     # this just serializes objectB - objectA was already serialized before
  216.     $packager->seal($env);
  217.  
  218.     # this does nothing except waste some cycles enumerating a hash table
  219.     $packager->seal($env=);
  220.  
  221.     # hash tables shut down at destruction of packager, releasing object references
  222.     $packager = undef;
  223.  
  224. =head1 DESCRIPTION
  225.  
  226. This is an internal class used by the SOAP/Perl implementation. It is designed to
  227. manage a table of object references and XML ids used for serializing object graphs
  228. that may contain multiref data (and perhaps even cycles). If you are extending
  229. SOAP/Perl, the above synopsis will probably be all you need if you want to reuse this
  230. class. Whatever you pass for the $env reference should implement a function called
  231. _alloc_id that returns a unique string each time it is called. This is normally
  232. implemented by SOAP::Envelope, so you can see a sample implementation there.
  233.  
  234. =head1 AUTHOR
  235.  
  236. Keith Brown
  237.  
  238. =head1 SEE ALSO
  239.  
  240. SOAP::Envelope
  241. SOAP::OutputStream
  242.  
  243. =cut
  244.