view release on metacpan or  search on metacpan

lib/SOAP/Envelope.pm  view on Meta::CPAN

########################################################################
# constructor
########################################################################
sub new {
    my ($class, $print_fcn, $namespace_uris_to_preload, $type_mapper) = @_;

    $type_mapper ||= SOAP::TypeMapper->defaultMapper();

    my $self = {
        print_fcn       => $print_fcn || \&__default_print_fcn,
        use_namespaces  => 1,
        header_count    => 0,
        soap_prefix     => '',
        cur_id          => 0,
        packager        => undef,
        type_mapper     => $type_mapper,
    };
    bless $self, $class;

    #
    # calculating $self->{soap_prefix} should be done VERY EARLY
    # because lots of objects (like the packager I create below)
    # copies this value for their own use...
    #
    my $attrs = '';
    if ($self->{use_namespaces}) {
        $self->{soap_prefix} = $soap_prefix . ':';

        $attrs .= $self->_preload_ns($soap_namespace, $soap_prefix);
        $attrs .= $self->_preload_ns($xsd_namespace, $xsd_prefix);
        $attrs .= $self->_preload_ns($xsi_namespace, $xsi_prefix);
    }

    $self->{packager} = $self->_create_new_packager();

    if ($namespace_uris_to_preload) {
        foreach my $uri (@$namespace_uris_to_preload) {
            $attrs .= $self->_preload_ns($uri);
        }
    }
    my $sp = $self->{soap_prefix};

    $attrs .= qq[ $sp$soap_encoding_style="$soap_section5_encoding"];

    $self->_print(qq[<$sp$soap_envelope$attrs>]);

    $self;
}

sub header {
    my ($self, $accessor_uri, $accessor_name,
               $typeuri, $typename,
               $must_understand, $is_package, $object) = @_;

    my $sp = $self->{soap_prefix};

    my $header_number = ++$self->{header_count};
    if (1 == $header_number) {
        #
        # this is the first header, so print the SOAP::Header tag to
        # delimit the headers
        #
        $self->_print(qq[<$sp$soap_header>]);
    }
    my $tag;
    my $attrs = '';
    if (defined $accessor_name) {
        my $nsprefix = '';
        if (defined $accessor_uri) {
            (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($accessor_uri);
            $attrs .= $nsdecl if $nsdecl;
        }
        $tag = qq[$nsprefix$accessor_name];
    }
    else {
        $tag = qq[header$header_number];
    }

    if (defined $typename) {
        my $nsprefix = '';
        if (defined $typeuri) {
            (my $nsdecl, $nsprefix) = $self->_get_ns_decl_and_prefix($typeuri);
            $attrs .= $nsdecl if $nsdecl;
        }
        $attrs .= qq[ $xsi_prefix:type="${nsprefix}$typename"];
    }

    if ($must_understand) {
        $attrs .= qq[ $sp$soap_must_understand="1"];
    }

    my $already_marshaled = 0;
    my $packager = $self->{packager};
    if ($object) {
        #
        # by passing in this optional parameter,
        # the header may be used as a multi-reference root
        #
        my $id = $packager->is_registered($object);
        if ($id) {
            $attrs .= qq[ $soap_href="#$id"];
            $already_marshaled = 1;
        }
        else {
            $id = $packager->register($self, $object, 1);
            $attrs .= qq[ $soap_id="$id"];
        }
        $attrs .= qq[ $sp$soap_root_with_id="1"];
    }

    if (!$already_marshaled && $is_package) {
        $attrs .= qq[ $sp$soap_package="1"];
    }

    $self->_print(qq[<$tag$attrs>]);

    my $stream = undef;
    if ($already_marshaled) {
        $self->_print(qq[</$tag>]);
    }