view release on metacpan or  search on metacpan

lib/Shipment/SOAP/WSDL.pm  view on Meta::CPAN

          class_resolver  => $args->{ class_resolver },
          body_parts      => $args->{ body_parts }   || [],
          header_parts    => $args->{ header_parts } || [],
          strict          => exists $args->{ strict } ? $args->{ strict } : 1,
      };
  
      bless $self, $class;
  
      $self->load_classes()
          if $args->{ class_resolver }
             && ! exists $LOADED_OF{ $self->{ class_resolver } };
  
      return $self;
  }
  
  sub set_header_parts {
      $_[0]->{ header_parts } = $_[1];
  }
  
  sub set_body_parts {
      $_[0]->{ body_parts } = $_[1];
  }
  
  sub class_resolver {
      my $self = shift;
      if ( @_ ) {
          $self->{ class_resolver } = shift
              or return;
          $self->load_classes() if ! exists $LOADED_OF{ $self->{ class_resolver } };
      }
      return $self->{ class_resolver };
  }
  
  sub load_classes {
      my $self = shift;
  
      return if $LOADED_OF{ $self->{ class_resolver } }
             || ! $self->{ class_resolver }->can('get_typemap');
  
      # requires sorting to make sub-packages load after their parent
      for ( sort values %{ $self->{ class_resolver }->get_typemap() } ) {
          no strict qw(refs);
          my $class = $_;
  
          # ignore __SKIP__
          next if $class eq '__SKIP__';
  
          # check if namespace exists
          next if defined *{ "$class\::" }; # bad test - know a better one?
  
          # Require takes a bareword or a file name - we have to take
          # the filname road here...
          $class =~s{ :: }{/}xmsg;
          require "$class.pm";
      }
      $LOADED_OF{ $self->{ class_resolver } } = 1;
  }
  
  sub get_type_class {
      my ($self, $name) = @_;
      my ($prefix,$localname) = split m{:}x , $name;
      my $namespace;
      if ($localname) {
          $namespace = $self->{ parser }->expand_ns_prefix($prefix);
      }
      else {
          $namespace = $self->{ parser }->expand_ns_prefix('#default');
          $localname = $name;
      }
  
      return "SOAP::WSDL::XSD::Typelib::Builtin::$localname"
          if ($namespace eq 'http://www.w3.org/2001/XMLSchema');
  
      # resolve perl prefix
      my $perl_prefix = $self->{ prefix_resolver }->resolve_prefix('type', $namespace);
  
      # TODO build a perl name from >type< prefix and name using the prefix resolver
      return "$perl_prefix$localname";
  }
  
  sub _initialize {
      my ($self, $parser) = @_;
      $self->{ parser } = $parser;
  
      delete $self->{ data };                     # remove potential old results
      delete $self->{ header };
  
      # Note: $current MUST be undef - it is used as sentinel
      # on the object stack via if (! defined $list->[-1])
      # DON'T set it to anything else !
      my $current = undef;
  
      my ($list, $path)  = ([], []); # node list (object stack) and path
      my ($skip, $depth) = (0, 0);   # skip elements, depth
  
      # use "globals" for speed
      my ($_prefix, $_method, $_class, $_leaf, $characters, $_current_classes_of_ref, $handling_multiple_parts) = ();
      my (@_attr_from, %_xsi_attr_of) = ();
  
      my %parts_of = (
          body => {
             map {
                  exists $LOADED_OF{ $_ }
                      || eval "require $_" and $LOADED_OF{ $_ } = undef;
                  $_->__get_name() => $_
             } @{ $self->{ body_parts } }
          },
          header => {
              map {
                  exists $LOADED_OF{ $_ }
                      || eval "require $_" and $LOADED_OF{ $_ } = undef;
                  eval "require $_"; $_->__get_name() => $_
              } @{ $self->{ header_parts } }
          }
      );
  
      my %content_check = (
          0 => sub {
              die "Bad top node $_[1]" if $_[1] ne 'Envelope';
              die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string()
                  if $_[0]->namespace($_[1]) ne 'http://schemas.xmlsoap.org/soap/envelope/';