[MOBY-guts] biomoby commit
Eddie Kawas
kawas at pub.open-bio.org
Thu Nov 18 17:38:56 UTC 2004
kawas
Thu Nov 18 12:41:16 EST 2004
Update of /home/repository/moby/moby-live/Perl/MOBY/Client
In directory pub.open-bio.org:/tmp/cvs-serv13854/Client
Modified Files:
Central.pm CollectionArticle.pm OntologyServer.pm
Registration.pm SecondaryArticle.pm Service.pm
ServiceInstance.pm SimpleArticle.pm SimpleInput.pm
Log Message:
Converted XML:DOM -> XML::LibXML and applicable module calls
Eddie
moby-live/Perl/MOBY/Client Central.pm,1.80,1.81 CollectionArticle.pm,1.9,1.10 OntologyServer.pm,1.6,1.7 Registration.pm,1.6,1.7 SecondaryArticle.pm,1.4,1.5 Service.pm,1.12,1.13 ServiceInstance.pm,1.12,1.13 SimpleArticle.pm,1.5,1.6 SimpleInput.pm,1.1,1.2
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/Central.pm,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -r1.80 -r1.81
--- /home/repository/moby/moby-live/Perl/MOBY/Client/Central.pm 2004/09/16 22:21:02 1.80
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/Central.pm 2004/11/18 17:41:15 1.81
@@ -1,18 +1,18 @@
#$Id$
-
package MOBY::Client::Central;
use SOAP::Lite;
+
#use SOAP::Lite + trace; # for debugging
use strict;
use Carp;
-use XML::DOM;
+use XML::LibXML;
+use MOBY::MobyXMLConstants;
use MOBY::Client::ServiceInstance;
use MOBY::Client::Registration;
use MOBY::Client::SimpleArticle;
use MOBY::Client::CollectionArticle;
use MOBY::Client::SecondaryArticle;
use MOBY::Client::OntologyServer;
-
use vars qw($AUTOLOAD @ISA $MOBY_server $MOBY_uri);
=head1 NAME
@@ -21,7 +21,6 @@
=cut
-
=head1 SYNOPSIS
use MOBY::Client::Central;
@@ -126,198 +125,219 @@
=cut
my $debug = 0;
-
-if ($debug){open (OUT, ">/tmp/CentralLogOut.txt") || die "cant open logfile CentralLogOut.txt $!\n";close OUT;}
-
+if ( $debug ) {
+ open( OUT, ">/tmp/CentralLogOut.txt" )
+ || die "cant open logfile CentralLogOut.txt $!\n";
+ close OUT;
+}
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- Connections => [undef, 'read/write'],
- default_MOBY_servername => ['mobycentral', 'read/write'],
- default_MOBY_server => ['http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY05/mobycentral.pl', 'read/write'],
- default_MOBY_uri => ['http://mobycentral.cbr.nrc.ca/MOBY/Central', 'read/write'],
- default_MOBY_proxy => [undef, 'read/write'],
- default_MOBY_type => ['soap', 'read/write'],
- Registries => [undef, 'read/write'],
- multiple_registries => [undef, 'read/write'],
- # SWITCH TO THESE FOR A LOCAL MOBY CENTRAL REGISTRY
- #default_MOBY_server => ['http://localhost/cgi-bin/MOBY-Central.pl', 'read/write'],
- #default_MOBY_uri => ['http://localhost/MOBY/Central', 'read/write'],
-
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ Connections => [ undef, 'read/write' ],
+ default_MOBY_servername => [ 'mobycentral', 'read/write' ],
+ default_MOBY_server => [
+ 'http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY05/mobycentral.pl',
+ 'read/write'
+ ],
+ default_MOBY_uri =>
+ [ 'http://mobycentral.cbr.nrc.ca/MOBY/Central', 'read/write' ],
+ default_MOBY_proxy => [ undef, 'read/write' ],
+ default_MOBY_type => [ 'soap', 'read/write' ],
+ Registries => [ undef, 'read/write' ],
+ multiple_registries => [ undef, 'read/write' ],
+
+# SWITCH TO THESE FOR A LOCAL MOBY CENTRAL REGISTRY
+#default_MOBY_server => ['http://localhost/cgi-bin/MOBY-Central.pl', 'read/write'],
+#default_MOBY_uri => ['http://localhost/MOBY/Central', 'read/write'],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ return 0 unless ( $mode && $_attr_data{$attr} );
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- return 0 unless ($mode && $_attr_data{$attr});
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
- # List of names of all specified object attributes
- sub _standard_keys {
+ # List of names of all specified object attributes
+ sub _standard_keys {
keys %_attr_data;
- }
-
+ }
+
sub Connection {
- my ($self, $desired) = @_;
- if ($desired){
- while (my ($name, $type, $connect) = (@{$self->Connections->[0]})){
- return ($type, $connect) if $name eq $desired;
- }
+ my ( $self, $desired ) = @_;
+ if ( $desired ) {
+ while ( my ( $name, $type, $connect ) =
+ ( @{ $self->Connections->[0] } ) )
+ {
+ return ( $type, $connect ) if $name eq $desired;
+ }
} else {
- my ($name, $type, $connect) = @{$self->Connections->[0]};
- return ($type,$connect);
+ my ( $name, $type, $connect ) = @{ $self->Connections->[0] };
+ return ( $type, $connect );
}
- return (undef, undef);
+ return ( undef, undef );
}
-
}
sub _call {
- # this method replaces the former calls directly
- # to teh SOAP_Connection, to give more flexibility
- # in how that call is made
- # most subroutines in here do the following:
- # $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
- # or $payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
- # so intercept that and figure out if we are actually making a SOAP call or not
- # and determine which registry it is
-
- my ($self, $reg, $method, @params) = @_;
+# this method replaces the former calls directly
+# to teh SOAP_Connection, to give more flexibility
+# in how that call is made
+# most subroutines in here do the following:
+# $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
+# or $payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
+# so intercept that and figure out if we are actually making a SOAP call or not
+# and determine which registry it is
+ my ( $self, $reg, $method, @params ) = @_;
$reg = $self->default_MOBY_servername if $reg eq "default";
$reg = $self->default_MOBY_servername if !$reg;
-
- my ($type, $connect) = $self->Connection($reg);
- return "<result>EXECUTION ERROR - registry $reg not found</result>" unless ($type && $connect);
+ my ( $type, $connect ) = $self->Connection( $reg );
+ return "<result>EXECUTION ERROR - registry $reg not found</result>"
+ unless ( $type && $connect );
+ my $param = join "", @params; # must be a single message!
+ if ( lc( $type ) eq "get" ) {
- my $param = join "", @params; # must be a single message!
-
- if (lc($type) eq "get"){
#print STDERR "executing CGI call\n";
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
use CGI;
- $param =~s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ $param =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
my $paramstring = "?action=$method";
- $paramstring .=";payload=$param" if $param;
- my $req = HTTP::Request->new(GET => $connect.$paramstring);
- my $res = $ua->request($req);
- if ($res->is_success){
+ $paramstring .= ";payload=$param" if $param;
+ my $req = HTTP::Request->new( GET => $connect . $paramstring );
+ my $res = $ua->request( $req );
+ if ( $res->is_success ) {
return $res->content;
} else {
- return "<result>EXECUTION ERROR - unsuccessful call to MOBY Central registry named '$reg'</result>"
+ return
+"<result>EXECUTION ERROR - unsuccessful call to MOBY Central registry named '$reg'</result>";
}
} else {
+
#print STDERR "executing SOAP call\n";
- my @payload = $connect->call($method => $param)->paramsall;
+ my @payload = $connect->call( $method => $param )->paramsall;
return @payload;
- }
+ }
}
-
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
- $self->Connections([]); # initialize;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ $self->Connections( [] ); # initialize;
+
# if user has set up preferred servers, then use those by default
- $self->default_MOBY_server($ENV{MOBY_SERVER}) if $ENV{MOBY_SERVER};
- $self->default_MOBY_uri($ENV{MOBY_URI}) if $ENV{MOBY_URI};
- $self->default_MOBY_type($ENV{MOBY_TYPE}) if $ENV{MOBY_TYPE};
- $self->default_MOBY_proxy($ENV{MOBY_PROXY}) if $ENV{MOBY_PROXY};
-
-
- if ($self->Registries){
+ $self->default_MOBY_server( $ENV{MOBY_SERVER} ) if $ENV{MOBY_SERVER};
+ $self->default_MOBY_uri( $ENV{MOBY_URI} ) if $ENV{MOBY_URI};
+ $self->default_MOBY_type( $ENV{MOBY_TYPE} ) if $ENV{MOBY_TYPE};
+ $self->default_MOBY_proxy( $ENV{MOBY_PROXY} ) if $ENV{MOBY_PROXY};
+ if ( $self->Registries ) {
my $regno = 0;
- my %reg = %{$self->Registries};
- while (my ($name, $acc) = each %reg){
- $regno++; # count how many registries we have in total
- my $url = $acc->{URL}?$acc->{URL}:$self->default_MOBY_server;
- my $uri = $acc->{URI}?$acc->{URI}:$self->default_MOBY_uri;
- my $type = $acc->{TYPE}?$acc->{TYPE}:$self->default_MOBY_type;
- my $proxy = $acc->{PROXY}?$acc->{PROXY}:$self->default_MOBY_proxy;
- $type ||='soap';
- if (lc($type) eq "get"){
- push @{$self->Connections}, [$name, $type, $url];
+ my %reg = %{ $self->Registries };
+ while ( my ( $name, $acc ) = each %reg ) {
+ $regno++; # count how many registries we have in total
+ my $url = $acc->{URL} ? $acc->{URL} : $self->default_MOBY_server;
+ my $uri = $acc->{URI} ? $acc->{URI} : $self->default_MOBY_uri;
+ my $type = $acc->{TYPE} ? $acc->{TYPE} : $self->default_MOBY_type;
+ my $proxy =
+ $acc->{PROXY} ? $acc->{PROXY} : $self->default_MOBY_proxy;
+ $type ||= 'soap';
+ if ( lc( $type ) eq "get" ) {
+ push @{ $self->Connections }, [ $name, $type, $url ];
} else {
- my @soapargs;
- if ($proxy){
- @soapargs = ($url,
- proxy => ['http' => $proxy]);
- } else {
- @soapargs = ($url);
- }
- push @{$self->Connections}, [$name, $type, SOAP::Lite->proxy(@soapargs)->uri($uri)->on_fault(
- sub{
- my($soap, $res) = @_;
- die ref $res ? $res->faultstring : $soap->transport->status, "\n ERROR ERROR ERROR\n";
- })];
+ my @soapargs;
+ if ( $proxy ) {
+ @soapargs = ( $url, proxy => [ 'http' => $proxy ] );
+ } else {
+ @soapargs = ( $url );
+ }
+ push @{ $self->Connections }, [
+ $name, $type,
+ SOAP::Lite->proxy( @soapargs )->uri( $uri )->on_fault(
+ sub {
+ my ( $soap, $res ) = @_;
+ die ref $res
+ ? $res->faultstring
+ : $soap->transport->status,
+ "\n ERROR ERROR ERROR\n";
+ }
+ )
+ ];
}
}
- $self->multiple_registries($regno-1); # one is not "multiple", it is just a change in default -> set to "false" if only one
+ $self->multiple_registries( $regno - 1 )
+ ; # one is not "multiple", it is just a change in default -> set to "false" if only one
} else {
- $self->multiple_registries(0);
- if (lc($self->default_MOBY_type) eq "get"){
- push @{$self->Connections}, [$self->default_MOBY_servername, $self->default_MOBY_type,$self->default_MOBY_server];
+ $self->multiple_registries( 0 );
+ if ( lc( $self->default_MOBY_type ) eq "get" ) {
+ push @{ $self->Connections },
+ [
+ $self->default_MOBY_servername, $self->default_MOBY_type,
+ $self->default_MOBY_server
+ ];
} else {
- $self->Registries({$self->default_MOBY_servername => {
- URL => $self->default_MOBY_server,
- URI => $self->default_MOBY_uri
- }}
- );
- my @soapargs;
- if ($self->default_MOBY_proxy){
- @soapargs = ($self->default_MOBY_server,
- proxy => ['http' => $self->default_MOBY_proxy]);
- } else {
- @soapargs = ($self->default_MOBY_server);
- }
- push @{$self->Connections},[$self->default_MOBY_servername,
- $self->default_MOBY_type,
- SOAP::Lite->proxy(@soapargs)->uri($self->default_MOBY_uri)->on_fault(
- sub{
- my($soap, $res) = @_;
- die ref $res ? $res->faultstring : $soap->transport->status, "\n ERROR ERROR ERROR\n";
- })];
+ $self->Registries(
+ {
+ $self->default_MOBY_servername => {
+ URL => $self->default_MOBY_server,
+ URI => $self->default_MOBY_uri
+ }
+ }
+ );
+ my @soapargs;
+ if ( $self->default_MOBY_proxy ) {
+ @soapargs = (
+ $self->default_MOBY_server,
+ proxy => [ 'http' => $self->default_MOBY_proxy ]
+ );
+ } else {
+ @soapargs = ( $self->default_MOBY_server );
+ }
+ push @{ $self->Connections }, [
+ $self->default_MOBY_servername,
+ $self->default_MOBY_type,
+ SOAP::Lite->proxy( @soapargs )->uri( $self->default_MOBY_uri )
+ ->on_fault(
+ sub {
+ my ( $soap, $res ) = @_;
+ die ref $res
+ ? $res->faultstring
+ : $soap->transport->status, "\n ERROR ERROR ERROR\n";
+ }
+ )
+ ];
}
}
- return undef unless $self->Connection(); # gotta have at least one...
- return $self;
-
+ return undef unless $self->Connection(); # gotta have at least one...
+ return $self;
}
-
=head2 registerObject a.k.a registerObjectClass
Title : registerObject ; registerObjectClass
@@ -338,50 +358,59 @@
=cut
-
sub registerObjectClass {
- my ($self, %a) = @_;
- return $self->registerObject(%a);
+ my ( $self, %a ) = @_;
+ return $self->registerObject( %a );
}
-sub registerObject {
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- return $self->errorRegXML("Contact email address (contactEmail parameter) is required for object registration") if (!$a{contactEmail});
-
- my $term = $a{'objectType'}; $term ||="";
- my $desc = $a{'description'}; $desc ||="";
- my $contactEmail = $a{'contactEmail'}; $contactEmail ||="";
- my $authURI = $a{'authURI'}; $authURI ||=""; $authURI ||="";
- my %Relationships = %{$a{'Relationships'}};
- my $clobber = $a{'Clobber'}?$a{'Clobber'}:0;
- my $message = "<registerObjectClass>
+sub registerObject {
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ return $self->errorRegXML(
+"Contact email address (contactEmail parameter) is required for object registration"
+ )
+ if ( !$a{contactEmail} );
+ my $term = $a{'objectType'};
+ $term ||= "";
+ my $desc = $a{'description'};
+ $desc ||= "";
+ my $contactEmail = $a{'contactEmail'};
+ $contactEmail ||= "";
+ my $authURI = $a{'authURI'};
+ $authURI ||= "";
+ $authURI ||= "";
+ my %Relationships = %{ $a{'Relationships'} };
+ my $clobber = $a{'Clobber'} ? $a{'Clobber'} : 0;
+ my $message = "<registerObjectClass>
<objectType>$term</objectType>
<Description><![CDATA[$desc]]></Description>
<authURI>$authURI</authURI>
<contactEmail>$contactEmail</contactEmail>
<Clobber>$clobber</Clobber>\n";
- while (my ($type, $objlistref) = each %Relationships){
- $message .="<Relationship relationshipType='$type'>\n";
- foreach my $objnamepair(@{$objlistref}){
- my $object = $objnamepair->[0];
+
+ while ( my ( $type, $objlistref ) = each %Relationships ) {
+ $message .= "<Relationship relationshipType='$type'>\n";
+ foreach my $objnamepair ( @{$objlistref} ) {
+ my $object = $objnamepair->[0];
my $article = $objnamepair->[1];
- return $self->errorRegXML("Object name missing from one of your $type relationships") unless ($object);
- $article ||="";
- $message .="<objectType articleName='$article'>$object</objectType>\n";
- }
- $message .="</Relationship>\n";
+ return $self->errorRegXML(
+ "Object name missing from one of your $type relationships" )
+ unless ( $object );
+ $article ||= "";
+ $message .=
+ "<objectType articleName='$article'>$object</objectType>\n";
+ }
+ $message .= "</Relationship>\n";
}
- $message .="</registerObjectClass>";
-
-# my $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
- my ($return) = $self->_call('default', 'registerObjectClass', $message);
-
- return ($self->parseRegXML($return));
+ $message .= "</registerObjectClass>";
+# my $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'registerObjectClass', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
=head2 deregisterObject a.k.a. deregisterObjectClass
Title : deregisterObject ; deregisterObjectClass
@@ -395,27 +424,28 @@
=cut
sub deregisterObjectClass {
- my ($self, %a) = @_;
- return $self->deregisterObject(%a);
+ my ( $self, %a ) = @_;
+ return $self->deregisterObject( %a );
}
-sub deregisterObject {
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $id = $a{'objectType'}; $id ||="";
+sub deregisterObject {
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $id = $a{'objectType'};
+ $id ||= "";
my $message = "
<deregisterObjectClass>
<objectType>$id</objectType>
</deregisterObjectClass>";
-# my $return = $self->SOAP_connection->call(deregisterObjectClass => ($message))->paramsall;
- my ($return) = $self->_call('default', 'deregisterObjectClass', $message);
-
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(deregisterObjectClass => ($message))->paramsall;
+ my ( $return ) =
+ $self->_call( 'default', 'deregisterObjectClass', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
-
=head2 retrieveObjectDefinition
Title : retrieveObjectDefinition
@@ -442,66 +472,76 @@
=cut
sub retrieveObjectDefinition {
-
- my ($self, $id, $reg) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
+ my ( $self, $id, $reg ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
my %def;
return \%def unless $id;
-
my $message = "
<retrieveObjectDefinition>
<objectType>$id</objectType>
</retrieveObjectDefinition>";
- my ($return) = $self->_call('default', 'retrieveObjectDefinition', $message);
-
+ my ( $return ) =
+ $self->_call( 'default', 'retrieveObjectDefinition', $message );
return \%def unless $return;
- my ($term, $desc, $relationships, $email, $authURI) = &_ObjectDefinitionPayload($return);
- $def{objectType} = $term;
- $def{description} = $desc;
- $def{contactEmail} = $email;
- $def{authURI} = $authURI;
+ my ( $term, $desc, $relationships, $email, $authURI ) =
+ &_ObjectDefinitionPayload( $return );
+ $def{objectType} = $term;
+ $def{description} = $desc;
+ $def{contactEmail} = $email;
+ $def{authURI} = $authURI;
$def{Relationships} = $relationships;
- $def{XML} = $return;
- return (\%def);
-
+ $def{XML} = $return;
+ return ( \%def );
}
sub _ObjectDefinitionPayload {
- my ($payload) = @_;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
- my $Object = $doc->getDocumentElement();
- my $obj = $Object->getTagName;
- return undef unless ($obj eq 'retrieveObjectDefinition');
-
- my $term = &_nodeTextContent($Object, "objectType");
- my $desc = &_nodeTextContent($Object, "Description");
- my $authURI = &_nodeTextContent($Object, "authURI");
- my $email = &_nodeTextContent($Object, "contactEmail");
- my %att_value; my %relationships;
- my $x = $doc->getElementsByTagName("Relationship");
- my $no_relationships = $x->getLength;
- for (my $n=0; $n<$no_relationships; ++$n){
- my $relationshipType = $x->item($n)->getAttributeNode('relationshipType'); # may or may not have a name
- if ($relationshipType){$relationshipType = $relationshipType->getValue()} else {return "FAILED! must include a relationshipType in every relationship\n"}
- my @child = $x->item($n)->getChildNodes;
- foreach (@child){
- next unless $_->getNodeType == ELEMENT_NODE;
- my $article = $_->getAttributeNode('articleName'); # may or may not have a name
- if ($article){$article = $article->getValue()}
-
- my @child2 = $_->getChildNodes;
- foreach (@child2){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
- next unless $_->getNodeType == TEXT_NODE;
- push @{$relationships{$relationshipType}}, [$_->toString, $article];
+ my ( $payload ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $Object = $doc->getDocumentElement();
+ my $obj = $Object->nodeName;
+ return undef unless ( $obj eq 'retrieveObjectDefinition' );
+ my $term = &_nodeTextContent( $Object, "objectType" );
+ my $desc = &_nodeTextContent( $Object, "Description" );
+ my $authURI = &_nodeTextContent( $Object, "authURI" );
+ my $email = &_nodeTextContent( $Object, "contactEmail" );
+ my %att_value;
+ my %relationships;
+ my $x = $doc->getElementsByTagName( "Relationship" );
+ my $no_relationships = $x->size();
+
+ for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) { #get_node starts at one
+ my $relationshipType =
+ $x->get_node( $n )->getAttributeNode( 'relationshipType' )
+ ; # may or may not have a name
+ if ( $relationshipType ) {
+ $relationshipType = $relationshipType->getValue();
+ } else {
+ return
+ "FAILED! must include a relationshipType in every relationship\n";
+ }
+ my @child = $x->get_node( $n )->childNodes;
+ foreach ( @child ) {
+ next unless $_->nodeType == ELEMENT_NODE;
+ my $article =
+ $_->getAttributeNode( 'articleName' )
+ ; # may or may not have a name
+ if ( $article ) { $article = $article->getValue() }
+ my @child2 = $_->childNodes;
+ foreach ( @child2 ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ next unless $_->nodeType == TEXT_NODE;
+ push @{ $relationships{$relationshipType} },
+ [ $_->toString, $article ];
}
}
}
- return ($term, $desc, \%relationships, $email,$authURI);
+ return ( $term, $desc, \%relationships, $email, $authURI );
}
-
=head2 registerServiceType
Title : registerServiceType
@@ -518,37 +558,40 @@
=cut
sub registerServiceType {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $type = $a{'serviceType'}; $type ||="";
- my $desc = $a{'description'}; $desc ||="";
- my $email = $a{'contactEmail'}; $email ||="";
- my $auth = $a{'authURI'}; $auth ||="";
- my %Relationships = %{$a{'Relationships'}};
-
- my $message = "
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $type = $a{'serviceType'};
+ $type ||= "";
+ my $desc = $a{'description'};
+ $desc ||= "";
+ my $email = $a{'contactEmail'};
+ $email ||= "";
+ my $auth = $a{'authURI'};
+ $auth ||= "";
+ my %Relationships = %{ $a{'Relationships'} };
+ my $message = "
<registerServiceType>
<serviceType>$type</serviceType>
<Description><![CDATA[$desc]]></Description>
<contactEmail>$email</contactEmail>
<authURI>$auth</authURI>\n";
- while (my ($type, $servlistref) = each %Relationships){
- $message .="<Relationship relationshipType='$type'>\n";
- foreach my $servicetype(@{$servlistref}){
- $message .="<serviceType>$servicetype</serviceType>\n";
+
+ while ( my ( $type, $servlistref ) = each %Relationships ) {
+ $message .= "<Relationship relationshipType='$type'>\n";
+ foreach my $servicetype ( @{$servlistref} ) {
+ $message .= "<serviceType>$servicetype</serviceType>\n";
}
- $message .="</Relationship>\n";
+ $message .= "</Relationship>\n";
}
$message .= "</registerServiceType>";
-# my $return = $self->SOAP_connection->call(registerServiceType => ($message))->paramsall;
- my ($return) = $self->_call('default', 'registerServiceType', $message);
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(registerServiceType => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'registerServiceType', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
-
=head2 deregisterServiceType
Title : deregisterServiceType
@@ -560,21 +603,22 @@
=cut
-
sub deregisterServiceType {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $id = $a{'serviceType'}; $id ||="";
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $id = $a{'serviceType'};
+ $id ||= "";
my $message = "
<deregisterServiceType>
<serviceType>$id</serviceType>
</deregisterServiceType>";
-# my $return = $self->SOAP_connection->call(deregisterServiceType => ($message))->paramsall;
- my ($return) = $self->_call('default', 'deregisterServiceType', $message);
-
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(deregisterServiceType => ($message))->paramsall;
+ my ( $return ) =
+ $self->_call( 'default', 'deregisterServiceType', $message );
+ return ( $self->parseRegXML( $return ) );
}
=head2 registerNamespace
@@ -592,13 +636,18 @@
=cut
sub registerNamespace {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $type = $a{'namespaceType'}; $type ||="";
- my $authURI = $a{'authURI'}; $authURI ||="";
- my $desc = $a{'description'}; $desc ||="";
- my $contact = $a{'contactEmail'};; $contact ||="";
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $type = $a{'namespaceType'};
+ $type ||= "";
+ my $authURI = $a{'authURI'};
+ $authURI ||= "";
+ my $desc = $a{'description'};
+ $desc ||= "";
+ my $contact = $a{'contactEmail'};
+ $contact ||= "";
my $message = "
<registerNamespace>
<namespaceType>$type</namespaceType>
@@ -606,15 +655,12 @@
<authURI>$authURI</authURI>
<contactEmail>$contact</contactEmail>
</registerNamespace>";
-
-# my $return = $self->SOAP_connection->call(registerNamespace => ($message))->paramsall;
- my ($return) = $self->_call('default', 'registerNamespace', $message);
-
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(registerNamespace => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'registerNamespace', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
=head2 deregisterNamespace
Title : deregisterNamespace
@@ -627,23 +673,22 @@
=cut
sub deregisterNamespace {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $id = $a{'namespaceType'}; $id ||="";
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $id = $a{'namespaceType'};
+ $id ||= "";
my $message = "
<deregisterNamespace>
<namespaceType>$id</namespaceType>
</deregisterNamespace>";
-# my $return = $self->SOAP_connection->call(deregisterNamespace => ($message))->paramsall;
- my ($return) = $self->_call('default', 'deregisterNamespace', $message);
-
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(deregisterNamespace => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'deregisterNamespace', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
-
=head2 registerService
Title : registerService
@@ -697,21 +742,41 @@
=cut
sub registerService {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $name = $a{serviceName}; $name ||="";
- my $type = $a{serviceType}; $type ||="";
- my $authURI = $a{authURI}; $authURI ||="";
- my $email = $a{contactEmail}; $email ||="";
- my $URL = $a{URL}; $URL ||="";
- my $desc = $a{description}; $desc ||="";
- my $signatureURL = $a{signatureURL}; $signatureURL ||="";
- my $Category = lc($a{category}); chomp $Category; $Category ||="";
- return $self->errorRegXML("Only 'moby' and 'wsdl' Service Categories are currently allowed - you gave me $Category") unless (($Category eq 'moby') || ($Category eq 'wsdl'));
- return $self->errorRegXML("All Fields Required: serviceName, serviceType, authURI, contactEmail, URL, description, Category, input, output, secondary") unless (
- $name && $type && $authURI && $email && $URL && $desc && $Category);
-
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $name = $a{serviceName};
+ $name ||= "";
+ my $type = $a{serviceType};
+ $type ||= "";
+ my $authURI = $a{authURI};
+ $authURI ||= "";
+ my $email = $a{contactEmail};
+ $email ||= "";
+ my $URL = $a{URL};
+ $URL ||= "";
+ my $desc = $a{description};
+ $desc ||= "";
+ my $signatureURL = $a{signatureURL};
+ $signatureURL ||= "";
+ my $Category = lc( $a{category} );
+ chomp $Category;
+ $Category ||= "";
+ return $self->errorRegXML(
+"Only 'moby' and 'wsdl' Service Categories are currently allowed - you gave me $Category"
+ )
+ unless ( ( $Category eq 'moby' ) || ( $Category eq 'wsdl' ) );
+ return $self->errorRegXML(
+"All Fields Required: serviceName, serviceType, authURI, contactEmail, URL, description, Category, input, output, secondary"
+ )
+ unless ( $name
+ && $type
+ && $authURI
+ && $email
+ && $URL
+ && $desc
+ && $Category );
my $message = "
<registerService>
<Category>$Category</Category>
@@ -723,127 +788,153 @@
<authURI>$authURI</authURI>
<contactEmail>$email</contactEmail>";
- if ($Category eq "moby" || $Category eq 'soap') {
+ if ( $Category eq "moby" || $Category eq 'soap' ) {
my %SEC;
- if ($a{'secondary'} && (ref($a{'secondary'}) =~ /hash/i)){
- %SEC = %{$a{secondary}};
- } elsif ($a{'secondary'} && !(ref($a{'secondary'}) =~ /hash/i)){
- return $self->errorRegXML("invalid structure of secondary parameters. Expected hashref.")
- }
-
-
- my %funkyhash = ( Input => $a{input}, Output => $a{output});
- while (my ($inout, $param) = each %funkyhash){
- my $inout_lc = lc ($inout);
+ if ( $a{'secondary'} && ( ref( $a{'secondary'} ) =~ /hash/i ) ) {
+ %SEC = %{ $a{secondary} };
+ } elsif ( $a{'secondary'} && !( ref( $a{'secondary'} ) =~ /hash/i ) ) {
+ return $self->errorRegXML(
+ "invalid structure of secondary parameters. Expected hashref." );
+ }
+ my %funkyhash = ( Input => $a{input}, Output => $a{output} );
+ while ( my ( $inout, $param ) = each %funkyhash ) {
+ my $inout_lc = lc( $inout );
my @ALLARTICLES = @{$param};
$message .= "<${inout_lc}Objects><${inout}>\n";
-
+
# input =>[
# [articleName1,[objType1 => \@namespaces]], # Simple
# [articleName2, [[objType2 => \@namespaces]]], # collection of one object type
# [articleName3,[[objType3 => \@namespaces],
# [objType4 => \@namespaces]]] # collection of multiple object types
# ]
+ foreach my $article ( @ALLARTICLES ) {
+ my ( $articleName, $def ) = @{$article};
+ $articleName ||= "";
+ my @Objects; #
+ unless ( ref( $def ) =~ /array/i ) {
+ return $self->errorRegXML(
+"invalid structure of $inout objects, expected arrayref for article $articleName"
+ );
+ }
+ my @objectdefs;
+ if ( ( ref $def->[0] ) =~ /array/i ) { # collection
+ # def= [[objType2 => [ns3, ns4...]], ...]
+ $message .= "<Collection articleName='$articleName'>\n";
+ @objectdefs = @{$def};
+ } else { # Nipple
+ @objectdefs = ( $def );
- foreach my $article(@ALLARTICLES){
- my ($articleName, $def) = @{$article};
- $articleName ||="";
- my @Objects; #
- unless (ref($def) =~ /array/i){return $self->errorRegXML("invalid structure of $inout objects, expected arrayref for article $articleName")}
- my @objectdefs;
- if ((ref $def->[0]) =~ /array/i){ # collection
- # def= [[objType2 => [ns3, ns4...]], ...]
- $message .="<Collection articleName='$articleName'>\n";
- @objectdefs = @{$def};
- } else { # Nipple
- @objectdefs = ($def);
# def = [objType1 => [ns1, ns2...]],
}
-
- foreach my $objectdef(@objectdefs){
- if ((ref($def->[0])) =~ /array/i){
- $message .="<Simple>\n";
+ foreach my $objectdef ( @objectdefs ) {
+ if ( ( ref( $def->[0] ) ) =~ /array/i ) {
+ $message .= "<Simple>\n";
} else {
- $message .="<Simple articleName='$articleName'>\n";
- }
- my ($type, $Namespaces) = @{$objectdef};
- $message .="<objectType>$type</objectType>\n";
- unless (ref($Namespaces) =~ /array/i){return $self->errorRegXML("invalid structure of $inout namespaces for object $type in article $articleName; expected arrayref")}
- foreach my $ns(@{$Namespaces}){
- $message .="<Namespace>$ns</Namespace>\n";
+ $message .= "<Simple articleName='$articleName'>\n";
+ }
+ my ( $type, $Namespaces ) = @{$objectdef};
+ $message .= "<objectType>$type</objectType>\n";
+ unless ( ref( $Namespaces ) =~ /array/i ) {
+ return $self->errorRegXML(
+"invalid structure of $inout namespaces for object $type in article $articleName; expected arrayref"
+ );
}
- $message .="</Simple>\n";
+ foreach my $ns ( @{$Namespaces} ) {
+ $message .= "<Namespace>$ns</Namespace>\n";
+ }
+ $message .= "</Simple>\n";
}
- if ((ref($def->[0])) =~ /array/i){
- $message .="</Collection>\n";
+ if ( ( ref( $def->[0] ) ) =~ /array/i ) {
+ $message .= "</Collection>\n";
}
}
$message .= "</${inout}></${inout_lc}Objects>\n";
}
-# secondary => {parametername1 => {datatype => TYPE,
-# default => DEFAULT,
-# max => MAX,
-# min => MIN,
-# enum => [one, two]},
-# parametername2 => {datatype => TYPE,
-# default => DEFAULT,
-# max => MAX,
-# min => MIN,
-# enum => [one, two]}
-# }
-#
-
- $message .="<secondaryArticles>\n";
- while (my ($param, $desc) = each %SEC){
- unless ((ref($desc)) =~ /hash/i){return $self->errorRegXML("invalid structure of secondary article $param; expected hashref of limitations")}
- my %data = %{$desc};
- my $default = $data{default};
- my $max = $data{max};
- my $min = $data{min};
+
+ # secondary => {parametername1 => {datatype => TYPE,
+ # default => DEFAULT,
+ # max => MAX,
+ # min => MIN,
+ # enum => [one, two]},
+ # parametername2 => {datatype => TYPE,
+ # default => DEFAULT,
+ # max => MAX,
+ # min => MIN,
+ # enum => [one, two]}
+ # }
+ #
+ $message .= "<secondaryArticles>\n";
+ while ( my ( $param, $desc ) = each %SEC ) {
+ unless ( ( ref( $desc ) ) =~ /hash/i ) {
+ return $self->errorRegXML(
+"invalid structure of secondary article $param; expected hashref of limitations"
+ );
+ }
+ my %data = %{$desc};
+ my $default = $data{default};
+ my $max = $data{max};
+ my $min = $data{min};
my $datatype = $data{datatype};
- unless ($datatype){return $self->errorRegXML("a secondaryArticle must contain at least a datatype value in secondary article $param");}
- unless (($datatype =~ /Integer/) || ($datatype =~ /Float/) || ($datatype =~ /String/) || ($datatype =~ /DateTime/)){return $self->errorRegXML("a secondaryArticle must have a datatype of Integer, Float, String, or DateTime");}
- unless ((ref($data{enum})) =~ /array/i){return $self->errorRegXML("invalid structure of enum limits in secondary article $param; expected arrayref")}
- my @enums = @{$data{enum}};
- $message .="<Parameter articleName='$param'>\n";
- $message .="<default>$default</default>\n";
- $message .="<datatype>$datatype</datatype>\n";
- $message .="<max>$max</max>\n";
- $message .="<min>$min</min>\n";
- foreach (@enums){
- $message .="<enum>$_</enum>\n";
+ unless ( $datatype ) {
+ return $self->errorRegXML(
+"a secondaryArticle must contain at least a datatype value in secondary article $param"
+ );
+ }
+ unless ( ( $datatype =~ /Integer/ )
+ || ( $datatype =~ /Float/ )
+ || ( $datatype =~ /String/ )
+ || ( $datatype =~ /DateTime/ ) )
+ {
+ return $self->errorRegXML(
+"a secondaryArticle must have a datatype of Integer, Float, String, or DateTime"
+ );
+ }
+ unless ( ( ref( $data{enum} ) ) =~ /array/i ) {
+ return $self->errorRegXML(
+"invalid structure of enum limits in secondary article $param; expected arrayref"
+ );
}
- $message .="</Parameter>\n";
+ my @enums = @{ $data{enum} };
+ $message .= "<Parameter articleName='$param'>\n";
+ $message .= "<default>$default</default>\n";
+ $message .= "<datatype>$datatype</datatype>\n";
+ $message .= "<max>$max</max>\n";
+ $message .= "<min>$min</min>\n";
+ foreach ( @enums ) {
+ $message .= "<enum>$_</enum>\n";
+ }
+ $message .= "</Parameter>\n";
}
$message .= "</secondaryArticles>\n";
$message .= "</registerService>";
- } else { return $self->errorRegXML("only 'moby' and 'wsdl' service types are allowed to be registered at this time.")}
-
- #elsif ($Category eq "cgi") {
- # my $IN = $a{input};
- # $message .= "
- # <inputObjects>
- # <Input><![CDATA[$IN]]></Input>
- # </inputObjects>
- # </registerService>";
- #} else {
- # $message .= "
- # </registerService>";
- #}
-
-
- #unless ($message =~ /\<\/registerService/){ return MOBY::Registration->new(
- # success => "0",
- # error_messsage => "missing parameters or other failure leading to incorrectly formatted XML",
- # registration_id => "0")};
+ } else {
+ return $self->errorRegXML(
+"only 'moby' and 'wsdl' service types are allowed to be registered at this time."
+ );
+ }
+#elsif ($Category eq "cgi") {
+# my $IN = $a{input};
+# $message .= "
+# <inputObjects>
+# <Input><![CDATA[$IN]]></Input>
+# </inputObjects>
+# </registerService>";
+#} else {
+# $message .= "
+# </registerService>";
+#}
+#unless ($message =~ /\<\/registerService/){ return MOBY::Registration->new(
+# success => "0",
+# error_messsage => "missing parameters or other failure leading to incorrectly formatted XML",
+# registration_id => "0")};
# print STDERR $message;
- $debug && &_LOG(" message\n\n$message\n\n");
-# my $return = $self->SOAP_connection->call(registerService => ($message))->paramsall;
- my ($return) = $self->_call('default', 'registerService', $message);
-
- return ($self->parseRegXML($return));
+ $debug && &_LOG( " message\n\n$message\n\n" );
+# my $return = $self->SOAP_connection->call(registerService => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'registerService', $message );
+ return ( $self->parseRegXML( $return ) );
}
=head2 registerServiceWSDL
@@ -854,20 +945,18 @@
=cut
-
sub registerServiceWSDL {
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
+ my $message = "";
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
- my $message = "";
# my $return = $self->SOAP_connection->call(registerServiceWSDL => ($message))->paramsall;
- my ($return) = $self->_call('default', 'registerServiceWSDL', $message);
-
- return ($self->parseRegXML($return));
-
+ my ( $return ) = $self->_call( 'default', 'registerServiceWSDL', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
=head2 deregisterService
Title : deregisterService
@@ -879,35 +968,32 @@
=cut
-
-
sub deregisterService {
-
- my ($self, %a) = @_;
- return $self->errorRegXML("Function not allowed when querying multiple registries") if $self->multiple_registries;
+ my ( $self, %a ) = @_;
+ return $self->errorRegXML(
+ "Function not allowed when querying multiple registries" )
+ if $self->multiple_registries;
my $name = $a{'serviceName'};
my $auth = $a{'authURI'};
- (defined($name) && defined($auth)) || return (&parseRegXML("
+ ( defined( $name ) && defined( $auth ) ) || return (
+ &parseRegXML( "
<MOBYRegistration>
<id></id>
<success>0</success>
<message><![CDATA[you did not pass a valid service ID number]]></message>
- </MOBYRegistration>"));
+ </MOBYRegistration>" )
+ );
my $message = "
<deregisterService>
<serviceName>$name</serviceName>
<authURI>$auth</authURI>
</deregisterService>";
-
-# my $return = $self->SOAP_connection->call(deregisterService => ($message))->paramsall;
- my ($return) = $self->_call('default', 'deregisterService', $message);
-
- return ($self->parseRegXML($return));
+# my $return = $self->SOAP_connection->call(deregisterService => ($message))->paramsall;
+ my ( $return ) = $self->_call( 'default', 'deregisterService', $message );
+ return ( $self->parseRegXML( $return ) );
}
-
-
=head2 findService
Title : findService
@@ -942,102 +1028,143 @@
=cut
-
sub findService {
-
- my ($self, %a) = @_;
- my $reg = ($a{Registry})?$a{Registry}:$self->default_MOBY_servername;
-
+ my ( $self, %a ) = @_;
+ my $reg = ( $a{Registry} ) ? $a{Registry} : $self->default_MOBY_servername;
my $id = $a{'serviceID'};
- my $servicename = $a{'serviceName'}; $servicename ||="";
- my $authoritative = $a{'authoritative'}; $authoritative ||= 0;
- my $serviceType = $a{'serviceType'}; $serviceType ||= "";
- my $authURI = $a{'authURI'}; $authURI ||="";
- my $category = $a{'category'}; $category ||= "moby" ;
- my $exObj = $a{'expandObjects'}; $exObj ||=0;
- my $exServ = $a{'expandServices'}; $exServ ||= 0;
- my $kw = $a{'keywords'}; $kw ||=[];
- ref($kw) =~ /array/i || return (undef, $self->errorRegXML("invalid structure of keywords. Expected arrayref"));
- my @kw = @{$kw};
-
+ my $servicename = $a{'serviceName'};
+ $servicename ||= "";
+ my $authoritative = $a{'authoritative'};
+ $authoritative ||= 0;
+ my $serviceType = $a{'serviceType'};
+ $serviceType ||= "";
+ my $authURI = $a{'authURI'};
+ $authURI ||= "";
+ my $category = $a{'category'};
+ $category ||= "moby";
+ my $exObj = $a{'expandObjects'};
+ $exObj ||= 0;
+ my $exServ = $a{'expandServices'};
+ $exServ ||= 0;
+ my $kw = $a{'keywords'};
+ $kw ||= [];
+ ref( $kw ) =~ /array/i || return (
+ undef,
+ $self->errorRegXML(
+ "invalid structure of keywords. Expected arrayref"
+ )
+ );
+ my @kw = @{$kw};
my $message = "<findService>\n";
-
- defined($authoritative) && ($message .="<authoritative>$authoritative</authoritative>\n");
- $category && ($message .="<Category>$category</Category>\n");
- $serviceType && ($message .="<serviceType>$serviceType</serviceType>\n");
- $servicename && ($message .="<serviceName>$servicename</serviceName>\n");
- $authURI && ($message .="<authURI>$authURI</authURI>\n");
- defined($exObj) && ($message .="<expandObjects>$exObj</expandObjects> \n");
- defined($exServ) && ($message .="<expandServices>$exServ</expandServices>\n");
- if (scalar(@kw)){
- $message .=" <keywords>\n";
- foreach my $kwd(@kw){
- $message .="<keyword>$kwd</keyword>\n";
+ defined( $authoritative )
+ && ( $message .= "<authoritative>$authoritative</authoritative>\n" );
+ $category && ( $message .= "<Category>$category</Category>\n" );
+ $serviceType && ( $message .= "<serviceType>$serviceType</serviceType>\n" );
+ $servicename && ( $message .= "<serviceName>$servicename</serviceName>\n" );
+ $authURI && ( $message .= "<authURI>$authURI</authURI>\n" );
+ defined( $exObj )
+ && ( $message .= "<expandObjects>$exObj</expandObjects> \n" );
+ defined( $exServ )
+ && ( $message .= "<expandServices>$exServ</expandServices>\n" );
+
+ if ( scalar( @kw ) ) {
+ $message .= " <keywords>\n";
+ foreach my $kwd ( @kw ) {
+ $message .= "<keyword>$kwd</keyword>\n";
}
- $message .="</keywords>\n";
- }
+ $message .= "</keywords>\n";
+ }
+
#$a{input} = [[]] unless (defined $a{input});
#$a{output} = [[]] unless (defined $a{output});
- if (defined $a{input} && !(ref($a{input}) =~ /array/i)){return (undef, $self->errorRegXML("invalid structure of input objects, expected arrayref for input"))}
- if (defined $a{output} && !(ref($a{output}) =~ /array/i)){return (undef, $self->errorRegXML("invalid structure of output objects, expected arrayref for output"))}
+ if ( defined $a{input} && !( ref( $a{input} ) =~ /array/i ) ) {
+ return (
+ undef,
+ $self->errorRegXML(
+"invalid structure of input objects, expected arrayref for input"
+ )
+ );
+ }
+ if ( defined $a{output} && !( ref( $a{output} ) =~ /array/i ) ) {
+ return (
+ undef,
+ $self->errorRegXML(
+"invalid structure of output objects, expected arrayref for output"
+ )
+ );
+ }
my %funkyhash;
-
- $funkyhash{Input} = $a{input} if (defined $a{input}) ;
- $funkyhash{Output} = $a{output} if (defined $a{output}) ;
- #input =>[
- # [objType1 => [ns1, ns2...]], # Simple
- # [[objType2 => [ns3, ns4...]]], # collection of one object type
- # [[objType3 => [ns3, ns4...]],
- # [objType4 => [ns5, ns6...]]], # collection of multiple object types
- # ]
- while (my ($inout, $param) = each %funkyhash){
+ $funkyhash{Input} = $a{input} if ( defined $a{input} );
+ $funkyhash{Output} = $a{output} if ( defined $a{output} );
+
+ #input =>[
+ # [objType1 => [ns1, ns2...]], # Simple
+ # [[objType2 => [ns3, ns4...]]], # collection of one object type
+ # [[objType3 => [ns3, ns4...]],
+ # [objType4 => [ns5, ns6...]]], # collection of multiple object types
+ # ]
+ while ( my ( $inout, $param ) = each %funkyhash ) {
die "no inout parameter from teh funkyhash" unless defined $inout;
die "no param parameter from teh funkyhash" unless defined $param;
- die "param parameter should be a listref" unless (ref($param) =~ /ARRAY/);
-
- my $inout_lc = lc ($inout);
- my @PARAM = @{$param};
+ die "param parameter should be a listref"
+ unless ( ref( $param ) =~ /ARRAY/ );
+ my $inout_lc = lc( $inout );
+ my @PARAM = @{$param};
$message .= "<${inout_lc}Objects><${inout}>\n";
- foreach my $param(@PARAM){
- unless (ref($param) =~ /array/i){return (undef, $self->errorRegXML("invalid structure of $inout objects, expected arrayref of class and \@namespaces"))}
- my ($class, $namespaces) = @{$param};
+ foreach my $param ( @PARAM ) {
+ unless ( ref( $param ) =~ /array/i ) {
+ return (
+ undef,
+ $self->errorRegXML(
+"invalid structure of $inout objects, expected arrayref of class and \@namespaces"
+ )
+ );
+ }
+ my ( $class, $namespaces ) = @{$param};
die "no class part of param " unless defined $class;
+
#warn "no namespace part of the param" unless defined $namespaces;
my @objectdefs;
- if ((ref $class) =~ /array/i){ # collection
- $message .="<Collection>\n";
- @objectdefs = $class;
- } else { # Nipple
- @objectdefs = ($param);
+ if ( ( ref $class ) =~ /array/i ) { # collection
+ $message .= "<Collection>\n";
+ @objectdefs = $class;
+ } else { # Nipple
+ @objectdefs = ( $param );
}
-
- foreach my $objectdef(@objectdefs){
- $message .="<Simple>\n";
- my ($type, $Namespaces) = @{$objectdef};
+ foreach my $objectdef ( @objectdefs ) {
+ $message .= "<Simple>\n";
+ my ( $type, $Namespaces ) = @{$objectdef};
die "type is missing from objectdef " unless $type;
- $message .="<objectType>$type</objectType>\n";
- if (defined($Namespaces) && !(ref($Namespaces) =~ /array/i)){return (undef, $self->errorRegXML("invalid structure of $inout namespaces for object $type; expected arrayref"))}
- foreach my $ns(@{$Namespaces}){
+ $message .= "<objectType>$type</objectType>\n";
+ if ( defined( $Namespaces )
+ && !( ref( $Namespaces ) =~ /array/i ) )
+ {
+ return (
+ undef,
+ $self->errorRegXML(
+"invalid structure of $inout namespaces for object $type; expected arrayref"
+ )
+ );
+ }
+ foreach my $ns ( @{$Namespaces} ) {
next unless $ns;
- $message .="<Namespace>$ns</Namespace>\n";
+ $message .= "<Namespace>$ns</Namespace>\n";
}
- $message .="</Simple>\n";
+ $message .= "</Simple>\n";
}
- if ((ref($class)) =~ /array/i){
- $message .="</Collection>\n";
+ if ( ( ref( $class ) ) =~ /array/i ) {
+ $message .= "</Collection>\n";
}
}
$message .= "</${inout}></${inout_lc}Objects>\n";
}
$message .= "</findService>\n";
-
-# my $return = $self->SOAP_connection($reg)->call('findService' => ($message))->paramsall;
- my ($return) = $self->_call($reg, 'findService', $message);
- return ($self->_parseServices($reg, $return), undef);
+# my $return = $self->SOAP_connection($reg)->call('findService' => ($message))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'findService', $message );
+ return ( $self->_parseServices( $reg, $return ), undef );
}
-
=head2 retrieveService
Title : retrieveService
@@ -1048,48 +1175,37 @@
=cut
-
sub retrieveService {
-
- my ($self, $SI)=@_;
- return undef unless $SI && $SI->isa('MOBY::Client::ServiceInstance');
-
+ my ( $self, $SI ) = @_;
+ return undef unless $SI && $SI->isa( 'MOBY::Client::ServiceInstance' );
my $auth = $SI->authority;
my $name = $SI->name;
- my $reg = $SI->registry;
-
- return undef unless ($auth && $name && $self->Connection($reg));
-
+ my $reg = $SI->registry;
+ return undef unless ( $auth && $name && $self->Connection( $reg ) );
my $message = "
<retrieveService>
- ".($SI->XML)."
+ " . ( $SI->XML ) . "
</retrieveService>";
-
# my $return = $self->SOAP_connection($reg)->call(retrieveService => ($message))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveService', $message);
-
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
-
- my $de = $doc->getDocumentElement;
- my @child = $de->getChildNodes;
- my $content;
- foreach (@child){
- $debug && &_LOG($_->getNodeTypeName, "\t", $_->toString,"\n");
- if ($_->getNodeType == TEXT_NODE) {
- $content .= $_->getNodeValue;
+ my ( $return ) = $self->_call( $reg, 'retrieveService', $message );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $de = $doc->getDocumentElement;
+ my @child = $de->childNodes;
+ my $content;
+ foreach ( @child ) {
+ $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" );
+ if ( $_->nodeType == TEXT_NODE ) {
+ $content .= $_->nodeValue; #else try $_->textContent
} else {
- $content .= $_->toString;
+ $content .= $_->toString;
}
- }
-
- $content =~ s/^\n//gs;
- return $content;
-
+ }
+ $content =~ s/^\n//gs;
+ return $content;
}
-
=head2 retrieveServiceNames
Title : retrieveServiceNames
@@ -1102,32 +1218,30 @@
=cut
-
sub retrieveServiceNames {
- my ($self) = shift;
+ my ( $self ) = shift;
my $reg = shift;
-
- $reg = $reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
# my $return = $self->SOAP_connection($reg)->call('retrieveServiceNames' => (@_))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveServiceNames', "");
-
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $names_list = $root->getChildNodes;
- my %servicenames;
- for (my $x = 0; $x < $names_list->getLength; $x++){
- next unless $names_list->item($x)->getNodeType == ELEMENT_NODE;
- my $name = $names_list->item($x)->getAttributeNode('name')->getValue;
- my $auth = $names_list->item($x)->getAttributeNode('authURI')->getValue;
- push @{$servicenames{$auth}}, $name;
- }
- return \%servicenames;
+ my ( $return ) = $self->_call( $reg, 'retrieveServiceNames', "" );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $names_list = $root->childNodes;
+ my %servicenames;
+ for ( my $x = 1 ; $x <= $names_list->size() ; $x++ ) {
+ next unless $names_list->get_node( $x )->nodeType == ELEMENT_NODE;
+ my $name =
+ $names_list->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ my $auth =
+ $names_list->get_node( $x )->getAttributeNode( 'authURI' )->getValue;
+ push @{ $servicenames{$auth} }, $name;
+ }
+ return \%servicenames;
}
-
=head2 retrieveServiceProviders
Title : retrieveServiceProviders
@@ -1138,26 +1252,26 @@
=cut
-
-sub retrieveServiceProviders{
- my ($self) = shift;
+sub retrieveServiceProviders {
+ my ( $self ) = shift;
my $reg = shift;
- $reg = $reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
-# my $return = $self->SOAP_connection($reg)->call('retrieveServiceProviders' => (@_))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveServiceProviders', "");
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $providers = $root->getChildNodes;
- my @serviceproviders;
- for (my $x = 0; $x < $providers->getLength; $x++){
- next unless $providers->item($x)->getNodeType == ELEMENT_NODE;
- push @serviceproviders, $providers->item($x)->getAttributeNode('name')->getValue;
- }
- return @serviceproviders;
-}
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
+# my $return = $self->SOAP_connection($reg)->call('retrieveServiceProviders' => (@_))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'retrieveServiceProviders', "" );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $providers = $root->childNodes;
+ my @serviceproviders;
+ for ( my $x = 1 ; $x <= $providers->size() ; $x++ ) {
+ next unless $providers->get_node( $x )->nodeType == ELEMENT_NODE;
+ push @serviceproviders,
+ $providers->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ }
+ return @serviceproviders;
+}
=head2 retrieveServiceTypes
@@ -1170,35 +1284,33 @@
=cut
-
sub retrieveServiceTypes {
- my ($self) = shift;
+ my ( $self ) = shift;
my $reg = shift;
- $reg = $reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
-# my $return = $self->SOAP_connection($reg)->call('retrieveServiceTypes' => (@_))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveServiceTypes', "");
-
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $types = $root->getChildNodes;
- my %servicetypes;
- for (my $x = 0; $x < $types->getLength; $x++){
- next unless $types->item($x)->getNodeType == ELEMENT_NODE;
- my $type = $types->item($x)->getAttributeNode('name')->getValue;
- my $desc;
- for my $elem($types->item($x)->getElementsByTagName('Description')){
- $desc = $elem->getFirstChild->toString;
- }
- $servicetypes{$type} = $desc;
- }
- return \%servicetypes;
-
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
+# my $return = $self->SOAP_connection($reg)->call('retrieveServiceTypes' => (@_))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'retrieveServiceTypes', "" );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $types = $root->childNodes;
+ my %servicetypes;
+ for ( my $x = 1 ; $x <= $types->size() ; $x++ ) {
+ next unless $types->get_node( $x )->nodeType == ELEMENT_NODE;
+ my $type = $types->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ my $desc;
+ for my $elem (
+ $types->get_node( $x )->getElementsByTagName( 'Description' ) )
+ {
+ $desc = $elem->firstChild->toString;
+ }
+ $servicetypes{$type} = $desc;
+ }
+ return \%servicetypes;
}
-
=head2 retrieveObjectNames
Title : retrieveObjectNames
@@ -1210,35 +1322,34 @@
=cut
-
sub retrieveObjectNames {
- my ($self) = shift;
+ my ( $self ) = shift;
my $reg = shift;
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
- $reg = $reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
- #my $return = $self->SOAP_connection($reg)->call('retrieveObjectNames' => (@_))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveObjectNames', "");
-
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $obnames = $root->getChildNodes;
- my %objectnames;
- for (my $x = 0; $x < $obnames->getLength; $x++){
- next unless $obnames->item($x)->getNodeType == ELEMENT_NODE;
- my $name = $obnames->item($x)->getAttributeNode('name')->getValue;
- my $desc;
- for my $elem($obnames->item($x)->getElementsByTagName('Description')){
- $desc = $elem->getFirstChild->toString;
- }
- $objectnames{$name} = $desc;
- }
- return \%objectnames;
-
+#my $return = $self->SOAP_connection($reg)->call('retrieveObjectNames' => (@_))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'retrieveObjectNames', "" );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $obnames = $root->childNodes;
+ my %objectnames;
+ for ( my $x = 1 ; $x <= $obnames->size() ; $x++ ) {
+ next unless $obnames->get_node( $x )->nodeType == ELEMENT_NODE;
+ my $name =
+ $obnames->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ my $desc;
+ for my $elem (
+ $obnames->get_node( $x )->getElementsByTagName( 'Description' ) )
+ {
+ $desc = $elem->firstChild->toString;
+ }
+ $objectnames{$name} = $desc;
+ }
+ return \%objectnames;
}
-
=head2 retrieveNamespaces
Title : retrieveNamespaces
@@ -1250,34 +1361,34 @@
=cut
-
sub retrieveNamespaces {
- my ($self)= shift;
+ my ( $self ) = shift;
my $reg = shift;
- $reg = $reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
-# my $return = $self->SOAP_connection($reg)->call('retrieveNamespaces' => (@_))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveNamespaces', "");
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $namesp = $root->getChildNodes;
- my %namespaces;
- for (my $x = 0; $x < $namesp->getLength; $x++){
- next unless $namesp->item($x)->getNodeType == ELEMENT_NODE;
- my $ns = $namesp->item($x)->getAttributeNode('name')->getValue;
- my $desc;
- for my $elem($namesp->item($x)->getElementsByTagName('Description')){
- $desc = $elem->getFirstChild;
- $desc = $desc?$desc->toString:"";
- }
- $namespaces{$ns} = $desc;
- }
- return \%namespaces;
+# my $return = $self->SOAP_connection($reg)->call('retrieveNamespaces' => (@_))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'retrieveNamespaces', "" );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $namesp = $root->childNodes;
+ my %namespaces;
+ for ( my $x = 1 ; $x <= $namesp->size() ; $x++ ) {
+ next unless $namesp->get_node( $x )->nodeType == ELEMENT_NODE;
+ my $ns = $namesp->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ my $desc;
+ for my $elem (
+ $namesp->get_node( $x )->getElementsByTagName( 'Description' ) )
+ {
+ $desc = $elem->firstChild;
+ $desc = $desc ? $desc->toString : "";
+ }
+ $namespaces{$ns} = $desc;
+ }
+ return \%namespaces;
}
-
=head2 retrieveObject
NOT YET IMPLEMENTED
@@ -1291,38 +1402,39 @@
=cut
-
sub retrieveObject {
- my ($self)= shift;
- my ($reg) = shift;
- my $type = shift;
- my $message = "
+ my ( $self ) = shift;
+ my ( $reg ) = shift;
+ my $type = shift;
+ my $message = "
<retrieveObject>
<objectType>$type</objectType>
</retrieveObject>";
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
- $reg =$reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
-# my $return = $self->SOAP_connection($reg)->call('retrieveObject' => ($message))->paramsall;
- my ($return) = $self->_call($reg, 'retrieveObject', $message);
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($return);
- my $root = $doc->getDocumentElement;
- my $objects = $root->getChildNodes;
- my %objects;
- for (my $x = 0; $x < $objects->getLength; $x++){
- next unless $objects->item($x)->getNodeType == ELEMENT_NODE;
- my $name = $objects->item($x)->getAttributeNode('name')->getValue;
- my $desc;
- for my $elem($objects->item($x)->getElementsByTagName('Schema')){
- $desc = $elem->getFirstChild->getNodeValue;
- }
- $objects{$name} = $desc;
- }
- return \%objects;
+# my $return = $self->SOAP_connection($reg)->call('retrieveObject' => ($message))->paramsall;
+ my ( $return ) = $self->_call( $reg, 'retrieveObject', $message );
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $return );
+ my $root = $doc->getDocumentElement;
+ my $objects = $root->childNodes;
+ my %objects;
+ for ( my $x = 1 ; $x <= $objects->size() ; $x++ ) {
+ next unless $objects->get_node( $x )->nodeType == ELEMENT_NODE;
+ my $name =
+ $objects->get_node( $x )->getAttributeNode( 'name' )->getValue;
+ my $desc;
+ for my $elem (
+ $objects->get_node( $x )->getElementsByTagName( 'Schema' ) )
+ {
+ $desc = $elem->firstChild->nodeValue;
+ }
+ $objects{$name} = $desc;
+ }
+ return \%objects;
}
-
=head2 Relationships
Title : Relationships
@@ -1338,77 +1450,86 @@
=cut
-
sub Relationships {
- my ($self, %args) = @_;
- my $object = $args{'objectType'};
+ my ( $self, %args ) = @_;
+ my $object = $args{'objectType'};
my $service = $args{'serviceType'};
- my $expand = $args{'expandRelationships'};
- $expand = $args{'expandRelationship'} unless defined($expand); # be forgiving of typos
-
+ my $expand = $args{'expandRelationships'};
+ $expand = $args{'expandRelationship'}
+ unless defined( $expand ); # be forgiving of typos
my @relationships;
- @relationships = @{$args{'Relationships'}} if ($args{'Relationships'} && (ref($args{'Relationships'}) =~ /array/i));
+ @relationships = @{ $args{'Relationships'} }
+ if ( $args{'Relationships'}
+ && ( ref( $args{'Relationships'} ) =~ /array/i ) );
my $reg = $args{'Registry'};
- my $m; my $payload;
- return {} unless ($object || $service);
- if ($object){
+ my $m;
+ my $payload;
+ return {} unless ( $object || $service );
+
+ if ( $object ) {
$m = "
<Relationships>
<objectType>$object</objectType>\n";
- foreach (@relationships){
+ foreach ( @relationships ) {
$m .= "<relationshipType>$_</relationshipType>\n";
}
$m .= "<expandRelationship>1</expandRelationship>\n" if $expand;
- $m .= "</Relationships>";
- $reg =$reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
- #$payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
- ($payload) = $self->_call($reg, 'Relationships', $m);
- } elsif ($service){
+ $m .= "</Relationships>";
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
+
+#$payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
+ ( $payload ) = $self->_call( $reg, 'Relationships', $m );
+ } elsif ( $service ) {
$m = "
<Relationships>
<serviceType>$service</serviceType>\n";
- foreach (@relationships){
+ foreach ( @relationships ) {
$m .= "<relationshipType>$_</relationshipType>\n";
}
$m .= "<expandRelationship>1</expandRelationship>\n" if $expand;
- $m .= "</Relationships>";
- $reg =$reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
+ $m .= "</Relationships>";
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
+
# $payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
- ($payload) = $self->_call($reg, 'Relationships', $m);
+ ( $payload ) = $self->_call( $reg, 'Relationships', $m );
}
- return &_relationshipsPayload($payload);
+ return &_relationshipsPayload( $payload );
}
-
-
-sub _relationshipsPayload{
- my ($payload) = @_;
+sub _relationshipsPayload {
+ my ( $payload ) = @_;
return undef unless $payload;
- my %att_value; my %relationships;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
- my $x = $doc->getElementsByTagName("Relationship");
- my $no_relationships = $x->getLength;
- for (my $n=0; $n<$no_relationships; ++$n){
- my $relationshipType = $x->item($n)->getAttributeNode('relationshipType'); # may or may not have a name
- if ($relationshipType){$relationshipType = $relationshipType->getValue()} else {return "FAILED! must include a relationshipType in every relationship\n"}
- my @child = $x->item($n)->getChildNodes;
- foreach (@child){
- next unless $_->getNodeType == ELEMENT_NODE;
- my @child2 = $_->getChildNodes;
- foreach (@child2){
- next unless $_->getNodeType == TEXT_NODE;
- push @{$relationships{$relationshipType}}, $_->toString;
+ my %att_value;
+ my %relationships;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $x = $doc->getElementsByTagName( "Relationship" );
+ my $no_relationships = $x->size();
+ for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) {
+ my $relationshipType =
+ $x->get_node( $n )->getAttributeNode( 'relationshipType' )
+ ; # may or may not have a name
+ if ( $relationshipType ) {
+ $relationshipType = $relationshipType->getValue();
+ } else {
+ return
+ "FAILED! must include a relationshipType in every relationship\n";
+ }
+ my @child = $x->get_node( $n )->childNodes;
+ foreach ( @child ) {
+ next unless $_->nodeType == ELEMENT_NODE;
+ my @child2 = $_->childNodes;
+ foreach ( @child2 ) {
+ next unless $_->nodeType == TEXT_NODE;
+ push @{ $relationships{$relationshipType} }, $_->toString;
}
}
}
return \%relationships;
}
-
-
=head2 ISA
Title : ISA
@@ -1421,35 +1542,40 @@
=cut
-
sub ISA {
- my ($self, $class1, $class2) = @_;
- return 1 if (($class1 eq $class2) || ("moby:$class1" eq $class2) || ($class1 eq "moby:$class2"));
- my $lsid1 = $self->ObjLSID($class1);
- my $lsid2 = $self->ObjLSID($class2);
+ my ( $self, $class1, $class2 ) = @_;
+ return 1
+ if ( ( $class1 eq $class2 )
+ || ( "moby:$class1" eq $class2 )
+ || ( $class1 eq "moby:$class2" ) );
+ my $lsid1 = $self->ObjLSID( $class1 );
+ my $lsid2 = $self->ObjLSID( $class2 );
return 0 unless $lsid1 && $lsid2;
my @lsids;
- unless (@lsids = $self->ISA_CACHE($lsid1)){
- my $resp = $self->Relationships(objectType => $lsid1, expandRelationship => 1, Relationships => ['ISA']);
+ unless ( @lsids = $self->ISA_CACHE( $lsid1 ) ) {
+ my $resp = $self->Relationships(
+ objectType => $lsid1,
+ expandRelationship => 1,
+ Relationships => ['ISA']
+ );
my $lsids = $resp->{'urn:lsid:biomoby.org:objectrelation:isa'};
@lsids = @$lsids;
- $self->ISA_CACHE($lsid1, [@lsids]);
- $self->ISA_CACHE($class1, [@lsids]);
+ $self->ISA_CACHE( $lsid1, [@lsids] );
+ $self->ISA_CACHE( $class1, [@lsids] );
my @hold = @lsids;
- while (shift @hold){
- $self->ISA_CACHE($_, [@hold]);
- if ($_ =~ /^urn:lsid:biomoby.org.\w+\.(\S+)/){
- $self->ISA_CACHE($1, [@lsids]);
- }
+ while ( shift @hold ) {
+ $self->ISA_CACHE( $_, [@hold] );
+ if ( $_ =~ /^urn:lsid:biomoby.org.\w+\.(\S+)/ ) {
+ $self->ISA_CACHE( $1, [@lsids] );
+ }
}
}
- foreach (@lsids){
+ foreach ( @lsids ) {
return 1 if $_ eq $lsid2;
}
return 0;
}
-
=head2 DUMP
@@ -1462,100 +1588,113 @@
=cut
-
sub DUMP {
- my ($self)= shift;
- my ($reg) = shift;
- my $type = shift;
-
- $reg =$reg?$reg:$self->default_MOBY_servername;
- return undef unless ($self->Connection($reg));
-# return $self->SOAP_connection($reg)->call('DUMP')->paramsall;
- my ($SQLs) = $self->_call($reg, 'DUMP_MySQL', "");
- my ($mobycentral, $mobyobject, $mobyservice, $mobynamespace, $mobyrelationship) = @{$SQLs};
- return ($mobycentral, $mobyobject, $mobyservice, $mobynamespace, $mobyrelationship);
+ my ( $self ) = shift;
+ my ( $reg ) = shift;
+ my $type = shift;
+ $reg = $reg ? $reg : $self->default_MOBY_servername;
+ return undef unless ( $self->Connection( $reg ) );
+
+ # return $self->SOAP_connection($reg)->call('DUMP')->paramsall;
+ my ( $SQLs ) = $self->_call( $reg, 'DUMP_MySQL', "" );
+ my (
+ $mobycentral, $mobyobject, $mobyservice,
+ $mobynamespace, $mobyrelationship
+ )
+ = @{$SQLs};
+ return (
+ $mobycentral, $mobyobject, $mobyservice,
+ $mobynamespace, $mobyrelationship
+ );
}
-
-*DUMP_MySQL =\&DUMP;
-*DUMP_MySQL =\&DUMP;
+*DUMP_MySQL = \&DUMP;
+*DUMP_MySQL = \&DUMP;
sub _parseServices {
- my ($self, $Registry, $XML) = @_;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($XML);
- my $Object = $doc->getDocumentElement();
- my $Services = $Object->getElementsByTagName("Service");
- my $num = $Services->getLength;
- my @Services;
- for (my $x = 0; $x < $num; $x++){
- my $Service = $Services->item($x);
- my $AuthURI = $Service->getAttributeNode('authURI')->getValue;
- my $servicename = $Service->getAttributeNode('serviceName')->getValue;
- my $Type = &_nodeTextContent($Service, 'serviceType');
- my $authoritative = &_nodeTextContent($Service, 'authoritative');
- my $contactEmail = &_nodeTextContent($Service, 'contactEmail');
- my $URL = &_nodeTextContent($Service, 'URL');
- #my $Output = &_nodeTextContent($Service, 'outputObject');
- my $Description = &_nodeTextContent($Service, 'Description');
- my $cat = &_nodeTextContent($Service, 'Category');
-
+ my ( $self, $Registry, $XML ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $XML );
+ my $Object = $doc->getDocumentElement();
+ my $Services = $Object->getElementsByTagName( "Service" );
+ my $num = $Services->size();
+ my @Services;
+ for ( my $x = 1 ; $x <= $num ; $x++ ) {
+ my $Service = $Services->get_node( $x );
+ my $AuthURI = $Service->getAttributeNode( 'authURI' )->getValue;
+ my $servicename = $Service->getAttributeNode( 'serviceName' )->getValue;
+ my $Type = &_nodeTextContent( $Service, 'serviceType' );
+ my $authoritative = &_nodeTextContent( $Service, 'authoritative' );
+ my $contactEmail = &_nodeTextContent( $Service, 'contactEmail' );
+ my $URL = &_nodeTextContent( $Service, 'URL' );
+
+ #my $Output = &_nodeTextContent($Service, 'outputObject');
+ my $Description = &_nodeTextContent( $Service, 'Description' );
+ my $cat = &_nodeTextContent( $Service, 'Category' );
my @INPUTS;
my @OUTPUTS;
-
- foreach my $inout("Input", "Output"){
- my $xPuts = $Service->getElementsByTagName($inout); # there should only be one, but... who knows what
- for my $in(0..$xPuts->getLength-1){
- my $current = $xPuts->item($in);
-
- foreach my $child($current->getChildNodes){ # child nodes will be either "Simple" or "Complex" tagnames
- next unless $child->getNodeType == ELEMENT_NODE;
+ foreach my $inout ( "Input", "Output" ) {
+ my $xPuts =
+ $Service->getElementsByTagName( $inout )
+ ; # there should only be one, but... who knows what
+ for my $in ( 1 .. $xPuts->size() ) {
+ my $current = $xPuts->get_node( $in );
+ foreach my $child ( $current->childNodes )
+ { # child nodes will be either "Simple" or "Complex" tagnames
+ next unless $child->nodeType == ELEMENT_NODE;
my $THIS;
- if ($child->getTagName eq "Simple"){
- $THIS = MOBY::Client::SimpleArticle->new(XML_DOM => $child);
- } elsif ($child->getTagName eq "Collection"){
- $THIS = MOBY::Client::CollectionArticle->new(XML_DOM => $child);
+ if ( $child->nodeName eq "Simple" ) {
+ $THIS =
+ MOBY::Client::SimpleArticle->new( XML_DOM => $child );
+ } elsif ( $child->nodeName eq "Collection" ) {
+ $THIS =
+ MOBY::Client::CollectionArticle->new(
+ XML_DOM => $child );
} else {
- next
+ next;
}
- if ($inout eq "Input"){
+ if ( $inout eq "Input" ) {
push @INPUTS, $THIS;
} else {
push @OUTPUTS, $THIS;
}
}
}
- }
- my @SECONDARIES;
- my $secs = $Service->getElementsByTagName("secondaryArticles"); # there should only be one, but... who knows what
- for my $in(0..$secs->getLength-1){
- my $current = $secs->item($in);
-
- foreach my $param($current->getChildNodes){ # child nodes will be "Parameter" tag names
- next unless $param->getNodeType == ELEMENT_NODE && $param->getTagName eq "Parameter";
- my $THIS;
- $THIS = MOBY::Client::SecondaryArticle->new(XML_DOM => $param);
- push @SECONDARIES, $THIS;
- }
- }
-
- my $Instance = MOBY::Client::ServiceInstance->new(
- authority => $AuthURI,
- authoritative => $authoritative,
- URL => $URL,
- contactEmail => $contactEmail,
- name => $servicename,
- type => $Type,
- category => $cat,
- input => \@INPUTS,
- output => \@OUTPUTS,
- secondary => \@SECONDARIES,
- description => $Description,
- registry => $Registry,
- XML => $Service->toString,
- );
- push @Services, $Instance;
- }
- return \@Services;
+ }
+ my @SECONDARIES;
+ my $secs =
+ $Service->getElementsByTagName( "secondaryArticles" )
+ ; # there should only be one, but... who knows what
+ for my $in ( 1 .. $secs->size() ) {
+ my $current = $secs->get_node( $in );
+ foreach my $param ( $current->childNodes )
+ { # child nodes will be "Parameter" tag names
+ next
+ unless $param->nodeType == ELEMENT_NODE
+ && $param->nodeName eq "Parameter";
+ my $THIS;
+ $THIS =
+ MOBY::Client::SecondaryArticle->new( XML_DOM => $param );
+ push @SECONDARIES, $THIS;
+ }
+ }
+ my $Instance = MOBY::Client::ServiceInstance->new(
+ authority => $AuthURI,
+ authoritative => $authoritative,
+ URL => $URL,
+ contactEmail => $contactEmail,
+ name => $servicename,
+ type => $Type,
+ category => $cat,
+ input => \@INPUTS,
+ output => \@OUTPUTS,
+ secondary => \@SECONDARIES,
+ description => $Description,
+ registry => $Registry,
+ XML => $Service->toString,
+ );
+ push @Services, $Instance;
+ }
+ return \@Services;
}
# my ($e, $m, $lsid) = $OS->objectExists(term => $_);
@@ -1565,20 +1704,20 @@
=cut
sub ObjLSID {
- my ($self, $term) = @_;
+ my ( $self, $term ) = @_;
return undef unless $term;
my $lsid;
- if ($lsid = $self->LSID_CACHE($term)){
+ if ( $lsid = $self->LSID_CACHE( $term ) ) {
return $lsid;
} else {
my $os = MOBY::Client::OntologyServer->new;
- my ($s, $m, $tlsid) = $os->objectExists(term => $term);
- if ($tlsid){
- $self->LSID_CACHE($term, $tlsid); # link both the term
- $self->LSID_CACHE($tlsid, $tlsid); # and the lsid to itself
- return $tlsid
+ my ( $s, $m, $tlsid ) = $os->objectExists( term => $term );
+ if ( $tlsid ) {
+ $self->LSID_CACHE( $term, $tlsid ); # link both the term
+ $self->LSID_CACHE( $tlsid, $tlsid ); # and the lsid to itself
+ return $tlsid;
} else {
- return undef
+ return undef;
}
}
}
@@ -1594,20 +1733,18 @@
=cut
-
sub LSID_CACHE {
- my ($self, $term, $lsid) = @_;
- if ($term && $lsid){
+ my ( $self, $term, $lsid ) = @_;
+ if ( $term && $lsid ) {
$self->{LSID_CACHE}->{$term} = $lsid;
- return $self->{LSID_CACHE}->{$term};
- } elsif ($term){
+ return $self->{LSID_CACHE}->{$term};
+ } elsif ( $term ) {
return $self->{LSID_CACHE}->{$term};
} else {
- return undef
+ return undef;
}
}
-
=head2 ISA_CACHE
Title : ISA_CACHE
@@ -1623,143 +1760,146 @@
=cut
sub ISA_CACHE {
- my ($self, $desiredterm, $isas) = @_;
+ my ( $self, $desiredterm, $isas ) = @_;
my $term = $desiredterm;
- return (undef) if $isas && !(ref($isas)=~/ARRAY/);
- if ($term && $isas){
+ return ( undef ) if $isas && !( ref( $isas ) =~ /ARRAY/ );
+ if ( $term && $isas ) {
$self->{ISA_CACHE}->{$desiredterm} = [@$isas];
- while (my $term = shift(@$isas)){
+ while ( my $term = shift( @$isas ) ) {
$self->{ISA_CACHE}->{$term} = [@$isas];
}
- return @{$self->{ISA_CACHE}->{$desiredterm}};
- } elsif ($term && $self->{ISA_CACHE}->{$desiredterm}){
- return @{$self->{ISA_CACHE}->{$desiredterm}};
+ return @{ $self->{ISA_CACHE}->{$desiredterm} };
+ } elsif ( $term && $self->{ISA_CACHE}->{$desiredterm} ) {
+ return @{ $self->{ISA_CACHE}->{$desiredterm} };
} else {
return ();
}
}
-
sub parseRegXML {
- #<MOBYRegistration>
- # <id>$id</id>
- # <success>$success</success>
- # <message><![CDATA[$message]]></message>
- #</MOBYRegistration>
- my ($self, $xml) = @_;
- my $Parser = new XML::DOM::Parser;
+
+ #<MOBYRegistration>
+ # <id>$id</id>
+ # <success>$success</success>
+ # <message><![CDATA[$message]]></message>
+ #</MOBYRegistration>
+ my ( $self, $xml ) = @_;
+ my $Parser = XML::LibXML->new();
+
#print STDERR $xml;
- my $doc = $Parser->parse($xml);
+ my $doc = $Parser->parse_string( $xml );
my $Object = $doc->getDocumentElement();
- my $obj = $Object->getTagName;
- return undef unless ($obj eq 'MOBYRegistration');
- my $id = &_nodeTextContent($Object, 'id');
- my $success = &_nodeTextContent($Object, 'success');
- my $message = &_nodeTextContent($Object, 'message');
- my $RDF = &_nodeRawContent($Object, 'RDF');
+ my $obj = $Object->nodeName;
+ return undef unless ( $obj eq 'MOBYRegistration' );
+ my $id = &_nodeTextContent( $Object, 'id' );
+ my $success = &_nodeTextContent( $Object, 'success' );
+ my $message = &_nodeTextContent( $Object, 'message' );
+ my $RDF = &_nodeRawContent( $Object, 'RDF' );
my $reg = MOBY::Client::Registration->new(
- success => $success,
- message => $message,
- registration_id => $id,
- RDF => $RDF,
- id => $id);
- return $reg;
+ success => $success,
+ message => $message,
+ registration_id => $id,
+ RDF => $RDF,
+ id => $id
+ );
+ return $reg;
}
sub errorRegXML {
- my ($self, $message) = @_;
+ my ( $self, $message ) = @_;
my $reg = MOBY::Client::Registration->new(
- success => 0,
- message => $message,
- registration_id => -1,);
- return $reg;
+ success => 0,
+ message => $message,
+ registration_id => -1,
+ );
+ return $reg;
}
sub _nodeTextContent {
+
# will get text of **all** child $node from the given $DOM
# regardless of their depth!!
- my ($DOM, $node) = @_;
- my $x = $DOM->getElementsByTagName($node);
- unless ($x->item(0)){return};
- my @child = $x->item(0)->getChildNodes;
- my $content;
- foreach (@child){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
- next unless $_->getNodeType == TEXT_NODE;
- $content = $_->toString;
- }
- return $content;
+ my ( $DOM, $node ) = @_;
+ my $x = $DOM->getElementsByTagName( $node );
+ unless ( $x->get_node( 1 ) ) { return }
+ my @child = $x->get_node( 1 )->childNodes;
+ my $content;
+ foreach ( @child ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ next unless $_->nodeType == TEXT_NODE;
+ $content = $_->toString;
+ }
+ return $content;
}
sub _nodeRawContent {
+
# will get text of **all** child $node from the given $DOM
# regardless of their depth!!
- my ($DOM, $node) = @_;
- my $x = $DOM->getElementsByTagName($node);
- unless ($x->item(0)){return};
- my @child = $x->item(0)->getChildNodes;
- my $content;
- foreach (@child){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
-# next unless $_->getNodeType == TEXT_NODE;
- $content .= $_->toString;
- }
- return $content;
+ my ( $DOM, $node ) = @_;
+ my $x = $DOM->getElementsByTagName( $node );
+ unless ( $x->get_node( 1 ) ) { return }
+ my @child = $x->get_node( 1 )->childNodes;
+ my $content;
+ foreach ( @child ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ # next unless $_->nodeType == TEXT_NODE;
+ $content .= $_->toString;
+ }
+ return $content;
}
-
sub _nodeArrayContent {
+
# will get array content of all child $node from given $DOM
# regardless of depth!
- my ($DOM, $node) = @_;
- $debug && &_LOG("_nodeArrayContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
- my @result;
- my $x = $DOM->getElementsByTagName($node);
- my @child = $x->item(0)->getChildNodes;
- foreach (@child){
- next unless $_->getNodeType == ELEMENT_NODE;
- my @child2 = $_->getChildNodes;
- foreach (@child2){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
- next unless $_->getNodeType == TEXT_NODE;
- push @result, $_->toString;
- }
- }
- return @result;
+ my ( $DOM, $node ) = @_;
+ $debug && &_LOG( "_nodeArrayContext received DOM: ",
+ $DOM->toString, "\nsearching for node $node\n" );
+ my @result;
+ my $x = $DOM->getElementsByTagName( $node );
+ my @child = $x->get_node( 1 )->childNodes;
+ foreach ( @child ) {
+ next unless $_->nodeType == ELEMENT_NODE;
+ my @child2 = $_->childNodes;
+ foreach ( @child2 ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ next unless $_->nodeType == TEXT_NODE;
+ push @result, $_->toString;
+ }
+ }
+ return @result;
}
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
+sub DESTROY { }
sub _LOG {
return unless $debug;
@@ -1768,5 +1908,4 @@
print LOG "\n---\n";
close LOG;
}
-
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/CollectionArticle.pm,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- /home/repository/moby/moby-live/Perl/MOBY/Client/CollectionArticle.pm 2004/07/27 22:56:32 1.9
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/CollectionArticle.pm 2004/11/18 17:41:16 1.10
@@ -1,12 +1,11 @@
package MOBY::Client::CollectionArticle;
-
use strict;
use Carp;
-use XML::DOM;
+use XML::LibXML;
+use MOBY::MobyXMLConstants;
use vars qw($AUTOLOAD @ISA);
use MOBY::Client::SimpleArticle;
-
=head1 NAME
MOBY::Client::CollectionArticle - a small object describing the Collection articles from the findService Response message of MOBY Central or representing the collection part of a MOBY invocation or response block
@@ -106,7 +105,6 @@
=cut
-
=head2 articleName
Title : articleName
@@ -138,8 +136,6 @@
=cut
-
-
=head2 XML
Title : XML
@@ -150,7 +146,6 @@
=cut
-
=head2 XML_DOM
Title : XML_DOM
@@ -161,7 +156,6 @@
=cut
-
=head2 isSimple
Title : isSimple
@@ -175,7 +169,6 @@
=cut
-
=head2 isCollection
Title : isCollection
@@ -189,7 +182,6 @@
=cut
-
=head2 isSecondary
Title : isSecondary
@@ -200,150 +192,133 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- articleName => [undef, 'read/write'],
- Simples => [[], 'read/write'],
- isSimple => [0, 'read' ],
- isSecondary => [0, 'read' ],
- isCollection => [1, 'read' ],
- XML => [undef, 'read/write'],
- XML_DOM => [undef, 'read/write'],
-
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ articleName => [ undef, 'read/write' ],
+ Simples => [ [], 'read/write' ],
+ isSimple => [ 0, 'read' ],
+ isSecondary => [ 0, 'read' ],
+ isCollection => [ 1, 'read' ],
+ XML => [ undef, 'read/write' ],
+ XML_DOM => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
- sub addSimple {
- my ($self, $s) = @_;
- return $self->{Simples} unless $s;
- return 0 unless $s->isa("MOBY::Client::SimpleArticle");
- push @{$self->{Simples}}, $s;
- return $self->{Simples};
- }
+ sub addSimple {
+ my ( $self, $s ) = @_;
+ return $self->{Simples} unless $s;
+ return 0 unless $s->isa( "MOBY::Client::SimpleArticle" );
+ push @{ $self->{Simples} }, $s;
+ return $self->{Simples};
+ }
}
-
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
- if ($self->XML && ref($self->XML)){
- return 0;
- } elsif ($self->XML_DOM && !(ref($self->XML_DOM) =~ /dom/i)){
- return 0;
- }
-
-
- $self->createFromXML if ($self->XML);
- $self->createFromDOM($self->XML_DOM) if ($self->XML_DOM);
-
- return $self;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ if ( $self->XML && ref( $self->XML ) ) {
+ return 0;
+ } elsif ( $self->XML_DOM && !( ref( $self->XML_DOM ) =~ /dom/i ) ) {
+ return 0;
+ }
+ $self->createFromXML if ( $self->XML );
+ $self->createFromDOM( $self->XML_DOM ) if ( $self->XML_DOM );
+ return $self;
}
-
-
sub createFromXML {
- my ($self) = @_;
- my $p = XML::DOM::Parser->new;
- my $doc = $p->parse($self->XML);
- my $root = $doc->getDocumentElement;
- return 0 unless ($root && ($root->getTagName eq "Collection"));
- return $self->createFromDOM($root);
+ my ( $self ) = @_;
+ my $p = XML::LibXML->new;
+ my $doc = $p->parse_string( $self->XML );
+ my $root = $doc->getDocumentElement;
+ return 0 unless ( $root && ( $root->nodeName eq "Collection" ) );
+ return $self->createFromDOM( $root );
}
sub createFromDOM {
- my ($self, $dom) = @_;
- return 0 unless ($dom && ($dom->getTagName eq "Collection"));
- $self->XML($dom->toString); # set the string version of the DOM
- $self->articleName("");
- $self->Simples([]);
-
- my $attr = $dom->getAttributeNode('articleName');
- my $articleName = "";
- $articleName = $attr->getValue if $attr;
- $self->articleName($articleName);
- my $objects = $dom->getElementsByTagName("Simple");
- for my $n(0..$objects->getLength - 1){
- $self->addSimple(MOBY::Client::SimpleArticle->new(articleName=>$self->articleName, XML_DOM => $objects->item($n)));
- }
- return $self;
+ my ( $self, $dom ) = @_;
+ return 0 unless ( $dom && ( $dom->nodeName eq "Collection" ) );
+ $self->XML( $dom->toString ); # set the string version of the DOM
+ $self->articleName( "" );
+ $self->Simples( [] );
+ my $attr = $dom->getAttributeNode( 'articleName' );
+ my $articleName = "";
+ $articleName = $attr->getValue if $attr;
+ $self->articleName( $articleName );
+ my $objects = $dom->getElementsByTagName( "Simple" );
+
+ for my $n ( 1 .. $objects->size ) {
+ $self->addSimple(
+ MOBY::Client::SimpleArticle->new(
+ articleName => $self->articleName,
+ XML_DOM => $objects->get_node( $n )
+ )
+ );
+ }
+ return $self;
}
-
-
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/OntologyServer.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- /home/repository/moby/moby-live/Perl/MOBY/Client/OntologyServer.pm 2004/08/10 15:57:48 1.6
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/OntologyServer.pm 2004/11/18 17:41:16 1.7
@@ -1,6 +1,5 @@
#$Id$
-
=head1 NAME
MOBY::Client::OntologyServer - A client interface to the Ontology
@@ -8,7 +7,6 @@
=cut
-
=head1 SYNOPSIS
use MOBY::Client::OntologyServer;
@@ -72,200 +70,178 @@
=cut
-
-
package MOBY::Client::OntologyServer;
-
use strict;
use Carp;
use vars qw($AUTOLOAD);
use LWP::UserAgent;
-
my $debug = 0;
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- host => ["http://mobycentral.cbr.nrc.ca/cgi-bin/OntologyServer.cgi", 'read/write'],
- proxy => [undef, 'read/write'],
-
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ host => [
+ "http://mobycentral.cbr.nrc.ca/cgi-bin/OntologyServer.cgi",
+ 'read/write'
+ ],
+ proxy => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $caller;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname} && defined $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
-
-
- return undef unless $self->host;
- return $self;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ my $class = $caller_is_obj || $caller;
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} && defined $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ return undef unless $self->host;
+ return $self;
}
=head2 objectExists
=cut
-
-sub objectExists{
- my ($self, %args) = @_;
-
- my $term = $args{'term'};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
- my $ua = $self->getUserAgent;
- my $req = HTTP::Request->new(POST => $self->host);
- $req->content("objectExists=$term");
- my $res = $ua->request($req);
- if ($res->is_success) {
- return split "\n", $res->content;
- } else {
- return (0,"Request Failed for unknown reasons","");
- }
+sub objectExists {
+ my ( $self, %args ) = @_;
+ my $term = $args{'term'};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $ua = $self->getUserAgent;
+ my $req = HTTP::Request->new( POST => $self->host );
+ $req->content( "objectExists=$term" );
+ my $res = $ua->request( $req );
+ if ( $res->is_success ) {
+ return split "\n", $res->content;
+ } else {
+ return ( 0, "Request Failed for unknown reasons", "" );
+ }
}
-
=head2 serviceExists
=cut
-
-sub serviceExists{
- my ($self, %args) = @_;
-
- my $term = $args{'term'};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
- my $ua = $self->getUserAgent;
- my $req = HTTP::Request->new(POST => $self->host);
- $req->content("serviceExists=$term");
- my $res = $ua->request($req);
- if ($res->is_success) {
- return split "\n", $res->content;
- } else {
- return (0,"Request Failed for unknown reasons","");
- }
+sub serviceExists {
+ my ( $self, %args ) = @_;
+ my $term = $args{'term'};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $ua = $self->getUserAgent;
+ my $req = HTTP::Request->new( POST => $self->host );
+ $req->content( "serviceExists=$term" );
+ my $res = $ua->request( $req );
+ if ( $res->is_success ) {
+ return split "\n", $res->content;
+ } else {
+ return ( 0, "Request Failed for unknown reasons", "" );
+ }
}
=head2 namespaceExists
=cut
-
-sub namespaceExists{
- my ($self, %args) = @_;
-
- my $term = $args{'term'};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
- my $ua = $self->getUserAgent;
- my $req = HTTP::Request->new(POST => $self->host);
- $req->content("namespaceExists=$term");
- my $res = $ua->request($req);
- if ($res->is_success) {
- return split "\n", $res->content;
- } else {
- return (0,"Request Failed for unknown reasons","");
- }
+sub namespaceExists {
+ my ( $self, %args ) = @_;
+ my $term = $args{'term'};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $ua = $self->getUserAgent;
+ my $req = HTTP::Request->new( POST => $self->host );
+ $req->content( "namespaceExists=$term" );
+ my $res = $ua->request( $req );
+ if ( $res->is_success ) {
+ return split "\n", $res->content;
+ } else {
+ return ( 0, "Request Failed for unknown reasons", "" );
+ }
}
=head2 relationshipExists
=cut
-
-sub relationshipsExists{
- my ($self, %args) = @_;
-
- my $term = $args{'term'};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
- my $ua = $self->getUserAgent;
- my $req = HTTP::Request->new(POST => $self->host);
- $req->content("relationshipExists=$term");
- my $res = $ua->request($req);
- if ($res->is_success) {
- return split "\n", $res->content;
- } else {
- return (0,"Request Failed for unknown reasons","");
- }
+sub relationshipsExists {
+ my ( $self, %args ) = @_;
+ my $term = $args{'term'};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $ua = $self->getUserAgent;
+ my $req = HTTP::Request->new( POST => $self->host );
+ $req->content( "relationshipExists=$term" );
+ my $res = $ua->request( $req );
+ if ( $res->is_success ) {
+ return split "\n", $res->content;
+ } else {
+ return ( 0, "Request Failed for unknown reasons", "" );
+ }
}
-sub getUserAgent{
- my ($self, @args) = @_;
- my $ua = LWP::UserAgent->new;
- my $proxy = $ENV{MOBY_PROXY} if $ENV{MOBY_PROXY}; # first check the environment
- $proxy = $self->proxy if $self->proxy; # but if the object was initialized with a proxy argument then use that instead
- if($proxy){
- $ua->proxy('http', $proxy);
- }
- return $ua;
+sub getUserAgent {
+ my ( $self, @args ) = @_;
+ my $ua = LWP::UserAgent->new;
+ my $proxy = $ENV{MOBY_PROXY}
+ if $ENV{MOBY_PROXY}; # first check the environment
+ $proxy = $self->proxy
+ if $self->proxy
+ ; # but if the object was initialized with a proxy argument then use that instead
+ if ( $proxy ) {
+ $ua->proxy( 'http', $proxy );
+ }
+ return $ua;
}
-
-sub DESTROY {}
+sub DESTROY { }
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/Registration.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- /home/repository/moby/moby-live/Perl/MOBY/Client/Registration.pm 2004/08/24 20:43:33 1.6
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/Registration.pm 2004/11/18 17:41:16 1.7
@@ -1,13 +1,11 @@
#$Id$
-
=head1 NAME
MOBY::Client::Registration - an object to wrap the registration XML from MOBY Central
=cut
-
=head1 SYNOPSIS
my $reg = $Central->registerService(%args);
@@ -68,110 +66,90 @@
=cut
-
package MOBY::Client::Registration;
-
use strict;
use Carp;
use vars qw($AUTOLOAD);
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- success => [0, 'read/write'],
- message => ["OK", 'read/write'],
- registration_id => [undef, 'read/write'],
- RDF => [undef, 'read/write'],
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ success => [ 0, 'read/write' ],
+ message => [ "OK", 'read/write' ],
+ registration_id => [ undef, 'read/write' ],
+ RDF => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
}
sub id {
- my ($self, $val) =@_;
- $self->registration_id($val) if defined $val;
+ my ( $self, $val ) = @_;
+ $self->registration_id( $val ) if defined $val;
return $self->registration_id;
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $caller;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname} && defined $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
-
- return $self;
-
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ my $class = $caller_is_obj || $caller;
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} && defined $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ return $self;
}
-
-sub DESTROY {}
+sub DESTROY { }
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-
-
-
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/SecondaryArticle.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- /home/repository/moby/moby-live/Perl/MOBY/Client/SecondaryArticle.pm 2004/08/17 17:48:10 1.4
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/SecondaryArticle.pm 2004/11/18 17:41:16 1.5
@@ -1,11 +1,10 @@
package MOBY::Client::SecondaryArticle;
-
use strict;
use Carp;
-use XML::DOM;
+use XML::LibXML;
+use MOBY::MobyXMLConstants;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::Client::SecondaryArticle - a small object describing the Simple articles from the findService Response message of MOBY Central
@@ -45,7 +44,6 @@
=cut
-
=head2 articleName
Title : articleName
@@ -76,7 +74,6 @@
=cut
-
=head2 XML
Title : XML
@@ -87,7 +84,6 @@
=cut
-
=head2 XML_DOM
Title : XML_DOM
@@ -98,7 +94,6 @@
=cut
-
=head2 isSecondary
Title : isSecondary
@@ -135,243 +130,213 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- articleName => [undef, 'read/write'],
- objectType => [undef, 'read/write'],
- namespaces => [[], 'read/write'],
- XML_DOM => [undef, 'read/write'],
- XML => [undef, 'read/write'],
- isSecondary => [1, 'read' ],
- isSimple => [0, 'read' ],
- isCollection => [0, 'read' ],
- datatype => [undef, 'read/write' ],
- default => [undef, 'read/write' ],
- max => [undef, 'read/write' ],
- min => [undef, 'read/write' ],
- enum => [undef, 'read/write' ],
- value => [undef, 'read/write'],
-
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
-
- sub addEnum {
- my ($self, $enum) = @_;
- $self->{enum} = [] unless $self->{enum};
- return $self->{enum} unless defined($enum);
- push @{$self->{enum}}, $enum;
- return $self->{enum};
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ articleName => [ undef, 'read/write' ],
+ objectType => [ undef, 'read/write' ],
+ namespaces => [ [], 'read/write' ],
+ XML_DOM => [ undef, 'read/write' ],
+ XML => [ undef, 'read/write' ],
+ isSecondary => [ 1, 'read' ],
+ isSimple => [ 0, 'read' ],
+ isCollection => [ 0, 'read' ],
+ datatype => [ undef, 'read/write' ],
+ default => [ undef, 'read/write' ],
+ max => [ undef, 'read/write' ],
+ min => [ undef, 'read/write' ],
+ enum => [ undef, 'read/write' ],
+ value => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
+ sub addEnum {
+ my ( $self, $enum ) = @_;
+ $self->{enum} = [] unless $self->{enum};
+ return $self->{enum} unless defined( $enum );
+ push @{ $self->{enum} }, $enum;
+ return $self->{enum};
+ }
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
- $self->{enum} = [] unless $self->enum;
-
- if ($self->XML && ref($self->XML)){
- return 0;
- } elsif ($self->XML_DOM && !(ref($self->XML_DOM) =~ /dom/i)){
- return 0;
- }
-
- $self->createFromXML if ($self->XML);
- $self->createFromDOM($self->XML_DOM) if ($self->XML_DOM);
-
-
- return $self;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ $self->{enum} = [] unless $self->enum;
+ if ( $self->XML && ref( $self->XML ) ) {
+ return 0;
+ } elsif ( $self->XML_DOM && !( ref( $self->XML_DOM ) =~ /dom/i ) ) {
+ return 0;
+ }
+ $self->createFromXML if ( $self->XML );
+ $self->createFromDOM( $self->XML_DOM ) if ( $self->XML_DOM );
+ return $self;
}
sub createFromXML {
- my ($self) = @_;
- my $p = XML::DOM::Parser->new;
- my $doc = $p->parse($self->XML);
- my $root = $doc->getDocumentElement;
- return 0 unless ($root && ($root->getTagName eq "Parameter"));
- return $self->createFromDOM($root);
+ my ( $self ) = @_;
+ my $p = XML::LibXML->new;
+ my $doc = $p->parse_string( $self->XML );
+ my $root = $doc->getDocumentElement;
+ return 0 unless ( $root && ( $root->nodeName eq "Parameter" ) );
+ return $self->createFromDOM( $root );
}
sub createFromDOM {
- my ($self, $dom) = @_;
- return 0 unless ($dom && ($dom->getTagName eq "Parameter"));
- $self->XML($dom->toString); # set the string version of the DOM
-
- $self->namespaces([]); # reset!
- $self->articleName("");
- $self->objectType("");
-
- my $attr = $dom->getAttributeNode('articleName');
- my $articleName = "";
- $articleName = $attr->getValue if $attr;
- $self->articleName($articleName);
-
- if (@{$dom->getElementsByTagName('Value')}[0]){
- return $self->_createInstantiatedArticle($dom)
- } else {
- return $self->_createTemplateArticle($dom)
- }
+ my ( $self, $dom ) = @_;
+ return 0 unless ( $dom && ( $dom->nodeName eq "Parameter" ) );
+ $self->XML( $dom->toString ); # set the string version of the DOM
+ $self->namespaces( [] ); # reset!
+ $self->articleName( "" );
+ $self->objectType( "" );
+ my $attr = $dom->getAttributeNode( 'articleName' );
+ my $articleName = "";
+ $articleName = $attr->getValue if $attr;
+ $self->articleName( $articleName );
+
+ if ( @{ $dom->getElementsByTagName( 'Value' ) }[0] ) {
+ return $self->_createInstantiatedArticle( $dom );
+ } else {
+ return $self->_createTemplateArticle( $dom );
+ }
}
sub _createTemplateArticle {
- my ($self, $dom) = @_;
- #datatype => [undef, 'read/write' ],
- #default => [undef, 'read/write' ],
- #max => [undef, 'read/write' ],
- #min => [undef, 'read/write' ],
- #enum => [[], 'read/write' ],
-
- my $objects = $dom->getElementsByTagName("datatype");
- if ($objects->item(0)){
- my $data;
- foreach my $child($objects->item(0)->getChildNodes){
- next unless $child->getNodeType == TEXT_NODE;
- $data .= $child->toString;
- $data =~ s/\s//g;
- }
- $self->datatype($data);
- }
-
- $objects = $dom->getElementsByTagName("default");
- if ($objects->item(0)){
- my $def;
- foreach my $child($objects->item(0)->getChildNodes){
- next unless $child->getNodeType == TEXT_NODE;
- $def .= $child->toString;
- $def =~ s/\s//g;
- }
- $self->default($def);
- }
-
- $objects = $dom->getElementsByTagName("max");
- if ($objects->item(0)){
- my $max;
- foreach my $child($objects->item(0)->getChildNodes){
- next unless $child->getNodeType == TEXT_NODE;
- $max .= $child->toString;
- $max =~ s/\s//g;
- }
- $self->max($max);
- }
-
- $objects = $dom->getElementsByTagName("min");
- if ($objects->item(0)){
- my $min;
- foreach my $child($objects->item(0)->getChildNodes){
- next unless $child->getNodeType == TEXT_NODE;
- $min .= $child->toString;
- $min =~ s/\s//g;
- }
- $self->min($min);
- }
-
- $objects = $dom->getElementsByTagName("enum");
- if ($objects->item(0)){
- foreach (0..$objects->getLength-1){
- foreach my $child($objects->item($_)->getChildNodes){
- my $val;
- next unless $child->getNodeType == TEXT_NODE;
- $val = $child->toString;
- next unless defined($val);
- $val =~ s/^\s//; $val =~ s/\s$//;
- $self->addEnum($val);
- }
- }
- }
-
- return $self;
-
-}
+ my ( $self, $dom ) = @_;
-sub _createInstantiatedArticle {
- my ($self, $dom) = @_;
-#<Parameter articleName='foo'><Value>43764</Value></Parameter>
- my $values = $dom->getElementsByTagName('Value');
- foreach my $child($values->item(0)->getChildNodes){
- next unless $child->getNodeType == TEXT_NODE;
- $self->value($self->value . $child->toString);
- }
-
+ #datatype => [undef, 'read/write' ],
+ #default => [undef, 'read/write' ],
+ #max => [undef, 'read/write' ],
+ #min => [undef, 'read/write' ],
+ #enum => [[], 'read/write' ],
+ my $objects = $dom->getElementsByTagName( "datatype" );
+ if ( $objects->get_node( 1 ) ) {
+ my $data;
+ foreach my $child ( $objects->get_node( 1 )->childNodes ) {
+ next unless $child->nodeType == TEXT_NODE;
+ $data .= $child->toString;
+ $data =~ s/\s//g;
+ }
+ $self->datatype( $data );
+ }
+ $objects = $dom->getElementsByTagName( "default" );
+ if ( $objects->get_node( 1 ) ) {
+ my $def;
+ foreach my $child ( $objects->get_node( 1 )->childNodes ) {
+ next unless $child->nodeType == TEXT_NODE;
+ $def .= $child->toString;
+ $def =~ s/\s//g;
+ }
+ $self->default( $def );
+ }
+ $objects = $dom->getElementsByTagName( "max" );
+ if ( $objects->get_node( 1 ) ) {
+ my $max;
+ foreach my $child ( $objects->get_node( 1 )->childNodes ) {
+ next unless $child->nodeType == TEXT_NODE;
+ $max .= $child->toString;
+ $max =~ s/\s//g;
+ }
+ $self->max( $max );
+ }
+ $objects = $dom->getElementsByTagName( "min" );
+ if ( $objects->get_node( 1 ) ) {
+ my $min;
+ foreach my $child ( $objects->get_node( 1 )->childNodes ) {
+ next unless $child->nodeType == TEXT_NODE;
+ $min .= $child->toString;
+ $min =~ s/\s//g;
+ }
+ $self->min( $min );
+ }
+ $objects = $dom->getElementsByTagName( "enum" );
+ if ( $objects->get_node( 1 ) ) {
+ foreach ( 1 .. $objects->size() ) {
+ foreach my $child ( $objects->get_node( $_ )->childNodes ) {
+ my $val;
+ next unless $child->nodeType == TEXT_NODE;
+ $val = $child->toString;
+ next unless defined( $val );
+ $val =~ s/^\s//;
+ $val =~ s/\s$//;
+ $self->addEnum( $val );
+ }
+ }
+ }
+ return $self;
}
+sub _createInstantiatedArticle {
+ my ( $self, $dom ) = @_;
-
-
+ #<Parameter articleName='foo'><Value>43764</Value></Parameter>
+ my $values = $dom->getElementsByTagName( 'Value' );
+ foreach my $child ( $values->get_node( 1 )->childNodes ) {
+ next unless $child->nodeType == TEXT_NODE;
+ $self->value( $self->value . $child->toString );
+ }
+}
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/Service.pm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- /home/repository/moby/moby-live/Perl/MOBY/Client/Service.pm 2004/08/10 15:57:48 1.12
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/Service.pm 2004/11/18 17:41:16 1.13
@@ -40,90 +40,77 @@
=cut
-
package MOBY::Client::Service;
use SOAP::Lite;
+
#use SOAP::Lite + 'trace';
use strict;
use Carp;
use Cwd;
use URI::Escape;
-
use vars qw($AUTOLOAD @ISA);
-
my $debug = 0;
-
-if ($debug){open (OUT, ">/tmp/ServiceCallLogOut.txt") || die "cant open logfile\n";close OUT;}
-
+if ( $debug ) {
+ open( OUT, ">/tmp/ServiceCallLogOut.txt" ) || die "cant open logfile\n";
+ close OUT;
+}
sub BEGIN {
-
-
}
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- service => [undef, 'read/write'],
- uri => [undef, 'read/write'],
- ServiceName => [undef, 'read/write'],
- _soapService => [undef, 'read/write'],
-
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
-
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ service => [ undef, 'read/write' ],
+ uri => [ undef, 'read/write' ],
+ ServiceName => [ undef, 'read/write' ],
+ _soapService => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
my $queryID = 0;
+
sub _nextQueryID {
- return ++$queryID
+ return ++$queryID;
}
-
}
-
-
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $caller;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ my $class = $caller_is_obj || $caller;
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
#my $dir = cwd;
-
# seems to be a bug in SOAP::Lite that the WSDL document
# fails a parse if it is passed as a scalar rather than a file
# this section can be removed when this bug is fixed
@@ -131,20 +118,16 @@
#print OUT $self->service;
#close OUT;
# ________________________________________
-
- my $wsdl = URI::Escape::uri_escape($self->service); # this seems to fix the bug
- return undef unless $wsdl;
- my $soap = SOAP::Lite->service("data:,$wsdl");
- if ($self->uri){$soap->uri($self->uri)}
-
- $self->ServiceName(&getServiceName($soap));
- $self->_soapService($soap);
- return $self;
-
+ my $wsdl =
+ URI::Escape::uri_escape( $self->service ); # this seems to fix the bug
+ return undef unless $wsdl;
+ my $soap = SOAP::Lite->service( "data:,$wsdl" );
+ if ( $self->uri ) { $soap->uri( $self->uri ) }
+ $self->ServiceName( &getServiceName( $soap ) );
+ $self->_soapService( $soap );
+ return $self;
}
-
-
=head2 execute
Title : execute
@@ -196,36 +179,41 @@
=cut
-
sub execute {
- my ($self, %args) = @_;
- return "ERROR: expected listref for XMLinputlist" unless (ref($args{XMLinputlist}) =~ /array/i);
- my @inputs = @{$args{XMLinputlist}};
- my $data;
- foreach (@inputs){
- return "ERROR: expected listref [articleName, XML] for data element" unless (ref($_) =~ /array/i);
+ my ( $self, %args ) = @_;
+ return "ERROR: expected listref for XMLinputlist"
+ unless ( ref( $args{XMLinputlist} ) =~ /array/i );
+ my @inputs = @{ $args{XMLinputlist} };
+ my $data;
+ foreach ( @inputs ) {
+ return "ERROR: expected listref [articleName, XML] for data element"
+ unless ( ref( $_ ) =~ /array/i );
my $qID = $self->_nextQueryID;
- $data .= "<moby:mobyData queryID='$qID'>";
- while (my ($articleName, $XML) = splice (@{$_}, 0, 2)){
- if (!(ref($XML)=~/array/i)){
- $articleName ||="";
- $XML ||= "";
- if (($XML =~ /\<Value\>/) || ($XML =~ /\<moby\:Value\>/)){
- $data .= "<moby:Parameter moby:articleName='$articleName'>$XML</moby:Parameter>";
- } else {
- $data .= "<moby:Simple moby:articleName='$articleName'>\n$XML\n</moby:Simple>\n";
- }
- # need to do this for collections also!!!!!!
- } elsif (ref($XML)=~/array/i){
- my @objs = @{$XML};
- $data .="<moby:Collection moby:articleName='$articleName'>\n";
- foreach (@objs){
- $data .= "<moby:Simple>$_</moby:Simple>\n";
- }
- $data .="</moby:Collection>\n";
- }
- }
- $data .="</moby:mobyData>\n";
+ $data .= "<moby:mobyData queryID='$qID'>";
+ while ( my ( $articleName, $XML ) = splice( @{$_}, 0, 2 ) ) {
+ if ( !( ref( $XML ) =~ /array/i ) ) {
+ $articleName ||= "";
+ $XML ||= "";
+ if ( ( $XML =~ /\<Value\>/ ) || ( $XML =~ /\<moby\:Value\>/ ) )
+ {
+ $data .=
+"<moby:Parameter moby:articleName='$articleName'>$XML</moby:Parameter>";
+ } else {
+ $data .=
+"<moby:Simple moby:articleName='$articleName'>\n$XML\n</moby:Simple>\n";
+ }
+
+ # need to do this for collections also!!!!!!
+ } elsif ( ref( $XML ) =~ /array/i ) {
+ my @objs = @{$XML};
+ $data .= "<moby:Collection moby:articleName='$articleName'>\n";
+ foreach ( @objs ) {
+ $data .= "<moby:Simple>$_</moby:Simple>\n";
+ }
+ $data .= "</moby:Collection>\n";
+ }
+ }
+ $data .= "</moby:mobyData>\n";
}
$data = "<![CDATA[<?xml version='1.0' encoding='UTF-8'?>
<moby:MOBY xmlns:moby='http://www.biomoby.org/moby-s'>
@@ -234,13 +222,12 @@
</moby:mobyContent>
</moby:MOBY>]]>";
my $METHOD = $self->ServiceName;
- &_LOG(%args, $METHOD);
+ &_LOG( %args, $METHOD );
my $response;
- eval {($response) = $self->_soapService->$METHOD($data)};
- return $@?"":$response; # the service execution failed then pass back ""
+ eval { ( $response ) = $self->_soapService->$METHOD( $data ) };
+ return $@ ? "" : $response; # the service execution failed then pass back ""
}
-
=head2 ServiceName
Title : ServiceName
@@ -251,58 +238,51 @@
=cut
-
sub getServiceName {
- my ($service) = @_;
+ my ( $service ) = @_;
no strict;
- my($method) = @{join '::', ref $service, 'EXPORT_OK'};
+ my ( $method ) = @{ join '::', ref $service, 'EXPORT_OK' };
return $method;
-
}
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
sub SOAP::Transport::HTTP::Client::get_basic_credentials {
- my ($username, $password);
- print "ENTER USERNAME: "; $username=<STDIN>; chomp $username;
- print "ENTER PASSWORD: "; $password=<STDIN>; chomp $password;
-
- return $username => $password;
+ my ( $username, $password );
+ print "ENTER USERNAME: ";
+ $username = <STDIN>;
+ chomp $username;
+ print "ENTER PASSWORD: ";
+ $password = <STDIN>;
+ chomp $password;
+ return $username => $password;
}
-
sub _LOG {
return unless $debug;
open LOG, ">>/tmp/ServiceCallLogOut.txt" or die "can't open logfile $!\n";
@@ -310,12 +290,11 @@
print LOG "\n---\n";
close LOG;
}
+
#
#
# --------------------------------------------------------------------------------------------------------
#
##
##
-
-
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/ServiceInstance.pm,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- /home/repository/moby/moby-live/Perl/MOBY/Client/ServiceInstance.pm 2004/08/18 23:06:03 1.12
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/ServiceInstance.pm 2004/11/18 17:41:16 1.13
@@ -1,10 +1,8 @@
package MOBY::Client::ServiceInstance;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::Client::ServiceInstance - a small object describing a MOBY service
@@ -67,7 +65,6 @@
=cut
-
=head2 authority
Title : authority
@@ -130,7 +127,6 @@
=cut
-
=head2 authoritative
Title : authoritative
@@ -141,7 +137,6 @@
=cut
-
=head2 URL
Title : URL
@@ -152,7 +147,6 @@
=cut
-
=head2 contactEmail
Title : contactEmail
@@ -163,7 +157,6 @@
=cut
-
=head2 registry
Title : registry
@@ -174,110 +167,96 @@
=cut
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- authority => [undef, 'read/write'],
- name => [undef, 'read/write'],
- type => [undef, 'read/write'],
- input => [undef, 'read/write'], # listref of Simple and Collection articles
- output => [undef, 'read/write'], # listref of Simple and Collection articles
- secondary => [undef, 'read/write'], # listref of SecondaryArticles
- category => [undef, 'read/write'],
- description => [undef, 'read/write'],
- registry => ['MOBY_Central', 'read/write'],
- XML => [undef, 'read/write'],
- authoritative => [undef, 'read/write'],
- URL => [undef, 'read/write'],
- contactEmail => [undef, 'read/write'],
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ authority => [ undef, 'read/write' ],
+ name => [ undef, 'read/write' ],
+ type => [ undef, 'read/write' ],
+ input => [ undef, 'read/write' ]
+ , # listref of Simple and Collection articles
+ output => [ undef, 'read/write' ]
+ , # listref of Simple and Collection articles
+ secondary => [ undef, 'read/write' ], # listref of SecondaryArticles
+ category => [ undef, 'read/write' ],
+ description => [ undef, 'read/write' ],
+ registry => [ 'MOBY_Central', 'read/write' ],
+ XML => [ undef, 'read/write' ],
+ authoritative => [ undef, 'read/write' ],
+ URL => [ undef, 'read/write' ],
+ contactEmail => [ undef, 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
-
- $self->input([]) unless $self->input;
- $self->output([]) unless $self->output;
- $self->secondary([]) unless $self->secondary;
-
- return $self;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ $self->input( [] ) unless $self->input;
+ $self->output( [] ) unless $self->output;
+ $self->secondary( [] ) unless $self->secondary;
+ return $self;
}
-
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleArticle.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleArticle.pm 2004/06/15 00:37:55 1.5
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleArticle.pm 2004/11/18 17:41:16 1.6
@@ -1,11 +1,10 @@
package MOBY::Client::SimpleArticle;
-
use strict;
use Carp;
-use XML::DOM;
+use XML::LibXML;
+use MOBY::MobyXMLConstants;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::Client::SimpleArticle - a small object describing the Simple articles from the findService Response message of MOBY Central
@@ -67,7 +66,6 @@
=cut
-
=head2 articleName
Title : articleName
@@ -98,7 +96,6 @@
=cut
-
=head2 XML
Title : XML
@@ -109,7 +106,6 @@
=cut
-
=head2 XML_DOM
Title : XML_DOM
@@ -120,7 +116,6 @@
=cut
-
=head2 addNamespace
Title : addNamespace
@@ -143,7 +138,6 @@
=cut
-
=head2 isCollection
Title : isCollection
@@ -157,7 +151,6 @@
=cut
-
=head2 isSecondary
Title : isSecondary
@@ -168,202 +161,185 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- articleName => [undef, 'read/write'],
- objectType => [undef, 'read/write'],
- namespaces => [[], 'read/write'],
- id => [undef, 'read/write'],
- XML_DOM => [undef, 'read/write'],
- XML => [undef, 'read/write'],
- isSecondary => [0, 'read' ],
- isSimple => [1, 'read' ],
- isCollection => [0, 'read' ],
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
-
- sub addNamespace {
- my ($self, $ns) = @_;
- return $self->{namespaces} unless $ns;
- push @{$self->{namespaces}}, $ns;
- return $self->{namespaces};
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ articleName => [ undef, 'read/write' ],
+ objectType => [ undef, 'read/write' ],
+ namespaces => [ [], 'read/write' ],
+ id => [ undef, 'read/write' ],
+ XML_DOM => [ undef, 'read/write' ],
+ XML => [ undef, 'read/write' ],
+ isSecondary => [ 0, 'read' ],
+ isSimple => [ 1, 'read' ],
+ isCollection => [ 0, 'read' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
+ sub addNamespace {
+ my ( $self, $ns ) = @_;
+ return $self->{namespaces} unless $ns;
+ push @{ $self->{namespaces} }, $ns;
+ return $self->{namespaces};
+ }
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
-
- if ($self->XML && ref($self->XML)){
- return 0;
- } elsif ($self->XML_DOM && !(ref($self->XML_DOM) =~ /dom/i)){
- return 0;
- }
-
- $self->createFromXML if ($self->XML);
- $self->createFromDOM($self->XML_DOM) if ($self->XML_DOM);
-
-
- return $self;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ if ( $self->XML && ref( $self->XML ) ) {
+ return 0;
+ } elsif ( $self->XML_DOM && !( ref( $self->XML_DOM ) =~ /dom/i ) ) {
+ return 0;
+ }
+ $self->createFromXML if ( $self->XML );
+ $self->createFromDOM( $self->XML_DOM ) if ( $self->XML_DOM );
+ return $self;
}
sub createFromXML {
- my ($self) = @_;
- my $p = XML::DOM::Parser->new;
- my $doc = $p->parse($self->XML);
- my $root = $doc->getDocumentElement;
- return 0 unless ($root && ($root->getTagName eq "Simple"));
- return $self->createFromDOM($root);
+ my ( $self ) = @_;
+ my $p = XML::LibXML->new;
+ my $doc = $p->parse_string( $self->XML );
+ my $root = $doc->getDocumentElement;
+ return 0 unless ( $root && ( $root->nodeName eq "Simple" ) );
+ return $self->createFromDOM( $root );
}
sub createFromDOM {
- my ($self, $dom) = @_;
- return 0 unless ($dom && ($dom->getTagName eq "Simple"));
- $self->XML($dom->toString); # set the string version of the DOM
- $self->namespaces([]); # reset!
- $self->articleName("");
- $self->objectType("");
-
- my $attr = $dom->getAttributeNode('articleName');
- my $articleName = "";
- $articleName = $attr->getValue if $attr;
- $self->articleName($articleName) if $articleName; # it may have already been set if this Simple is part of a Collection...
-
+ my ( $self, $dom ) = @_;
+ return 0 unless ( $dom && ( $dom->nodeName eq "Simple" ) );
+ $self->XML( $dom->toString ); # set the string version of the DOM
+ $self->namespaces( [] ); # reset!
+ $self->articleName( "" );
+ $self->objectType( "" );
+ my $attr = $dom->getAttributeNode( 'articleName' );
+ my $articleName = "";
+ $articleName = $attr->getValue if $attr;
+ $self->articleName( $articleName )
+ if $articleName
+ ; # it may have already been set if this Simple is part of a Collection...
+
# fork here - it may be an instantiated object (coming from a service invocation/response)
# or it may be a template object as in the SimpleArticle element of a registration call
-
# if the objectType tag exists, then it is a template object
- if (@{$dom->getElementsByTagName("objectType")}[0]){
- return $self->_createTemplateArticle($dom)
- }
- else { return $self->_createInstantiatedArticle($dom)}
-# otherwise it should simpy contain an instantiated MOBY object
-
+ if ( @{ $dom->getElementsByTagName( "objectType" ) }[0] ) {
+ return $self->_createTemplateArticle( $dom );
+ } else {
+ return $self->_createInstantiatedArticle( $dom );
+ }
+ # otherwise it should simpy contain an instantiated MOBY object
}
sub _createInstantiatedArticle {
- my ($self, $dom) = @_;
-
- # this will take a <Simple> node from a MOBY invocation message
- # and extract the object-type and namespace from the
- # contained data object
-
- foreach my $child($dom->getChildNodes){ # there should be only one child node, and that is the data object itself; ignore whitespace
- next unless $child->getNodeType == ELEMENT_NODE;
- $self->objectType($child->getTagName);
- my $attr = $child->getAttributeNode('namespace');
- $self->addNamespace($attr->getValue) if $attr;
- my $id = $child->getAttributeNode('id');
- $self->id($id->getValue) if $id;
- }
- return $self;
+ my ( $self, $dom ) = @_;
+
+ # this will take a <Simple> node from a MOBY invocation message
+ # and extract the object-type and namespace from the
+ # contained data object
+ foreach my $child ( $dom->childNodes )
+ { # there should be only one child node, and that is the data object itself; ignore whitespace
+ next unless $child->nodeType == ELEMENT_NODE;
+ $self->objectType( $child->nodeName );
+ my $attr = $child->getAttributeNode( 'namespace' );
+ $self->addNamespace( $attr->getValue ) if $attr;
+ my $id = $child->getAttributeNode( 'id' );
+ $self->id( $id->getValue ) if $id;
+ }
+ return $self;
}
sub _createTemplateArticle {
- my ($self, $dom) = @_;
-
- # this will take a <Simple> node from a MOBY findServiceResponse
- # message and extract the objectType and namespace array
- # from the service signature.
-
- my $objects = $dom->getElementsByTagName("objectType");
- foreach my $child($objects->item(0)->getChildNodes){ # there must be only one in a simple! so take element 0
- next unless $child->getNodeType == TEXT_NODE;
- $self->objectType($child->toString);
- }
-
- $objects = $dom->getElementsByTagName("Namespace");
- foreach (0..$objects->getLength-1){
- foreach my $child($objects->item($_)->getChildNodes){ # there must be only one in a simple! so take element 0
- next unless $child->getNodeType == TEXT_NODE;
- next unless $child->toString;
- $self->addNamespace($child->toString);
- }
- }
- return $self;
-}
+ my ( $self, $dom ) = @_;
-sub value {
- my ($self) = @_;
- # ????? what to do here ????
-
+ # this will take a <Simple> node from a MOBY findServiceResponse
+ # message and extract the objectType and namespace array
+ # from the service signature.
+ my $objects = $dom->getElementsByTagName( "objectType" );
+ foreach my $child ( $objects->get_node( 1 )->getChildNodes )
+ { # there must be only one in a simple! so take first element
+ next unless $child->nodeType == TEXT_NODE;
+ $self->objectType( $child->toString );
+ }
+ $objects = $dom->getElementsByTagName( "Namespace" );
+ foreach ( 1 .. $objects->size() ) {
+ foreach my $child ( $objects->get_node( $_ )->childNodes )
+ { # there must be only one in a simple! so take element 0
+ next unless $child->nodeType == TEXT_NODE;
+ next unless $child->toString;
+ $self->addNamespace( $child->toString );
+ }
+ }
+ return $self;
}
-sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
+sub value {
+ my ( $self ) = @_;
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
+ # ????? what to do here ????
+}
+sub AUTOLOAD {
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleInput.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleInput.pm 2004/06/16 01:15:30 1.1
+++ /home/repository/moby/moby-live/Perl/MOBY/Client/SimpleInput.pm 2004/11/18 17:41:16 1.2
@@ -1,11 +1,8 @@
package MOBY::Client::SimpleInput;
-
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::Client::SimpleInput - a small object describing a MOBY service
@@ -34,7 +31,6 @@
namespaces => \@namesapces (optional)
=cut
-
=head2 articleName
Title : articleName
@@ -62,7 +58,6 @@
=cut
-
=head2 addNamespace
Title : addNamespace
@@ -73,103 +68,88 @@
=cut
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- articleName => [undef, 'read/write'],
- objectType => [undef, 'read/write'],
- namespaces => [[], 'read/write'],
- );
-
- #_____________________________________________________________
-
- # METHODS, to operate on encapsulated class data
-
- # Is a specified object attribute accessible in a given mode
- sub _accessible {
- my ($self, $attr, $mode) = @_;
- $_attr_data{$attr}[1] =~ /$mode/
- }
-
- # Classwide default value for a specified object attribute
- sub _default_for {
- my ($self, $attr) = @_;
- $_attr_data{$attr}[0];
- }
-
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
-
- sub addNamespace {
- my ($self, $ns) = @_;
- return $self->{namespaces} unless $ns;
- push @{$self->{namespaces}}, $ns;
- return $self->{namespaces};
- }
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ articleName => [ undef, 'read/write' ],
+ objectType => [ undef, 'read/write' ],
+ namespaces => [ [], 'read/write' ],
+ );
+
+ #_____________________________________________________________
+ # METHODS, to operate on encapsulated class data
+ # Is a specified object attribute accessible in a given mode
+ sub _accessible {
+ my ( $self, $attr, $mode ) = @_;
+ $_attr_data{$attr}[1] =~ /$mode/;
+ }
+ # Classwide default value for a specified object attribute
+ sub _default_for {
+ my ( $self, $attr ) = @_;
+ $_attr_data{$attr}[0];
+ }
+
+ # List of names of all specified object attributes
+ sub _standard_keys {
+ keys %_attr_data;
+ }
+
+ sub addNamespace {
+ my ( $self, $ns ) = @_;
+ return $self->{namespaces} unless $ns;
+ push @{ $self->{namespaces} }, $ns;
+ return $self->{namespaces};
+ }
}
sub new {
- my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ my ( $caller, %args ) = @_;
+ my $caller_is_obj = ref( $caller );
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
- foreach my $attrname ( $self->_standard_keys ) {
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- }
-
- return $self;
-
+ my $self = bless {}, $class;
+ foreach my $attrname ( $self->_standard_keys ) {
+ if ( exists $args{$attrname} ) {
+ $self->{$attrname} = $args{$attrname};
+ } elsif ( $caller_is_obj ) {
+ $self->{$attrname} = $caller->{$attrname};
+ } else {
+ $self->{$attrname} = $self->_default_for( $attrname );
+ }
+ }
+ return $self;
}
-
sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
+ no strict "refs";
+ my ( $self, $newval ) = @_;
+ $AUTOLOAD =~ /.*::(\w+)/;
+ my $attr = $1;
+ if ( $self->_accessible( $attr, 'write' ) ) {
+ *{$AUTOLOAD} = sub {
+ if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
+ if ( defined $newval ) {
+ $self->{$attr} = $newval;
+ }
+ return $self->{$attr};
+ } elsif ( $self->_accessible( $attr, 'read' ) ) {
+ *{$AUTOLOAD} = sub {
+ return $_[0]->{$attr};
+ }; ### end of created subroutine
+ return $self->{$attr};
}
- return $self->{$attr};
-
- } elsif ($self->_accessible($attr,'read')) {
-
- *{$AUTOLOAD} = sub {
- return $_[0]->{$attr} }; ### end of created subroutine
- return $self->{$attr} }
-
- # Must have been a mistake then...
- croak "No such method: $AUTOLOAD";
+ # Must have been a mistake then...
+ croak "No such method: $AUTOLOAD";
}
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
More information about the MOBY-guts
mailing list