package UDDI::SOAP;

# Copyright 2000 ActiveState Tool Corp.

use strict;

sub SOAP_ENV () { "http://schemas.xmlsoap.org/soap/envelope/" }
sub UDDI_API () { "urn:uddi-org:api" }

for (qw(Envelope Header Body Fault detail)) {
    $UDDI::elementContent{"UDDI::SOAP::$_"} = UDDI::ELEM_CONTENT();
}

for (qw(faultcode faultstring faultactor)) {
    $UDDI::elementContent{"UDDI::SOAP::$_"} = UDDI::TEXT_CONTENT();
}

sub parse {
    my $doc = shift;

    require XML::Parser::Expat;

    my $p = XML::Parser::Expat->new(ErrorContext => 0);

    $p->setHandlers(Start => \&start_h,
		    End   => \&end_h,
		    Char  => \&char_h,
		   );

    $p->{stack} = [[]];
    $p->parse($doc);
    my $tree = (delete $p->{stack})->[0][0];
    $p->release;
    undef($p);

    $tree;
}

sub ns_set
{
    my($p, $ns, $v) = @_;
    # push handlers to clean up when namespace scope has been left.
    if (exists $p->{ns}{$ns}) {
	my $old = $p->{ns}{$ns};
	push(@{$p->{ns_stack}[-1]}, sub { $p->{ns}{$ns} = $old  });
    }
    else {
	push(@{$p->{ns_stack}[-1]}, sub { delete $p->{ns}{$ns} });
    }
    # update namespace
    $p->{ns}{$ns} = $v;
}

sub ns_qualify
{
    my($p, $name, $attr) = @_;
    return "$p\0$name" unless ref($p);

    if ($name =~ s/^([^:]+)://) {
	my $prefix = $1;
	unless (exists $p->{ns}{$prefix}) {
	    if ($prefix eq "xml") {
		return "xml\0$name";
	    }
	    else {
		$p->xpcroak("Unknown namespace prefix '$prefix'")
	    }
	}
	return "$p->{ns}{$prefix}\0$name";
    }
    elsif (!$attr && exists $p->{ns}{""}) {
	return "$p->{ns}{''}\0$name";
    }
    elsif ($attr) {
	return "$attr\0$name";
    }
    else {
	return "\0$name";
    }
}

sub ns_split
{
    my $qname = shift;
    my @s = split(/\0/, $qname, 2);
    @s;
}

sub ns_enter
{
    my $p = shift;
    push(@{$p->{ns_stack}}, []);
}

sub ns_leave
{
    my $p = shift;
    my $frame = pop(@{$p->{ns_stack}});
    for (@$frame) {
	&$_(); # invoke cleanup functions
    }
}

sub start_h
{
    my $p = shift;
    my $e = shift;

    ns_enter($p);

    my @attr;
    while (@_) {
	my($k, $v) = splice(@_, 0, 2);
	if ($k eq "xmlns") {
	    ns_set($p, "", $v);
	}
	elsif ($k =~ s/^xmlns://) {
	    ns_set($p, $k, $v);
	}
	else {
	    push(@attr, $k => $v);
	}
    }

    $e = ns_qualify($p, $e);
    my($e_ns, undef) = ns_split($e);
    for (my $i = 0; $i < @attr; $i += 2) {
	$attr[$i] = ns_qualify($p, $attr[$i], $e_ns);
    }

    my $node = [$e, { @attr }];

    my($ns, $name) = ns_split($e);
    my $class;
    if ($ns eq UDDI_API) {
	$class = "UDDI::$name";

	# trick, generate classes on the fly
	no strict 'refs';
	@{"$class\::ISA"} = ('UDDI::Object') unless @{"$class\::ISA"};
    }
    elsif ($ns eq SOAP_ENV) {
	$class = "UDDI::SOAP::$name";
    }
    else {
	$p->xpcroak("Unrecognized element $name ($ns)");
    }

    if ($class) {
	shift @$node;
	bless $node, $class;
    }

    push(@{$p->{stack}}, $node);
}

sub end_h
{
    my($p, $e) = @_;
    ns_leave($p);
    my $node = pop(@{$p->{stack}});

    # XXX might process $node here...

    push(@{$p->{stack}[-1]}, $node);
    return;
}

sub char_h
{
    my($p, $str) = @_;

    my $elem_type = ref($p->{stack}[-1]);

    if (exists $UDDI::elementContent{$elem_type}) {
	my $content = $UDDI::elementContent{$elem_type};
	unless ($content & UDDI::TEXT_CONTENT) {
	    $p->xpcroak("Text not allowed for $elem_type elements")
		if $str =~ /\S/;
	    return;
	}
    }

    if (!ref($p->{stack}[-1][-1])) {
	# Avoid subsequenct text segments
	$p->{stack}[-1][-1] .= $str;
    }
    else {
	push(@{$p->{stack}[-1]}, $str);
    }
}


package UDDI::SOAP::Envelope;

sub must_understand_headers
{
    my $self = shift;
    my @elem = @$self;
    shift(@elem); # attributes
    pop(@elem);   # body
    my @h;
    for (@elem) {
	die "Assert $_" unless ref($_) eq "UDDI::SOAP::Header";
	push(@h, $_->[1])
	    if $_->[1][0]{UDDI::SOAP::SOAP_ENV . "\0mustUnderstand"};
    }
    return @h;
}

sub body_content
{
    my $self = shift;
    my $body = $self->[-1];
    if (wantarray) {
	my @tmp = @$body;
	shift(@tmp);  # attributes
	return @tmp;
    }
    else {
	return $body->[1];
    }
}


package UDDI::SOAP::Fault;

sub code
{
    my $self = shift;
    my $code;
    for (@$self) {
	if (ref($_) eq "UDDI::SOAP::detail") {
	    my $d = $_->[-1];
	    if (ref($d) eq "UDDI::dispositionReport") {
		eval {
		    # hope for the best
		    $code = $d->result->errInfo->errCode;
		};
	    }
	    last;
	}
    }

    if (!$code) {
	for (@$self) {
	    if (ref($_) eq "UDDI::SOAP::faultcode") {
		$code = $_->[-1];
		last;
	    }
	}
    }

    $code ||= "SOAP_Fault";

    $code;
}

sub message
{
    my $self = shift;
    my $mess;
    for (@$self) {
	if (ref($_) eq "UDDI::SOAP::faultstring") {
	    $mess = $_->[-1];
	    last;
	}
    }

    $mess ||= $self->code . " fault";
    $mess;
}

1;