File Coverage

blib/lib/UDDI.pm

Criterion	Covered	Total	%
statement	6	187	3.2
branch	0	72	0.0
condition	0	6	0.0
subroutine	2	21	9.5
pod	9	9	100.0
total	17	295	5.7

package UDDI;

# Copyright 2000 ActiveState Tool Corp.

use strict;

our $VERSION = "0.03";

our $registry ||= "http://test.uddi.microsoft.com/inquire";
#our $registry = "http://uddi.microsoft.com/inquire";
our $TRACE;
our %err;

require Exporter;
our @EXPORT_OK = qw(find_binding find_business find_service find_tModel
		    get_bindingDetail get_businessDetail get_businessDetailExt
		    get_serviceDetail get_tModelDetail
                   );

my %findQualifier = map {$_ => 1}
   qw(exactNameMatch caseSensitiveMatch
      sortByNameAsc sortByNameDesc
      sortByDateAsc sortByDateDesc
     );

sub _esc_q {
    for (@_) {
	s/&/&/g;
	s/\"/"/g;
	s/
    }
}

sub _esc {
    for (@_) {
	s/&/&/g;
	s/
    }
}

sub _rows_and_fq
{
    my $arg = shift;
    my $msg = "";
    if (defined(my $maxRows = delete $arg->{maxRows})) {
	$msg .= qq( maxRows="$maxRows");
    }
    $msg .= qq( xmlns="urn:uddi-org:api">);
    if (my $findQ = delete $arg->{findQualifiers}) {
	unless (ref($findQ)) {
	    $findQ = [split(' ', $findQ)];
	}
	if ($^W) {
	    for (@$findQ) {
		warn "Unknown findQualifier '$_'\n" unless $findQualifier{$_};
	    }
	}
	$msg .= "" .
                   join("", map "$_", @$findQ) .
                "";
    }
    return $msg;
}

sub _tbag
{
    my $arg = shift;
    my $msg = "";
    if (my $tBag = delete $arg->{tModelBag}) {
	unless (ref($tBag)) {
	    $tBag = [split(' ', $tBag)];
	}
	$msg .= "" .
                   join("", map "$_", @$tBag) .
                "";
    }
    return $msg;
}

sub _key_ref
{
    my($arg, $bag) = @_;
    my $msg = "";
    if (my $refs = delete $arg->{$bag}) {
	# XXX using a hash to implement a keyedReference bag is problematic
	# because there is no obvous place to put tModelKey if wanted...
	if (ref($refs) eq "HASH") {
	    my @kref;
	    for my $k (sort keys %$refs) {
		my $v = $refs->{$k};
		for ($k, $v) {
		    _esc_q($_);
		}
		push(@kref, qq());
	    }
	    $msg = "<$bag>" . join("", @kref) . "";
	}
	else {
	    die "Unknown $bag argument type(must be hash)";
	}
    }
    $msg;
}

sub find_binding
{
    my %arg = @_;
    my $serviceKey = delete $arg{serviceKey};
    die "Missing serviceKey" unless $serviceKey;
    my $msg = qq(
    $msg .= _rows_and_fq(\%arg);
    $msg .= _tbag(\%arg);
    $msg .= qq();
    if (%arg) {
	my $a = join(", ", keys %arg);
	warn "Unrecongized parameters: $a";
    }

    return _request($msg);
}

sub find_business
{
    my %arg = @_;
    my $msg = qq(
    $msg .= _rows_and_fq(\%arg);

    if (my $n = delete $arg{name}) {
	_esc($n);
	$msg .= qq($n);
    }
    $msg .= _key_ref(\%arg, "identifierBag");
    $msg .= _key_ref(\%arg, "categoryBag");
    $msg .= _tbag(\%arg);

    if (my $discU = delete $arg{discoveryURLs}) {
	unless (ref($discU)) {
	    $discU = [split(' ', $discU)];
	}
	$msg .= "" .
                   join("", map "$_", @$discU) .
                "";
    }

    $msg .= qq();
    if (%arg) {
	my $a = join(", ", keys %arg);
	warn "Unrecongized parameters: $a";
    }

    return _request($msg);
}

sub find_service
{
    my %arg = @_;
    my $businessKey = delete $arg{businessKey};
    die "Missing businessKey" unless $businessKey;
    my $msg = qq(
    $msg .= _rows_and_fq(\%arg);
    if (my $n = delete $arg{name}) {
	_esc($n);
	$msg .= qq($n);
    }
    $msg .= _key_ref(\%arg, "categoryBag");
    $msg .= _tbag(\%arg);
    $msg .= qq();
    if (%arg) {
	my $a = join(", ", keys %arg);
	warn "Unrecongized parameters: $a";
    }

    return _request($msg);
}

sub find_tModel
{
    my %arg = @_;
    my $msg = qq(
    $msg .= _rows_and_fq(\%arg);
    if (my $n = delete $arg{name}) {
	_esc($n);
	$msg .= qq($n);
    }
    $msg .= _key_ref(\%arg, "identifierBag");
    $msg .= _key_ref(\%arg, "categoryBag");
    $msg .= _tbag(\%arg);
    $msg .= qq();
    if (%arg) {
	my $a = join(", ", keys %arg);
	warn "Unrecongized parameters: $a";
    }

    return _request($msg);
}

sub get_bindingDetail
{
    my $msg = qq();
    for (@_) {
	$msg .= "$_";
    }
    $msg .= "";

    return _request($msg);
}

sub _get_businessDetail
{
    my $ext = (shift) ? "Ext" : "";
    my $msg = qq();
    for (@_) {
	$msg .= "$_";
    }
    $msg .= "";

    return _request($msg);
}

sub get_businessDetail
{
    unshift(@_, 0);
    goto &_get_businessDetail;
}

sub get_businessDetailExt
{
    unshift(@_, 1);
    goto &_get_businessDetail;
}

sub get_serviceDetail
{
    my $msg = qq();
    for (@_) {
	$msg .= "$_";
    }
    $msg .= "";

    return _request($msg);
}

sub get_tModelDetail
{
    my $msg = qq();
    for (@_) {
	$msg .= "$_";
    }
    $msg .= "";

    return _request($msg);
}



# ----------------------------------

my $ua;

sub _request {
    my $msg = shift;

    if (!$ua) {
	require LWP::UserAgent;
	$ua = LWP::UserAgent->new;
	$ua->agent("UDDI.pm/$VERSION " . $ua->agent);
	$ua->env_proxy;
    }

    undef(%UDDI::err);

    my $req = HTTP::Request->new(POST => $registry);
    $req->date(time) if $TRACE;
    $req->header("SOAPAction", '""');
    $req->content_type("text/xml");
    $req->content(qq($msg\n));

    print $TRACE "\n\n", ("=" x 50), "\n", $req->as_string if $TRACE;

    my $res = $ua->request($req);

    print $TRACE $res->as_string if $TRACE;

    if ($res->content_type eq "text/xml" && $res->header("SOAPAction")) {
	#warn $res->content;

	require UDDI::SOAP;
	my $envelope = UDDI::SOAP::parse($res->content);
	if ($envelope->must_understand_headers) {
	    %UDDI::err = ( type => "SOAP",
			   code => "MustUnderstand",
			   message => "UDDI response contained SOAP headers that ".
			              "the client libarary did not understand",
			   detail => $envelope,
			 );
	    return undef;
	}

	my $obj = $envelope->body_content;

	if (ref($obj) eq "UDDI::SOAP::Fault") {
	    %UDDI::err = ( type    => "SOAP",
			   code    => $obj->code,
			   message => $obj->message,
			   detail  => $obj,
			 );
	    return undef;
	}

	return $obj;
    }

    %UDDI::err = (
		  type    => "HTTP",
		  code    => $res->code,
		  message => $res->status_line,
		  detail  => $res,
		 );
    return undef;
}

# The following table is auto-generated from:
# "UDDI API schema.  Version 1.0, revision 0.  Last change 2000-09-06"

# urn:uddi-org:api elements

sub TEXT_CONTENT () { 0x01 }
sub ELEM_CONTENT () { 0x02 }

our %elementContent = (
    'UDDI::addressLine'           => 0x01,
    'UDDI::bindingKey'            => 0x01,
    'UDDI::businessKey'           => 0x01,
    'UDDI::description'           => 0x01,
    'UDDI::keyValue'              => 0x01,
    'UDDI::name'                  => 0x01,
    'UDDI::overviewURL'           => 0x01,
    'UDDI::personName'            => 0x01,
    'UDDI::serviceKey'            => 0x01,
    'UDDI::tModelKey'             => 0x01,
    'UDDI::uploadRegister'        => 0x01,
    'UDDI::address'               => 0x02,
    'UDDI::contacts'              => 0x02,
    'UDDI::contact'               => 0x02,
    'UDDI::discoveryURL'          => 0x01,
    'UDDI::discoveryURLs'         => 0x02,
    'UDDI::phone'                 => 0x01,
    'UDDI::email'                 => 0x01,
    'UDDI::businessEntity'        => 0x02,
    'UDDI::businessServices'      => 0x02,
    'UDDI::businessService'       => 0x02,
    'UDDI::bindingTemplates'      => 0x02,
    'UDDI::identifierBag'         => 0x02,
    'UDDI::keyedReference'        => 0000,
    'UDDI::categoryBag'           => 0x02,
    'UDDI::bindingTemplate'       => 0x02,
    'UDDI::accessPoint'           => 0x01,
    'UDDI::hostingRedirector'     => 0000,
    'UDDI::tModelInstanceDetails' => 0x02,
    'UDDI::tModelInstanceInfo'    => 0x02,
    'UDDI::instanceDetails'       => 0x02,
    'UDDI::instanceParms'         => 0x01,
    'UDDI::tModel'                => 0x02,
    'UDDI::tModelBag'             => 0x02,
    'UDDI::overviewDoc'           => 0x02,
    'UDDI::authInfo'              => 0x01,
    'UDDI::get_authToken'         => 0000,
    'UDDI::authToken'             => 0x02,
    'UDDI::discard_authToken'     => 0x02,
    'UDDI::save_tModel'           => 0x02,
    'UDDI::delete_tModel'         => 0x02,
    'UDDI::save_business'         => 0x02,
    'UDDI::delete_business'       => 0x02,
    'UDDI::save_service'          => 0x02,
    'UDDI::delete_service'        => 0x02,
    'UDDI::save_binding'          => 0x02,
    'UDDI::delete_binding'        => 0x02,
    'UDDI::dispositionReport'     => 0x02,
    'UDDI::result'                => 0x02,
    'UDDI::errInfo'               => 0x01,
    'UDDI::findQualifiers'        => 0x02,
    'UDDI::findQualifier'         => 0x01,
    'UDDI::find_tModel'           => 0x02,
    'UDDI::find_business'         => 0x02,
    'UDDI::find_binding'          => 0x02,
    'UDDI::find_service'          => 0x02,
    'UDDI::serviceList'           => 0x02,
    'UDDI::businessList'          => 0x02,
    'UDDI::tModelList'            => 0x02,
    'UDDI::businessInfo'          => 0x02,
    'UDDI::businessInfos'         => 0x02,
    'UDDI::serviceInfo'           => 0x02,
    'UDDI::serviceInfos'          => 0x02,
    'UDDI::get_businessDetail'    => 0x02,
    'UDDI::businessDetail'        => 0x02,
    'UDDI::get_serviceDetail'     => 0x02,
    'UDDI::serviceDetail'         => 0x02,
    'UDDI::get_registeredInfo'    => 0x02,
    'UDDI::registeredInfo'        => 0x02,
    'UDDI::tModelInfo'            => 0x02,
    'UDDI::tModelInfos'           => 0x02,
    'UDDI::get_tModelDetail'      => 0x02,
    'UDDI::tModelDetail'          => 0x02,
    'UDDI::businessEntityExt'     => 0x02,
    'UDDI::get_businessDetailExt' => 0x02,
    'UDDI::businessDetailExt'     => 0x02,
    'UDDI::get_bindingDetail'     => 0x02,
    'UDDI::bindingDetail'         => 0x02,
    'UDDI::validate_categorization' => 0x02,
);


package UDDI::Object;

use overload '""' => \&as_string;

our $AUTOLOAD;

sub AUTOLOAD
{
    my $self = shift;
    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
    return if $method eq "DESTROY";

    my $k = "urn:uddi-org:api\0$method";
    if (exists $self->[0]{$k}) {
	return $self->[0]{$k};
    }

    my @res = grep ref($_) eq "UDDI::$method", @$self;
    return wantarray ? @res : $res[0];
}

sub xml_lang
{
    my $self = shift;
    return $self->[0]{"xml\0lang"};
}

sub as_string
{
    my($self, $elem) = @_;
    my $class = ref($self);

    unless ($class) {
	# plain string
	UDDI::_esc($self) if $elem;
	return $self;
    }

    return $self->[1]
	if $UDDI::elementContent{$class} == UDDI::TEXT_CONTENT && !$elem;

    (my $tag = $class) =~ s/^UDDI:://;

    my @e = @$self;
    my $attr = shift @e;
    if (%$attr) {
	my @attr;
	for my $k (sort keys %$attr) {
	    my $v = $attr->{$k};
	    $k =~ s/^[^\0]*\0//; # kill namespace qualifier
	    UDDI::_esc_q($v);
	    @attr = qq($k="$v");
	}
	$attr = join(" ", "", @attr);
    }
    else {
	$attr = "";
    }

    return "<$tag$attr/>" unless @e;

    return join("", "<$tag$attr>", (map as_string($_, 1), @e), "");
}

1;

__END__