[MOBY-guts] biomoby commit
Eddie Kawas
kawas at pub.open-bio.org
Thu Nov 18 17:38:44 UTC 2004
kawas
Thu Nov 18 12:41:15 EST 2004
Update of /home/repository/moby/moby-live/Perl/MOBY
In directory pub.open-bio.org:/tmp/cvs-serv13854
Modified Files:
Central.pm CommonSubs.pm Config.pm CrossReference.pm
OntologyServer.pm authority.pm central_db_connection.pm
collection_input.pm collection_output.pm dbConfig.pm mysql.pm
secondary_input.pm service_instance.pm service_type.pm
simple_input.pm simple_output.pm
Log Message:
Converted XML:DOM -> XML::LibXML and applicable module calls
Eddie
moby-live/Perl/MOBY Central.pm,1.141,1.142 CommonSubs.pm,1.53,1.54 Config.pm,1.5,1.6 CrossReference.pm,1.2,1.3 OntologyServer.pm,1.45,1.46 authority.pm,1.1,1.2 central_db_connection.pm,1.5,1.6 collection_input.pm,1.2,1.3 collection_output.pm,1.2,1.3 dbConfig.pm,1.3,1.4 mysql.pm,1.1,1.2 secondary_input.pm,1.1,1.2 service_instance.pm,1.8,1.9 service_type.pm,1.1,1.2 simple_input.pm,1.4,1.5 simple_output.pm,1.3,1.4
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Central.pm,v
retrieving revision 1.141
retrieving revision 1.142
diff -u -r1.141 -r1.142
--- /home/repository/moby/moby-live/Perl/MOBY/Central.pm 2004/09/16 22:21:01 1.141
+++ /home/repository/moby/moby-live/Perl/MOBY/Central.pm 2004/11/18 17:41:14 1.142
@@ -10,7 +10,7 @@
use strict;
use Carp;
use vars qw($AUTOLOAD $WSDL_TEMPLATE);
-use XML::DOM;
+use XML::LibXML;
use MOBY::OntologyServer;
use MOBY::service_type;
use MOBY::authority;
@@ -30,10 +30,14 @@
use RDF::Core::Model::Serializer;
use RDF::Core::Storage::Memory;
use RDF::Core::Constants qw(:xml :rdf :rdfs);
-
+use MOBY::MobyXMLConstants;
my $debug = 0;
-if ($debug){open (OUT, ">/tmp/CentralRegistryLogOut.txt") || die "cant open logfile\n";print OUT "created logfile\n";close OUT;}
+if ( $debug ) {
+ open( OUT, ">/tmp/CentralRegistryLogOut.txt" ) || die "cant open logfile\n";
+ print OUT "created logfile\n";
+ close OUT;
+}
=head1 SYNOPSIS
@@ -86,7 +90,6 @@
=cut
-
=head1 CONFIGURATION
This depends on a config file to get its database connection information. At a minimum
@@ -130,7 +133,6 @@
=cut
-
=head1 Registration XML Object
This is sent back to you for all registration and
@@ -155,22 +157,20 @@
=cut
-
sub Registration {
- my ( $details) = @_;
- my $id = $details->{id};
- my $success = $details->{success};
- my $message = $details->{message};
- my $RDF = "";
- $RDF = $details->{RDF};
-
-
-# return "<MOBYRegistration>
-# <id>$id</id>
-# <success>$success</success>
-# <message><![CDATA[$message]]></message>
-# <RDF><![CDATA[$RDF]]></RDF>
-# </MOBYRegistration>";
+ my ( $details ) = @_;
+ my $id = $details->{id};
+ my $success = $details->{success};
+ my $message = $details->{message};
+ my $RDF = "";
+ $RDF = $details->{RDF};
+
+ # return "<MOBYRegistration>
+ # <id>$id</id>
+ # <success>$success</success>
+ # <message><![CDATA[$message]]></message>
+ # <RDF><![CDATA[$RDF]]></RDF>
+ # </MOBYRegistration>";
return "<MOBYRegistration>
<id>$id</id>
<success>$success</success>
@@ -178,9 +178,12 @@
<RDF>$RDF</RDF>
</MOBYRegistration>";
}
-
=cut
+
+
+
+
=head1 METHODS
@@ -192,14 +195,12 @@
=cut
-
sub new {
- my ($caller, %args) = @_;
+ my ( $caller, %args ) = @_;
print STDERR "\nuse of MOBY::Central->new is deprecated\n";
return 0;
}
-
=head2 registerObjectClass
The registerObjectClass call is:
@@ -253,137 +254,185 @@
=cut
-
sub registerObjectClass {
+
# this contacts the ontology server to register
# the ontology and writes the resulting URI into
# the MOBY Central database
- my ($pkg, $payload) = @_;
- my ($success, $message);
- my $OntologyServer = &_getOntologyServer(ontology => 'object');
- my $RelOntologyServer = &_getOntologyServer(ontology => 'relationship');
-
- $debug && &_LOG("\n\npayload\n**********************\n$payload\n***********************\n\n");
- my ($term, $desc, $relationships, $email, $auth, $clobber) = &_registerObjectPayload($payload);
- $debug && &_LOG("\n\nterm $term\ndesc $desc\nemail $email\nauth $auth\nclobber $clobber\n\n");
- unless (defined $term && defined $desc && defined $auth && defined $email){
- if ($term =~ /FAILED/){return &_error("Malformed XML;","");}
- return &_error("Malformed XML; may be missing required parameters objectType, Description, authURI or contactEmail","");
- }
- return &_error("Malformed authURI - must not have an http:// prefix","") if $auth =~ '[/:]';
- return &_error("Malformed authURI - must take the form NNN.NNN.NNN","") unless $auth =~ /\./;
- return &_error("Malformed email - must be a valid email address of the form name\@organization.foo","") unless $email =~ /\S\@\S+\.\S+/;
- return &_error("Object name may not contain spaces or other characters invalid in a URN","") if $term =~ /\s\"\&\<\>\[\]\^\`\{\|\}\~/;
- if ($term =~ m"^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?"){ # matches a URI
- return &_error("Object name may not be an URN or URI","") if $1;
- }
-
- my $ISAs;
- # validate that the final ontology will be valid by testing against existing relationships and such
- while (my ($reltype, $obj) = each %{$relationships}){
- my ($success, $message, $URI) = $RelOntologyServer->relationshipExists(term => $reltype, ontology => 'object'); # success = 1 if it does
- $success==0 && return &_error($message, $URI );
- foreach (@{$obj}){
- ++$ISAs if ($URI =~ /isa$/i);
- my ($objectType, $articleName) = @{$_};
- my ($success, $message, $URI) = $OntologyServer->objectExists(term => $objectType); # success = 1 if it does
- $success==0 && return &_error($message, $URI );
- }
- }
- return &_error("Object must have exactly one ISA parent in the MOBY Object ontology") unless $ISAs == 1;
-
- $clobber = defined($clobber)?$clobber:0;
- $clobber = 0 unless ($clobber eq 0 || $clobber eq 1 || $clobber eq 2); # safety!
- my ($exists, $exists_message, $URI) = $OntologyServer->objectExists(term => $term); # success = 1 if it does
- (($exists==1 && !$clobber) && return &_error("Object $term already exists", $URI));
-
- $clobber = 0 unless ($exists); # it makes no sense to clobber something that doesnt' exist
- if ($exists){
- if ($clobber == 1){
- my ($success, $message) = $OntologyServer->deprecateObject(term => $term);
- $success==0 && return &_error($message, $URI);
- } elsif ($clobber == 2) {
- my ($success, $message) = $OntologyServer->deleteObject(term => $term);
- $success==0 && return &_error($message, $URI);
- }
- }
-
- ($success, $message, $URI) = $OntologyServer->createObject(
- node => $term,
- description => $desc,
- authority => $auth,
- contact_email => $email);
- $success==0 && return &_error($message, $URI);
-
+ my ( $pkg, $payload ) = @_;
+ my ( $success, $message );
+ my $OntologyServer = &_getOntologyServer( ontology => 'object' );
+ my $RelOntologyServer = &_getOntologyServer( ontology => 'relationship' );
+ $debug
+ && &_LOG(
+"\n\npayload\n**********************\n$payload\n***********************\n\n" );
+ my ( $term, $desc, $relationships, $email, $auth, $clobber ) =
+ &_registerObjectPayload( $payload );
+ $debug
+ && &_LOG(
+"\n\nterm $term\ndesc $desc\nemail $email\nauth $auth\nclobber $clobber\n\n" );
+
+ unless ( defined $term && defined $desc && defined $auth && defined $email )
+ {
+ if ( $term =~ /FAILED/ ) { return &_error( "Malformed XML;", "" ); }
+ return &_error(
+"Malformed XML; may be missing required parameters objectType, Description, authURI or contactEmail",
+ ""
+ );
+ }
+ return &_error( "Malformed authURI - must not have an http:// prefix", "" )
+ if $auth =~ '[/:]';
+ return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" )
+ unless $auth =~ /\./;
+ return &_error(
+"Malformed email - must be a valid email address of the form name\@organization.foo",
+ ""
+ )
+ unless $email =~ /\S\@\S+\.\S+/;
+ return &_error(
+"Object name may not contain spaces or other characters invalid in a URN",
+ ""
+ )
+ if $term =~ /\s\"\&\<\>\[\]\^\`\{\|\}\~/;
+ if ( $term =~ m"^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?" )
+ { # matches a URI
+ return &_error( "Object name may not be an URN or URI", "" ) if $1;
+ }
+ my $ISAs;
+
+# validate that the final ontology will be valid by testing against existing relationships and such
+ while ( my ( $reltype, $obj ) = each %{$relationships} ) {
+ my ( $success, $message, $URI ) =
+ $RelOntologyServer->relationshipExists( term => $reltype,
+ ontology => 'object' ); # success = 1 if it does
+ $success == 0 && return &_error( $message, $URI );
+ foreach ( @{$obj} ) {
+ ++$ISAs if ( $URI =~ /isa$/i );
+ my ( $objectType, $articleName ) = @{$_};
+ my ( $success, $message, $URI ) =
+ $OntologyServer->objectExists( term => $objectType )
+ ; # success = 1 if it does
+ $success == 0 && return &_error( $message, $URI );
+ }
+ }
+ return &_error(
+ "Object must have exactly one ISA parent in the MOBY Object ontology" )
+ unless $ISAs == 1;
+ $clobber = defined( $clobber ) ? $clobber : 0;
+ $clobber = 0
+ unless ( $clobber eq 0 || $clobber eq 1 || $clobber eq 2 ); # safety!
+ my ( $exists, $exists_message, $URI ) =
+ $OntologyServer->objectExists( term => $term ); # success = 1 if it does
+ ( ( $exists == 1 && !$clobber )
+ && return &_error( "Object $term already exists", $URI ) );
+ $clobber = 0
+ unless ( $exists )
+ ; # it makes no sense to clobber something that doesnt' exist
+ if ( $exists ) {
+
+ if ( $clobber == 1 ) {
+ my ( $success, $message ) =
+ $OntologyServer->deprecateObject( term => $term );
+ $success == 0 && return &_error( $message, $URI );
+ } elsif ( $clobber == 2 ) {
+ my ( $success, $message ) =
+ $OntologyServer->deleteObject( term => $term );
+ $success == 0 && return &_error( $message, $URI );
+ }
+ }
+ ( $success, $message, $URI ) = $OntologyServer->createObject(
+ node => $term,
+ description => $desc,
+ authority => $auth,
+ contact_email => $email
+ );
+ $success == 0 && return &_error( $message, $URI );
my @failures;
- if (keys %{$relationships}){
- while (my ($reltype, $obj) = each %{$relationships}){
- foreach (@{$obj}){
- my ($objectType, $articleName) = @{$_};
- my ($success, $message) = $OntologyServer->addObjectRelationship(
- subject_node => $term,
- relationship => $reltype,
- object_node => $objectType,
- articleName => $articleName,
- authority => $auth,
- contact_email => $email);
- $success==0 && push @failures, $objectType;
- }
- }
- }
-
- if (scalar(@failures)){
- my ($success, $message, $deleteURI) = $OntologyServer->deleteObject(term => $term); # hopefully this situation will never happen!
- $success==0 && return &_error("object failed ISA and/or HASA connections,
+ if ( keys %{$relationships} ) {
+ while ( my ( $reltype, $obj ) = each %{$relationships} ) {
+ foreach ( @{$obj} ) {
+ my ( $objectType, $articleName ) = @{$_};
+ my ( $success, $message ) =
+ $OntologyServer->addObjectRelationship(
+ subject_node => $term,
+ relationship => $reltype,
+ object_node => $objectType,
+ articleName => $articleName,
+ authority => $auth,
+ contact_email => $email
+ );
+ $success == 0 && push @failures, $objectType;
+ }
+ }
+ }
+ if ( scalar( @failures ) ) {
+ my ( $success, $message, $deleteURI ) =
+ $OntologyServer->deleteObject( term => $term )
+ ; # hopefully this situation will never happen!
+ $success == 0 && return &_error(
+ "object failed ISA and/or HASA connections,
and subsequently failed deletion. This is a critical error,
- and may indicate corruption of the MOBY Central registry.", $deleteURI);
- return &_error("object failed to register due to failure during registration of ISA/HASA relationships".(join ",", (@failures))."\n", "");
+ and may indicate corruption of the MOBY Central registry.", $deleteURI
+ );
+ return &_error(
+"object failed to register due to failure during registration of ISA/HASA relationships"
+ . ( join ",", ( @failures ) ) . "\n",
+ ""
+ );
}
- return &_success("Object $term registered successfully.", $URI);
+ return &_success( "Object $term registered successfully.", $URI );
}
-
+#Eddie - converted
sub _registerObjectPayload {
- 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 'registerObjectClass');
-
- my $term = &_nodeTextContent($Object, "objectType");
- my $desc = &_nodeTextContent($Object, "Description");
- my $authURI = &_nodeTextContent($Object, "authURI");
- my $email = &_nodeTextContent($Object, "contactEmail");
- my $clobber = &_nodeTextContent($Object, "Clobber");
+ my ( $payload ) = @_; #EDDIE - assuming that payload is a string
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $Object = $doc->documentElement();
+ my $obj = $Object->nodeName;
+ return undef unless ( $obj eq 'registerObjectClass' );
+ my $term = &_nodeTextContent( $Object, "objectType" );
+ my $desc = &_nodeTextContent( $Object, "Description" );
+ my $authURI = &_nodeTextContent( $Object, "authURI" );
+ my $email = &_nodeTextContent( $Object, "contactEmail" );
+ my $clobber = &_nodeTextContent( $Object, "Clobber" );
+
#my @ISA = &_nodeArrayContent($Object, "ISA");
#my @HASA = &_nodeArrayExtraContent($Object, "HASA","articleName");
- 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 %att_value;
+ my %relationships;
+ 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 $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, $clobber);
-
+ return ( $term, $desc, \%relationships, $email, $authURI, $clobber );
}
-
-
=head2 deregisterObjectClass
=over 3
@@ -413,51 +462,72 @@
=cut
-
sub deregisterObjectClass {
- my ($pkg, $payload) = @_;
- my $OntologyServer = &_getOntologyServer(ontology => 'object');
-
- return &_error("Message Format Incorrect","") unless ($payload);
-
- my ($class) = &_deregisterObjectPayload($payload);
- $debug && &_LOG("deregister object type $class\n");
- return &_error("Must include class of object to deregister","") unless ($class);
-
- my ($success, $message, $existingURI) = $OntologyServer->objectExists(term => $class);
- return &_error("Object class $class does not exist","") unless ($existingURI);
-
+ my ( $pkg, $payload ) = @_;
+ my $OntologyServer = &_getOntologyServer( ontology => 'object' );
+ return &_error( "Message Format Incorrect", "" ) unless ( $payload );
+ my ( $class ) = &_deregisterObjectPayload( $payload );
+ $debug && &_LOG( "deregister object type $class\n" );
+ return &_error( "Must include class of object to deregister", "" )
+ unless ( $class );
+ my ( $success, $message, $existingURI ) =
+ $OntologyServer->objectExists( term => $class );
+ return &_error( "Object class $class does not exist", "" )
+ unless ( $existingURI );
my $dbh = MOBY::central_db_connection->new()->dbh;
- my ($id) = $dbh->selectrow_array(q{select service_instance.service_instance_id from service_instance natural join simple_input where object_type_uri = ?},undef,$existingURI);
- return &_error("Object class $class is used by a service and may not be deregistered","") if ($id);
-
- ($id) = $dbh->selectrow_array(q{select service_instance.service_instance_id from service_instance natural join simple_output where object_type_uri = ?},undef,$existingURI);
- return &_error("Object class $class is used by a service and may not be deregistered","") if ($id);
-
- ($id) = $dbh->selectrow_array(q{select service_instance.service_instance_id from service_instance natural join collection_input natural join simple_input where object_type_uri = ?},undef,$existingURI);
- return &_error("Object class $class is used by a service and may not be deregistered","") if ($id);
-
- ($id) = $dbh->selectrow_array(q{select service_instance.service_instance_id from service_instance natural join collection_output natural join simple_output where object_type_uri = ?},undef,$existingURI);
- return &_error("Object class $class is used by a service and may not be deregistered","") if ($id);
-
- my ($success2, $message2, $URI) = $OntologyServer->deleteObject(term => $class);
- $success2==0 && return &_error($message2, $URI);
- return &_success($message2, $URI);
-
+ my ( $id ) = $dbh->selectrow_array(
+q{select service_instance.service_instance_id from service_instance natural join simple_input where object_type_uri = ?},
+ undef, $existingURI
+ );
+ return &_error(
+ "Object class $class is used by a service and may not be deregistered",
+ ""
+ )
+ if ( $id );
+ ( $id ) = $dbh->selectrow_array(
+q{select service_instance.service_instance_id from service_instance natural join simple_output where object_type_uri = ?},
+ undef, $existingURI
+ );
+ return &_error(
+ "Object class $class is used by a service and may not be deregistered",
+ ""
+ )
+ if ( $id );
+ ( $id ) = $dbh->selectrow_array(
+q{select service_instance.service_instance_id from service_instance natural join collection_input natural join simple_input where object_type_uri = ?},
+ undef, $existingURI
+ );
+ return &_error(
+ "Object class $class is used by a service and may not be deregistered",
+ ""
+ )
+ if ( $id );
+ ( $id ) = $dbh->selectrow_array(
+q{select service_instance.service_instance_id from service_instance natural join collection_output natural join simple_output where object_type_uri = ?},
+ undef, $existingURI
+ );
+ return &_error(
+ "Object class $class is used by a service and may not be deregistered",
+ ""
+ )
+ if ( $id );
+ my ( $success2, $message2, $URI ) =
+ $OntologyServer->deleteObject( term => $class );
+ $success2 == 0 && return &_error( $message2, $URI );
+ return &_success( $message2, $URI );
}
+#Eddie - converted
sub _deregisterObjectPayload {
- 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 'deregisterObjectClass');
-
- return &_nodeTextContent($Object, "objectType");
+ 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 'deregisterObjectClass' );
+ return &_nodeTextContent( $Object, "objectType" );
}
-
=head2 registerServiceType
=over 3
@@ -499,127 +569,167 @@
=cut
-
sub registerServiceType {
+
# this contacts the ontology server to register
# the ontology and writes the resulting URI into
# the MOBY Central database
- my ($pkg, $payload) = @_;
- my ($success, $message, $URI);
- my $OntologyServer = &_getOntologyServer(ontology => 'service');
- $debug && &_LOG("\n\npayload\n**********************\n$payload\n***********************\n\n");
- my ($term, $desc, $relationships, $email, $auth) = &_registerServiceTypePayload($payload);
- $debug && &_LOG("\n\nterm $term\ndesc $desc\nrel $relationships\nemail $email\nauth $auth");
- unless (defined $term && defined $desc && defined $auth && defined $email){
- if ($term =~ /FAILED/){ return &_error("Malformed XML\n $term","");}
- return &_error("Malformed XML\n may be missing required parameters serviceType, Description, authURI or contactEmail","");
- }
- return &_error("Malformed authURI - must not have an http:// prefix","") if $auth =~ '[/:]';
- return &_error("Malformed authURI - must take the form NNN.NNN.NNN","") unless $auth =~ /\./;
- return &_error("Malformed email - must be a valid email address of the form name\@organization.foo","") unless $email =~ /\S\@\S+\.\S+/;
+ my ( $pkg, $payload ) = @_;
+ my ( $success, $message, $URI );
+ my $OntologyServer = &_getOntologyServer( ontology => 'service' );
+ $debug
+ && &_LOG(
+"\n\npayload\n**********************\n$payload\n***********************\n\n" );
+ my ( $term, $desc, $relationships, $email, $auth ) =
+ &_registerServiceTypePayload( $payload );
+ $debug
+ && &_LOG(
+"\n\nterm $term\ndesc $desc\nrel $relationships\nemail $email\nauth $auth" );
+ unless ( defined $term && defined $desc && defined $auth && defined $email )
+ {
+
+ if ( $term =~ /FAILED/ ) {
+ return &_error( "Malformed XML\n $term", "" );
+ }
+ return &_error(
+"Malformed XML\n may be missing required parameters serviceType, Description, authURI or contactEmail",
+ ""
+ );
+ }
+ return &_error( "Malformed authURI - must not have an http:// prefix", "" )
+ if $auth =~ '[/:]';
+ return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" )
+ unless $auth =~ /\./;
+ return &_error(
+"Malformed email - must be a valid email address of the form name\@organization.foo",
+ ""
+ )
+ unless $email =~ /\S\@\S+\.\S+/;
# validate that the final ontology will be valid
-
- my ($exists, $exists_message, $existingURI) = $OntologyServer->serviceExists(term => $term); # success = 1 if it does
- (($exists==1) && return &_error("Service type $term already exists", $existingURI));
-
+ my ( $exists, $exists_message, $existingURI ) =
+ $OntologyServer->serviceExists( term => $term ); # success = 1 if it does
+ ( ( $exists == 1 )
+ && return &_error( "Service type $term already exists", $existingURI )
+ );
# is the relationship valid?
- my $OSrel = MOBY::OntologyServer->new(ontology => 'relationship');
- if (keys %{$relationships}){
- while (my ($reltype, $obj) = each %{$relationships}){
- my ($success, $desc, $URI) = $OSrel->relationshipExists(term => $reltype, ontology => 'service');
- (!$success) && return &_error("Relationship type $reltype does not exist in the relationship ontology","");
+ my $OSrel = MOBY::OntologyServer->new( ontology => 'relationship' );
+ if ( keys %{$relationships} ) {
+ while ( my ( $reltype, $obj ) = each %{$relationships} ) {
+ my ( $success, $desc, $URI ) = $OSrel->relationshipExists(
+ term => $reltype,
+ ontology => 'service' );
+ ( !$success ) && return &_error(
+"Relationship type $reltype does not exist in the relationship ontology",
+ ""
+ );
}
}
# are the predicate service types valid?
- my $OSsrv = MOBY::OntologyServer->new(ontology => 'service');
- if (keys %{$relationships}){
- while (my ($srvtype, $svcs) = each %{$relationships}){
- foreach my $svc(@{$svcs}){
- my ($success, $desc,$URI) = $OSsrv->serviceExists(term => $svc);
- (!$success) && return &_error("Service type $srvtype does not exist in the service ontology","");
+ my $OSsrv = MOBY::OntologyServer->new( ontology => 'service' );
+ if ( keys %{$relationships} ) {
+ while ( my ( $srvtype, $svcs ) = each %{$relationships} ) {
+ foreach my $svc ( @{$svcs} ) {
+ my ( $success, $desc, $URI ) =
+ $OSsrv->serviceExists( term => $svc );
+ ( !$success ) && return &_error(
+"Service type $srvtype does not exist in the service ontology",
+ ""
+ );
}
}
}
# hunky dorey. Now register!
-
- ($success, $message, $URI) = $OntologyServer->createServiceType(
- node => $term,
- description => $desc,
- authority => $auth,
- contact_email => $email);
- $success==0 && return &_error($message, $URI);
-
+ ( $success, $message, $URI ) = $OntologyServer->createServiceType(
+ node => $term,
+ description => $desc,
+ authority => $auth,
+ contact_email => $email
+ );
+ $success == 0 && return &_error( $message, $URI );
my @failures;
- if (keys %{$relationships}){
- while (my ($reltype, $obj) = each %{$relationships}){
- foreach my $serviceType(@{$obj}){
- my ($success, $message) = $OntologyServer->addServiceRelationship(
- subject_node => $term,
- relationship => $reltype,
- object_node => $serviceType,
- authority => $auth,
- contact_email => $email);
- $success==0 && push @failures, $serviceType;
- }
- }
- }
- if (scalar(@failures)){
- my ($success, $message, $deleteURI) = $OntologyServer->deleteServiceType(term => $term); # hopefully this situation will never happen!
- $success==0 && return &_error("Service registration failed ISA connections,
+ if ( keys %{$relationships} ) {
+ while ( my ( $reltype, $obj ) = each %{$relationships} ) {
+ foreach my $serviceType ( @{$obj} ) {
+ my ( $success, $message ) =
+ $OntologyServer->addServiceRelationship(
+ subject_node => $term,
+ relationship => $reltype,
+ object_node => $serviceType,
+ authority => $auth,
+ contact_email => $email
+ );
+ $success == 0 && push @failures, $serviceType;
+ }
+ }
+ }
+ if ( scalar( @failures ) ) {
+ my ( $success, $message, $deleteURI ) =
+ $OntologyServer->deleteServiceType( term => $term )
+ ; # hopefully this situation will never happen!
+ $success == 0 && return &_error(
+ "Service registration failed ISA connections,
and subsequently failed deletion. This is a critical error,
- and may indicate corruption of the MOBY Central registry", $deleteURI);
- return &_error("Service failed to register due to failure during registration of relationships".(join ",", (@failures))."\n", "");
+ and may indicate corruption of the MOBY Central registry", $deleteURI
+ );
+ return &_error(
+"Service failed to register due to failure during registration of relationships"
+ . ( join ",", ( @failures ) ) . "\n",
+ ""
+ );
}
-
- return &_success("Service type $term registered successfully.", $URI);
-
+ return &_success( "Service type $term registered successfully.", $URI );
}
-
+#Eddie - converted
sub _registerServiceTypePayload {
- my ($payload) = @_;
- $debug && &_LOG("_registerServiceTypePayload payload=$payload\n");
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
+ my ( $payload ) = @_;
+ $debug && &_LOG( "_registerServiceTypePayload payload=$payload\n" );
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
my $Object = $doc->getDocumentElement();
- my $obj = $Object->getTagName;
- return undef unless ($obj eq 'registerServiceType');
-
- my $type = &_nodeTextContent($Object, "serviceType");
- my $email = &_nodeTextContent($Object, "contactEmail");
- my $auth = &_nodeTextContent($Object, "authURI");
- my $desc = &_nodeTextContent($Object, "Description");
-
+ my $obj = $Object->nodeName;
+ return undef unless ( $obj eq 'registerServiceType' );
+ my $type = &_nodeTextContent( $Object, "serviceType" );
+ my $email = &_nodeTextContent( $Object, "contactEmail" );
+ my $auth = &_nodeTextContent( $Object, "authURI" );
+ my $desc = &_nodeTextContent( $Object, "Description" );
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 @child2 = $_->getChildNodes;
- foreach (@child2){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
- next unless $_->getNodeType == TEXT_NODE;
- push @{$relationships{$relationshipType}}, $_->toString;
+ 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 ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ next unless $_->nodeType == TEXT_NODE;
+ push @{ $relationships{$relationshipType} }, $_->toString;
}
}
}
-
- $debug && &_LOG("got $type, $desc, \%relationships, $email, $auth from registerServiceTypePayload\n");
- return ($type, $desc, \%relationships, $email, $auth);
-
+ $debug
+ && &_LOG(
+"got $type, $desc, \%relationships, $email, $auth from registerServiceTypePayload\n"
+ );
+ return ( $type, $desc, \%relationships, $email, $auth );
}
-
-
-
=head2 deregisterServiceType
=over 3
@@ -645,44 +755,46 @@
=cut
-
sub deregisterServiceType {
- my ($pkg, $payload) = @_;
- my $OntologyServer = &_getOntologyServer(ontology => 'service');
-
- return &_error("Message Format Incorrect","") unless ($payload);
-
- my ($term) = &_deregisterServiceTypePayload($payload);
- $debug && &_LOG("deregister serviceType accession $term\n");
- return &_error("Must include an accession number to deregister a serviceType","") unless ($term);
-
- my ($success, $message, $existingURI) = $OntologyServer->serviceExists(term => $term); # hopefully this situation will never happen!
- return &_error("Service Type $term does not exist in the ontology","") unless ($existingURI);
-
+ my ( $pkg, $payload ) = @_;
+ my $OntologyServer = &_getOntologyServer( ontology => 'service' );
+ return &_error( "Message Format Incorrect", "" ) unless ( $payload );
+ my ( $term ) = &_deregisterServiceTypePayload( $payload );
+ $debug && &_LOG( "deregister serviceType accession $term\n" );
+ return &_error(
+ "Must include an accession number to deregister a serviceType",
+ "" )
+ unless ( $term );
+ my ( $success, $message, $existingURI ) =
+ $OntologyServer->serviceExists( term => $term )
+ ; # hopefully this situation will never happen!
+ return &_error( "Service Type $term does not exist in the ontology", "" )
+ unless ( $existingURI );
my $dbh = MOBY::central_db_connection->new()->dbh;
- my ($id) = $dbh->selectrow_array(q{select service_instance.service_instance_id from service_instance where service_type_uri = ?}, undef, $existingURI);
- return &_error("A registered service depends on this service type","") if ($id);
-
- my ($success2, $message2, $deleteURI) = $OntologyServer->deleteServiceType(term => $term); # hopefully this situation will never happen!
- $success==0 && return &_error($message2, $deleteURI);
- return &_success("Service type $term deleted.", $deleteURI);
+ my ( $id ) = $dbh->selectrow_array(
+q{select service_instance.service_instance_id from service_instance where service_type_uri = ?},
+ undef, $existingURI
+ );
+ return &_error( "A registered service depends on this service type", "" )
+ if ( $id );
+ my ( $success2, $message2, $deleteURI ) =
+ $OntologyServer->deleteServiceType( term => $term )
+ ; # hopefully this situation will never happen!
+ $success == 0 && return &_error( $message2, $deleteURI );
+ return &_success( "Service type $term deleted.", $deleteURI );
}
-
+#Eddie - converted
sub _deregisterServiceTypePayload {
- 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 'deregisterServiceType');
-
- return &_nodeTextContent($Object, "serviceType");
+ my ( $payload ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $Object = $doc->getDocumentElement();
+ my $obj = $Object->nodeName; #Eddie- unsure
+ return undef unless ( $obj eq 'deregisterServiceType' );
+ return &_nodeTextContent( $Object, "serviceType" );
}
-
-
-
=head2 registerNamespace
=over 3
@@ -715,57 +827,65 @@
=cut
-
-
sub registerNamespace {
+
# this contacts the ontology server to register
# the ontology and writes the resulting URI into
# the MOBY Central database
- my ($pkg, $payload) = @_;
- my ($success, $message);
- my $OntologyServer = &_getOntologyServer(ontology => 'namespace');
- $debug && &_LOG("\n\npayload\n**********************\n$payload\n***********************\n\n");
- my ($term, $auth, $desc, $email) = &_registerNamespacePayload($payload);
- $debug && &_LOG("\n\nterm $term\ndesc $desc\nemail $email\nauth $auth");
- unless (defined $term && defined $desc && defined $auth && defined $email){
- return &_error("Malformed XML; may be missing required parameters namespaceType, Description, authURI or contactEmail","");
- }
- return &_error("Malformed authURI - must not have an http:// prefix","") if $auth =~ '[/:]';
- return &_error("Malformed authURI - must take the form NNN.NNN.NNN","") unless $auth =~ /\./;
- return &_error("Malformed email - must be a valid email address of the form name\@organization.foo","") unless $email =~ /\S\@\S+\.\S+/;
-
- my ($exists, $exists_message, $URI) = $OntologyServer->namespaceExists(term => $term); # success = 1 if it does
- (($exists==1) && return &_error("Namespace $term already exists", $URI));
-
- ($success, $message, $URI) = $OntologyServer->createNamespace(
- node => $term,
- description => $desc,
- authority => $auth,
- contact_email => $email);
- $success==0 && return &_error($message, $URI);
-
- return &_success("Namespace type $term registered successfully.", $URI);
-
+ my ( $pkg, $payload ) = @_;
+ my ( $success, $message );
+ my $OntologyServer = &_getOntologyServer( ontology => 'namespace' );
+ $debug
+ && &_LOG(
+"\n\npayload\n**********************\n$payload\n***********************\n\n" );
+ my ( $term, $auth, $desc, $email ) = &_registerNamespacePayload( $payload );
+ $debug && &_LOG( "\n\nterm $term\ndesc $desc\nemail $email\nauth $auth" );
+ unless ( defined $term && defined $desc && defined $auth && defined $email )
+ {
+ return &_error(
+"Malformed XML; may be missing required parameters namespaceType, Description, authURI or contactEmail",
+ ""
+ );
+ }
+ return &_error( "Malformed authURI - must not have an http:// prefix", "" )
+ if $auth =~ '[/:]';
+ return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" )
+ unless $auth =~ /\./;
+ return &_error(
+"Malformed email - must be a valid email address of the form name\@organization.foo",
+ ""
+ )
+ unless $email =~ /\S\@\S+\.\S+/;
+ my ( $exists, $exists_message, $URI ) =
+ $OntologyServer->namespaceExists( term => $term )
+ ; # success = 1 if it does
+ ( ( $exists == 1 )
+ && return &_error( "Namespace $term already exists", $URI ) );
+ ( $success, $message, $URI ) = $OntologyServer->createNamespace(
+ node => $term,
+ description => $desc,
+ authority => $auth,
+ contact_email => $email
+ );
+ $success == 0 && return &_error( $message, $URI );
+ return &_success( "Namespace type $term registered successfully.", $URI );
}
-
+#Eddie - converted
sub _registerNamespacePayload {
- 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 'registerNamespace');
-
- my $type = &_nodeTextContent($Object, "namespaceType");
- my $authURI = &_nodeTextContent($Object, "authURI");
- my $desc = &_nodeTextContent($Object, "Description");
- my $contact = &_nodeTextContent($Object, "contactEmail");
-
- return ($type, $authURI, $desc, $contact);
+ 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 'registerNamespace' );
+ my $type = &_nodeTextContent( $Object, "namespaceType" );
+ my $authURI = &_nodeTextContent( $Object, "authURI" );
+ my $desc = &_nodeTextContent( $Object, "Description" );
+ my $contact = &_nodeTextContent( $Object, "contactEmail" );
+ return ( $type, $authURI, $desc, $contact );
}
-
=head2 deregisterNamespace
=over
@@ -792,81 +912,101 @@
=cut
-
sub deregisterNamespace {
- my ($pkg, $payload) = @_;
- my $OntologyServer = &_getOntologyServer(ontology => 'namespace');
-
- return &_error("Message Format Incorrect","") unless ($payload);
-
- my ($term) = &_deregisterNamespacePayload($payload);
- $debug && &_LOG("deregister namespaceType accession $term\n");
- return &_error("Must include a Namespace type to deregister.","") unless ($term);
-
- my ($success, $message, $existingURI) = $OntologyServer->namespaceExists(term => $term);
- return &_error("Namespace Type $term does not exist","") unless ($existingURI);
-
+ my ( $pkg, $payload ) = @_;
+ my $OntologyServer = &_getOntologyServer( ontology => 'namespace' );
+ return &_error( "Message Format Incorrect", "" ) unless ( $payload );
+ my ( $term ) = &_deregisterNamespacePayload( $payload );
+ $debug && &_LOG( "deregister namespaceType accession $term\n" );
+ return &_error( "Must include a Namespace type to deregister.", "" )
+ unless ( $term );
+ my ( $success, $message, $existingURI ) =
+ $OntologyServer->namespaceExists( term => $term );
+ return &_error( "Namespace Type $term does not exist", "" )
+ unless ( $existingURI );
my $dbh = MOBY::central_db_connection->new->dbh;
-
- my $sth = $dbh->prepare("select service_instance.service_instance_id, namespace_type_uris from service_instance natural join simple_input where INSTR(namespace_type_uris,'$existingURI')");
+ my $sth =
+ $dbh->prepare(
+"select service_instance.service_instance_id, namespace_type_uris from service_instance natural join simple_input where INSTR(namespace_type_uris,'$existingURI')"
+ );
$sth->execute;
- while (my ($id, $ns) = $sth->fetchrow_array()){
+
+ while ( my ( $id, $ns ) = $sth->fetchrow_array() ) {
my @nss = split ",", $ns;
- foreach (@nss){
- $_=~s/\s//g;
- return &_error("Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered","") if ($_ eq $existingURI);
+ foreach ( @nss ) {
+ $_ =~ s/\s//g;
+ return &_error(
+"Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered",
+ ""
+ )
+ if ( $_ eq $existingURI );
}
}
-
- $sth = $dbh->prepare("select service_instance.service_instance_id, namespace_type_uris from service_instance natural join simple_output where INSTR(namespace_type_uris,'$existingURI')");
+ $sth =
+ $dbh->prepare(
+"select service_instance.service_instance_id, namespace_type_uris from service_instance natural join simple_output where INSTR(namespace_type_uris,'$existingURI')"
+ );
$sth->execute;
- while (my ($id, $ns) = $sth->fetchrow_array()){
+ while ( my ( $id, $ns ) = $sth->fetchrow_array() ) {
my @nss = split ",", $ns;
- foreach (@nss){
- $_=~s/\s//g;
- return &_error("Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered","") if ($_ eq $existingURI);
+ foreach ( @nss ) {
+ $_ =~ s/\s//g;
+ return &_error(
+"Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered",
+ ""
+ )
+ if ( $_ eq $existingURI );
}
}
-
- $sth = $dbh->prepare("select service_instance.service_instance_id, namespace_type_uris from service_instance natural join collection_input natural join simple_input where INSTR(namespace_type_uris, '$existingURI')");
+ $sth =
+ $dbh->prepare(
+"select service_instance.service_instance_id, namespace_type_uris from service_instance natural join collection_input natural join simple_input where INSTR(namespace_type_uris, '$existingURI')"
+ );
$sth->execute;
- while (my ($id, $ns) = $sth->fetchrow_array()){
+ while ( my ( $id, $ns ) = $sth->fetchrow_array() ) {
my @nss = split ",", $ns;
- foreach (@nss){
- $_=~s/\s//g;
- return &_error("Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered","") if ($_ eq $existingURI);
+ foreach ( @nss ) {
+ $_ =~ s/\s//g;
+ return &_error(
+"Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered",
+ ""
+ )
+ if ( $_ eq $existingURI );
}
}
-
- $sth = $dbh->prepare("select service_instance.service_instance_id, namespace_type_uris from service_instance natural join collection_output natural join simple_output where INSTR(namespace_type_uris, '$existingURI')");
+ $sth =
+ $dbh->prepare(
+"select service_instance.service_instance_id, namespace_type_uris from service_instance natural join collection_output natural join simple_output where INSTR(namespace_type_uris, '$existingURI')"
+ );
$sth->execute;
- while (my ($id, $ns) = $sth->fetchrow_array()){
+ while ( my ( $id, $ns ) = $sth->fetchrow_array() ) {
my @nss = split ",", $ns;
- foreach (@nss){
- $_=~s/\s//g;
- return &_error("Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered","") if ($_ eq $existingURI);
- }
- }
-
- my ($success2, $message2, $URI) = $OntologyServer->deleteNamespace(
- term => $term);
- $success2==0 && return &_error($message2, $URI);
-
- return &_success("Namespace type $term deregistered successfully.", $URI);
+ foreach ( @nss ) {
+ $_ =~ s/\s//g;
+ return &_error(
+"Namespace Type $term ($_) is used by a service (service ID number $id) and may not be deregistered",
+ ""
+ )
+ if ( $_ eq $existingURI );
+ }
+ }
+ my ( $success2, $message2, $URI ) =
+ $OntologyServer->deleteNamespace( term => $term );
+ $success2 == 0 && return &_error( $message2, $URI );
+ return &_success( "Namespace type $term deregistered successfully.", $URI );
}
+#Eddie - converted
sub _deregisterNamespacePayload {
- 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 'deregisterNamespace');
-
- return &_nodeTextContent($Object, "namespaceType");
+ 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 'deregisterNamespace' );
+ return &_nodeTextContent( $Object, "namespaceType" );
}
-
=head2 registerService
=over 3
@@ -1063,7 +1203,7 @@
=cut
-
+
# inputXML (FOR CGI GET SERVICES):
# <registerService>
# <Category>cgi</Category>
@@ -1085,316 +1225,414 @@
# human readable description of your service]]>
# </Description>
# </registerService>
-
-sub registerService {
- my ($pkg, $payload) = @_;
- my ($serviceName, $serviceType, $AuthURI, $contactEmail, $URL, $authoritativeService, $desc, $Category, $INPUTS, $OUTPUTS, $SECONDARY, $signatureURL) = &_registerServicePayload($payload);
- $authoritativeService = defined($authoritativeService)?1:0;
+sub registerService {
+ my ( $pkg, $payload ) = @_;
+ my (
+ $serviceName, $serviceType, $AuthURI,
+ $contactEmail, $URL, $authoritativeService,
+ $desc, $Category, $INPUTS,
+ $OUTPUTS, $SECONDARY, $signatureURL
+ )
+ = &_registerServicePayload( $payload );
+ $authoritativeService = defined( $authoritativeService ) ? 1 : 0;
my $error;
- $error .="missing serviceName \n" unless defined $serviceName;
- $error .="missing serviceType \n" unless defined $serviceType;
-# $error .="missing signatureURL \n" unless defined $signatureURL;
- $error .="missing authURI \n" unless defined $AuthURI;
- $error .="missing contactEmail \n" unless defined $contactEmail;
- return &_error("Malformed authURI - must not have an http:// prefix","") if $AuthURI =~ '[/:]';
- return &_error("Malformed authURI - must take the form NNN.NNN.NNN","") unless $AuthURI =~ /\./;
- return &_error("Malformed email - must be a valid email address of the form name\@organization.foo","") unless $contactEmail =~ /\S\@\S+\.\S+/;
- $error .="missing URL \n" unless defined $URL;
- $error .="missing description \n" unless defined $desc;
- $error .="missing Category \n" unless defined $Category;
-
- return &_error("malformed payload $error\n\n","") if ($error);
- return &_error("Category may take the (case sensitive) values 'moby', 'cgi', 'soap'\n","") unless (
- ($Category eq "wsdl")
-# || ($Category eq "cgi")
- || ($Category eq "moby")
- );
- $debug && &_LOG("Entering switch with $Category method\n");
+ $error .= "missing serviceName \n" unless defined $serviceName;
+ $error .= "missing serviceType \n" unless defined $serviceType;
- return &_error("Service categories other than 'moby' and 'wsdl' are not yet implemented","") unless (($Category eq "moby") || ($Category eq "wsdl"));
- my @IN = @{$INPUTS};
- my @OUT = @{$OUTPUTS};
+ # $error .="missing signatureURL \n" unless defined $signatureURL;
+ $error .= "missing authURI \n" unless defined $AuthURI;
+ $error .= "missing contactEmail \n" unless defined $contactEmail;
+ return &_error( "Malformed authURI - must not have an http:// prefix", "" )
+ if $AuthURI =~ '[/:]';
+ return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" )
+ unless $AuthURI =~ /\./;
+ return &_error(
+"Malformed email - must be a valid email address of the form name\@organization.foo",
+ ""
+ )
+ unless $contactEmail =~ /\S\@\S+\.\S+/;
+ $error .= "missing URL \n" unless defined $URL;
+ $error .= "missing description \n" unless defined $desc;
+ $error .= "missing Category \n" unless defined $Category;
+ return &_error( "malformed payload $error\n\n", "" ) if ( $error );
+ return &_error(
+ "Category may take the (case sensitive) values 'moby', 'cgi', 'soap'\n",
+ ""
+ )
+ unless (
+ ( $Category eq "wsdl" )
+
+ # || ($Category eq "cgi")
+ || ( $Category eq "moby" )
+ );
+ $debug && &_LOG( "Entering switch with $Category method\n" );
+ return &_error(
+"Service categories other than 'moby' and 'wsdl' are not yet implemented",
+ ""
+ )
+ unless ( ( $Category eq "moby" ) || ( $Category eq "wsdl" ) );
+ my @IN = @{$INPUTS};
+ my @OUT = @{$OUTPUTS};
my @SECS = @{$SECONDARY};
-
- return &_error("must include at least one input and/or one output object type","") unless (scalar @IN || scalar @OUT);
+ return &_error(
+ "must include at least one input and/or one output object type",
+ "" )
+ unless ( scalar @IN || scalar @OUT );
my %objects_to_be_validated;
- foreach (@IN, @OUT){
- foreach my $objectName(&_extractObjectTypes($_)){
+ foreach ( @IN, @OUT ) {
+
+ foreach my $objectName ( &_extractObjectTypes( $_ ) ) {
$objects_to_be_validated{$objectName} = 1;
}
}
- my $OS = MOBY::OntologyServer->new(ontology => 'object');
-
- foreach (keys %objects_to_be_validated){
- my ($valid, $message, $URI) = $OS->objectExists(term => $_);
- return &_error("$message","$URI") unless ($valid || (($_ =~ /urn:lsid/i) && !($_ =~ /urn:lsid:biomoby.org/i))); # either valid, or a non-moby LSID
- }
-
- $debug && &_LOG("\n\n\aall objects okay - either valid MOBY objects, or LSID's\n");
+ my $OS = MOBY::OntologyServer->new( ontology => 'object' );
+ foreach ( keys %objects_to_be_validated ) {
+ my ( $valid, $message, $URI ) = $OS->objectExists( term => $_ );
+ return &_error( "$message", "$URI" )
+ unless ( $valid
+ || ( ( $_ =~ /urn:lsid/i ) && !( $_ =~ /urn:lsid:biomoby.org/i ) )
+ ); # either valid, or a non-moby LSID
+ }
+ $debug
+ && &_LOG(
+ "\n\n\aall objects okay - either valid MOBY objects, or LSID's\n" );
+ $OS = MOBY::OntologyServer->new( ontology => 'service' );
+ my ( $valid, $message, $URI ) = $OS->serviceExists( term => $serviceType );
- $OS = MOBY::OntologyServer->new(ontology => 'service');
- my ($valid, $message, $URI) = $OS->serviceExists(term => $serviceType);
#print STDERR "\n\nChecking $URI\n\n";
- return &_error("$message","$URI") unless ($valid || (($serviceType =~ /urn:lsid/i) && !($serviceType =~ /urn:lsid:biomoby.org/i))); # either valid, or a non-MOBY LSID
- #print STDERR "\n\nChecking $URI OK!!\n\n";
- # right, registration should be successful now!
-
+ return &_error( "$message", "$URI" )
+ unless (
+ $valid
+ || ( ( $serviceType =~ /urn:lsid/i )
+ && !( $serviceType =~ /urn:lsid:biomoby.org/i ) )
+ ); # either valid, or a non-MOBY LSID
+ #print STDERR "\n\nChecking $URI OK!!\n\n";
+ # right, registration should be successful now!
my $SVC = MOBY::service_instance->new(
- category => $Category,
- servicename => $serviceName,
- service_type => $serviceType,
- authority_uri => $AuthURI,
- url => $URL,
- contact_email => $contactEmail,
- authoritative => $authoritativeService,
- description => $desc,
- signatureURL => $signatureURL,
- );
-
- return &_error("Service registration failed for unknown reasons","") if (!defined $SVC);
- return &_error("Service with this authority/servicename already exists","") if ($SVC == -1);
-
- $debug && &_LOG("new service instance created\n");
-
- foreach my $IN(@IN){
- my ($success,$msg) = &_registerArticles($SVC, "input", $IN, undef);
- return &_error("Registration Failed During INPUT Article Registration: $msg","") unless ($success==1);
- }
- foreach my $OUT(@OUT){
- my ($success,$msg) = &_registerArticles($SVC, "output", $OUT, undef);
- return &_error("Registration Failed During OUTPUT Article Registration: $msg","") unless ($success==1);
- }
- foreach my $SEC(@SECS){
- my ($success,$msg) = &_registerArticles($SVC, "secondary", $SEC, undef);
- return &_error("Registration Failed During SECONDARY Article Registration: $msg","") unless ($success==1);
- }
-
- # we're going to do a findService here to find the service that we just created
- # and use the resulting XML to create a MOBY::Client::ServiceInstance object
- # that we can then use to retrieve the RDF for that service signature.
- # this is roundabout, I agree, but it is the most re-usable way to go at
- # the moment.
-
- my ($si, $reg) = &findService('',"<findService>
+ category => $Category,
+ servicename => $serviceName,
+ service_type => $serviceType,
+ authority_uri => $AuthURI,
+ url => $URL,
+ contact_email => $contactEmail,
+ authoritative => $authoritativeService,
+ description => $desc,
+ signatureURL => $signatureURL,
+ );
+ return &_error( "Service registration failed for unknown reasons", "" )
+ if ( !defined $SVC );
+ return &_error( "Service with this authority/servicename already exists",
+ "" )
+ if ( $SVC == -1 );
+ $debug && &_LOG( "new service instance created\n" );
+
+ foreach my $IN ( @IN ) {
+ my ( $success, $msg ) = &_registerArticles( $SVC, "input", $IN, undef );
+ return &_error(
+ "Registration Failed During INPUT Article Registration: $msg",
+ "" )
+ unless ( $success == 1 );
+ }
+ foreach my $OUT ( @OUT ) {
+ my ( $success, $msg ) =
+ &_registerArticles( $SVC, "output", $OUT, undef );
+ return &_error(
+ "Registration Failed During OUTPUT Article Registration: $msg",
+ "" )
+ unless ( $success == 1 );
+ }
+ foreach my $SEC ( @SECS ) {
+ my ( $success, $msg ) =
+ &_registerArticles( $SVC, "secondary", $SEC, undef );
+ return &_error(
+ "Registration Failed During SECONDARY Article Registration: $msg",
+ "" )
+ unless ( $success == 1 );
+ }
+
+ # we're going to do a findService here to find the service that we just created
+ # and use the resulting XML to create a MOBY::Client::ServiceInstance object
+ # that we can then use to retrieve the RDF for that service signature.
+ # this is roundabout, I agree, but it is the most re-usable way to go at
+ # the moment.
+ my ( $si, $reg ) = &findService(
+ '', "<findService>
<authURI>$AuthURI</authURI>;
<serviceName>$serviceName</serviceName>;
- </findService>");
- unless ($si){
- $SVC->DELETE_THYSELF;
- return &_error("Registration Failed - newly registered service could not be discovered","");
- }
- use MOBY::Client::Central;
- my $services = MOBY::Client::Central::_parseServices('', '', $si);
- my $service_instance = shift @{$services};
- my $storage = new RDF::Core::Storage::Memory;
- my $model = new RDF::Core::Model (Storage => $storage);
- my $RDF_MODEL = MOBY::RDF::ServiceInstanceRDF->new(model => $model, service_instance => $service_instance);
- my $RDF_XML = $RDF_MODEL->serialize;
- return &_success("Registration successful", $SVC->service_instance_id, $RDF_XML);
+ </findService>"
+ );
+ unless ( $si ) {
+ $SVC->DELETE_THYSELF;
+ return &_error(
+"Registration Failed - newly registered service could not be discovered",
+ ""
+ );
+ }
+ use MOBY::Client::Central;
+ my $services = MOBY::Client::Central::_parseServices( '', '', $si );
+ my $service_instance = shift @{$services};
+ my $storage = new RDF::Core::Storage::Memory;
+ my $model = new RDF::Core::Model( Storage => $storage );
+ my $RDF_MODEL = MOBY::RDF::ServiceInstanceRDF->new(
+ model => $model,
+ service_instance => $service_instance );
+ my $RDF_XML = $RDF_MODEL->serialize;
+ return &_success( "Registration successful",
+ $SVC->service_instance_id, $RDF_XML );
}
+#Eddie - Converted
sub _registerArticles {
- my ($SVC, $inout, $node,$collid) = @_; # node is a node of the XML dom representing an article to be registered
- my $dbh = $SVC->dbh;
- return (-1,'Bad node') unless $node->getNodeType == ELEMENT_NODE;
-
- # this is a Simple, Collection, or Parameter object
- my $simp_coll = $node->getTagName;
- $debug && &_LOG("TAGNAME in $inout _registerArticle is $simp_coll");
-
- my $article = $node->getAttributeNode("articleName"); # may or may not have a name
- if ($article){$article = $article->getValue()}
- $debug && &_LOG("ARTICLENAME in _registerArticle is $article");
-
- my ($object_type, @namespaces);
-
- if ($simp_coll eq "Collection"){
- $debug && &_LOG("Collection!\n");
- my $collection_id;
- if ($inout eq 'input'){
- $collection_id = $SVC->add_collection_input(article_name => $article);
- } elsif ($inout eq 'output') {
- $collection_id = $SVC->add_collection_output(article_name => $article);
- } else {
- $SVC->DELETE_THYSELF; return (-1,"found article that was neither input nor output");
- }
-
- # the following SQl belongs in the service_instance object, but screw it, I'm running out of time!
- #$dbh->do("insert into collection_$inout (service_instance_id, article_name) values (?,?)", undef, ($SVC->service_instance_id, $article));
- #my $collection_id=$dbh->{mysql_insertid};
-
- my $Simples = $node->getElementsByTagName('Simple');
- my $length = $Simples->getLength;
- unless ($length > 0){return (-1, "Your collection must be a collection of one or more Simple types");}
- for (my $x=0; $x<$length; ++$x){
- my ($success, $message) = &_registerArticles($SVC, $inout, $Simples->item($x),$collection_id);
- unless ($success == 1){return (-1, $message);}
+ my ( $SVC, $inout, $node, $collid ) = @_
+ ; # node is a node of the XML dom representing an article to be registered
+ my $dbh = $SVC->dbh;
+ return ( -1, 'Bad node' ) unless $node->nodeType == ELEMENT_NODE;
+
+ # this is a Simple, Collection, or Parameter object
+ my $simp_coll = $node->nodeName;
+ $debug && &_LOG( "TAGNAME in $inout _registerArticle is $simp_coll" );
+ my $article =
+ $node->getAttributeNode( "articleName" ); # may or may not have a name
+ if ( $article ) { $article = $article->getValue() }
+ $debug && &_LOG( "ARTICLENAME in _registerArticle is $article" );
+ my ( $object_type, @namespaces );
+ if ( $simp_coll eq "Collection" ) {
+ $debug && &_LOG( "Collection!\n" );
+ my $collection_id;
+ if ( $inout eq 'input' ) {
+ $collection_id =
+ $SVC->add_collection_input( article_name => $article );
+ } elsif ( $inout eq 'output' ) {
+ $collection_id =
+ $SVC->add_collection_output( article_name => $article );
+ } else {
+ $SVC->DELETE_THYSELF;
+ return ( -1, "found article that was neither input nor output" );
+ }
+
+# the following SQl belongs in the service_instance object, but screw it, I'm running out of time!
+#$dbh->do("insert into collection_$inout (service_instance_id, article_name) values (?,?)", undef, ($SVC->service_instance_id, $article));
+#my $collection_id=$dbh->{mysql_insertid};
+ my $Simples = $node->getElementsByTagName( 'Simple' );
+ my $length = $Simples->size();
+ unless ( $length > 0 ) {
+ return (
+ -1,
+"Your collection must be a collection of one or more Simple types"
+ );
+ }
+ for ( my $x = 1 ; $x <= $length ; ++$x ) {
+ my ( $success, $message ) =
+ &_registerArticles( $SVC, $inout, $Simples->get_node( $x ),
+ $collection_id );
+ unless ( $success == 1 ) { return ( -1, $message ); }
}
- } elsif ($simp_coll eq "Simple") {
- my $article = $node->getAttributeNode("articleName");
+ } elsif ( $simp_coll eq "Simple" ) {
+ my $article = $node->getAttributeNode( "articleName" );
$article = $article->getValue() if $article;
# get object type and its URI from the ontoogy server
- my $types = $node->getElementsByTagName('objectType');
- my $OE = MOBY::OntologyServer->new(ontology => "object");
- foreach ($types->item(0)->getChildNodes) { # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && ($object_type = $_->toString);
- }
- my ($success, $message, $typeURI) = $OE->objectExists(term => $object_type);
- if ((!($success) && ($object_type =~ /urn:lsid:biomoby.org/i)) || (!($success) && !($object_type =~ /urn:lsid/i))) { # if the object doesn't exist, and it isn't an LSID
- $SVC->DELETE_THYSELF; return (-1,"object: $object_type does not exist, and is not an LSID");
- } # kill it all unless this was successful!
-
+ my $types = $node->getElementsByTagName( 'objectType' );
+ my $OE = MOBY::OntologyServer->new( ontology => "object" );
+ foreach ( $types->get_node( 1 )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE ) && ( $object_type = $_->toString );
+ }
+ my ( $success, $message, $typeURI ) =
+ $OE->objectExists( term => $object_type );
+ if ( ( !( $success ) && ( $object_type =~ /urn:lsid:biomoby.org/i ) )
+ || ( !( $success ) && !( $object_type =~ /urn:lsid/i ) ) )
+ { # if the object doesn't exist, and it isn't an LSID
+ $SVC->DELETE_THYSELF;
+ return ( -1,
+ "object: $object_type does not exist, and is not an LSID"
+ );
+ } # kill it all unless this was successful!
my $namespace_string;
- my $namespaces = $node->getElementsByTagName('Namespace');
- my $num_ns = $namespaces->getLength;
- $OE = MOBY::OntologyServer->new(ontology => "namespace");
- for (my $n = 0; $n<$num_ns;++$n) {
- foreach my $name ($namespaces->item($n)->getChildNodes) {
- if ($name->getNodeType == TEXT_NODE) {
+ my $namespaces = $node->getElementsByTagName( 'Namespace' );
+ my $num_ns = $namespaces->size();
+ $OE = MOBY::OntologyServer->new( ontology => "namespace" );
+ for ( my $n = 1 ; $n <= $num_ns ; ++$n ) {
+ foreach my $name ( $namespaces->get_node( $n )->childNodes ) {
+ if ( $name->nodeType == TEXT_NODE ) {
my $term = $name->toString;
- my ($success, $message, $URI) = $OE->namespaceExists(term => $term);
- if ((!($success) && ($term =~ /urn:lsid:biomoby.org/i)) || (!($success) && !($term =~ /urn:lsid/i))) { # if the object doesn't exist, and it isn't an LSID
+ my ( $success, $message, $URI ) =
+ $OE->namespaceExists( term => $term );
+ if (
+ (
+ !( $success ) && ( $term =~ /urn:lsid:biomoby.org/i )
+ )
+ || ( !( $success ) && !( $term =~ /urn:lsid/i ) )
+ )
+ { # if the object doesn't exist, and it isn't an LSID
$SVC->DELETE_THYSELF;
- return (-1,"namespace: $term doesn't exist and is not an LSID");
+ return (
+ -1,
+ "namespace: $term doesn't exist and is not an LSID"
+ );
}
- $namespace_string .=$URI.",";
+ $namespace_string .= $URI . ",";
}
}
}
- chop($namespace_string); # remove trailing comma
+ chop( $namespace_string ); # remove trailing comma
my $dbh = $SVC->dbh;
my $service_instance_id;
- unless ($collid) { # this SIMPLE is either alone, or is part of a COLLECTION ($collid > 0)
- # therefore we want either its service instance ID, or its Collection ID.
+ unless ( $collid )
+ { # this SIMPLE is either alone, or is part of a COLLECTION ($collid > 0)
+ # therefore we want either its service instance ID, or its Collection ID.
$service_instance_id = $SVC->service_instance_id;
- } # one or the other, but not both
-
- if ($inout eq 'input'){
- my $sinput = $SVC->add_simple_input(
- object_type_uri => $typeURI,
- namespace_type_uris => $namespace_string,
- article_name => $article,
- collection_input_id => $collid,
- );
- unless ($sinput){
- $SVC->DELETE_THYSELF; return (-1,"registration failed during registration of input object $typeURI. Unknown reasons.");
- }
-
- } elsif ($inout eq 'output'){
- my $soutput = $SVC->add_simple_output(
- object_type_uri => $typeURI,
- namespace_type_uris => $namespace_string,
- article_name => $article,
- collection_output_id => $collid,
- );
- unless ($soutput){
- $SVC->DELETE_THYSELF; return (-1,"registration failed during registration of output object $typeURI. Unknown reasons.");
- }
- }
-
- } elsif ($simp_coll eq "Parameter"){
- my $parameter = $node;
- my $article = $parameter->getAttributeNode("articleName");
- $article = $article->getValue() if $article;
- my ($datatype, $def, $max, $min, @enums);
- my $types = $parameter->getElementsByTagName('datatype');
- if ($types->item(0)){
- foreach ($types->item(0)->getChildNodes){ # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && ($datatype = $_->toString);
- }
- }
- my $defs = $parameter->getElementsByTagName('default');
- if ($defs->item(0)){
- foreach ($defs->item(0)->getChildNodes){ # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && ($def = $_->toString);
- }
- }
- my $maxs = $parameter->getElementsByTagName('max');
- if ($maxs->item(0)){
- foreach ($maxs->item(0)->getChildNodes){ # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && ($max = $_->toString);
- }
- }
- my $mins = $parameter->getElementsByTagName('min');
- if ($mins->item(0)){
- foreach ($mins->item(0)->getChildNodes){ # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && ($min = $_->toString);
- }
- }
- my $enums = $parameter->getElementsByTagName('enum');
- my $numenums = $enums->getLength;
- for (my $n=0;$n<$numenums;++$n){
- foreach ($enums->item($n)->getChildNodes){ # should only ever be one!
- ($_->getNodeType == TEXT_NODE) && (push @enums, $_->toString);
- }
- }
- my $enum_string = join "",(map {$_.","} @enums);
- chop $enum_string; # get rid of trailing comma
- my $sec = $SVC->add_secondary_input(
- default_value => $def,
- maximum_value => $max,
- minimum_value => $min,
- enum_value => $enum_string,
- datatype => $datatype,
- article_name => $article,
- );
- unless ($sec){
- $SVC->DELETE_THYSELF; return (-1,"registration failed during registration of parameter $article. Must be of type Integer, String, DateTime, or Float.");
- }
+ } # one or the other, but not both
+ if ( $inout eq 'input' ) {
+ my $sinput = $SVC->add_simple_input(
+ object_type_uri => $typeURI,
+ namespace_type_uris => $namespace_string,
+ article_name => $article,
+ collection_input_id => $collid,
+ );
+ unless ( $sinput ) {
+ $SVC->DELETE_THYSELF;
+ return (
+ -1,
+"registration failed during registration of input object $typeURI. Unknown reasons."
+ );
+ }
+ } elsif ( $inout eq 'output' ) {
+ my $soutput = $SVC->add_simple_output(
+ object_type_uri => $typeURI,
+ namespace_type_uris => $namespace_string,
+ article_name => $article,
+ collection_output_id => $collid,
+ );
+ unless ( $soutput ) {
+ $SVC->DELETE_THYSELF;
+ return (
+ -1,
+"registration failed during registration of output object $typeURI. Unknown reasons."
+ );
+ }
+ }
+ } elsif ( $simp_coll eq "Parameter" ) {
+ my $parameter = $node;
+ my $article = $parameter->getAttributeNode( "articleName" );
+ $article = $article->getValue() if $article;
+ my ( $datatype, $def, $max, $min, @enums );
+ my $types = $parameter->getElementsByTagName( 'datatype' );
+ if ( $types->get_node( 1 ) ) {
+ foreach ( $types->get_node( 1 )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE )
+ && ( $datatype = $_->toString );
+ }
+ }
+ my $defs = $parameter->getElementsByTagName( 'default' );
+ if ( $defs->get_node( 1 ) ) {
+ foreach ( $defs->get_node( 1 )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE ) && ( $def = $_->toString );
+ }
+ }
+ my $maxs = $parameter->getElementsByTagName( 'max' );
+ if ( $maxs->get_node( 1 ) ) {
+ foreach ( $maxs->get_node( 1 )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE ) && ( $max = $_->toString );
+ }
+ }
+ my $mins = $parameter->getElementsByTagName( 'min' );
+ if ( $mins->get_node( 1 ) ) {
+ foreach ( $mins->get_node( 1 )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE ) && ( $min = $_->toString );
+ }
+ }
+ my $enums = $parameter->getElementsByTagName( 'enum' );
+ my $numenums = $enums->size();
+ for ( my $n = 1 ; $n <= $numenums ; ++$n ) {
+ foreach ( $enums->get_node( $n )->childNodes )
+ { # should only ever be one!
+ ( $_->nodeType == TEXT_NODE )
+ && ( push @enums, $_->toString );
+ }
+ }
+ my $enum_string = join "", ( map { $_ . "," } @enums );
+ chop $enum_string; # get rid of trailing comma
+ my $sec = $SVC->add_secondary_input(
+ default_value => $def,
+ maximum_value => $max,
+ minimum_value => $min,
+ enum_value => $enum_string,
+ datatype => $datatype,
+ article_name => $article,
+ );
+ unless ( $sec ) {
+ $SVC->DELETE_THYSELF;
+ return (
+ -1,
+"registration failed during registration of parameter $article. Must be of type Integer, String, DateTime, or Float."
+ );
+ }
}
return 1;
}
-
+#Eddie - converted
sub _registerServicePayload {
- 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 'registerService');
-
- my $serviceName = &_nodeTextContent($Object, "serviceName");
- my $Category = &_nodeTextContent($Object, "Category");
- my $serviceType = &_nodeTextContent($Object, "serviceType");
- my $AuthURI = &_nodeTextContent($Object, "authURI");
- my $contactEmail = &_nodeTextContent($Object, "contactEmail");
- my $authoritativeService = &_nodeTextContent($Object, "authoritativeService");
- my $URL = &_nodeTextContent($Object, "URL");
- my $signatureURL = &_nodeTextContent($Object, "signatureURL");
- my $desc = &_nodeTextContent($Object, "Description");
- my $INPUTS = &_nodeRawContent($Object, "Input"); # returns array ref
- my $OUTPUTS = &_nodeRawContent($Object, "Output"); # returns array ref
- my $SECONDARIES = &_nodeRawContent($Object, "secondaryArticles"); # returns array ref
-
- return ($serviceName, $serviceType, $AuthURI, $contactEmail, $URL, $authoritativeService, $desc, $Category, $INPUTS, $OUTPUTS, $SECONDARIES, $signatureURL);
+ 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 'registerService' );
+ my $serviceName = &_nodeTextContent( $Object, "serviceName" );
+ my $Category = &_nodeTextContent( $Object, "Category" );
+ my $serviceType = &_nodeTextContent( $Object, "serviceType" );
+ my $AuthURI = &_nodeTextContent( $Object, "authURI" );
+ my $contactEmail = &_nodeTextContent( $Object, "contactEmail" );
+ my $authoritativeService =
+ &_nodeTextContent( $Object, "authoritativeService" );
+ my $URL = &_nodeTextContent( $Object, "URL" );
+ my $signatureURL = &_nodeTextContent( $Object, "signatureURL" );
+ my $desc = &_nodeTextContent( $Object, "Description" );
+ my $INPUTS = &_nodeRawContent( $Object, "Input" ); # returns array ref
+ my $OUTPUTS = &_nodeRawContent( $Object, "Output" ); # returns array ref
+ my $SECONDARIES =
+ &_nodeRawContent( $Object, "secondaryArticles" ); # returns array ref
+ return (
+ $serviceName, $serviceType, $AuthURI,
+ $contactEmail, $URL, $authoritativeService,
+ $desc, $Category, $INPUTS,
+ $OUTPUTS, $SECONDARIES, $signatureURL
+ );
}
+#Eddie - converted
sub _extractObjectTypes {
- my ($DOM) = @_; # DOM is either a <Simple/> or a <Collection/> article
- $debug && &_LOG("\n\n\nExtracting object types from \n$DOM \n\n");
- unless (ref($DOM) =~ /^XML/){
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($DOM);
+ my ( $DOM ) = @_; # DOM is either a <Simple/> or a <Collection/> article
+ $debug && &_LOG( "\n\n\nExtracting object types from \n$DOM \n\n" );
+ unless ( ref( $DOM ) =~ /^XML/ ) {
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $DOM );
$DOM = $doc->getDocumentElement();
}
- my $x = $DOM->getElementsByTagName("objectType");
+ my $x = $DOM->getElementsByTagName( "objectType" );
my @objectnames;
- my $l = $x->getLength; # might be a Collection object with multiple simples...
- for (my $n=0; $n < $l; ++$n){
- my @child = $x->item($n)->getChildNodes;
- foreach (@child){
- $debug && &_LOG ($_->getNodeTypeName, "\t", $_->toString,"\n");
- next unless ($_->getNodeType == TEXT_NODE);
- my $name = $_->toString; chomp $name;
+ my $l = $x->size(); # might be a Collection object with multiple simples...
+ for ( my $n = 1 ; $n <= $l ; ++$n ) {
+ my @child = $x->get_node( $n )->childNodes;
+ foreach ( @child ) {
+ $debug
+ && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" )
+ ; #hopefully uses MobyXMLConstants.pm
+ next unless ( $_->nodeType == TEXT_NODE );
+ my $name = $_->toString;
+ chomp $name;
push @objectnames, $name;
}
}
- return (@objectnames);
+ return ( @objectnames );
}
-
=head2 registerServiceWSDL
Title : NOT YET IMPLEMENTED
@@ -1403,13 +1641,11 @@
=cut
-
sub registerServiceWSDL {
- my ( $pkg, $serviceType, $wsdl) = @_;
- return &_error("not yet implemented", "");
+ my ( $pkg, $serviceType, $wsdl ) = @_;
+ return &_error( "not yet implemented", "" );
}
-
=head2 deregisterService
Title : deregisterService
@@ -1427,40 +1663,51 @@
=cut
-
-
sub deregisterService {
- my ($pkg, $payload) = @_;
- $debug && &_LOG("\nstarting deregistration\n");
- my ($authURI, $serviceName) = &_deregisterServicePayload($payload);
- return &_error("must provide an authority and a service name\n", "") unless ($authURI && $serviceName);
-
-
- return &_error("The service specified by authority=$authURI servicename=$serviceName does not exist in the registry", "") unless (MOBY::service_instance->new(servicename => $serviceName, authority_uri => $authURI, test => 1));
- my $SERVICE = MOBY::service_instance->new(servicename => $serviceName, authority_uri => $authURI);
- if ($SERVICE->signatureURL){
- return &_error("it is illegal to deregister a service that has a signatureURL. Such services must be deregistered by deleting the RDF at the location identified by the signatureURL","");
- }
-
- my $result = $SERVICE->DELETE_THYSELF;
- if ($result){
- return &_success("Service Deregistered Successfully","");
+ my ( $pkg, $payload ) = @_;
+ $debug && &_LOG( "\nstarting deregistration\n" );
+ my ( $authURI, $serviceName ) = &_deregisterServicePayload( $payload );
+ return &_error( "must provide an authority and a service name\n", "" )
+ unless ( $authURI && $serviceName );
+ return &_error(
+"The service specified by authority=$authURI servicename=$serviceName does not exist in the registry",
+ ""
+ )
+ unless (
+ MOBY::service_instance->new(
+ servicename => $serviceName,
+ authority_uri => $authURI,
+ test => 1
+ )
+ );
+ my $SERVICE = MOBY::service_instance->new( servicename => $serviceName,
+ authority_uri => $authURI );
+ if ( $SERVICE->signatureURL ) {
+ return &_error(
+"it is illegal to deregister a service that has a signatureURL. Such services must be deregistered by deleting the RDF at the location identified by the signatureURL",
+ ""
+ );
+ }
+ my $result = $SERVICE->DELETE_THYSELF;
+ if ( $result ) {
+ return &_success( "Service Deregistered Successfully", "" );
} else {
- return &_error("Service deletion failed for unknown reasons","");
+ return &_error( "Service deletion failed for unknown reasons", "" );
}
}
+#Eddie - converted
sub _deregisterServicePayload {
- my ($payload) = @_;
- $debug && &_LOG("deregisterService payload: ",($payload),"\n");
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
+ my ( $payload ) = @_;
+ $debug && &_LOG( "deregisterService payload: ", ( $payload ), "\n" );
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
my $Object = $doc->getDocumentElement();
- my $obj = $Object->getTagName;
- return undef unless ($obj eq 'deregisterService');
- my $authURI = &_nodeTextContent($Object, "authURI");
- my $name = &_nodeTextContent($Object, "serviceName");
- return ($authURI, $name);
+ my $obj = $Object->nodeName; #Eddie - unsure
+ return undef unless ( $obj eq 'deregisterService' );
+ my $authURI = &_nodeTextContent( $Object, "authURI" );
+ my $name = &_nodeTextContent( $Object, "serviceName" );
+ return ( $authURI, $name );
}
=head2 findService
@@ -1567,11 +1814,11 @@
=cut
sub findService {
- my ($pkg, $payload) = @_;
- $debug && &_LOG("\nLOOKING FOR SERVICES\n");
- my %findme = &_findServicePayload($payload);
-
- $debug && &_LOG ("'serviceType' => $findme{serviceType},
+ my ( $pkg, $payload ) = @_;
+ $debug && &_LOG( "\nLOOKING FOR SERVICES\n" );
+ my %findme = &_findServicePayload( $payload );
+ $debug && &_LOG(
+ "'serviceType' => $findme{serviceType},
'authURI' => $findme{AuthURI},
'servicename' => $findme{servicename},
'expandObjects' => $findme{expandObjects},
@@ -1579,281 +1826,393 @@
'authoritative' => $findme{authoritative},
'category' => $findme{Category},
'keywords' => $findme{keywords},
- ");
-
+ "
+ );
my %valid_service_ids;
- my $criterion_count=0;
- # we want to avoid joins, since they slow things down, so...
- # the logic is that we keep a hash of valid id's
- # and the number of times they are discovered
- # we also count the number of criterion
- # we only want the service_id's that appear as many times as the criterion we have
- # since they will have matched every criterion.
+ my $criterion_count = 0;
+
+# we want to avoid joins, since they slow things down, so...
+# the logic is that we keep a hash of valid id's
+# and the number of times they are discovered
+# we also count the number of criterion
+# we only want the service_id's that appear as many times as the criterion we have
+# since they will have matched every criterion.
my $dbh = MOBY::central_db_connection->new()->dbh;
- if ($findme{authoritative}){
+ if ( $findme{authoritative} ) {
++$criterion_count;
- $debug && _LOG("authoritative added; criterion count is now $criterion_count\n");
- my $ids = $dbh->selectall_arrayref(q{select service_instance_id from service_instance where authoritative=?}, undef, $findme{authoritative});
- unless (scalar @{$ids}){
- return &_serviceListResponse($dbh,undef);
- }
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ $debug
+ && _LOG(
+ "authoritative added; criterion count is now $criterion_count\n" );
+ my $ids = $dbh->selectall_arrayref(
+q{select service_instance_id from service_instance where authoritative=?},
+ undef, $findme{authoritative}
+ );
+ unless ( scalar @{$ids} ) {
+ return &_serviceListResponse( $dbh, undef );
+ }
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
- if ($findme{serviceType}){ # must have something more than empty content
- my $OS = MOBY::OntologyServer->new(ontology => 'service');
+ if ( $findme{serviceType} ) { # must have something more than empty content
+ my $OS = MOBY::OntologyServer->new( ontology => 'service' );
$findme{serviceType} =~ s/^moby\://;
- my ($exists, $message, $URI) = $OS->serviceExists(term =>$findme{serviceType});
- unless ($exists){
- return &_serviceListResponse($dbh,undef);
+ my ( $exists, $message, $URI ) =
+ $OS->serviceExists( term => $findme{serviceType} );
+ unless ( $exists ) {
+ return &_serviceListResponse( $dbh, undef );
}
++$criterion_count;
- $debug && _LOG("serviceType added; criterion count is now $criterion_count\n");
-
+ $debug
+ && _LOG(
+ "serviceType added; criterion count is now $criterion_count\n" );
my $children_string = "'$URI',";
- if ($findme{'expandServices'}){
- $debug && _LOG("Expanding Services\n");
- my $OS = MOBY::OntologyServer->new(ontology => 'service');
- my %relationships = %{$OS->traverseDAG($URI, "leaves")};
- my (@children) = @{$relationships{'urn:lsid:biomoby.org:servicerelation:isa'}};
- $children_string .= (join ',', map {"\'$_\'"} @children);
+ if ( $findme{'expandServices'} ) {
+ $debug && _LOG( "Expanding Services\n" );
+ my $OS = MOBY::OntologyServer->new( ontology => 'service' );
+ my %relationships = %{ $OS->traverseDAG( $URI, "leaves" ) };
+ my ( @children ) =
+ @{ $relationships{'urn:lsid:biomoby.org:servicerelation:isa'} };
+ $children_string .= ( join ',', map { "\'$_\'" } @children );
}
$children_string =~ s/\,$//;
- my $ids = $dbh->selectall_arrayref("select service_instance_id from service_instance where service_type_uri in ($children_string)");
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ my $ids =
+ $dbh->selectall_arrayref(
+"select service_instance_id from service_instance where service_type_uri in ($children_string)"
+ );
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
- if ($findme{authURI}){
+ if ( $findme{authURI} ) {
++$criterion_count;
- $debug && _LOG("authURI added; criterion count is now $criterion_count\n");
-
- my ($id) = $dbh->selectrow_array(q{select authority_id from authority where authority_uri = ? or authority_common_name = ?},undef,($findme{authURI}, $findme{authURI}));
- unless ($id){
- return &_serviceListResponse($dbh,undef);
- }
- my $ids = $dbh->selectall_arrayref(q{select service_instance_id from service_instance where authority_id=?}, undef, $id);
- unless (scalar @{$ids}){
- return &_serviceListResponse($dbh,undef);
- }
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ $debug
+ && _LOG( "authURI added; criterion count is now $criterion_count\n" );
+ my ( $id ) = $dbh->selectrow_array(
+q{select authority_id from authority where authority_uri = ? or authority_common_name = ?},
+ undef,
+ ( $findme{authURI}, $findme{authURI} )
+ );
+ unless ( $id ) {
+ return &_serviceListResponse( $dbh, undef );
+ }
+ my $ids = $dbh->selectall_arrayref(
+q{select service_instance_id from service_instance where authority_id=?},
+ undef, $id
+ );
+ unless ( scalar @{$ids} ) {
+ return &_serviceListResponse( $dbh, undef );
+ }
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
- if ($findme{servicename}){
+ if ( $findme{servicename} ) {
++$criterion_count;
- $debug && _LOG("servicename added; criterion count is now $criterion_count\n");
-
- my $ids = $dbh->selectall_arrayref(q{select service_instance_id from service_instance where servicename=?}, undef, $findme{servicename});
- unless (scalar @{$ids}){
- return &_serviceListResponse($dbh,undef);
- }
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ $debug
+ && _LOG(
+ "servicename added; criterion count is now $criterion_count\n" );
+ my $ids = $dbh->selectall_arrayref(
+q{select service_instance_id from service_instance where servicename=?},
+ undef, $findme{servicename}
+ );
+ unless ( scalar @{$ids} ) {
+ return &_serviceListResponse( $dbh, undef );
+ }
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
$findme{category} = 'moby' unless $findme{category};
- if ($findme{category}){
+ if ( $findme{category} ) {
++$criterion_count;
- $debug && _LOG("category added; criterion count is now $criterion_count\n");
-
- my $ids = $dbh->selectall_arrayref(q{select service_instance_id from service_instance where category=?}, undef, lc($findme{category}));
- unless (scalar @{$ids}){
- return &_serviceListResponse($dbh,undef);
- }
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ $debug
+ && _LOG(
+ "category added; criterion count is now $criterion_count\n" );
+ my $ids = $dbh->selectall_arrayref(
+q{select service_instance_id from service_instance where category=?},
+ undef,
+ lc( $findme{category} )
+ );
+ unless ( scalar @{$ids} ) {
+ return &_serviceListResponse( $dbh, undef );
+ }
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
- if ($findme{keywords} && (scalar @{$findme{keywords}})){
+ if ( $findme{keywords} && ( scalar @{ $findme{keywords} } ) ) {
++$criterion_count;
- $debug && _LOG("Keywords added; criterion count is now $criterion_count\n");
+ $debug
+ && _LOG(
+ "Keywords added; criterion count is now $criterion_count\n" );
my $searchstring;
- foreach my $kw(@{$findme{keywords}}){
- $debug && &_LOG("KEYWORD $kw\n");
+ foreach my $kw ( @{ $findme{keywords} } ) {
+ $debug && &_LOG( "KEYWORD $kw\n" );
$kw =~ s/\*//g;
- $kw = $dbh->quote("%$kw%");
+ $kw = $dbh->quote( "%$kw%" );
$searchstring .= " OR description like $kw ";
}
- $searchstring =~ s/OR//; # just the first one
- $debug && &_LOG("search $searchstring\n");
-
- my $ids = $dbh->selectall_arrayref("select service_instance_id from service_instance where $searchstring");
- unless (scalar @{$ids}){
- $debug && &_LOG("found no ids @{$ids}!\nselect service_instance_id from service_instance where $searchstring\n");
- return &_serviceListResponse($dbh, undef);
- }
- $debug && _LOG("services ".(join ',', @{$ids})." incrememted\n");
- foreach (@{$ids}){
- $debug && &_LOG("found id $_->[0]\n");
- ++$valid_service_ids{$_->[0]}; # increment that particular id's count by one
+ $searchstring =~ s/OR//; # just the first one
+ $debug && &_LOG( "search $searchstring\n" );
+ my $ids =
+ $dbh->selectall_arrayref(
+"select service_instance_id from service_instance where $searchstring" );
+ unless ( scalar @{$ids} ) {
+ $debug
+ && &_LOG( "found no ids @{$ids}!\nselect service_instance_id from service_instance where $searchstring\n"
+ );
+ return &_serviceListResponse( $dbh, undef );
+ }
+ $debug
+ && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" );
+ foreach ( @{$ids} ) {
+ $debug && &_LOG( "found id $_->[0]\n" );
+ ++$valid_service_ids{ $_->[0]
+ }; # increment that particular id's count by one
}
}
- if ($findme{inputObjects} && (scalar @{$findme{inputObjects}})){
+ if ( $findme{inputObjects} && ( scalar @{ $findme{inputObjects} } ) ) {
++$criterion_count;
- $debug && _LOG("inputObject added; criterion count is now $criterion_count\n");
- my $obj = (shift @{$findme{inputObjects}});
+ $debug
+ && _LOG(
+ "inputObject added; criterion count is now $criterion_count\n" );
+ my $obj = ( shift @{ $findme{inputObjects} } );
my @si_ids;
- @si_ids = &_searchForServicesWithArticle($dbh, "input", $obj, $findme{'expandObjects'}, '') if defined $obj;
- $debug && _LOG("Initial Search For Services with INPUT Article found @si_ids\n");
+ @si_ids =
+ &_searchForServicesWithArticle( $dbh, "input", $obj,
+ $findme{'expandObjects'}, '' )
+ if defined $obj;
+ $debug
+ && _LOG(
+ "Initial Search For Services with INPUT Article found @si_ids\n" );
my %instances;
+
# we need to do a join, without doing a join...
- if (scalar @si_ids){
- map {$instances{$_}=1} @si_ids; # get an id of the good services from the first object
- while (my $obj = shift(@{$findme{inputObjects}})){ # iterate through the rest of the objects
+ if ( scalar @si_ids ) {
+ map { $instances{$_} = 1 }
+ @si_ids; # get an id of the good services from the first object
+ while ( my $obj = shift( @{ $findme{inputObjects} } ) )
+ { # iterate through the rest of the objects
next unless $obj;
- $debug && _LOG("FIRST: ", $dbh, "input", $obj, $findme{'expandObjects'}, '');
- my @new_ids = &_searchForServicesWithArticle($dbh, "input", $obj, $findme{'expandObjects'}, ''); # get their service ids
- $debug && _LOG("Subsequent Search For Services with INPUT Article found @new_ids\n");
- my @good_ids;my %good_ids;
- foreach my $id(@new_ids){ # check the new id set against the set we know is already valid
+ $debug
+ && _LOG( "FIRST: ", $dbh, "input", $obj,
+ $findme{'expandObjects'}, '' );
+ my @new_ids =
+ &_searchForServicesWithArticle( $dbh, "input", $obj,
+ $findme{'expandObjects'}, '' ); # get their service ids
+ $debug
+ && _LOG( "Subsequent Search For Services with INPUT Article found @new_ids\n"
+ );
+ my @good_ids;
+ my %good_ids;
+ foreach my $id ( @new_ids )
+ { # check the new id set against the set we know is already valid
next unless defined $id;
- if ($instances{$id}){push @good_ids, $id} # if they are in common, then that id is still good
+ if ( $instances{$id} ) {
+ push @good_ids, $id;
+ } # if they are in common, then that id is still good
}
- map {$good_ids{$_}=1} @good_ids; # make a hash of the new good id's
- %instances = %good_ids; # and replace the original list with this more limited one
+ map { $good_ids{$_} = 1 }
+ @good_ids; # make a hash of the new good id's
+ %instances = %good_ids
+ ; # and replace the original list with this more limited one
}
}
- # now %instances contains only valid ID numbers
- $debug && _LOG("Final results incremented of search for INPUT: ".(join ',',(keys %instances))."\n");
- foreach (keys %instances){
- $debug && &_LOG("found id $_\n");
+ # now %instances contains only valid ID numbers
+ $debug
+ && _LOG( "Final results incremented of search for INPUT: "
+ . ( join ',', ( keys %instances ) )
+ . "\n" );
+ foreach ( keys %instances ) {
+ $debug && &_LOG( "found id $_\n" );
++$valid_service_ids{$_};
}
}
- if ($findme{outputObjects} && (scalar @{$findme{outputObjects}})){
+ if ( $findme{outputObjects} && ( scalar @{ $findme{outputObjects} } ) ) {
++$criterion_count;
- $debug && _LOG("outputObject added; criterion count is now $criterion_count\n");
- my $obj = (shift @{$findme{outputObjects}});
+ $debug
+ && _LOG(
+ "outputObject added; criterion count is now $criterion_count\n" );
+ my $obj = ( shift @{ $findme{outputObjects} } );
my @si_ids;
- @si_ids = &_searchForServicesWithArticle($dbh, "output", $obj, '') if defined $obj;
- $debug && _LOG("Initial Search For Services with OUTPUT Article found @si_ids\n");
+ @si_ids = &_searchForServicesWithArticle( $dbh, "output", $obj, '' )
+ if defined $obj;
+ $debug
+ && _LOG(
+ "Initial Search For Services with OUTPUT Article found @si_ids\n" );
my %instances;
+
# we need to do a join, without doing a join...
- if (scalar @si_ids){
- map {$instances{$_}=1} @si_ids; # get an id of the good services from the first object
- while (my $obj = shift(@{$findme{outputObjects}})){ # iterate through the rest of the objects
+ if ( scalar @si_ids ) {
+ map { $instances{$_} = 1 }
+ @si_ids; # get an id of the good services from the first object
+ while ( my $obj = shift( @{ $findme{outputObjects} } ) )
+ { # iterate through the rest of the objects
next unless $obj;
- my @new_ids = &_searchForServicesWithArticle($dbh, "output", $obj,''); # get their service ids
- $debug && _LOG("Subsequent Search For Services with OUTPUT Article found @new_ids\n");
- my @good_ids;my %good_ids;
- foreach my $id(@new_ids){ # check the new id set against the set we know is already valid
+ my @new_ids =
+ &_searchForServicesWithArticle( $dbh, "output", $obj, '' )
+ ; # get their service ids
+ $debug
+ && _LOG( "Subsequent Search For Services with OUTPUT Article found @new_ids\n"
+ );
+ my @good_ids;
+ my %good_ids;
+ foreach my $id ( @new_ids )
+ { # check the new id set against the set we know is already valid
next unless defined $id;
- if ($instances{$id}){push @good_ids, $id} # if they are in common, then that id is still good
+ if ( $instances{$id} ) {
+ push @good_ids, $id;
+ } # if they are in common, then that id is still good
}
- map {$good_ids{$_}=1} @good_ids; # make a hash of the new good id's
- %instances = %good_ids; # and replace the original list with this more limited one
+ map { $good_ids{$_} = 1 }
+ @good_ids; # make a hash of the new good id's
+ %instances = %good_ids
+ ; # and replace the original list with this more limited one
}
}
+
# now %instances contains only valid ID numbers
- $debug && _LOG("Final results incremented of search for OUTPUT: ".(join ',',(keys %instances))."\n");
- foreach (keys %instances){
- $debug && &_LOG("found id $_\n");
+ $debug
+ && _LOG( "Final results incremented of search for OUTPUT: "
+ . ( join ',', ( keys %instances ) )
+ . "\n" );
+ foreach ( keys %instances ) {
+ $debug && &_LOG( "found id $_\n" );
++$valid_service_ids{$_};
}
}
my @final;
- while (my ($id, $freq) = each %valid_service_ids){
- $debug && _LOG("TALLY IS ID: $id FREQ:$freq\n CRITERION COUNT $criterion_count\n");
- next unless $freq == $criterion_count; # has to have matched every criterion
+ while ( my ( $id, $freq ) = each %valid_service_ids ) {
+ $debug
+ && _LOG( "TALLY IS ID: $id FREQ:$freq\n CRITERION COUNT $criterion_count\n"
+ );
+ next
+ unless $freq ==
+ $criterion_count; # has to have matched every criterion
push @final, $id;
}
- return &_serviceListResponse($dbh, @final);
-
+ return &_serviceListResponse( $dbh, @final );
}
+#Eddie - converted
sub _searchForServicesWithArticle {
- my ($dbh, $inout, $node, $expand, $coll) = @_;
-
- return () unless $node->getNodeType == ELEMENT_NODE; # this will erase all current successful service instances!
- $debug && _LOG("searchServWthArticle ",$dbh, $inout, $node, $expand, $coll);
- # this element node may be a Simple or a Collection object
- my $simp_coll = $node->getTagName;
- $debug && &_LOG("TAGNAME in _searchForArticle is $simp_coll");
-
+ my ( $dbh, $inout, $node, $expand, $coll ) = @_;
+ return ()
+ unless $node->nodeType ==
+ ELEMENT_NODE; # this will erase all current successful service instances!
+ $debug
+ && _LOG( "searchServWthArticle ", $dbh, $inout, $node, $expand, $coll );
+
+ # this element node may be a Simple or a Collection object
+ my $simp_coll = $node->nodeName;
+ $debug && &_LOG( "TAGNAME in _searchForArticle is $simp_coll" );
my @valid_ids;
- if ($simp_coll eq "Collection"){
- @valid_ids = &_searchForCollection($dbh, $node, $expand, $inout);
- } elsif ($simp_coll eq "Simple") {
- @valid_ids = &_searchForSimple($dbh,$node, $expand, $inout);
- }
- return @valid_ids;
+ if ( $simp_coll eq "Collection" ) {
+ @valid_ids = &_searchForCollection( $dbh, $node, $expand, $inout );
+ } elsif ( $simp_coll eq "Simple" ) {
+ @valid_ids = &_searchForSimple( $dbh, $node, $expand, $inout );
+ }
+ return @valid_ids;
}
+
sub _searchForSimple {
+
# returns list of service_instance ID's
# that match this simple
- my ($dbh,$node, $expand, $inout) = @_;
- $debug && _LOG($dbh,$node, $expand, $inout);
- my ($objectURI, $namespaceURIs) = &_extractObjectTypesAndNamespaces($node); # (objectType, [ns1, ns2, ns3])
- unless ($objectURI){return ()};
+ my ( $dbh, $node, $expand, $inout ) = @_;
+ $debug && _LOG( $dbh, $node, $expand, $inout );
+ my ( $objectURI, $namespaceURIs ) =
+ &_extractObjectTypesAndNamespaces( $node )
+ ; # (objectType, [ns1, ns2, ns3])
+ unless ( $objectURI ) { return () }
my $ancestor_string = "'$objectURI',";
- if ($expand){
- $debug && _LOG("Expanding Objects\n");
- my $OS = MOBY::OntologyServer->new(ontology => 'object');
- my %relationships = %{$OS->traverseDAG($objectURI, "root")};
- my (@ancestors) = @{$relationships{'urn:lsid:biomoby.org:objectrelation:isa'}};
- $ancestor_string .= (join ',', map {"\'$_\'"} @ancestors);
+ if ( $expand ) {
+ $debug && _LOG( "Expanding Objects\n" );
+ my $OS = MOBY::OntologyServer->new( ontology => 'object' );
+ my %relationships = %{ $OS->traverseDAG( $objectURI, "root" ) };
+ my ( @ancestors ) =
+ @{ $relationships{'urn:lsid:biomoby.org:objectrelation:isa'} };
+ $ancestor_string .= ( join ',', map { "\'$_\'" } @ancestors );
}
$ancestor_string =~ s/\,$//;
-
- my $query = "select service_instance_id, namespace_type_uris from simple_$inout where object_type_uri in ($ancestor_string) and service_instance_id IS NOT NULL ";# if service_instance_id is null then it must be a collection input.
-
+ my $query =
+"select service_instance_id, namespace_type_uris from simple_$inout where object_type_uri in ($ancestor_string) and service_instance_id IS NOT NULL "
+ ; # if service_instance_id is null then it must be a collection input.
my $nsquery;
- foreach my $ns(@{$namespaceURIs}){ # namespaces are already URI's
- $nsquery .=" OR INSTR(namespace_type_uris, '$ns') ";
+ foreach my $ns ( @{$namespaceURIs} ) { # namespaces are already URI's
+ $nsquery .= " OR INSTR(namespace_type_uris, '$ns') ";
}
- if ($nsquery){
- $nsquery =~ s/OR//; # just the first
+ if ( $nsquery ) {
+ $nsquery =~ s/OR//; # just the first
$nsquery .= " OR namespace_type_uris IS NULL";
- $query .=" AND ($nsquery) ";
+ $query .= " AND ($nsquery) ";
}
- $debug && _LOG("\nQUERY $query\n");
-
+ $debug && _LOG( "\nQUERY $query\n" );
my @valid_services;
-
- my $sth = $dbh->prepare($query);
+ my $sth = $dbh->prepare( $query );
$sth->execute;
- while (my ($id, $nss) = $sth->fetchrow_array){ # get the service instance ID and the namespaces that matched
- if ($nss && scalar @{$namespaceURIs}){ # if this service cares about namespaces at all,
- # and if namespaces were specified in the query,
- # then validate the discovered service against this list
- my @ns = split ",", $nss; # because of the database structure we have to re-test for *identity*, not just like%% similarity
- my %nshash = map {($_, 1)} @ns,@{$namespaceURIs}; #we're going to test identity by building a hash of namespaces as keys
- if (scalar(keys %nshash) < scalar(@ns)+scalar(@{$namespaceURIs})){ # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical
- push @valid_services, $id; # and therefore it really is a match, and is valid
+ while ( my ( $id, $nss ) = $sth->fetchrow_array )
+ { # get the service instance ID and the namespaces that matched
+ if ( $nss && scalar @{$namespaceURIs} )
+ { # if this service cares about namespaces at all,
+ # and if namespaces were specified in the query,
+ # then validate the discovered service against this list
+ my @ns = split ",", $nss
+ ; # because of the database structure we have to re-test for *identity*, not just like%% similarity
+ my %nshash = map { ( $_, 1 ) } @ns, @{ $namespaceURIs
+ }; #we're going to test identity by building a hash of namespaces as keys
+ if (
+ scalar( keys %nshash ) <
+ scalar( @ns ) + scalar( @{$namespaceURIs} ) )
+ { # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical
+ push @valid_services,
+ $id; # and therefore it really is a match, and is valid
}
- } else { # if no namespace was specified, then all of them are valid
- push @valid_services, $id
+ } else { # if no namespace was specified, then all of them are valid
+ push @valid_services, $id;
}
}
- $debug && _LOG("Resulting IDs were ".(join ',', @valid_services)."\n");
- return @valid_services;
+ $debug
+ && _LOG( "Resulting IDs were " . ( join ',', @valid_services ) . "\n" );
+ return @valid_services;
}
+#Eddie - converted
sub _searchForCollection {
- my ($dbh, $node, $expand, $inout)= @_; # $node in this case is a Collection object
+ my ( $dbh, $node, $expand, $inout ) =
+ @_; # $node in this case is a Collection object
my $query;
+
# luckily, we can return a redundant list of service id's and
# this will be cleaned up in the caller
-
- my @validservices;
- foreach my $simple($node->getChildNodes()){
- next unless ($simple->getNodeType == ELEMENT_NODE);
- next unless ($simple->getTagName =~ /simple/i);
- my ($objectURI, $namespaceURIs) = &_extractObjectTypesAndNamespaces($simple);
-
+ my @validservices;
+ foreach my $simple ( $node->childNodes() ) {
+ next unless ( $simple->nodeType == ELEMENT_NODE );
+ next unless ( $simple->nodeName =~ /simple/i );
+ my ( $objectURI, $namespaceURIs ) =
+ &_extractObjectTypesAndNamespaces( $simple );
$query = "select
c.service_instance_id,
s.namespace_type_uris
@@ -1864,119 +2223,134 @@
s.collection_${inout}_id IS NOT NULL
AND s.collection_${inout}_id = c.collection_${inout}_id
AND object_type_uri = '$objectURI' ";
-
my $nsquery;
- foreach my $ns(@{$namespaceURIs}){ # namespaces are already URI's
- $nsquery .=" OR INSTR(namespace_type_uris, '$ns') ";
+ foreach my $ns ( @{$namespaceURIs} ) { # namespaces are already URI's
+ $nsquery .= " OR INSTR(namespace_type_uris, '$ns') ";
}
- if ($nsquery){
- $nsquery =~ s/^\sOR//; # just the first
+ if ( $nsquery ) {
+ $nsquery =~ s/^\sOR//; # just the first
$nsquery .= " OR namespace_type_uris IS NULL";
- $query .= " AND ($nsquery) "; # add the AND clause
- }
-
- $debug && &_LOG("QUERY: $query");
- my $sth = $dbh->prepare($query);
+ $query .= " AND ($nsquery) "; # add the AND clause
+ }
+ $debug && &_LOG( "QUERY: $query" );
+ my $sth = $dbh->prepare( $query );
$sth->execute;
- while (my ($id, $nss) = $sth->fetchrow_array){ # get the service instance ID and the namespaces that matched
- if ($nss && scalar @{$namespaceURIs}){ # if this service cares about namespaces at all,
- # and if namespaces were specified in the query,
- # then validate the discovered service against this list
- my @ns = split ",", $nss; # because of the database structure we have to re-test for *identity*, not just like%% similarity
- my %nshash = map {($_, 1)} @ns,@{$namespaceURIs}; #we're going to test identity by building a hash of namespaces as keys
- if (scalar(keys %nshash) < scalar(@ns)+scalar(@{$namespaceURIs})){ # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical
- push @validservices, $id; # and therefore it really is a match, and is valid
+ while ( my ( $id, $nss ) = $sth->fetchrow_array )
+ { # get the service instance ID and the namespaces that matched
+ if ( $nss && scalar @{$namespaceURIs} )
+ { # if this service cares about namespaces at all,
+ # and if namespaces were specified in the query,
+ # then validate the discovered service against this list
+ my @ns = split ",", $nss
+ ; # because of the database structure we have to re-test for *identity*, not just like%% similarity
+ my %nshash = map { ( $_, 1 ) } @ns, @{ $namespaceURIs
+ }; #we're going to test identity by building a hash of namespaces as keys
+ if (
+ scalar( keys %nshash ) <
+ scalar( @ns ) + scalar( @{$namespaceURIs} ) )
+ { # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical
+ push @validservices,
+ $id; # and therefore it really is a match, and is valid
}
- } else { # if no namespace was specified, then all of them are valid
- push @validservices, $id
+ } else { # if no namespace was specified, then all of them are valid
+ push @validservices, $id;
}
}
- }
+ }
return @validservices;
}
+#Eddie - converted
sub _findServicePayload {
-
- 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 'findService');
-
- my $serviceType = &_nodeTextContent($Object, "serviceType");
- $serviceType && ($serviceType =~ s/\s+//g);
- my $servicename = &_nodeTextContent($Object, "serviceName");
- $servicename && ($servicename =~ s/\s+//g);
- my $authoritative = &_nodeTextContent($Object, "authoritative");
- $authoritative && ($authoritative =~ s/\s+//g);
- my $Category = &_nodeTextContent($Object, "Category");
- $Category && ($Category =~ s/\s+//g);
- my $AuthURI = &_nodeTextContent($Object, "authURI");
- $AuthURI && ($AuthURI =~ s/\s+//g);
- my $expandObjects = &_nodeTextContent($Object, "expandObjects");
- $expandObjects && ($expandObjects =~ s/\s+//g);
- my $expandServices = &_nodeTextContent($Object, "expandServices");
- $expandServices && ($expandServices =~ s/\s+//g);
- my @kw = &_nodeArrayContent($Object, "keywords");
- my $INPUTS = &_nodeRawContent($Object, "Input"); # returns array ref
- my $OUTPUTS = &_nodeRawContent($Object, "Output"); # returns array ref
-
- return ('serviceType' => $serviceType,
- 'authURI' => $AuthURI,
- 'servicename' => $servicename,
- 'expandObjects' => $expandObjects,
- 'expandServices' => $expandServices,
- 'authoritative' => $authoritative,
- 'Category' => $Category,
- 'inputObjects' => $INPUTS,
- 'outputObjects' => $OUTPUTS,
- 'keywords' => \@kw);
-
+ 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 'findService' );
+ my $serviceType = &_nodeTextContent( $Object, "serviceType" );
+ $serviceType && ( $serviceType =~ s/\s+//g );
+ my $servicename = &_nodeTextContent( $Object, "serviceName" );
+ $servicename && ( $servicename =~ s/\s+//g );
+ my $authoritative = &_nodeTextContent( $Object, "authoritative" );
+ $authoritative && ( $authoritative =~ s/\s+//g );
+ my $Category = &_nodeTextContent( $Object, "Category" );
+ $Category && ( $Category =~ s/\s+//g );
+ my $AuthURI = &_nodeTextContent( $Object, "authURI" );
+ $AuthURI && ( $AuthURI =~ s/\s+//g );
+ my $expandObjects = &_nodeTextContent( $Object, "expandObjects" );
+ $expandObjects && ( $expandObjects =~ s/\s+//g );
+ my $expandServices = &_nodeTextContent( $Object, "expandServices" );
+ $expandServices && ( $expandServices =~ s/\s+//g );
+ my @kw = &_nodeArrayContent( $Object, "keywords" );
+ my $INPUTS = &_nodeRawContent( $Object, "Input" ); # returns array ref
+ my $OUTPUTS = &_nodeRawContent( $Object, "Output" ); # returns array ref
+ return (
+ 'serviceType' => $serviceType,
+ 'authURI' => $AuthURI,
+ 'servicename' => $servicename,
+ 'expandObjects' => $expandObjects,
+ 'expandServices' => $expandServices,
+ 'authoritative' => $authoritative,
+ 'Category' => $Category,
+ 'inputObjects' => $INPUTS,
+ 'outputObjects' => $OUTPUTS,
+ 'keywords' => \@kw
+ );
}
+#Eddie - converted
sub _extractObjectTypesAndNamespaces {
- # takes a SINGLE simple article and return regular list ($objectURI, [nsURI1, nsURI2, nsURI3])
- my ($DOM) = @_;
- $debug && &_LOG("\n\n_extractObjectTypesAndNamespaces\nExtracting object types from \n$DOM \n\n");
- unless (ref($DOM) =~ /^XML/){
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($DOM);
+
+# takes a SINGLE simple article and return regular list ($objectURI, [nsURI1, nsURI2, nsURI3])
+ my ( $DOM ) = @_;
+ $debug
+ && &_LOG(
+"\n\n_extractObjectTypesAndNamespaces\nExtracting object types from \n$DOM \n\n"
+ );
+ unless ( ref( $DOM ) =~ /^XML/ ) {
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $DOM );
$DOM = $doc->getDocumentElement();
}
- my $x = $DOM->getElementsByTagName("objectType");
+ my $x = $DOM->getElementsByTagName( "objectType" );
my $objectname;
- my @child = $x->item(0)->getChildNodes;
- foreach (@child){
- $debug && &_LOG ($_->getNodeTypeName, "\t", $_->toString,"\n");
- next unless ($_->getNodeType == TEXT_NODE);
- my $name = $_->toString; chomp $name;
+ my @child = $x->get_node( 1 )->childNodes;
+ foreach ( @child ) {
+ $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" );
+ next unless ( $_->nodeType == TEXT_NODE );
+ my $name = $_->toString;
+ chomp $name;
$objectname = $name;
}
- $objectname =~ s/^moby\://; # damn XML DOM can't deal with namespaces... so get rid of it if it exists, though this is going to limit us to only MOBY objects again :-(
- my $OS= MOBY::OntologyServer->new(ontology => 'object');
- my ($exists, $message, $objectURI) = $OS->objectExists(term => $objectname);
- return (undef, []) unless $objectURI;
-
- my $ns = $DOM->getElementsByTagName("Namespace");
+ $objectname =~ s/^moby\://
+ ; # damn XML DOM can't deal with namespaces... so get rid of it if it exists, though this is going to limit us to only MOBY objects again :-(
+ my $OS = MOBY::OntologyServer->new( ontology => 'object' );
+ my ( $exists, $message, $objectURI ) =
+ $OS->objectExists( term => $objectname );
+ return ( undef, [] ) unless $objectURI;
+ my $ns = $DOM->getElementsByTagName( "Namespace" );
my @namespaces;
- my $nonamespaces = $ns->getLength;
- $OS= MOBY::OntologyServer->new(ontology => 'namespace');
- for (my $n=0; $n<$nonamespaces; ++$n){
- my @child = $ns->item($n)->getChildNodes;
- foreach (@child){
- $debug && &_LOG ($_->getNodeTypeName, "\t", $_->toString,"\n");
- next unless ($_->getNodeType == TEXT_NODE);
- my $name = $_->toString; chomp $name;
- my ($success, $message, $URI) = $OS->namespaceExists(term => $name);
- $URI?(push @namespaces, $URI):(push @namespaces, "__MOBY__INVALID__NAMESPACE__");
+ my $nonamespaces = $ns->size();
+ $OS = MOBY::OntologyServer->new( ontology => 'namespace' );
+
+ for ( my $n = 1 ; $n <= $nonamespaces ; ++$n ) {
+ my @child = $ns->get_node( $n )->childNodes;
+ foreach ( @child ) {
+ $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" );
+ next unless ( $_->nodeType == TEXT_NODE );
+ my $name = $_->toString;
+ chomp $name;
+ my ( $success, $message, $URI ) =
+ $OS->namespaceExists( term => $name );
+ $URI
+ ? ( push @namespaces, $URI )
+ : ( push @namespaces, "__MOBY__INVALID__NAMESPACE__" );
}
}
- return ($objectURI, \@namespaces);
+ return ( $objectURI, \@namespaces );
}
-
-
=head2 retrieveService
Title : retrieveService
@@ -1998,67 +2372,67 @@
=cut
-sub retrieveService {
- my ($pkg, $payload) = @_;
- # the payload here is actually the full XML from the findService call above...
- #return "<Services>NOT YET IMPLEMENTED</Services>";
- my ($AuthURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML) = &_retrieveServicePayload($payload);
- unless ($AuthURI && $serviceName){return "<Services/>"}
- my $SI = MOBY::service_instance->new(authority_uri => $AuthURI, servicename => $serviceName);
+sub retrieveService {
+ my ( $pkg, $payload ) = @_;
+
+ # the payload here is actually the full XML from the findService call above...
+ #return "<Services>NOT YET IMPLEMENTED</Services>";
+ my ( $AuthURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML ) =
+ &_retrieveServicePayload( $payload );
+ unless ( $AuthURI && $serviceName ) { return "<Services/>" }
+ my $SI = MOBY::service_instance->new( authority_uri => $AuthURI,
+ servicename => $serviceName );
my $wsdls;
- return "<Service/>" unless ($SI);
-
- if ($SI->category eq 'moby'){
- my $wsdl = &_getServiceWSDL($SI, $InputXML, $OutputXML, $SecondaryXML);
- if ($wsdl){
- $wsdls .= "<Service><![CDATA[$wsdl]]></Service>\n";
- }
- #$debug && &_LOG("WSDL_________________$wsdls\n____________________");
- return $wsdls;
+ return "<Service/>" unless ( $SI );
+ if ( $SI->category eq 'moby' ) {
+ my $wsdl =
+ &_getServiceWSDL( $SI, $InputXML, $OutputXML, $SecondaryXML );
+ if ( $wsdl ) {
+ $wsdls .= "<Service><![CDATA[$wsdl]]></Service>\n";
+ }
+
+ #$debug && &_LOG("WSDL_________________$wsdls\n____________________");
+ return $wsdls;
}
}
-
-
+#Eddie - converted
sub _retrieveServicePayload {
-
- my ($payload) = @_;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
- my $x = $doc->getElementsByTagName("Service");
- my $authURI = "";
+ my ( $payload ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $x = $doc->getElementsByTagName( "Service" );
+ my $authURI = "";
my $serviceName = "";
- my $l = $x->getLength; # might be a Collection object with multiple simples...
- for (my $n=0; $n < $l; ++$n){
- $authURI= $x->item($n)->getAttributeNode("authURI"); # may or may not have a name
- if ($authURI){$authURI = $authURI->getValue()}
- $serviceName = $x->item($n)->getAttributeNode("serviceName"); # may or may not have a name
- if ($serviceName){$serviceName = $serviceName->getValue()}
- }
-
- my $INPUT = $doc->getElementsByTagName("Input");
- my $InputXML = "";
- if ($INPUT->item(0)){
- $InputXML = $INPUT->item(0)->toString;
+ my $l = $x->size(); # might be a Collection object with multiple simples...
+ for ( my $n = 1 ; $n <= $l ; ++$n ) {
+ $authURI =
+ $x->get_node( $n )->getAttributeNode( "authURI" )
+ ; # may or may not have a name
+ if ( $authURI ) { $authURI = $authURI->getValue() }
+ $serviceName =
+ $x->get_node( $n )->getAttributeNode( "serviceName" )
+ ; # may or may not have a name
+ if ( $serviceName ) { $serviceName = $serviceName->getValue() }
+ }
+ my $INPUT = $doc->getElementsByTagName( "Input" );
+ my $InputXML = "";
+ if ( $INPUT->get_node( 1 ) ) {
+ $InputXML = $INPUT->get_node( 1 )->toString;
+ }
+ my $OUTPUT = $doc->getElementsByTagName( "Output" );
+ my $OutputXML = "";
+ if ( $OUTPUT->get_node( 1 ) ) {
+ $OutputXML = $OUTPUT->get_node( 1 )->toString;
+ }
+ my $SECONDARY = $doc->getElementsByTagName( "Output" );
+ my $SecondaryXML = "";
+ if ( $SECONDARY->get_node( 1 ) ) {
+ $SecondaryXML = $SECONDARY->get_Node( 1 )->toString;
}
-
- my $OUTPUT = $doc->getElementsByTagName("Output");
- my $OutputXML = "";
- if ($OUTPUT->item(0)){
- $OutputXML = $OUTPUT->item(0)->toString;
- }
-
- my $SECONDARY = $doc->getElementsByTagName("Output");
- my $SecondaryXML = "";
- if ($SECONDARY->item(0)){
- $SecondaryXML = $SECONDARY->item(0)->toString;
- }
-
- return ($authURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML);
-
+ return ( $authURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML );
}
-
=head2 retrieveServiceProviders
Title : retrieveServiceProviders
@@ -2075,18 +2449,17 @@
=cut
-
sub retrieveServiceProviders {
- my ($pkg) = @_;
+ my ( $pkg ) = @_;
my $dbh = MOBY::central_db_connection->new()->dbh;
- my $sth = $dbh->prepare("select distinct authority_uri from authority");
+ my $sth = $dbh->prepare( "select distinct authority_uri from authority" );
$sth->execute;
my $providers = "<serviceProviders>\n";
- while (my ($prov) = $sth->fetchrow_array){
+ while ( my ( $prov ) = $sth->fetchrow_array ) {
$providers .= "<serviceProvider name='$prov'/>\n";
}
$providers .= "</serviceProviders>\n";
- return $providers;
+ return $providers;
}
=head2 retrieveServiceNames
@@ -2106,22 +2479,22 @@
=cut
-
sub retrieveServiceNames {
- my ($pkg) = shift;
-
- my $dbh = MOBY::central_db_connection->new()->dbh;
- my $sth = $dbh->prepare("select authority_uri, servicename from authority as a, service_instance as s where s.authority_id = a.authority_id");
+ my ( $pkg ) = shift;
+ my $dbh = MOBY::central_db_connection->new()->dbh;
+ my $sth =
+ $dbh->prepare(
+"select authority_uri, servicename from authority as a, service_instance as s where s.authority_id = a.authority_id"
+ );
$sth->execute;
my $names = "<serviceNames>\n";
- while (my ($auth, $name) = $sth->fetchrow_array){
+ while ( my ( $auth, $name ) = $sth->fetchrow_array ) {
$names .= "<serviceName name='$name' authURI='$auth'/>\n";
}
$names .= "</serviceNames>\n";
- return $names;
+ return $names;
}
-
=head2 retrieveServiceTypes
Title : retrieveServiceTypes
@@ -2140,22 +2513,19 @@
=cut
-
-
sub retrieveServiceTypes {
- my ($pkg) = @_;
- my $OS = MOBY::OntologyServer->new(ontology => 'service');
- my %types = %{$OS->retrieveAllServiceTypes()};
+ my ( $pkg ) = @_;
+ my $OS = MOBY::OntologyServer->new( ontology => 'service' );
+ my %types = %{ $OS->retrieveAllServiceTypes() };
my $types = "<serviceTypes>\n";
- while (my ($serv, $desc) = each %types){
- $types .= "<serviceType name='$serv'>\n<Description><![CDATA[$desc]]></Description>\n</serviceType>\n";
+ while ( my ( $serv, $desc ) = each %types ) {
+ $types .=
+"<serviceType name='$serv'>\n<Description><![CDATA[$desc]]></Description>\n</serviceType>\n";
}
$types .= "</serviceTypes>\n";
- return $types;
+ return $types;
}
-
-
=head2 retrieveRelationshipTypes
Title : retrieveRelationshipTypes
@@ -2176,29 +2546,25 @@
=cut
-
-
+#Eddie - converted
sub retrieveRelationshipTypes {
- my ($pkg, $payload) = @_;
-
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
- my $ontology = &_nodeTextContent($doc, "Ontology");
- my $OS = MOBY::OntologyServer->new(ontology => 'relationship');
- my %types = %{$OS->getRelationshipTypes(ontology => $ontology)};
- my $types = "<relationshipTypes>\n";
- while (my ($name, $authdesc) = each %types){
+ my ( $pkg, $payload ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $ontology = &_nodeTextContent( $doc, "Ontology" );
+ my $OS = MOBY::OntologyServer->new( ontology => 'relationship' );
+ my %types = %{ $OS->getRelationshipTypes( ontology => $ontology ) };
+ my $types = "<relationshipTypes>\n";
+ while ( my ( $name, $authdesc ) = each %types ) {
my $auth = $authdesc->[0];
my $desc = $authdesc->[1];
- $types .= "<relationshipType relationship='$name' authority='$auth'>\n<Description><![CDATA[$desc]]></Description>\n</relationshipType>\n";
+ $types .=
+"<relationshipType relationship='$name' authority='$auth'>\n<Description><![CDATA[$desc]]></Description>\n</relationshipType>\n";
}
$types .= "</relationshipTypes>\n";
- return $types;
+ return $types;
}
-
-
-
=head2 retrieveObjectNames
Title : retrieveObjectNames
@@ -2217,21 +2583,19 @@
=cut
-
sub retrieveObjectNames {
- my ($pkg) = @_;
- my $OS = MOBY::OntologyServer->new(ontology => 'object');
- my %types = %{$OS->retrieveAllObjectTypes()};
- my $obj = "<objectNames>\n";
- while (my ($name, $desc) = each %types){
- $obj .= "<Object name='$name'>\n<Description><![CDATA[$desc]]></Description>\n</Object>\n";
+ my ( $pkg ) = @_;
+ my $OS = MOBY::OntologyServer->new( ontology => 'object' );
+ my %types = %{ $OS->retrieveAllObjectTypes() };
+ my $obj = "<objectNames>\n";
+ while ( my ( $name, $desc ) = each %types ) {
+ $obj .=
+"<Object name='$name'>\n<Description><![CDATA[$desc]]></Description>\n</Object>\n";
}
$obj .= "</objectNames>\n";
- return $obj;
+ return $obj;
}
-
-
=head2 retrieveObjectDefinition
Title : retrieveObjectDefinition
@@ -2262,37 +2626,41 @@
=cut
+#Eddie - converted
sub retrieveObjectDefinition {
- my ($pkg, $payload) = @_;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
- my $term = &_nodeTextContent($doc, "objectType");
+ my ( $pkg, $payload ) = @_;
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $term = &_nodeTextContent( $doc, "objectType" );
return "<retrieveObjectDefinition/>" unless $term;
- my $OS = MOBY::OntologyServer->new(ontology => 'object');
- my $def = $OS->retrieveObject(node => $term); # will return undef if this term does not exist, and does not look like an LSID
+ my $OS = MOBY::OntologyServer->new( ontology => 'object' );
+ my $def =
+ $OS->retrieveObject( node => $term )
+ ; # will return undef if this term does not exist, and does not look like an LSID
return "<retrieveObjectDefinition/>" unless $def;
- my %def = %{$OS->retrieveObject(node => $term)};
+ my %def = %{ $OS->retrieveObject( node => $term ) };
my $response;
$response = "<retrieveObjectDefinition>
<objectType>$def{objectType}</objectType>
<Description><![CDATA[$def{description}]]></Description>
<authURI>$def{authURI}</authURI>
<contactEmail>$def{contactEmail}</contactEmail>\n";
- my %relationships = %{$def{Relationships}};
- while (my ($rel, $objdefs) = each %relationships){
+ my %relationships = %{ $def{Relationships} };
+
+ while ( my ( $rel, $objdefs ) = each %relationships ) {
$response .= "<Relationship relationshipType='$rel'>\n";
- foreach my $def(@{$objdefs}){
- my ($lsid, $articlename) = @{$def};
- $articlename="" unless defined $articlename;
- $response .="<objectType articleName='$articlename'>$lsid</objectType>\n";
+ foreach my $def ( @{$objdefs} ) {
+ my ( $lsid, $articlename ) = @{$def};
+ $articlename = "" unless defined $articlename;
+ $response .=
+ "<objectType articleName='$articlename'>$lsid</objectType>\n";
}
- $response .="</Relationship>\n";
+ $response .= "</Relationship>\n";
}
- $response .="</retrieveObjectDefinition>\n";
+ $response .= "</retrieveObjectDefinition>\n";
return $response;
}
-
=head2 retrieveNamespaces
Title : retrieveNamespaces
@@ -2311,20 +2679,19 @@
=cut
-
sub retrieveNamespaces {
- my ($pkg) = @_;
- my $OS = MOBY::OntologyServer->new(ontology => 'namespace');
- my %types = %{$OS->retrieveAllNamespaceTypes()};
- my $ns = "<Namespaces>\n";
- while (my ($namespace, $desc) = each %types){
- $ns .= "<Namespace name='$namespace'>\n<Description><![CDATA[$desc]]></Description>\n</Namespace>\n";
+ my ( $pkg ) = @_;
+ my $OS = MOBY::OntologyServer->new( ontology => 'namespace' );
+ my %types = %{ $OS->retrieveAllNamespaceTypes() };
+ my $ns = "<Namespaces>\n";
+ while ( my ( $namespace, $desc ) = each %types ) {
+ $ns .=
+"<Namespace name='$namespace'>\n<Description><![CDATA[$desc]]></Description>\n</Namespace>\n";
}
- $ns .="</Namespaces>";
- return $ns;
+ $ns .= "</Namespaces>";
+ return $ns;
}
-
=head2 retrieveObject
NOT YET IMPLEMENTED
@@ -2350,30 +2717,26 @@
=cut
-
sub retrieveObject {
- my ($pkg, $payload) = @_;
- my $response = "<Objects>\n";
- $response .="<NOT_YET_IMPLEMENTED/>\n";
- $response .= "</Objects>\n";
- return $response;
+ my ( $pkg, $payload ) = @_;
+ my $response = "<Objects>\n";
+ $response .= "<NOT_YET_IMPLEMENTED/>\n";
+ $response .= "</Objects>\n";
+ return $response;
}
-
+#Eddie - converted
sub _retrieveObjectPayload {
-
- 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 'retrieveObject');
- my $type = &_nodeTextContent($Object, "objectType");
- return ($type);
+ 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 'retrieveObject' );
+ my $type = &_nodeTextContent( $Object, "objectType" );
+ return ( $type );
}
-
-
=head2 Relationships
Title : Relationships
@@ -2429,71 +2792,75 @@
=cut
-
sub Relationships {
- my ($pkg, $payload) = @_;
+ my ( $pkg, $payload ) = @_;
my $ontology;
- my $Parser = new XML::DOM::Parser;
- my $doc = $Parser->parse($payload);
-
- my $x = $doc->getElementsByTagName("relationshipType");
- my $l = $x->getLength;
-
- my $exp = $doc->getElementsByTagName("expandRelationship");
- my $expl = $exp->getLength;
-
- my $expand_relationship = &_nodeTextContent($doc, 'expandRelationship');
+ my $Parser = XML::LibXML->new();
+ my $doc = $Parser->parse_string( $payload );
+ my $x = $doc->getElementsByTagName( "relationshipType" );
+ my $l = $x->size();
+ my $exp = $doc->getElementsByTagName( "expandRelationship" );
+ my $expl = $exp->size();
+ my $expand_relationship = &_nodeTextContent( $doc, 'expandRelationship' );
$expand_relationship =~ s/\s//g;
- $expand_relationship ||=0;
-
+ $expand_relationship ||= 0;
my %reltypes;
- for (my $n=0; $n < $l; ++$n){
- my @child = $x->item($n)->getChildNodes;
- foreach (@child){
- next unless ($_->getNodeType == TEXT_NODE);
- my $name .= $_->toString; $name =~ s/\s//g;
+
+ for ( my $n = 1 ; $n <= $l ; ++$n ) {
+ my @child = $x->get_node( $n )->childNodes;
+ foreach ( @child ) {
+ next unless ( $_->nodeType == TEXT_NODE );
+ my $name .= $_->toString;
+ $name =~ s/\s//g;
$reltypes{$name} = 1;
}
}
-
- my $term = &_nodeTextContent($doc, "objectType");
- $ontology = "object" if $term; # pick up the ontology "object" that we used here if we got an object term
- $term ||= &_nodeTextContent($doc, "serviceType"); # if we didn't get anything using objectType try serviceType
- return undef unless $term; # and bail out if we didn't succeed
-
- $ontology ||="service"; # if we have now succeeded and haven't already taken the ontology then it must be the service ontology
- &_LOG("Ontology was $ontology; Term was $term\n");
- my $OS = MOBY::OntologyServer->new(ontology => $ontology);
- my %rels = %{$OS->Relationships(term => $term, expand => $expand_relationship)}; # %rels = $rels{relationship} = [lsid, lsid,lsid]
-
- my $response="<Relationships>\n";
- my $OSrel = MOBY::OntologyServer->new(ontology => 'relationship');
- foreach (keys %reltypes){ # for each of our desired types
- my $rellsid = $OSrel->getRelationshipURI($ontology, $_); # get the LSID
- delete $reltypes{$_}; # remove the non-LSID version from the hash
+ my $term = &_nodeTextContent( $doc, "objectType" );
+ $ontology = "object"
+ if $term
+ ; # pick up the ontology "object" that we used here if we got an object term
+ $term ||=
+ &_nodeTextContent( $doc, "serviceType" )
+ ; # if we didn't get anything using objectType try serviceType
+ return undef unless $term; # and bail out if we didn't succeed
+ $ontology ||= "service"
+ ; # if we have now succeeded and haven't already taken the ontology then it must be the service ontology
+ &_LOG( "Ontology was $ontology; Term was $term\n" );
+ my $OS = MOBY::OntologyServer->new( ontology => $ontology );
+ my %rels =
+ %{ $OS->Relationships( term => $term, expand => $expand_relationship )
+ }; # %rels = $rels{relationship} = [lsid, lsid,lsid]
+ my $response = "<Relationships>\n";
+ my $OSrel = MOBY::OntologyServer->new( ontology => 'relationship' );
+
+ foreach ( keys %reltypes ) { # for each of our desired types
+ my $rellsid =
+ $OSrel->getRelationshipURI( $ontology, $_ ); # get the LSID
+ delete $reltypes{$_}; # remove the non-LSID version from the hash
$reltypes{$rellsid} = 1; # set the LSID as valid
}
+
# now for each of the relationship types that we were returned
- foreach (keys %rels){
- my $rellsid = $OSrel->getRelationshipURI($ontology, $_);
+ foreach ( keys %rels ) {
+ my $rellsid = $OSrel->getRelationshipURI( $ontology, $_ );
next unless $rellsid;
- if (keys %reltypes){
- next unless $reltypes{$rellsid}; # next unless it is one ofthe relationship types we requested
+ if ( keys %reltypes ) {
+ next
+ unless $reltypes{ $rellsid
+ }; # next unless it is one ofthe relationship types we requested
}
my $lsids = $rels{$rellsid};
next unless $lsids->[0];
- $response .="<Relationship relationshipType='$rellsid'>\n";
- foreach my $lsid(@{$lsids}){
- $response .="<${ontology}Type>$lsid</${ontology}Type>\n";
+ $response .= "<Relationship relationshipType='$rellsid'>\n";
+ foreach my $lsid ( @{$lsids} ) {
+ $response .= "<${ontology}Type>$lsid</${ontology}Type>\n";
}
$response .= "</Relationship>\n";
}
- $response .="</Relationships>\n";
+ $response .= "</Relationships>\n";
return $response;
}
-
-
=head2 DUMP_MySQL
Title : DUMP_MySQL
@@ -2504,58 +2871,60 @@
=cut
-
sub DUMP_MySQL {
- my ($pkg) = @_;
- open (IN, "/usr/local/bin/mysqldump -u mobycentral mobycentral |") || die "can't open mobycentral for dumping";
+ my ( $pkg ) = @_;
+ open( IN, "/usr/local/bin/mysqldump -u mobycentral mobycentral |" )
+ || die "can't open mobycentral for dumping";
my @response;
- while (<IN>){
+ while ( <IN> ) {
push @response, $_;
}
- my $mobycentral = (join "", @response);
-
+ my $mobycentral = ( join "", @response );
close IN;
- open (IN, "/usr/local/bin/mysqldump -u mobycentral mobyobject |") || die "can't open mobyobject for dumping";
+ open( IN, "/usr/local/bin/mysqldump -u mobycentral mobyobject |" )
+ || die "can't open mobyobject for dumping";
@response = ();
- while (<IN>){
+ while ( <IN> ) {
push @response, $_;
}
- my $mobyobject = (join "", @response);
-
+ my $mobyobject = ( join "", @response );
close IN;
- open (IN, "/usr/local/bin/mysqldump -u mobycentral mobyservice |") || die "can't open mobyservice for dumping";
+ open( IN, "/usr/local/bin/mysqldump -u mobycentral mobyservice |" )
+ || die "can't open mobyservice for dumping";
@response = ();
- while (<IN>){
+ while ( <IN> ) {
push @response, $_;
}
- my $mobyservice = (join "", @response);
-
+ my $mobyservice = ( join "", @response );
close IN;
- open (IN, "/usr/local/bin/mysqldump -u mobycentral mobynamespace |");
+ open( IN, "/usr/local/bin/mysqldump -u mobycentral mobynamespace |" );
@response = ();
- while (<IN>){
+ while ( <IN> ) {
push @response, $_;
}
- my $mobynamespace = (join "", @response);
+ my $mobynamespace = ( join "", @response );
close IN;
- open (IN, "/usr/local/bin/mysqldump -u mobycentral mobyrelationship |");
+ open( IN, "/usr/local/bin/mysqldump -u mobycentral mobyrelationship |" );
@response = ();
- while (<IN>){
+ while ( <IN> ) {
push @response, $_;
}
- my $mobyrelationship = (join "", @response);
+ my $mobyrelationship = ( join "", @response );
close IN;
- return [$mobycentral, $mobyobject, $mobyservice, $mobynamespace, $mobyrelationship];
+ return [
+ $mobycentral, $mobyobject, $mobyservice,
+ $mobynamespace, $mobyrelationship
+ ];
}
-
-*DUMP = \&DUMP_MySQL; # alias it for backward compatibility
-*DUMP = \&DUMP_MySQL; # alias it for backward compatibility
+*DUMP = \&DUMP_MySQL; # alias it for backward compatibility
+*DUMP = \&DUMP_MySQL; # alias it for backward compatibility
sub _flatten {
+
# from a given term, traverse the ontology
# and flatten it into a list of parent terms
- my ($dbh,$type,$term, $seen) = @_;
- my $sth = $dbh->prepare("
+ my ( $dbh, $type, $term, $seen ) = @_;
+ my $sth = $dbh->prepare( "
select
OE1.term
from
@@ -2567,30 +2936,31 @@
and ontologyentry1_id = OE1.id
and relationship_type_id = $type
and OE2.term = ?"
- );
- $sth->execute($term);
- while (my ($term) = $sth->fetchrow_array){
+ );
+ $sth->execute( $term );
+ while ( my ( $term ) = $sth->fetchrow_array ) {
next if ${$seen}{$term};
- &_flatten($dbh, $type, $term, $seen);
+ &_flatten( $dbh, $type, $term, $seen );
${$seen}{$term} = 1;
}
-
-}
+}
+#Eddie - Converted
sub _ISAPayload {
-
- 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 'ISA');
- my $type = &_nodeTextContent($Object, "objectType");
- return ($type);
+ 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 'ISA' );
+ my $type = &_nodeTextContent( $Object, "objectType" );
+ return ( $type );
}
+=cut
+
+
-=cut
=head1 Internal Object Methods
@@ -2598,7 +2968,6 @@
=cut
-
=head2 _getValidServices
Title : _getValidServices
@@ -2609,35 +2978,39 @@
=cut
-
sub _getValidServices {
- my ( $dbh, $sth_hash, $query, $max_return) = @_;
+ my ( $dbh, $sth_hash, $query, $max_return ) = @_;
my %sth = %{$sth_hash};
- $debug && &_LOG("QUERY: \n$query\n\n");
- my $this_query = $dbh->prepare($query);
+ $debug && &_LOG( "QUERY: \n$query\n\n" );
+ my $this_query = $dbh->prepare( $query );
$this_query->execute;
my $response;
my %seen;
- $response = "<Services>\n";
- while (my ($serviceName, $objectOUT, $AuthURI,$desc, $type, $cat) =$this_query->fetchrow_array()){
- $debug && &_LOG("$serviceName, $objectOUT, $AuthURI,$desc, $type, $cat\n");
- next if $seen{"$AuthURI"."||"."$serviceName"}; # non-redundant list please
- $seen{"$AuthURI"."||"."$serviceName"} = 1;
- $response .="<Service authURI='$AuthURI' serviceName='$serviceName'>\n";
- $response .="<Category>$cat</Category>\n";
- $response .="<serviceType>$type</serviceType>\n";
- $response .="<outputObject>$objectOUT</outputObject>\n";
- $response .= "<Description><![CDATA[$desc]]></Description>\n";
- $response .= "</Service>\n";
-
- if ($max_return){--$max_return;last unless $max_return}
+ $response = "<Services>\n";
+
+ while ( my ( $serviceName, $objectOUT, $AuthURI, $desc, $type, $cat ) =
+ $this_query->fetchrow_array() )
+ {
+ $debug
+ && &_LOG( "$serviceName, $objectOUT, $AuthURI,$desc, $type, $cat\n" );
+ next
+ if $seen{ "$AuthURI" . "||"
+ . "$serviceName" }; # non-redundant list please
+ $seen{ "$AuthURI" . "||" . "$serviceName" } = 1;
+ $response .=
+ "<Service authURI='$AuthURI' serviceName='$serviceName'>\n";
+ $response .= "<Category>$cat</Category>\n";
+ $response .= "<serviceType>$type</serviceType>\n";
+ $response .= "<outputObject>$objectOUT</outputObject>\n";
+ $response .= "<Description><![CDATA[$desc]]></Description>\n";
+ $response .= "</Service>\n";
+ if ( $max_return ) { --$max_return; last unless $max_return }
}
- $response .= "</Services>\n";
- $debug && &_LOG("\nFINAL RESPONSE IS \n$response\n\n");
+ $response .= "</Services>\n";
+ $debug && &_LOG( "\nFINAL RESPONSE IS \n$response\n\n" );
return $response;
}
-
=head2 _getServiceWSDL
Title : _getServiceWSDL
@@ -2648,60 +3021,63 @@
=cut
-
sub _getServiceWSDL {
- my ($SI, $InputXML, $OutputXML, $SecondaryXML) = @_;
- # the lines below causes no end of grief. It is now in a variable.
- #open (WSDL, "./MOBY/Central_WSDL_SandR.wsdl") || die "can't open WSDL file for search and replace\n";
- #my $wsdl = join "", (<WSDL>);
- my $wsdl = $WSDL_TEMPLATE;
- $wsdl =~ s/^\n//gs;
+ my ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_;
+
+# the lines below causes no end of grief. It is now in a variable.
+#open (WSDL, "./MOBY/Central_WSDL_SandR.wsdl") || die "can't open WSDL file for search and replace\n";
+#my $wsdl = join "", (<WSDL>);
+ my $wsdl = $WSDL_TEMPLATE;
+ $wsdl =~ s/^\n//gs;
+
#close WSDL;
# do substitutions
-
my $serviceName = $SI->servicename;
- my $AuthURI = $SI->authority_uri;
- my $desc = $SI->description;
- my $URL = $SI->url;
- my $IN = "NOT_YET_DEFINED_INPUTS";
- my $OUT = "NOT_YET_DEFINED_OUTPUTS";
-
- my $INxsd = &_getInputXSD($InputXML, $SecondaryXML);
- my $OUTxsd = &_getOutputXSD($OutputXML);
-
- $INxsd ||= "<NOT_YET_IMPLEMENTED_INPUT_XSD/>";
- $OUTxsd ||="<NOT_YET_IMPLEMENTED_OUTPUT_XSD/>";
-
- $wsdl =~ s/MOBY__SERVICE__NAME__/$serviceName/g; # replace all of the goofy portbindingpottype crap
- $wsdl =~ s/\<\!\-\-\s*MOBY__SERVICE__DESCRIPTION\s*\-\-\>/Authority: $AuthURI - $desc/g; # add a sensible description
- $wsdl =~ s/MOBY__SERVICE__URL/$URL/g; # the URL to the service
- #if (scalar @in){my ($IN, $INxsd) = @{shift @in}};
- #if (scalar @out){my ($OUT, $OUTxsd) = @{shift @out}};
- $wsdl =~ s/MOBY__INPUT__OBJECT__NAME/$IN/g; # SINGLE input object (for now)
- $wsdl =~ s/MOBY__OUTPUT__OBJECT__NAME/$OUT/g; # SINGLE output object (for now)
- $wsdl =~ s/\<\!\-\-\s*MOBY__INPUT__OBJECT__XSD\s*\-\-\>/$INxsd/g; # XSD stright from the database
- $wsdl =~ s/\<\!\-\-\s*MOBY__OUTPUT__OBJECT__XSD\s*\-\-\>/$OUTxsd/g; # XSD straight from the database
- $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call
+ my $AuthURI = $SI->authority_uri;
+ my $desc = $SI->description;
+ my $URL = $SI->url;
+ my $IN = "NOT_YET_DEFINED_INPUTS";
+ my $OUT = "NOT_YET_DEFINED_OUTPUTS";
+ my $INxsd = &_getInputXSD( $InputXML, $SecondaryXML );
+ my $OUTxsd = &_getOutputXSD( $OutputXML );
+ $INxsd ||= "<NOT_YET_IMPLEMENTED_INPUT_XSD/>";
+ $OUTxsd ||= "<NOT_YET_IMPLEMENTED_OUTPUT_XSD/>";
+ $wsdl =~ s/MOBY__SERVICE__NAME__/$serviceName/g
+ ; # replace all of the goofy portbindingpottype crap
+ $wsdl =~
+s/\<\!\-\-\s*MOBY__SERVICE__DESCRIPTION\s*\-\-\>/Authority: $AuthURI - $desc/g
+ ; # add a sensible description
+ $wsdl =~ s/MOBY__SERVICE__URL/$URL/g; # the URL to the service
+ #if (scalar @in){my ($IN, $INxsd) = @{shift @in}};
+ #if (scalar @out){my ($OUT, $OUTxsd) = @{shift @out}};
+ $wsdl =~ s/MOBY__INPUT__OBJECT__NAME/$IN/g; # SINGLE input object (for now)
+ $wsdl =~
+ s/MOBY__OUTPUT__OBJECT__NAME/$OUT/g; # SINGLE output object (for now)
+ $wsdl =~ s/\<\!\-\-\s*MOBY__INPUT__OBJECT__XSD\s*\-\-\>/$INxsd/g
+ ; # XSD stright from the database
+ $wsdl =~ s/\<\!\-\-\s*MOBY__OUTPUT__OBJECT__XSD\s*\-\-\>/$OUTxsd/g
+ ; # XSD straight from the database
+ $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g
+ ; # finally replace the actual subroutine call
return $wsdl;
}
-
sub _getCGIService {
- my ( $dbh, $sth_hash, $id, $serviceName, $AuthURI,$URL, $desc, $category) = @_;
+ my ( $dbh, $sth_hash, $id, $serviceName, $AuthURI, $URL, $desc, $category )
+ = @_;
my %sth = %{$sth_hash};
- # "Select OE.term, O.xsd, SP.type
- # from Object as O, OntologyEntry as OE, ServiceParameter as SP, Service as S
- # where O.ontologyentry_id = OE.id
- # AND SP.ontologyentry_id = OE.id
- # and SP.service_id = ?
-
- my $sth = $dbh->prepare($sth{get_server_parameters});
- $sth->execute($id);
- my ($Object, $sprintf, $in) = $sth->fetchrow_array();
+
+ # "Select OE.term, O.xsd, SP.type
+ # from Object as O, OntologyEntry as OE, ServiceParameter as SP, Service as S
+ # where O.ontologyentry_id = OE.id
+ # AND SP.ontologyentry_id = OE.id
+ # and SP.service_id = ?
+ my $sth = $dbh->prepare( $sth{get_server_parameters} );
+ $sth->execute( $id );
+ my ( $Object, $sprintf, $in ) = $sth->fetchrow_array();
return "<GETstring><![CDATA[$sprintf]]></GETstring>";
}
-
=head2 _traverseServiceDAG
Title : _traverseServiceDAG
@@ -2713,35 +3089,41 @@
=cut
-
sub _traverseServiceDAG {
- my ( $dbh, $serviceType, $sth_hash) = @_;
+ my ( $dbh, $serviceType, $sth_hash ) = @_;
my %sth = %{$sth_hash};
my %ServiceIDs;
- my $sth = $dbh->prepare($sth{get_service_type_id});
- $sth->execute($serviceType);
- my ($root_id) = $sth->fetchrow_array;
+ my $sth = $dbh->prepare( $sth{get_service_type_id} );
+ $sth->execute( $serviceType );
+ my ( $root_id ) = $sth->fetchrow_array;
return undef unless $root_id;
-
- # we have to do a traversal of the DAG here to get all child nodes...
- # this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
- $ServiceIDs{$root_id} = "untested"; # mark the one in-hand as untested
- while (grep /untested/, (values %ServiceIDs)){ # now, while there are untested services in our list...
- foreach my $service(keys %ServiceIDs){ # start parsing through the list
- next if ($ServiceIDs{$service} eq "tested"); # if it has been tested already then move on
- my $sth = $dbh->prepare($sth{get_service_hierarchy_list});
- $sth->execute($service); # execute the query for child nodes
- $ServiceIDs{$service} = "tested"; # mark it as tested
- while (my $new = $sth->fetchrow_array){ # now get each of the child nodes
- next if (defined $ServiceIDs{$new}); # if we have already heard about it then move on
- $ServiceIDs{$new} = "untested"; #otherwise mark it as untested, and start all over again
+
+# we have to do a traversal of the DAG here to get all child nodes...
+# this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
+ $ServiceIDs{$root_id} = "untested"; # mark the one in-hand as untested
+ while ( grep /untested/, ( values %ServiceIDs ) )
+ { # now, while there are untested services in our list...
+ foreach my $service ( keys %ServiceIDs )
+ { # start parsing through the list
+ next
+ if ( $ServiceIDs{$service} eq "tested" )
+ ; # if it has been tested already then move on
+ my $sth = $dbh->prepare( $sth{get_service_hierarchy_list} );
+ $sth->execute( $service ); # execute the query for child nodes
+ $ServiceIDs{$service} = "tested"; # mark it as tested
+ while ( my $new = $sth->fetchrow_array )
+ { # now get each of the child nodes
+ next
+ if ( defined $ServiceIDs{$new} )
+ ; # if we have already heard about it then move on
+ $ServiceIDs{$new} = "untested"
+ ; #otherwise mark it as untested, and start all over again
}
}
}
return keys %ServiceIDs;
}
-
=head2 _traverseObjectDAG
Title : _traverseObjectDAG
@@ -2753,270 +3135,339 @@
=cut
-
-
sub _traverseObjectDAG {
- my ( $dbh, $objectType, $sth_hash, $dir) = @_;
+ my ( $dbh, $objectType, $sth_hash, $dir ) = @_;
my %sth = %{$sth_hash};
my %ObjectIDs;
- my $sth = $dbh->prepare($sth{get_object_type_id});
- $sth->execute($objectType);
- my ($root_id) = $sth->fetchrow_array;
+ my $sth = $dbh->prepare( $sth{get_object_type_id} );
+ $sth->execute( $objectType );
+ my ( $root_id ) = $sth->fetchrow_array;
return undef unless $root_id;
-
- if ($dir eq "p"){
- $debug && &_LOG("getting parents");
- $sth = $dbh->prepare($sth{get_object_parent_list});
- }
- else {
- $debug && &_LOG("getting children");
- $sth = $dbh->prepare($sth{get_object_child_list});
- }
-
- # we have to do a traversal of the DAG here to get all child nodes...
- # this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
- $ObjectIDs{$root_id} = "untested"; # mark the one in-hand as untested
-
- while (grep /untested/, (values %ObjectIDs)){ # now, while there are untested services in our list...
- foreach my $object(keys %ObjectIDs){ # start parsing through the list
- next if ($ObjectIDs{$object} eq "tested"); # if it has been tested already then move on
- $sth->execute($object); # execute the query for child nodes
- $ObjectIDs{$object} = "tested"; # mark it as tested
- while (my $new = $sth->fetchrow_array){ # now get each of the child nodes
- next if (defined $ObjectIDs{$new}); # if we have already heard about it then move on
- $ObjectIDs{$new} = "untested"; #otherwise mark it as untested, and start all over again
+ if ( $dir eq "p" ) {
+ $debug && &_LOG( "getting parents" );
+ $sth = $dbh->prepare( $sth{get_object_parent_list} );
+ } else {
+ $debug && &_LOG( "getting children" );
+ $sth = $dbh->prepare( $sth{get_object_child_list} );
+ }
+
+# we have to do a traversal of the DAG here to get all child nodes...
+# this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
+ $ObjectIDs{$root_id} = "untested"; # mark the one in-hand as untested
+ while ( grep /untested/, ( values %ObjectIDs ) )
+ { # now, while there are untested services in our list...
+ foreach my $object ( keys %ObjectIDs )
+ { # start parsing through the list
+ next
+ if ( $ObjectIDs{$object} eq "tested" )
+ ; # if it has been tested already then move on
+ $sth->execute( $object ); # execute the query for child nodes
+ $ObjectIDs{$object} = "tested"; # mark it as tested
+ while ( my $new = $sth->fetchrow_array )
+ { # now get each of the child nodes
+ next
+ if ( defined $ObjectIDs{$new} )
+ ; # if we have already heard about it then move on
+ $ObjectIDs{$new} = "untested"
+ ; #otherwise mark it as untested, and start all over again
}
}
}
return keys %ObjectIDs;
}
+#Eddie - converted
sub _nodeTextContent {
+
# will get text of **all** child $node from the given $DOM
# regardless of their depth!!
- my ($DOM, $node) = @_;
- $debug && &_LOG("_nodeTextContent received DOM: ", $DOM->toString,"\nsearching for node $node\n");
- my $x = $DOM->getElementsByTagName($node);
- return undef unless $x->item(0);
- my @child = $x->item(0)->getChildNodes;
- my $content;
- foreach (@child){
- $debug && &_LOG($_->getNodeTypeName, "\t", $_->toString,"\n");
- #next unless $_->getNodeType == TEXT_NODE;
- $content .= $_->toString;
- }
- return $content;
+ my ( $DOM, $node ) = @_;
+ $debug && &_LOG( "_nodeTextContent received DOM: ",
+ $DOM->toString, "\nsearching for node $node\n" );
+ my $x = $DOM->getElementsByTagName( $node );
+ return undef unless $x->get_node( 1 );
+ my @child = $x->get_node( 1 )->childNodes;
+ my $content;
+ foreach ( @child ) {
+ $debug
+ && &_LOG( $_->nodeType, "\t", $_->toString, "\n" );
+
+ #next unless $_->nodeType == TEXT_NODE;
+ $content .= $_->toString;
+ }
+ return $content;
}
+#Eddie - converted
sub _nodeRawContent {
+
# will get raw child nodes of $node from the given $DOM
- my ($DOM, $nodename) = @_;
- my @content;
- $debug && &_LOG("_nodeRawContent received DOM: ", $DOM->toString,"\nsearching for node $nodename\n");
- my $x = $DOM->getElementsByTagName($nodename);
- my $node = $x->item(0);
+ my ( $DOM, $nodename ) = @_;
+ my @content;
+ $debug && &_LOG( "_nodeRawContent received DOM: ",
+ $DOM->toString, "\nsearching for node $nodename\n" );
+ my $x = $DOM->getElementsByTagName( $nodename );
+ my $node = $x->get_node( 1 );
return [] unless $node;
- foreach my $child($node->getChildNodes){
- next unless $child->getNodeType == ELEMENT_NODE;
+ foreach my $child ( $node->childNodes ) {
+ next unless $child->nodeType == ELEMENT_NODE;
push @content, $child;
}
- return \@content;
+ return \@content;
}
+#Eddie - converted
sub _nodeArrayContent {
+
# will get array content of all child $node from given $DOM
# regardless of depth!
# e.g. the following XML:
#<ISA>
# <objectType>first</objectType>
# <objectType>second</objectType>
- #</ISA>
+ #</ISA>
#will return the list "first", "second"
- my ($DOM, $node) = @_;
- $debug && &_LOG("_nodeArrayContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
- my @result;
- my $x = $DOM->getElementsByTagName($node);
- return @result unless $x->item(0);
- 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;
- next unless (length($_->toString) > 0);
- push @result, $_->toString;
- }
- }
- $debug && _LOG("_nodeArrayContent resulted in @result\n");
- return @result;
+ my ( $DOM, $node ) = @_;
+ $debug && &_LOG( "_nodeArrayContext received DOM: ",
+ $DOM->toString, "\nsearching for node $node\n" );
+ my @result;
+ my $x = $DOM->getElementsByTagName( $node );
+ return @result unless $x->get_node( 1 );
+ 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;
+ next unless ( length( $_->toString ) > 0 );
+ push @result, $_->toString;
+ }
+ }
+ $debug && _LOG( "_nodeArrayContent resulted in @result\n" );
+ return @result;
}
+#Eddie - converted
sub _nodeArrayExtraContent {
+
# will get array content of all child $node from given $DOM
# regardless of depth!
# e.g. the following XML:
#<ISA>
# <objectType articleName="thisone">first</objectType>
# <objectType articleName="otherone">second</objectType>
- #</ISA>
+ #</ISA>
#will return the list
# ['first',{'articleName' => 'thisone'}],
# ['second',{'articleName' => 'otherone'},...
-
- my ($DOM, $node, at attrs) = @_;
- $debug && &_LOG("_nodeArrayExtraContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
+ my ( $DOM, $node, @attrs ) = @_;
+ $debug && &_LOG( "_nodeArrayExtraContext received DOM: ",
+ $DOM->toString, "\nsearching for node $node\n" );
my @result;
my %att_value;
- my $x = $DOM->getElementsByTagName($node);
- my @child = $x->item(0)->getChildNodes;
- foreach (@child){
- next unless $_->getNodeType == ELEMENT_NODE;
- foreach my $attr(@attrs){
- $debug && &_LOG("_nodeArrayExtraContext received DOM: ", $DOM->toString,"\nsearching for attributre $attr\n");
- my $article = $_->getAttributeNode($attr); # may or may not have a name
- if ($article){$article = $article->getValue()}
+ my $x = $DOM->getElementsByTagName( $node );
+ my @child = $x->get_node( 1 )->childNodes;
+ foreach ( @child ) {
+ next unless $_->nodeType == ELEMENT_NODE;
+ foreach my $attr ( @attrs ) {
+ $debug && &_LOG( "_nodeArrayExtraContext received DOM: ",
+ $DOM->toString, "\nsearching for attributre $attr\n" );
+ my $article =
+ $_->getAttributeNode( $attr ); # may or may not have a name
+ if ( $article ) { $article = $article->getValue() }
$att_value{$attr} = $article;
}
- my @child2 = $_->getChildNodes;
- foreach (@child2){
- #print $_->getNodeTypeName, "\t", $_->toString,"\n";
- next unless $_->getNodeType == TEXT_NODE;
- push @result, [$_->toString,\%att_value];
- }
- }
- $debug && &_LOG(@result);
- return @result;
+ my @child2 = $_->childNodes;
+ foreach ( @child2 ) {
+
+ #print getNodeTypeName($_), "\t", $_->toString,"\n";
+ next unless $_->nodeType == TEXT_NODE;
+ push @result, [ $_->toString, \%att_value ];
+ }
+ }
+ $debug && &_LOG( @result );
+ return @result;
}
sub _serviceListResponse {
-
- my ($dbh, @ids) = @_;
-
- my $output="";
- my $sth = $dbh->prepare(q{
+ my ( $dbh, @ids ) = @_;
+ my $output = "";
+ my $sth = $dbh->prepare(
+ q{
select
category, url, servicename, service_type_uri, authority_id, description, authoritative, contact_email, signatureURL
from service_instance where
- service_instance_id = ?});
- my $sth_simple_in = $dbh->prepare("select object_type_uri, namespace_type_uris, article_name from simple_input where service_instance_id=? and collection_input_id IS NULL");
- my $sth_simple_out = $dbh->prepare("select object_type_uri, namespace_type_uris, article_name from simple_output where service_instance_id=? and collection_output_id IS NULL");
- my $sth_collection_ins = $dbh->prepare("select collection_input_id, article_name from collection_input where service_instance_id=?");
- my $sth_collection_outs = $dbh->prepare("select collection_output_id, article_name from collection_output where service_instance_id=?");
- my $sth_collection_in = $dbh->prepare("select object_type_uri, namespace_type_uris, article_name from simple_input where service_instance_id IS NULL and collection_input_id =?");
- my $sth_collection_out = $dbh->prepare("select object_type_uri, namespace_type_uris, article_name from simple_output where service_instance_id IS NULL and collection_output_id =?");
- my $sth_secondary_in = $dbh->prepare("select default_value, maximum_value, minimum_value, enum_value, datatype, article_name from secondary_input where service_instance_id=?");
-
-
- my $OSobj = MOBY::OntologyServer->new(ontology => 'object');
- my $OSns = MOBY::OntologyServer->new(ontology => 'namespace');
- my $OSserv = MOBY::OntologyServer->new(ontology => 'service');
-
- foreach (@ids){
- $sth->execute($_);
- my ($category, $url, $servicename, $service_type_uri, $authority_id, $desc, $authoritative, $email, $signatureURL) = $sth->fetchrow_array;
- #print "\n\nAFTER EXECUTE $category, $servicename, $service_type_uri, $authority_id, $desc, $authoritative\n\n";
- $signatureURL ||="";
- next unless ($servicename && $authority_id);
- my $service_type = $OSserv->getServiceCommonName($service_type_uri);
- my ($authURI) = $dbh->selectrow_array(q{select authority_uri from authority where authority_id=?},undef,$authority_id);
- $output .= "\t<Service authURI='$authURI' serviceName='$servicename'>\n";
+ service_instance_id = ?}
+ );
+ my $sth_simple_in =
+ $dbh->prepare(
+"select object_type_uri, namespace_type_uris, article_name from simple_input where service_instance_id=? and collection_input_id IS NULL"
+ );
+ my $sth_simple_out =
+ $dbh->prepare(
+"select object_type_uri, namespace_type_uris, article_name from simple_output where service_instance_id=? and collection_output_id IS NULL"
+ );
+ my $sth_collection_ins =
+ $dbh->prepare(
+"select collection_input_id, article_name from collection_input where service_instance_id=?"
+ );
+ my $sth_collection_outs =
+ $dbh->prepare(
+"select collection_output_id, article_name from collection_output where service_instance_id=?"
+ );
+ my $sth_collection_in =
+ $dbh->prepare(
+"select object_type_uri, namespace_type_uris, article_name from simple_input where service_instance_id IS NULL and collection_input_id =?"
+ );
+ my $sth_collection_out =
+ $dbh->prepare(
+"select object_type_uri, namespace_type_uris, article_name from simple_output where service_instance_id IS NULL and collection_output_id =?"
+ );
+ my $sth_secondary_in =
+ $dbh->prepare(
+"select default_value, maximum_value, minimum_value, enum_value, datatype, article_name from secondary_input where service_instance_id=?"
+ );
+ my $OSobj = MOBY::OntologyServer->new( ontology => 'object' );
+ my $OSns = MOBY::OntologyServer->new( ontology => 'namespace' );
+ my $OSserv = MOBY::OntologyServer->new( ontology => 'service' );
+
+ foreach ( @ids ) {
+ $sth->execute( $_ );
+ my (
+ $category, $url, $servicename,
+ $service_type_uri, $authority_id, $desc,
+ $authoritative, $email, $signatureURL
+ )
+ = $sth->fetchrow_array;
+
+#print "\n\nAFTER EXECUTE $category, $servicename, $service_type_uri, $authority_id, $desc, $authoritative\n\n";
+ $signatureURL ||= "";
+ next unless ( $servicename && $authority_id );
+ my $service_type = $OSserv->getServiceCommonName( $service_type_uri );
+ my ( $authURI ) =
+ $dbh->selectrow_array(
+ q{select authority_uri from authority where authority_id=?},
+ undef, $authority_id );
+ $output .=
+ "\t<Service authURI='$authURI' serviceName='$servicename'>\n";
$output .= "\t<serviceType>$service_type</serviceType>\n";
$output .= "\t<authoritative>$authoritative</authoritative>\n";
$output .= "\t<Category>$category</Category>\n";
$output .= "\t<Description>\n$desc\n\t</Description>\n";
$output .= "\t<contactEmail>$email</contactEmail>\n";
- $output .= "\t<signatureURL>$signatureURL</signatureURL>\n";
- $output .= "\t<URL>$url</URL>\n";
- $output .="\t<Input>\n";
- $sth_simple_in->execute($_);
- while (my ($objURI, $nsURI, $article) = $sth_simple_in->fetchrow_array()){
- my $objName = $OSobj->getObjectCommonName($objURI);
- $nsURI ||="";
+ $output .= "\t<signatureURL>$signatureURL</signatureURL>\n";
+ $output .= "\t<URL>$url</URL>\n";
+ $output .= "\t<Input>\n";
+ $sth_simple_in->execute( $_ );
+
+ while ( my ( $objURI, $nsURI, $article ) =
+ $sth_simple_in->fetchrow_array() )
+ {
+ my $objName = $OSobj->getObjectCommonName( $objURI );
+ $nsURI ||= "";
my @nsURIs = split ",", $nsURI;
- $article ||="";
- $output .="\t\t<Simple articleName='$article'>\n";
- $output .="\t\t\t<objectType>$objName</objectType>\n";
- foreach my $ns(@nsURIs){
- my $NSname = $OSns->getNamespaceCommonName($ns);
- $output .="\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
- }
- $output .="\t\t</Simple>\n";
- }
- $sth_collection_ins->execute($_);
- while (my ($collid, $articlename) = $sth_collection_ins->fetchrow_array){
- $output .="\t\t<Collection articleName='$articlename'>\n";
- $sth_collection_in->execute($collid);
- while (my ($objURI, $nsURI, $article) = $sth_collection_in->fetchrow_array()){
- my $objName = $OSobj->getObjectCommonName($objURI);
- $nsURI ||="";
+ $article ||= "";
+ $output .= "\t\t<Simple articleName='$article'>\n";
+ $output .= "\t\t\t<objectType>$objName</objectType>\n";
+ foreach my $ns ( @nsURIs ) {
+ my $NSname = $OSns->getNamespaceCommonName( $ns );
+ $output .= "\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
+ }
+ $output .= "\t\t</Simple>\n";
+ }
+ $sth_collection_ins->execute( $_ );
+ while ( my ( $collid, $articlename ) =
+ $sth_collection_ins->fetchrow_array )
+ {
+ $output .= "\t\t<Collection articleName='$articlename'>\n";
+ $sth_collection_in->execute( $collid );
+ while ( my ( $objURI, $nsURI, $article ) =
+ $sth_collection_in->fetchrow_array() )
+ {
+ my $objName = $OSobj->getObjectCommonName( $objURI );
+ $nsURI ||= "";
my @nsURIs = split ",", $nsURI;
- $article ||="";
- $output .="\t\t\t<Simple articleName='$article'>\n";
- $output .="\t\t\t\t<objectType>$objName</objectType>\n";
- foreach my $ns(@nsURIs){
- my $NSname = $OSns->getNamespaceCommonName($ns);
- $output .="\t\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
+ $article ||= "";
+ $output .= "\t\t\t<Simple articleName='$article'>\n";
+ $output .= "\t\t\t\t<objectType>$objName</objectType>\n";
+ foreach my $ns ( @nsURIs ) {
+ my $NSname = $OSns->getNamespaceCommonName( $ns );
+ $output .= "\t\t\t\t<Namespace>$NSname</Namespace>\n"
+ if $NSname;
}
- $output .="\t\t\t</Simple>\n";
+ $output .= "\t\t\t</Simple>\n";
}
- $output .="\t\t</Collection>\n";
- }
-
- $output .="\t</Input>\n";
-
- $output .="\t<Output>\n";
- $sth_simple_out->execute($_);
- while (my ($objURI, $nsURI, $article) = $sth_simple_out->fetchrow_array()){
- my $objName = $OSobj->getObjectCommonName($objURI);
- $nsURI ||="";
+ $output .= "\t\t</Collection>\n";
+ }
+ $output .= "\t</Input>\n";
+ $output .= "\t<Output>\n";
+ $sth_simple_out->execute( $_ );
+ while ( my ( $objURI, $nsURI, $article ) =
+ $sth_simple_out->fetchrow_array() )
+ {
+ my $objName = $OSobj->getObjectCommonName( $objURI );
+ $nsURI ||= "";
my @nsURIs = split ",", $nsURI;
- $article ||="";
- $output .="\t\t<Simple articleName='$article'>\n";
- $output .="\t\t\t<objectType>$objName</objectType>\n";
- foreach my $ns(@nsURIs){
- my $NSname = $OSns->getNamespaceCommonName($ns);
- $output .="\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
- }
- $output .="\t\t</Simple>\n";
- }
- $sth_collection_outs->execute($_);
- while (my ($collid, $articlename) = $sth_collection_outs->fetchrow_array){
- $output .="\t\t<Collection articleName='$articlename'>\n";
- $sth_collection_out->execute($collid);
- while (my ($objURI, $nsURI, $article) = $sth_collection_out->fetchrow_array()){
- my $objName = $OSobj->getObjectCommonName($objURI);
- $nsURI ||="";
+ $article ||= "";
+ $output .= "\t\t<Simple articleName='$article'>\n";
+ $output .= "\t\t\t<objectType>$objName</objectType>\n";
+ foreach my $ns ( @nsURIs ) {
+ my $NSname = $OSns->getNamespaceCommonName( $ns );
+ $output .= "\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
+ }
+ $output .= "\t\t</Simple>\n";
+ }
+ $sth_collection_outs->execute( $_ );
+ while ( my ( $collid, $articlename ) =
+ $sth_collection_outs->fetchrow_array )
+ {
+ $output .= "\t\t<Collection articleName='$articlename'>\n";
+ $sth_collection_out->execute( $collid );
+ while ( my ( $objURI, $nsURI, $article ) =
+ $sth_collection_out->fetchrow_array() )
+ {
+ my $objName = $OSobj->getObjectCommonName( $objURI );
+ $nsURI ||= "";
my @nsURIs = split ",", $nsURI;
- $article ||="";
- $output .="\t\t\t<Simple articleName='$article'>\n";
- $output .="\t\t\t\t<objectType>$objName</objectType>\n";
- foreach my $ns(@nsURIs){
- my $NSname = $OSns->getNamespaceCommonName($ns);
- $output .="\t\t\t\t<Namespace>$NSname</Namespace>\n" if $NSname;
+ $article ||= "";
+ $output .= "\t\t\t<Simple articleName='$article'>\n";
+ $output .= "\t\t\t\t<objectType>$objName</objectType>\n";
+ foreach my $ns ( @nsURIs ) {
+ my $NSname = $OSns->getNamespaceCommonName( $ns );
+ $output .= "\t\t\t\t<Namespace>$NSname</Namespace>\n"
+ if $NSname;
}
- $output .="\t\t\t</Simple>\n";
+ $output .= "\t\t\t</Simple>\n";
}
- $output .="\t\t</Collection>\n";
- }
- $output .="\t</Output>\n";
-
- $output .="\t<secondaryArticles>\n";
- $sth_secondary_in->execute($_);
- while (my ($default_value, $maximum_value, $minimum_value, $enum_value, $datatype, $article_name) = $sth_secondary_in->fetchrow_array()){
- $article_name ||="";
- $datatype ||="";
- $default_value ||="";
- $maximum_value ||="";
- $minimum_value ||="";
+ $output .= "\t\t</Collection>\n";
+ }
+ $output .= "\t</Output>\n";
+ $output .= "\t<secondaryArticles>\n";
+ $sth_secondary_in->execute( $_ );
+ while (
+ my (
+ $default_value, $maximum_value, $minimum_value,
+ $enum_value, $datatype, $article_name
+ )
+ = $sth_secondary_in->fetchrow_array()
+ )
+ {
+ $article_name ||= "";
+ $datatype ||= "";
+ $default_value ||= "";
+ $maximum_value ||= "";
+ $minimum_value ||= "";
$output .= "\t\t\t<Parameter articleName='$article_name'>\n";
$output .= "\t\t\t\t<datatype>$datatype</datatype>\n";
- $output .="\t\t\t\t<default>$default_value</default>\n";
- $output .="\t\t\t\t<max>$maximum_value</max>\n";
- $output .="\t\t\t\t<min>$minimum_value</min>\n";
+ $output .= "\t\t\t\t<default>$default_value</default>\n";
+ $output .= "\t\t\t\t<max>$maximum_value</max>\n";
+ $output .= "\t\t\t\t<min>$minimum_value</min>\n";
my @enums = split ",", $enum_value;
- if (scalar(@enums)){
- foreach my $enum(@enums){
+
+ if ( scalar( @enums ) ) {
+ foreach my $enum ( @enums ) {
$output .= "\t\t\t\t<enum>$enum</enum>\n";
}
} else {
@@ -3024,64 +3475,63 @@
}
$output .= "\t\t\t</Parameter>\n";
}
- $output .="\t\t</secondaryArticles>\n";
+ $output .= "\t\t</secondaryArticles>\n";
$output .= "\t</Service>\n";
}
return "<Services>\n$output\n</Services>\n";
-
}
-
sub _error {
- my ($message, $id) = @_;
- my $reg = &Registration({
- success => 0,
- message => "$message",
- id => "$id",
- });
+ my ( $message, $id ) = @_;
+ my $reg = &Registration(
+ {
+ success => 0,
+ message => "$message",
+ id => "$id",
+ }
+ );
return $reg;
}
sub _success {
- my ($message, $id, $RDF) = @_;
- my $reg = &Registration({
- success => 1,
- message => "$message",
- id => "$id",
- RDF => $RDF,
- });
+ my ( $message, $id, $RDF ) = @_;
+ my $reg = &Registration(
+ {
+ success => 1,
+ message => "$message",
+ id => "$id",
+ RDF => $RDF,
+ }
+ );
return $reg;
}
-sub _getOntologyServer { # may want to make this more complex
- my (%args) = @_;
- my $OS = MOBY::OntologyServer->new(%args);
+sub _getOntologyServer { # may want to make this more complex
+ my ( %args ) = @_;
+ my $OS = MOBY::OntologyServer->new( %args );
return $OS;
}
-
-
-sub DESTROY {}
-
+sub DESTROY { }
sub _LOG {
+
#return unless $debug;
#print join "\n", @_;
#print "\n---\n";
#return;
- open LOG, ">>/tmp/CentralRegistryLogOut.txt" or die "can't open logfile $!\n";
+ open LOG, ">>/tmp/CentralRegistryLogOut.txt"
+ or die "can't open logfile $!\n";
print LOG join "\n", @_;
print LOG "\n---\n";
close LOG;
}
+
#
#
# --------------------------------------------------------------------------------------------------------
#
##
##
-
-
-
$WSDL_TEMPLATE = <<END;
<?xml version="1.0"?>
<definitions name="MOBY_Central_Generated_WSDL"
@@ -3141,7 +3591,6 @@
END
-
=head2 _getInputXSD
name : _getInputXSD($InputXML, $SecondaryXML)
@@ -3202,13 +3651,10 @@
=cut
-
sub _getInputXSD {
- my ($Input, $Secondary) =@_;
- my $XSD;
-
-
- return $XSD;
+ my ( $Input, $Secondary ) = @_;
+ my $XSD;
+ return $XSD;
}
=head2 _getOuputXSD
@@ -3254,13 +3700,8 @@
=cut
sub _getOutputXSD {
- my ($Output) =@_;
- my $XSD;
-
-
- return $XSD;
+ my ( $Output ) = @_;
+ my $XSD;
+ return $XSD;
}
-
-
1;
-
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/CommonSubs.pm,v
retrieving revision 1.53
retrieving revision 1.54
diff -u -r1.53 -r1.54
--- /home/repository/moby/moby-live/Perl/MOBY/CommonSubs.pm 2004/06/29 16:23:59 1.53
+++ /home/repository/moby/moby-live/Perl/MOBY/CommonSubs.pm 2004/11/18 17:41:14 1.54
@@ -14,7 +14,6 @@
=cut
-
=head2 Service-Side Paradigm
The following is a generalized architecture for *all*
@@ -150,15 +149,13 @@
=cut
-
=head1 METHODS
=cut
-
package MOBY::CommonSubs;
require Exporter;
-use XML::DOM;
+use XML::LibXML;
use MOBY::CrossReference;
use MOBY::Client::OntologyServer;
use strict;
@@ -166,87 +163,87 @@
use MOBY::Client::SimpleArticle;
use MOBY::Client::CollectionArticle;
use MOBY::Client::SecondaryArticle;
-
-
+use MOBY::MobyXMLConstants;
use constant COLLECTION => 1;
-use constant SIMPLE => 2;
-use constant SECONDARY => 3;
-use constant PARAMETER => 3; # be friendly in case they use this instead
-use constant BE_NICE => 1;
-use constant BE_STRICT => 0;
-
-our @ISA = qw(Exporter);
-our @EXPORT = qw(COLLECTION SIMPLE SECONDARY PARAMETER BE_NICE BE_STRICT);
+use constant SIMPLE => 2;
+use constant SECONDARY => 3;
+use constant PARAMETER => 3; # be friendly in case they use this instead
+use constant BE_NICE => 1;
+use constant BE_STRICT => 0;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(COLLECTION SIMPLE SECONDARY PARAMETER BE_NICE BE_STRICT);
our @EXPORT_OK = qw(
- getSimpleArticleIDs
- getSimpleArticleNamespaceURI
- simpleResponse
- responseHeader
- responseFooter
- getInputArticles
- getInputs
- getInputID
- getArticles
- getCollectedSimples
- getNodeContentWithArticle
- extractRawContent
- collectionResponse
- validateNamespaces
- validateThisNamespace
- isSimpleArticle
- isCollectionArticle
- isSecondaryArticle
- extractResponseArticles
- getResponseArticles
- getCrossReferences
- genericServiceInputParser
- genericServiceInputParserAsObject
- complexServiceInputParser
- whichDeepestParentObject
- getServiceNotes
- COLLECTION
- SIMPLE
- SECONDARY
- PARAMETER
- BE_NICE
- BE_STRICT
- );
-our %EXPORT_TAGS =(all => [qw(
- getSimpleArticleIDs
- getSimpleArticleNamespaceURI
- simpleResponse
- responseHeader
- responseFooter
- getInputArticles
- getInputs
- getInputID
- getArticles
- getCollectedSimples
- getNodeContentWithArticle
- extractRawContent
- collectionResponse
- validateNamespaces
- validateThisNamespace
- isSimpleArticle
- isCollectionArticle
- isSecondaryArticle
- extractResponseArticles
- getResponseArticles
- getCrossReferences
- genericServiceInputParser
- genericServiceInputParserAsObject
- complexServiceInputParser
- whichDeepestParentObject
- getServiceNotes
- COLLECTION
- SIMPLE
- SECONDARY
- PARAMETER
- BE_NICE
- BE_STRICT
- )]);
-
-
+ getSimpleArticleIDs
+ getSimpleArticleNamespaceURI
+ simpleResponse
+ responseHeader
+ responseFooter
+ getInputArticles
+ getInputs
+ getInputID
+ getArticles
+ getCollectedSimples
+ getNodeContentWithArticle
+ extractRawContent
+ collectionResponse
+ validateNamespaces
+ validateThisNamespace
+ isSimpleArticle
+ isCollectionArticle
+ isSecondaryArticle
+ extractResponseArticles
+ getResponseArticles
+ getCrossReferences
+ genericServiceInputParser
+ genericServiceInputParserAsObject
+ complexServiceInputParser
+ whichDeepestParentObject
+ getServiceNotes
+ COLLECTION
+ SIMPLE
+ SECONDARY
+ PARAMETER
+ BE_NICE
+ BE_STRICT
+);
+our %EXPORT_TAGS = (
+ all => [
+ qw(
+ getSimpleArticleIDs
+ getSimpleArticleNamespaceURI
+ simpleResponse
+ responseHeader
+ responseFooter
+ getInputArticles
+ getInputs
+ getInputID
+ getArticles
+ getCollectedSimples
+ getNodeContentWithArticle
+ extractRawContent
+ collectionResponse
+ validateNamespaces
+ validateThisNamespace
+ isSimpleArticle
+ isCollectionArticle
+ isSecondaryArticle
+ extractResponseArticles
+ getResponseArticles
+ getCrossReferences
+ genericServiceInputParser
+ genericServiceInputParserAsObject
+ complexServiceInputParser
+ whichDeepestParentObject
+ getServiceNotes
+ COLLECTION
+ SIMPLE
+ SECONDARY
+ PARAMETER
+ BE_NICE
+ BE_STRICT
+ )
+ ]
+);
=head2 genericServiceInputParser
@@ -302,33 +299,33 @@
=cut
-
sub genericServiceInputParser {
- my ($message) = @_; # get the incoming MOBY query XML
- my @inputs; # set empty response
- my @queries = getInputs($message); # returns XML::DOM nodes <mobyData>...</mobyData>
-
- foreach my $query(@queries){
- my $queryID = getInputID($query); # get the queryID attribute of the mobyData
- my @input_articles = getArticles($query); # get the Simple/Collection/Secondary articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter>
- foreach my $input(@input_articles){ # input is a listref
- my ($articleName, $article) = @{$input}; # get the named article
- if (isCollectionArticle($article)){
- my @simples = getCollectedSimples($article);
- push @inputs, [COLLECTION,$queryID, \@simples];
- } elsif (isSimpleArticle($article)){
- push @inputs, [SIMPLE,$queryID,$article];
- } elsif (isSecondaryArticle($article)){ # should never happen in a generic service parser!
- push @inputs, [SECONDARY,$queryID,$article];
- }
- }
- }
- return @inputs;
+ my ( $message ) = @_; # get the incoming MOBY query XML
+ my @inputs; # set empty response
+ my @queries =
+ getInputs( $message ); # returns XML::DOM nodes <mobyData>...</mobyData>
+ foreach my $query ( @queries ) {
+ my $queryID =
+ getInputID( $query ); # get the queryID attribute of the mobyData
+ my @input_articles =
+ getArticles( $query )
+ ; # get the Simple/Collection/Secondary articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter>
+ foreach my $input ( @input_articles ) { # input is a listref
+ my ( $articleName, $article ) = @{$input}; # get the named article
+ if ( isCollectionArticle( $article ) ) {
+ my @simples = getCollectedSimples( $article );
+ push @inputs, [ COLLECTION, $queryID, \@simples ];
+ } elsif ( isSimpleArticle( $article ) ) {
+ push @inputs, [ SIMPLE, $queryID, $article ];
+ } elsif ( isSecondaryArticle( $article ) )
+ { # should never happen in a generic service parser!
+ push @inputs, [ SECONDARY, $queryID, $article ];
+ }
+ }
+ }
+ return @inputs;
}
-
-
-
=head2 serviceInputParser
name : DO NOT USE!!
@@ -345,32 +342,33 @@
=cut
-
sub serviceInputParser {
- my ($message) = @_; # get the incoming MOBY query XML
- my @inputs; # set empty response
- my @queries = getInputs($message); # returns XML::DOM nodes <mobyData>...</mobyData>
-
+ my ( $message ) = @_; # get the incoming MOBY query XML
+ my @inputs; # set empty response
+ my @queries =
+ getInputs( $message ); # returns XML::DOM nodes <mobyData>...</mobyData>
# mark, this doesn't work for complex services. We need to allow more than one input per invocation
- foreach my $query(@queries){
- my $queryID = getInputID($query); # get the queryID attribute of the mobyData
- my @input_articles = getArticlesAsObjects($query); # get the Simple/Collection articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter
- foreach my $article(@input_articles){ # input is a listref
- if ($article->isCollection){
- my @simples = getCollectedSimples($article->XML);
- push @inputs, [COLLECTION,$queryID, \@simples];
- } elsif ($article->isSimple){
- push @inputs, [SIMPLE,$queryID,$article];
- } elsif ($article->isSecondary){
- push @inputs, [SECONDARY,$queryID,$article];
- }
- }
- }
- return @inputs;
+ foreach my $query ( @queries ) {
+ my $queryID =
+ getInputID( $query ); # get the queryID attribute of the mobyData
+ my @input_articles =
+ getArticlesAsObjects( $query )
+ ; # get the Simple/Collection articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter
+ foreach my $article ( @input_articles ) { # input is a listref
+ if ( $article->isCollection ) {
+ my @simples = getCollectedSimples( $article->XML );
+ push @inputs, [ COLLECTION, $queryID, \@simples ];
+ } elsif ( $article->isSimple ) {
+ push @inputs, [ SIMPLE, $queryID, $article ];
+ } elsif ( $article->isSecondary ) {
+ push @inputs, [ SECONDARY, $queryID, $article ];
+ }
+ }
+ }
+ return @inputs;
}
-
=head2 complexServiceInputParser
name : complexServiceInputParser
@@ -439,32 +437,34 @@
=cut
-
sub complexServiceInputParser {
- my ($message) = @_; # get the incoming MOBY query XML
- my @inputs; # set empty response
- my @queries = getInputs($message); # returns XML::DOM nodes <mobyData>...</mobyData>
- my %input_parameters; # $input_parameters{$queryID} = [
-
- foreach my $query(@queries){
- my $queryID = getInputID($query); # get the queryID attribute of the mobyData
- my @input_articles = getArticles($query); # get the Simple/Collection/Secondary articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter>
- foreach my $input(@input_articles){ # input is a listref
- my ($articleName, $article) = @{$input}; # get the named article
- if (isCollectionArticle($article)){
- my @simples = getCollectedSimples($article);
- push @{$input_parameters{$queryID}}, [COLLECTION, \@simples];
- } elsif (isSimpleArticle($article)){
- push @{$input_parameters{$queryID}}, [SIMPLE, $article];
- } elsif (isSecondaryArticle($article)){
- push @{$input_parameters{$queryID}}, [SECONDARY, $article];
- }
- }
- }
- return \%input_parameters;
+ my ( $message ) = @_; # get the incoming MOBY query XML
+ my @inputs; # set empty response
+ my @queries =
+ getInputs( $message ); # returns XML::DOM nodes <mobyData>...</mobyData>
+ my %input_parameters; # $input_parameters{$queryID} = [
+ foreach my $query ( @queries ) {
+ my $queryID =
+ getInputID( $query ); # get the queryID attribute of the mobyData
+ my @input_articles =
+ getArticles( $query )
+ ; # get the Simple/Collection/Secondary articles making up this query <Simple>...</Simple> or <Collection>...</Collection> or <Parameter>...</Parameter>
+ foreach my $input ( @input_articles ) { # input is a listref
+ my ( $articleName, $article ) = @{$input}; # get the named article
+ if ( isCollectionArticle( $article ) ) {
+ my @simples = getCollectedSimples( $article );
+ push @{ $input_parameters{$queryID} },
+ [ COLLECTION, \@simples ];
+ } elsif ( isSimpleArticle( $article ) ) {
+ push @{ $input_parameters{$queryID} }, [ SIMPLE, $article ];
+ } elsif ( isSecondaryArticle( $article ) ) {
+ push @{ $input_parameters{$queryID} }, [ SECONDARY, $article ];
+ }
+ }
+ }
+ return \%input_parameters;
}
-
=head2 getArticles
name : getArticles
@@ -506,37 +506,39 @@
=cut
-
sub getArticles {
-
- my ($moby) = @_;
- unless (ref($moby) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($moby);
- $moby = $doc->getDocumentElement();
- }
-
- return undef unless $moby->getNodeType == ELEMENT_NODE;
- return undef unless (($moby->getTagName =~ /queryInput/) || ($moby->getTagName =~ /queryResponse/) || ($moby->getTagName =~ /mobyData/));
- my @articles;
- foreach my $child($moby->getChildNodes){ # there may be more than one Simple/Collection per input; iterate over them
- next unless $child->getNodeType == ELEMENT_NODE; # ignore whitespace
- next unless ($child->getTagName =~ /Simple/ || $child->getTagName =~ /Collection/ || $child->getTagName =~ /Parameter/);
- my $articleName = $child->getAttribute('articleName');
- $articleName ||= $child->getAttribute('moby:articleName');
- push @articles, [$articleName, $child]; # push the named child DOM elements (which are <Simple> or <Collection>, <Parameter>)
- }
- return @articles; # return them.
+ my ( $moby ) = @_;
+ unless ( ref( $moby ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $moby );
+ $moby = $doc->getDocumentElement();
+ }
+ return undef unless $moby->nodeType == ELEMENT_NODE;
+ return undef
+ unless ( ( $moby->nodeName =~ /queryInput/ )
+ || ( $moby->nodeName =~ /queryResponse/ )
+ || ( $moby->nodeName =~ /mobyData/ ) );
+ my @articles;
+ foreach my $child ( $moby->childNodes )
+ { # there may be more than one Simple/Collection per input; iterate over them
+ next unless $child->nodeType == ELEMENT_NODE; # ignore whitespace
+ next
+ unless ( $child->nodeName =~ /Simple/
+ || $child->nodeName =~ /Collection/
+ || $child->nodeName =~ /Parameter/ );
+ my $articleName = $child->getAttribute( 'articleName' );
+ $articleName ||= $child->getAttribute( 'moby:articleName' );
+ push @articles, [ $articleName, $child ]
+ ; # push the named child DOM elements (which are <Simple> or <Collection>, <Parameter>)
+ }
+ return @articles; # return them.
}
-
-
-
#################################################
- ##################################
- ##################################
- # COMMON SUBROUTINES for Clients and Services
- ##################################
- ##################################
+##################################
+##################################
+# COMMON SUBROUTINES for Clients and Services
+##################################
+##################################
#################################################
=head2 getSimpleArticleIDs
@@ -560,60 +562,74 @@
=cut
-
+#Eddie - converted
sub getSimpleArticleIDs {
- my ($desired_namespace, $input_nodes) = @_;
- if ($desired_namespace && !($input_nodes)){ # if called with ONE argument, then these are the input nodes!
- $input_nodes = $desired_namespace;
- $desired_namespace = undef;
+ my ( $desired_namespace, $input_nodes ) = @_;
+ if ( $desired_namespace && !( $input_nodes ) )
+ { # if called with ONE argument, then these are the input nodes!
+ $input_nodes = $desired_namespace;
+ $desired_namespace = undef;
}
- $input_nodes = [$input_nodes] unless ref($input_nodes) =~ /ARRAY/; # be flexible!
+ $input_nodes = [$input_nodes]
+ unless ref( $input_nodes ) =~ /ARRAY/; # be flexible!
return undef unless scalar @{$input_nodes};
-
my @input_nodes = @{$input_nodes};
- my $OS = MOBY::Client::OntologyServer->new;
- my ($s, $m);
- if ($desired_namespace){
- ($s, $m, $desired_namespace) = $OS->namespaceExists(term => $desired_namespace); # returns (success, message, lsid)
- unless ($s){ # bail if not successful
- print STDERR "MOBY::CommonSubs WARNING ** the namespace $desired_namespace does not exist in the MOBY ontology, and is not a valid LSID\n";
- return undef;
- }
- }
+ my $OS = MOBY::Client::OntologyServer->new;
+ my ( $s, $m );
+ if ( $desired_namespace ) {
+ ( $s, $m, $desired_namespace ) =
+ $OS->namespaceExists( term => $desired_namespace )
+ ; # returns (success, message, lsid)
+ unless ( $s ) { # bail if not successful
+ print STDERR
+"MOBY::CommonSubs WARNING ** the namespace $desired_namespace does not exist in the MOBY ontology, and is not a valid LSID\n";
+ return undef;
+ }
+ }
+ my @ids;
+ foreach my $in ( @input_nodes ) {
+ next unless $in;
- my @ids;
- foreach my $in(@input_nodes){
- next unless $in;
#$in = "<Simple><Object namespace='' id=''/></Simple>"
- next unless $in->getNodeName =~ /simple/i; # only allow simples
- my @simples = $in->getChildNodes;
- foreach (@simples){ # $_ = <Object namespace='' id=''/>
- next unless $_->getNodeType == ELEMENT_NODE;
- if ($desired_namespace){
- my $ns = $_->getAttributeNode('namespace'); # get the namespace DOM node
- $ns = $_->getAttributeNode('moby:namespace') unless ($ns); # perhaps it is namespaced...
- unless ($ns){ # if we don't get it at all, then move on to the next input
- push @ids, undef; # but push an undef onto teh stack in order
- next;
- }
- $ns = $ns->getValue; # if we have a namespace, then get its value
- ($s, $m, $ns) = $OS->namespaceExists(term => $ns);
-
- unless ($ns eq $desired_namespace){ # we are registering as working in a particular namespace, so check this
- push @ids, undef; # and push undef onto the stack if it isn't
- next;
- }
+ next unless $in->nodeName =~ /simple/i; # only allow simples
+ my @simples = $in->childNodes;
+ foreach ( @simples ) { # $_ = <Object namespace='' id=''/>
+ next unless $_->nodeType == ELEMENT_NODE;
+ if ( $desired_namespace ) {
+ my $ns =
+ $_->getAttributeNode( 'namespace' )
+ ; # get the namespace DOM node
+ $ns = $_->getAttributeNode( 'moby:namespace' )
+ unless ( $ns ); # perhaps it is namespaced...
+ unless ( $ns )
+ { # if we don't get it at all, then move on to the next input
+ push @ids,
+ undef; # but push an undef onto teh stack in order
+ next;
+ }
+ $ns =
+ $ns->getValue; # if we have a namespace, then get its value
+ ( $s, $m, $ns ) = $OS->namespaceExists( term => $ns );
+ unless ( $ns eq $desired_namespace )
+ { # we are registering as working in a particular namespace, so check this
+ push @ids,
+ undef; # and push undef onto the stack if it isn't
+ next;
+ }
}
+
# Now do the same thing for ID's
- my $id = $_->getAttributeNode('id');
- $id = $_->getAttributeNode('moby:id') unless ($id);
- unless ($id){
+ my $id = $_->getAttributeNode( 'id' );
+ $id = $_->getAttributeNode( 'moby:id' ) unless ( $id );
+ unless ( $id ) {
push @ids, undef;
next;
}
$id = $id->getValue;
- unless (defined $id){ # it has to have a hope in hell of retrieving something...
- push @ids, undef; # otherwise push undef onto the stack if it isn't
+ unless ( defined $id )
+ { # it has to have a hope in hell of retrieving something...
+ push @ids,
+ undef; # otherwise push undef onto the stack if it isn't
next;
}
push @ids, $id;
@@ -622,7 +638,6 @@
return @ids;
}
-
=head2 getSimpleArticleNamespaceURI
name : getSimpleArticleNamespaceURI
@@ -636,32 +651,35 @@
=cut
-
+#Eddie - converted
sub getSimpleArticleNamespaceURI {
- # pass me a <SIMPLE> input node and I will give you the lsid of the namespace of that input object
-
- my ($input_node) = @_;
+# pass me a <SIMPLE> input node and I will give you the lsid of the namespace of that input object
+ my ( $input_node ) = @_;
return undef unless $input_node;
my $OS = MOBY::Client::OntologyServer->new;
-
+
#$input_node = "<Simple><Object namespace='' id=''/></Simple>"
- my @simples = $input_node->getChildNodes;
- foreach (@simples){ # $_ = <Object namespace='' id=''/> # should be just one, so I will return at will from this routine
- next unless $_->getNodeType == ELEMENT_NODE;
- my $ns = $_->getAttributeNode('namespace'); # get the namespace DOM node
- $ns = $_->getAttributeNode('moby:namespace') unless ($ns); # perhaps it is namespaced...
- unless ($ns){ # if we don't get it at all, then move on to the next input
- return undef
+ my @simples = $input_node->childNodes;
+ foreach ( @simples )
+ { # $_ = <Object namespace='' id=''/> # should be just one, so I will return at will from this routine
+ next unless $_->nodeType == ELEMENT_NODE;
+ my $ns =
+ $_->getAttributeNode( 'namespace' ); # get the namespace DOM node
+ $ns = $_->getAttributeNode( 'moby:namespace' )
+ unless ( $ns ); # perhaps it is namespaced...
+ unless ( $ns )
+ { # if we don't get it at all, then move on to the next input
+ return undef;
}
- my ($s, $m, $lsid) = $OS->namespaceExists(term => $ns->getValue); # if we have a namespace, then get its value
+ my ( $s, $m, $lsid ) =
+ $OS->namespaceExists( term => $ns->getValue )
+ ; # if we have a namespace, then get its value
return undef unless $s;
- return $lsid
+ return $lsid;
}
}
-
-
=head2 simpleResponse
name : simpleResponse
@@ -678,47 +696,49 @@
=cut
-
sub simpleResponse {
- my ($data, $articleName, $qID) = @_; # articleName optional
- $qID = &_getQueryID($qID) if ref($qID) =~ /XML::DOM/; # in case they send the DOM instead of the ID
-
- $data ||=''; # initialize to avoid uninit value errors
- $qID ||="";
- $articleName ||="";
- if ($articleName) {
- return "
+ my ( $data, $articleName, $qID ) = @_; # articleName optional
+ $qID = &_getQueryID( $qID )
+ if ref( $qID ) =~
+ /XML::DOM/; # in case they send the DOM instead of the ID
+ $data ||= ''; # initialize to avoid uninit value errors
+ $qID ||= "";
+ $articleName ||= "";
+ if ( $articleName ) {
+ return "
<moby:mobyData moby:queryID='$qID'>
<moby:Simple moby:articleName='$articleName'>$data</moby:Simple>
</moby:mobyData>
";
- } elsif($data) {
- return "
+ } elsif ( $data ) {
+ return "
<moby:mobyData moby:queryID='$qID'>
<moby:Simple moby:articleName='$articleName'>$data</moby:Simple>
</moby:mobyData>
";
- } else {
- return "
+ } else {
+ return "
<moby:mobyData moby:queryID='$qID'/>
";
}
}
+#Eddie - converted
sub _getQueryID {
- my ($query) = @_;
- unless (ref($query) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($query);
- $query = $doc->getDocumentElement();
- }
- return '' unless ($query->getTagName =~/queryInput/ || $query->getTagName =~/mobyData/);
- my $id = $query->getAttribute('queryID');
- $id ||= $query->getAttribute('moby:queryID');
- return $id;
+ my ( $query ) = @_;
+ unless ( ref( $query ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $query );
+ $query = $doc->getDocumentElement();
+ }
+ return ''
+ unless ( $query->nodeName =~ /queryInput/
+ || $query->nodeName =~ /mobyData/ ); #Eddie - unsure
+ my $id = $query->getAttribute( 'queryID' );
+ $id ||= $query->getAttribute( 'moby:queryID' );
+ return $id;
}
-
=head2 collectionResponse
name : collectionResponse
@@ -735,45 +755,43 @@
=cut
-
sub collectionResponse {
- my ($data, $articleName, $qID) = @_; # articleName optional
- my $content = "";
- $data ||=[];
- $qID ||= '';
- unless ((ref($data) =~ /array/i) && $data->[0]){ # we're expecting an arrayref as input data,and it must not be empty
- return "<moby:mobyData moby:queryID='$qID'/>";
- }
-
- foreach (@{$data}){
- if($_) {
- $content .= "
+ my ( $data, $articleName, $qID ) = @_; # articleName optional
+ my $content = "";
+ $data ||= [];
+ $qID ||= '';
+ unless ( ( ref( $data ) =~ /array/i ) && $data->[0] )
+ { # we're expecting an arrayref as input data,and it must not be empty
+ return "<moby:mobyData moby:queryID='$qID'/>";
+ }
+ foreach ( @{$data} ) {
+ if ( $_ ) {
+ $content .= "
<moby:Simple>$_</moby:Simple>
";
- } else {
- $content .= "
+ } else {
+ $content .= "
<moby:Simple/>
";
- }
- }
- if ($articleName) {
- return "
+ }
+ }
+ if ( $articleName ) {
+ return "
<moby:mobyData moby:queryID='$qID'>
<moby:Collection moby:articleName='$articleName'>
$content
</moby:Collection>
</moby:mobyData>
";
- } else {
- return "
+ } else {
+ return "
<moby:mobyData moby:queryID='$qID'>
<moby:Collection moby:articleName='$articleName'>$content</moby:Collection>
</moby:mobyData>
";
- }
+ }
}
-
=head2 responseHeader
name : responseHeader
@@ -795,23 +813,22 @@
=cut
-
sub responseHeader {
- use HTML::Entities ();
- my ($auth, $notes) = &_rearrange([qw[AUTHORITY NOTE]], @_);
- $auth ||="not_provided";
- $notes ||="";
- my $xml = "<?xml version='1.0' encoding='UTF-8'?>".
- "<moby:MOBY xmlns:moby='http://www.biomoby.org/moby' xmlns='http://www.biomoby.org/moby'>".
- "<moby:mobyContent moby:authority='$auth'>";
- if ($notes){
- my $encodednotes = HTML::Entities::encode($notes);
- $xml .="<moby:serviceNotes>$encodednotes</moby:serviceNotes>";
- }
- return $xml;
+ use HTML::Entities ();
+ my ( $auth, $notes ) = &_rearrange( [qw[AUTHORITY NOTE]], @_ );
+ $auth ||= "not_provided";
+ $notes ||= "";
+ my $xml =
+ "<?xml version='1.0' encoding='UTF-8'?>"
+ . "<moby:MOBY xmlns:moby='http://www.biomoby.org/moby' xmlns='http://www.biomoby.org/moby'>"
+ . "<moby:mobyContent moby:authority='$auth'>";
+ if ( $notes ) {
+ my $encodednotes = HTML::Entities::encode( $notes );
+ $xml .= "<moby:serviceNotes>$encodednotes</moby:serviceNotes>";
+ }
+ return $xml;
}
-
=head2 responseFooter
name : responseFooter
@@ -825,13 +842,10 @@
=cut
-
sub responseFooter {
- return "</moby:mobyContent></moby:MOBY>";
+ return "</moby:mobyContent></moby:MOBY>";
}
-
-
=head2 getInputs
name : getInputs
@@ -845,28 +859,29 @@
=cut
-
+#Eddie - converted
sub getInputs {
-
- my ($XML) = @_;
- my $moby;
- unless (ref($XML) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($XML);
- $moby = $doc->getDocumentElement();
- }
- my @queries;
-
- foreach my $querytag('queryInput', 'moby:queryInput', 'mobyData', 'moby:mobyData'){
- my $x = $moby->getElementsByTagName($querytag); # get the mobyData block
- for (0..$x->getLength-1){ # there may be more than one mobyData per message
- push @queries, $x->item($_);
- }
- }
- return @queries; # return them in the order that they were discovered.
+ my ( $XML ) = @_;
+ my $moby;
+ unless ( ref( $XML ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $XML );
+ $moby = $doc->getDocumentElement();
+ }
+ my @queries;
+ foreach my $querytag ( 'queryInput', 'moby:queryInput', 'mobyData',
+ 'moby:mobyData' )
+ {
+ my $x =
+ $moby->getElementsByTagName( $querytag ); # get the mobyData block
+ for ( 1 .. $x->size() )
+ { # there may be more than one mobyData per message
+ push @queries, $x->get_node( $_ );
+ }
+ }
+ return @queries; # return them in the order that they were discovered.
}
-
=head2 getInputID
name : getInputID
@@ -881,23 +896,21 @@
=cut
-
sub getInputID {
- my ($XML) = @_;
- unless (ref($XML) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($XML);
- $XML = $doc->getDocumentElement();
- }
- return '' unless (($XML->getTagName =~ /queryInput/) || ($XML->getTagName =~ /mobyData/));
- my $qid = $XML->getAttribute('queryID');
- $qid ||= $XML->getAttribute('moby:queryID');
-
- return defined($qid)?$qid:'';
+ my ( $XML ) = @_;
+ unless ( ref( $XML ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $XML );
+ $XML = $doc->getDocumentElement();
+ }
+ return ''
+ unless ( ( $XML->nodeName =~ /queryInput/ )
+ || ( $XML->nodeName =~ /mobyData/ ) );
+ my $qid = $XML->getAttribute( 'queryID' );
+ $qid ||= $XML->getAttribute( 'moby:queryID' );
+ return defined( $qid ) ? $qid : '';
}
-
-
=head2 getArticlesAsObjects
name : DO NOT USE!!
@@ -910,37 +923,42 @@
=cut
-
+#Eddie - converted
sub getArticlesAsObjects {
-
- my ($moby) = @_;
- unless (ref($moby) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($moby);
- $moby = $doc->getDocumentElement();
- }
-
- return undef unless $moby->getNodeType == ELEMENT_NODE;
- return undef unless (($moby->getTagName =~ /queryInput/) || ($moby->getTagName =~ /queryResponse/) || ($moby->getTagName =~ /mobyData/));
- my @articles;
- foreach my $child($moby->getChildNodes){ # there may be more than one Simple/Collection per input; iterate over them
- next unless $child->getNodeType == ELEMENT_NODE; # ignore whitespace
- next unless ($child->getTagName =~ /Simple/ || $child->getTagName =~ /Collection/ || $child->getTagName =~ /Parameter/);
- my $object;
- if ($child->getTagName =~ /Simple/){
- $object = MOBY::Client::SimpleArticle->new(XML_DOM => $child);
- } elsif ($child->getTagName =~ /Collection/){
- $object = MOBY::Client::CollectionArticle->new(XML_DOM => $child);
- } elsif ($child->getTagName =~ /Parameter/){
- $object = MOBY::Client::SecondaryArticle->new(XML_DOM => $child);
- }
- next unless $object;
- push @articles, $object; # take the child elements, which are <Simple/> or <Collection/>
- }
- return @articles; # return them.
+ my ( $moby ) = @_;
+ unless ( ref( $moby ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $moby );
+ $moby = $doc->getDocumentElement();
+ }
+ return undef unless $moby->nodeType == ELEMENT_NODE;
+ return undef
+ unless ( ( $moby->nodeName =~ /queryInput/ )
+ || ( $moby->nodeName =~ /queryResponse/ )
+ || ( $moby->nodeName =~ /mobyData/ ) );
+ my @articles;
+ foreach my $child ( $moby->childNodes )
+ { # there may be more than one Simple/Collection per input; iterate over them
+ next unless $child->nodeType == ELEMENT_NODE; # ignore whitespace
+ next
+ unless ( $child->nodeName =~ /Simple/
+ || $child->nodeName =~ /Collection/
+ || $child->nodeName =~ /Parameter/ );
+ my $object;
+ if ( $child->nodeName =~ /Simple/ ) {
+ $object = MOBY::Client::SimpleArticle->new( XML_DOM => $child );
+ } elsif ( $child->nodeName =~ /Collection/ ) {
+ $object = MOBY::Client::CollectionArticle->new( XML_DOM => $child );
+ } elsif ( $child->nodeName =~ /Parameter/ ) {
+ $object = MOBY::Client::SecondaryArticle->new( XML_DOM => $child );
+ }
+ next unless $object;
+ push @articles, $object
+ ; # take the child elements, which are <Simple/> or <Collection/>
+ }
+ return @articles; # return them.
}
-
=head2 getCollectedSimples
name : getCollectedSimples
@@ -951,29 +969,26 @@
=cut
-
sub getCollectedSimples {
-
- my ($moby) = @_;
- unless (ref($moby) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($moby);
- $moby = $doc->getDocumentElement();
- }
-
- return undef unless $moby->getNodeType == ELEMENT_NODE;
- return undef unless ($moby->getTagName =~ /Collection/);
-
- my @articles;
- foreach my $child($moby->getChildNodes){ # there may be more than one Simple/Collection per input; iterate over them
- next unless $child->getNodeType == ELEMENT_NODE; # ignore whitespace
- next unless ($child->getTagName =~ /Simple/);
- push @articles, $child; # take the child elements, which are <Simple/> or <Collection/>
- }
- return (@articles); # return them.
+ my ( $moby ) = @_;
+ unless ( ref( $moby ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $moby );
+ $moby = $doc->getDocumentElement();
+ }
+ return undef unless $moby->nodeType == ELEMENT_NODE;
+ return undef unless ( $moby->nodeName =~ /Collection/ );
+ my @articles;
+ foreach my $child ( $moby->childNodes )
+ { # there may be more than one Simple/Collection per input; iterate over them
+ next unless $child->nodeType == ELEMENT_NODE; # ignore whitespace
+ next unless ( $child->nodeName =~ /Simple/ );
+ push @articles, $child
+ ; # take the child elements, which are <Simple/> or <Collection/>
+ }
+ return ( @articles ); # return them.
}
-
=head2 getInputArticles
name : getInputArticles
@@ -1006,36 +1021,34 @@
=cut
-
+#Eddie - converted
sub getInputArticles {
-
- my ($moby) = @_;
- unless (ref($moby) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($moby);
- $moby = $doc->getDocumentElement();
- }
-
- my $x;
- foreach ('queryInput', 'moby:queryInput', 'mobyData', 'moby:mobyData'){
- $x = $moby->getElementsByTagName($_); # get the mobyData block
- last if $x->item(0);
- }
- return undef unless $x->item(0); # in case there was no match at all
-
- my @queries;
- for (0..$x->getLength-1){ # there may be more than one mobyData per message
+ my ( $moby ) = @_;
+ unless ( ref( $moby ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $moby );
+ $moby = $doc->getDocumentElement();
+ }
+ my $x;
+ foreach ( 'queryInput', 'moby:queryInput', 'mobyData', 'moby:mobyData' ) {
+ $x = $moby->getElementsByTagName( $_ ); # get the mobyData block
+ last if $x->get_node( 1 );
+ }
+ return undef unless $x->get_node( 1 ); # in case there was no match at all
+ my @queries;
+ for ( 1 .. $x->size() ) { # there may be more than one mobyData per message
my @this_query;
- foreach my $child($x->item($_)->getChildNodes){ # there may be more than one Simple/Collection per input; iterate over them
- next unless $child->getNodeType == ELEMENT_NODE; # ignore whitespace
- push @this_query, $child; # take the child elements, which are <Simple/> or <Collection/>
- }
- push @queries, \@this_query;
+ foreach my $child ( $x->get_node( $_ )->childNodes )
+ { # there may be more than one Simple/Collection per input; iterate over them
+ next unless $child->nodeType == ELEMENT_NODE; # ignore whitespace
+ push @this_query, $child
+ ; # take the child elements, which are <Simple/> or <Collection/>
+ }
+ push @queries, \@this_query;
}
- return @queries; # return them in the order that they were discovered.
+ return @queries; # return them in the order that they were discovered.
}
-
=head2 isSimpleArticle
name : isSimpleArticle
@@ -1046,18 +1059,19 @@
=cut
+#Eddie - converted
sub isSimpleArticle {
- my ($DOM) = @_;
- unless (ref($DOM) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc;
- eval {$doc = $parser->parse($DOM);};
- return 0 if ($@);
- $DOM = $doc->getDocumentElement();
- }
- $DOM = $DOM->getDocumentElement if ($DOM->isa("XML::DOM::Document"));
- return 1 if ($DOM->getTagName =~ /Simple/);
- return 0;
+ my ( $DOM ) = @_;
+ unless ( ref( $DOM ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc;
+ eval { $doc = $parser->parse_string( $DOM ); };
+ return 0 if ( $@ );
+ $DOM = $doc->getDocumentElement();
+ }
+ $DOM = $DOM->getDocumentElement if ( $DOM->isa( "XML::LibXML::Document" ) );
+ return 1 if ( $DOM->nodeName =~ /Simple/ );
+ return 0;
}
=head2 isCollectionArticle
@@ -1070,21 +1084,21 @@
=cut
+#Eddie - converted
sub isCollectionArticle {
- my ($DOM) = @_;
- unless (ref($DOM) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc;
- eval {$doc = $parser->parse($DOM);};
- return 0 if ($@);
- $DOM = $doc->getDocumentElement();
- }
- $DOM = $DOM->getDocumentElement if ($DOM->isa("XML::DOM::Document"));
- return 1 if ($DOM->getTagName =~ /Collection/);
- return 0;
+ my ( $DOM ) = @_;
+ unless ( ref( $DOM ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc;
+ eval { $doc = $parser->parse_string( $DOM ); };
+ return 0 if ( $@ );
+ $DOM = $doc->getDocumentElement();
+ }
+ $DOM = $DOM->getDocumentElement if ( $DOM->isa( "XML::LibXML::Document" ) );
+ return 1 if ( $DOM->nodeName =~ /Collection/ );
+ return 0;
}
-
=head2 isSecondaryArticle
name : isSecondaryArticle
@@ -1095,21 +1109,21 @@
=cut
+#Eddie - converted
sub isSecondaryArticle {
- my ($DOM) = @_;
- unless (ref($DOM) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc;
- eval {$doc = $parser->parse($DOM);};
- return 0 if ($@);
- $DOM = $doc->getDocumentElement();
- }
- $DOM = $DOM->getDocumentElement if ($DOM->isa("XML::DOM::Document"));
- return 1 if ($DOM->getTagName =~ /Parameter/);
- return 0;
+ my ( $DOM ) = @_;
+ unless ( ref( $DOM ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc;
+ eval { $doc = $parser->parse( _string $DOM); };
+ return 0 if ( $@ );
+ $DOM = $doc->getDocumentElement();
+ }
+ $DOM = $DOM->getDocumentElement if ( $DOM->isa( "XML::LibXML::Document" ) );
+ return 1 if ( $DOM->nodeName =~ /Parameter/ );
+ return 0;
}
-
=head2 extractRawContent
name : extractRawContent
@@ -1121,20 +1135,17 @@
=cut
-
sub extractRawContent {
- my ($article) = @_;
- return "" unless $article;
- return "" unless ref($article) =~ /XML::DOM/;
- my $response;
- foreach ($article->getChildNodes){
- $response .= $_->toString;
- }
- return $response;
-
+ my ( $article ) = @_;
+ return "" unless $article;
+ return "" unless ref( $article ) =~ /XML::DOM/;
+ my $response;
+ foreach ( $article->childNodes ) {
+ $response .= $_->toString;
+ }
+ return $response;
}
-
=head2 getNodeContentWithArticle
name : getNodeContentWithArticle
@@ -1219,62 +1230,73 @@
=cut
-sub getNodeContentWithArticle{
- # give me a DOM, a TagName, an articleName and I will return you the content
- # of that node **as a string** (beware if there are additional XML tags in there!)
- # this is meant for MOBYesque PRIMITIVES - things like:
- # <String articleName="SeuqenceString">TAGCTGATCGAGCTGATGCTGA</String>
- # call _getNodeContentsWithAttribute($DOM_NODE, "String", "SequenceString")
- # and I will return "TACGATGCTAGCTAGCGATCGG"
- # Caveat Emptor - I will NOT chop off leading and trailing whitespace or
- # carriage returns, as these might be meaningful!
- my ($node, $element, $articleName) = @_;
- my @contents;
- return () unless ref($node)=~/XML::DOM/;
- return () unless $element;
- return () unless $articleName;
- my $nodes = $node->getElementsByTagName($element);
- unless ($nodes->item(0)){
- $nodes = $node->getElementsByTagName("moby:$element");
- }
+#Eddie - converted
+sub getNodeContentWithArticle {
- for (0..$nodes->getLength-1){
- my $child = $nodes->item($_);
- if (
- (($child->getAttribute("articleName")) && (($child->getAttribute("articleName") eq $articleName)))
- || (($child->getAttribute("moby:articleName")) && (($child->getAttribute("moby:articleName") eq $articleName)))){
- # now we have a valid child, get the content... stringified... regardless of what it is
-
- if (isSecondaryArticle($child)){
- my $resp;
- my $valuenodes = $child->getElementsByTagName('Value');
- unless ($valuenodes->item(0)){
- $valuenodes = $child->getElementsByTagName("moby:Value");
- }
- for (0..$valuenodes->getLength-1){
- my $valuenode = $valuenodes->item($_);
- foreach my $amount ($valuenode->getChildNodes){
- next unless $amount->getNodeType == TEXT_NODE;
- $resp .= $amount->toString;
- }
- }
- push @contents, $resp;
-
- } else {
- my $resp;
- foreach ($child->getChildNodes){
- next unless $_->getNodeType == TEXT_NODE;
- $resp .= $_->toString;
- }
- push @contents, $resp;
- }
- }
+# give me a DOM, a TagName, an articleName and I will return you the content
+# of that node **as a string** (beware if there are additional XML tags in there!)
+# this is meant for MOBYesque PRIMITIVES - things like:
+# <String articleName="SeuqenceString">TAGCTGATCGAGCTGATGCTGA</String>
+# call _getNodeContentsWithAttribute($DOM_NODE, "String", "SequenceString")
+# and I will return "TACGATGCTAGCTAGCGATCGG"
+# Caveat Emptor - I will NOT chop off leading and trailing whitespace or
+# carriage returns, as these might be meaningful!
+ my ( $node, $element, $articleName ) = @_;
+ my @contents;
+ return () unless ref( $node ) =~ /XML::DOM/;
+ return () unless $element;
+ return () unless $articleName;
+ my $nodes = $node->getElementsByTagName( $element );
+ unless ( $nodes->get_node( 1 ) ) {
+ $nodes = $node->getElementsByTagName( "moby:$element" );
+ }
+ for ( 1 .. $nodes->size() ) {
+ my $child = $nodes->get_node( $_ );
+ if (
+ (
+ ( $child->getAttribute( "articleName" ) )
+ && ( ( $child->getAttribute( "articleName" ) eq $articleName ) )
+ )
+ || (
+ ( $child->getAttribute( "moby:articleName" ) )
+ && (
+ (
+ $child->getAttribute( "moby:articleName" ) eq
+ $articleName
+ )
+ )
+ )
+ )
+ {
+
+# now we have a valid child, get the content... stringified... regardless of what it is
+ if ( isSecondaryArticle( $child ) ) {
+ my $resp;
+ my $valuenodes = $child->getElementsByTagName( 'Value' );
+ unless ( $valuenodes->get_node( 1 ) ) {
+ $valuenodes = $child->getElementsByTagName( "moby:Value" );
+ }
+ for ( 1 .. $valuenodes->size() ) {
+ my $valuenode = $valuenodes->get_node( $_ );
+ foreach my $amount ( $valuenode->childNodes ) {
+ next unless $amount->nodeType == TEXT_NODE;
+ $resp .= $amount->toString;
+ }
+ }
+ push @contents, $resp;
+ } else {
+ my $resp;
+ foreach ( $child->childNodes ) {
+ next unless $_->nodeType == TEXT_NODE;
+ $resp .= $_->toString;
+ }
+ push @contents, $resp;
+ }
+ }
}
return @contents;
}
-
-
=head2 validateNamespaces
name : validateNamespaces
@@ -1287,22 +1309,19 @@
=cut
-
sub validateNamespaces {
- # give me a list of namespaces and I will return the LSID's in order
- # I return undef in that list position if the namespace is invalid
- my (@namespaces) = @_;
- my $OS = MOBY::Client::OntologyServer->new;
- my @lsids;
- foreach (@namespaces){
- my ($s, $m, $LSID) = $OS->namespaceExists(term => $_);
- push @lsids, $s?$LSID:undef;
- }
- return @lsids;
-}
-
-
+ # give me a list of namespaces and I will return the LSID's in order
+ # I return undef in that list position if the namespace is invalid
+ my ( @namespaces ) = @_;
+ my $OS = MOBY::Client::OntologyServer->new;
+ my @lsids;
+ foreach ( @namespaces ) {
+ my ( $s, $m, $LSID ) = $OS->namespaceExists( term => $_ );
+ push @lsids, $s ? $LSID : undef;
+ }
+ return @lsids;
+}
=head2 validateThisNamespace
@@ -1315,19 +1334,21 @@
=cut
-
sub validateThisNamespace {
- my ($ns, @namespaces) = @_;
- return 1 unless scalar @namespaces; # if you don't give me a list, I assume everything is valid...
- if (ref($namespaces[1]) =~ /ARRAY/){@namespaces = @{$namespaces[1]}} # if you send me an arrayref I should be kind... DWIM!
- foreach (@namespaces){
- next unless $_;
- return 1 if $ns eq $_;
- }
- return 0;
+ my ( $ns, @namespaces ) = @_;
+ return 1
+ unless scalar @namespaces
+ ; # if you don't give me a list, I assume everything is valid...
+ if ( ref( $namespaces[1] ) =~ /ARRAY/ ) {
+ @namespaces = @{ $namespaces[1] };
+ } # if you send me an arrayref I should be kind... DWIM!
+ foreach ( @namespaces ) {
+ next unless $_;
+ return 1 if $ns eq $_;
+ }
+ return 0;
}
-
=head2 getResponseArticles (a.k.a. extractResponseArticles)
name : getResponseArticles
@@ -1343,56 +1364,63 @@
*getResponseArticles = \&extractResponseArticles;
*getResponseArticles = \&extractResponseArticles;
+#Eddie - converted
sub extractResponseArticles {
- my ($result) = @_;
- return ([], []) unless $result;
- my $moby;
- unless (ref($result) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($result);
- $moby = $doc->getDocumentElement();
- } else {
- $moby = $result->getDocumentElement();
- }
- my @objects;
- my @collections;
- my @Xrefs;
- my $success = 0;
- foreach my $which ('moby:queryResponse', 'queryResponse', 'mobyData', 'moby:mobyData'){
- my $responses = $moby->getElementsByTagName($which);
- next unless $responses;
- foreach my $n(0..($responses->getLength - 1)){
- my $resp = $responses->item($n);
- foreach my $response_component($resp->getChildNodes){
- next unless $response_component->getNodeType == ELEMENT_NODE;
- if (($response_component->getTagName eq "Simple") || ($response_component->getTagName eq "moby:Simple")){
- foreach my $Object($response_component->getChildNodes) {
- next unless $Object->getNodeType == ELEMENT_NODE;
- $success = 1;
- push @objects,$Object;
- }
- } elsif (($response_component->getTagName eq "Collection") || ($response_component->getTagName eq "moby:Collection")){
- my @objects;
- foreach my $simple($response_component->getChildNodes){
- next unless $simple->getNodeType == ELEMENT_NODE;
- next unless (($simple->getTagName eq "Simple") || ($simple->getTagName eq "moby:Simple"));
- foreach my $Object($simple->getChildNodes) {
- next unless $Object->getNodeType == ELEMENT_NODE;
- $success = 1;
- push @objects,$Object;
- }
- }
- push @collections, \@objects; #I'm not using collections yet, so we just use Simples.
- }
- }
- }
- }
- return (\@collections, \@objects);
+ my ( $result ) = @_;
+ return ( [], [] ) unless $result;
+ my $moby;
+ unless ( ref( $result ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $result );
+ $moby = $doc->getDocumentElement();
+ } else {
+ $moby = $result->getDocumentElement();
+ }
+ my @objects;
+ my @collections;
+ my @Xrefs;
+ my $success = 0;
+ foreach my $which ( 'moby:queryResponse', 'queryResponse', 'mobyData',
+ 'moby:mobyData' )
+ {
+ my $responses = $moby->getElementsByTagName( $which );
+ next unless $responses;
+ foreach my $n ( 1 .. ( $responses->size() ) ) {
+ my $resp = $responses->get_node( $n );
+ foreach my $response_component ( $resp->childNodes ) {
+ next unless $response_component->nodeType == ELEMENT_NODE;
+ if ( ( $response_component->nodeName eq "Simple" )
+ || ( $response_component->nodeName eq "moby:Simple" ) )
+ {
+ foreach my $Object ( $response_component->childNodes ) {
+ next unless $Object->nodeType == ELEMENT_NODE;
+ $success = 1;
+ push @objects, $Object;
+ }
+ } elsif ( ( $response_component->nodeName eq "Collection" )
+ || ( $response_component->nodeName eq "moby:Collection" ) )
+ {
+ my @objects;
+ foreach my $simple ( $response_component->childNodes ) {
+ next unless $simple->nodeType == ELEMENT_NODE;
+ next
+ unless ( ( $simple->nodeName eq "Simple" )
+ || ( $simple->nodeName eq "moby:Simple" ) );
+ foreach my $Object ( $simple->childNodes ) {
+ next unless $Object->nodeType == ELEMENT_NODE;
+ $success = 1;
+ push @objects, $Object;
+ }
+ }
+ push @collections, \@objects
+ ; #I'm not using collections yet, so we just use Simples.
+ }
+ }
+ }
+ }
+ return ( \@collections, \@objects );
}
-
-
-
=head2 getServiceNotes
name : getServiceNotes
@@ -1403,37 +1431,38 @@
=cut
-
+#Eddie - converted
sub getServiceNotes {
- my ($result) = @_;
- return ("") unless $result;
- my $moby;
- unless (ref($result) =~ /XML\:\:DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($result);
- $moby = $doc->getDocumentElement();
- } else {
- $moby = $result->getDocumentElement();
- }
- my @objects;
- my @collections;
- my @Xrefs;
- my $success = 0;
- my $responses = $moby->getElementsByTagName('moby:serviceNotes');
- $responses ||= $moby->getElementsByTagName('serviceNotes');
- my $content;
- foreach my $n(0..($responses->getLength - 1)){
- my $resp = $responses->item($n);
- foreach my $response_component($resp->getChildNodes){
-# $content .= $response_component->toString;
- $content .= $response_component->getNodeValue if ($response_component->getNodeType == TEXT_NODE);
- }
- }
- return ($content);
+ my ( $result ) = @_;
+ return ( "" ) unless $result;
+ my $moby;
+ unless ( ref( $result ) =~ /XML\:\:DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $result );
+ $moby = $doc->getDocumentElement();
+ } else {
+ $moby = $result->getDocumentElement();
+ }
+ my @objects;
+ my @collections;
+ my @Xrefs;
+ my $success = 0;
+ my $responses = $moby->getElementsByTagName( 'moby:serviceNotes' );
+ $responses ||= $moby->getElementsByTagName( 'serviceNotes' );
+ my $content;
+
+ foreach my $n ( 1 .. ( $responses->size() ) ) {
+ my $resp = $responses->get_node( $n );
+ foreach my $response_component ( $resp->childNodes ) {
+
+ # $content .= $response_component->toString;
+ $content .= $response_component->getNodeValue
+ if ( $response_component->nodeType == TEXT_NODE );
+ }
+ }
+ return ( $content );
}
-
-
=head2 getCrossReferences
name : getCrossReferences
@@ -1460,43 +1489,44 @@
=cut
-
+#Eddie - converted
sub getCrossReferences {
-
- my ($XML) = @_;
- unless (ref($XML) =~ /XML::DOM/){
- my $parser = new XML::DOM::Parser;
- my $doc = $parser->parse($XML);
- $XML = $doc->getDocumentElement();
- }
- my @xrefs; my @XREFS;
- my @simples;
- return @XREFS if ($XML->getTagName =~/Collection/);
- if ($XML->getTagName =~/Simple/){
- foreach my $child ($XML->getChildNodes){
- next unless $child->getNodeType == ELEMENT_NODE;
- $XML = $child;
- last; # enforce proper MOBY message structure
- }
- }
- foreach ($XML->getChildNodes){
- next unless $_->getNodeType == ELEMENT_NODE;
- next unless $_->getTagName =~/CrossReference/;
- foreach my $xref($_->getChildNodes){
- next unless $xref->getNodeType == ELEMENT_NODE;
- next unless ($xref->getTagName =~/Xref/ || $xref->getTagName =~ /Object/);
- push @xrefs, $xref;
- }
- }
- foreach (@xrefs){
- my $x = &_makeXrefType($_) if $_->getTagName =~/Xref/;
- $x = &_makeObjectType($_) if $_->getTagName =~ /Object/;
- push @XREFS, $x if $x;
- }
+ my ( $XML ) = @_;
+ unless ( ref( $XML ) =~ /XML::DOM/ ) {
+ my $parser = XML::LibXML->new();
+ my $doc = $parser->parse_string( $XML );
+ $XML = $doc->getDocumentElement();
+ }
+ my @xrefs;
+ my @XREFS;
+ my @simples;
+ return @XREFS if ( $XML->nodeName =~ /Collection/ );
+ if ( $XML->nodeName =~ /Simple/ ) {
+ foreach my $child ( $XML->childNodes ) {
+ next unless $child->nodeType == ELEMENT_NODE;
+ $XML = $child;
+ last; # enforce proper MOBY message structure
+ }
+ }
+ foreach ( $XML->childNodes ) {
+ next unless $_->nodeType == ELEMENT_NODE;
+ next unless $_->nodeName =~ /CrossReference/;
+ foreach my $xref ( $_->childNodes ) {
+ next unless $xref->nodeType == ELEMENT_NODE;
+ next
+ unless ( $xref->nodeName =~ /Xref/
+ || $xref->nodeName =~ /Object/ );
+ push @xrefs, $xref;
+ }
+ }
+ foreach ( @xrefs ) {
+ my $x = &_makeXrefType( $_ ) if $_->nodeName =~ /Xref/;
+ $x = &_makeObjectType( $_ ) if $_->nodeName =~ /Object/;
+ push @XREFS, $x if $x;
+ }
return @XREFS;
}
-
=head2 whichDeepestParentObject
name : whichDeepestParentObject
@@ -1515,76 +1545,87 @@
=cut
-
sub whichDeepestParentObject {
- use MOBY::Client::OntologyServer;
- my ($CENTRAL, $queryTerm, $termlist) = @_;
- return (undef,undef) unless ($CENTRAL && $queryTerm && $termlist && (ref($termlist) =~ /ARRAY/));
- my %nodeLSIDs;
- my $queryLSID = $CENTRAL->ObjLSID($queryTerm);
- foreach (@$termlist){ # get list of known LSIDs
- my $lsid = $CENTRAL->ObjLSID($_);
- return ($_, $lsid) if ($lsid eq $queryLSID); # of course, if we find it in the list, then return it right away!
- $nodeLSIDs{$lsid}=$_;
- }
- return (undef, undef) unless keys(%nodeLSIDs);
- my $isa = $CENTRAL->ISA($queryTerm, 'Object'); # set the complete parentage in the cache if it isn't already
- return (undef, undef) unless $isa; # this should return true or we are in BIIIG trouble!
- my @ISAlsids = $CENTRAL->ISA_CACHE($queryTerm); # returns **LSIDs** in order, so we can shift our way back to root
- while (my $thislsid = shift @ISAlsids){ # @isas are lsid's
- return ($nodeLSIDs{$thislsid},$thislsid) if $nodeLSIDs{$thislsid};
- }
- return (undef, undef);
+ use MOBY::Client::OntologyServer;
+ my ( $CENTRAL, $queryTerm, $termlist ) = @_;
+ return ( undef, undef )
+ unless ( $CENTRAL
+ && $queryTerm
+ && $termlist
+ && ( ref( $termlist ) =~ /ARRAY/ ) );
+ my %nodeLSIDs;
+ my $queryLSID = $CENTRAL->ObjLSID( $queryTerm );
+ foreach ( @$termlist ) { # get list of known LSIDs
+ my $lsid = $CENTRAL->ObjLSID( $_ );
+ return ( $_, $lsid )
+ if ( $lsid eq $queryLSID )
+ ; # of course, if we find it in the list, then return it right away!
+ $nodeLSIDs{$lsid} = $_;
+ }
+ return ( undef, undef ) unless keys( %nodeLSIDs );
+ my $isa =
+ $CENTRAL->ISA( $queryTerm, 'Object' )
+ ; # set the complete parentage in the cache if it isn't already
+ return ( undef, undef )
+ unless $isa; # this should return true or we are in BIIIG trouble!
+ my @ISAlsids =
+ $CENTRAL->ISA_CACHE( $queryTerm )
+ ; # returns **LSIDs** in order, so we can shift our way back to root
+ while ( my $thislsid = shift @ISAlsids ) { # @isas are lsid's
+ return ( $nodeLSIDs{$thislsid}, $thislsid ) if $nodeLSIDs{$thislsid};
+ }
+ return ( undef, undef );
}
+#Eddie - converted
sub _makeXrefType {
- my ($xref) = @_;
- my $ns = $xref->getAttributeNode('namespace');
- $ns = $xref->getAttributeNode('moby:namespace') unless $ns;
- return undef unless $ns;
- my $id = $xref->getAttributeNode('id');
- $id = $xref->getAttributeNode('moby:id') unless $id;
- return undef unless $id;
- my $xr = $xref->getAttributeNode('xref_type');
- $xr = $xref->getAttributeNode('moby:xref_type') unless $xr;
- return undef unless $xr;
- my $ec = $xref->getAttributeNode('evidence_code');
- $ec = $xref->getAttributeNode('moby:evidence_code') unless $ec;
- return undef unless $ec;
- my $au = $xref->getAttributeNode('authURI');
- $au = $xref->getAttributeNode('moby:authURI') unless $au;
- return undef unless $au;
- my $sn = $xref->getAttributeNode('serviceName');
- $sn = $xref->getAttributeNode('moby:serviceName') unless $sn;
- return undef unless $sn;
- my $XREF = MOBY::CrossReference->new(
- type => "xref",
- namespace => $ns->getValue,
- id => $id->getValue,
- authURI => $au->getValue,
- serviceName => $sn->getValue,
- evidence_code => $ec->getValue,
- xref_type => $xr->getValue
- );
- return $XREF;
+ my ( $xref ) = @_;
+ my $ns = $xref->getAttributeNode( 'namespace' );
+ $ns = $xref->getAttributeNode( 'moby:namespace' ) unless $ns;
+ return undef unless $ns;
+ my $id = $xref->getAttributeNode( 'id' );
+ $id = $xref->getAttributeNode( 'moby:id' ) unless $id;
+ return undef unless $id;
+ my $xr = $xref->getAttributeNode( 'xref_type' );
+ $xr = $xref->getAttributeNode( 'moby:xref_type' ) unless $xr;
+ return undef unless $xr;
+ my $ec = $xref->getAttributeNode( 'evidence_code' );
+ $ec = $xref->getAttributeNode( 'moby:evidence_code' ) unless $ec;
+ return undef unless $ec;
+ my $au = $xref->getAttributeNode( 'authURI' );
+ $au = $xref->getAttributeNode( 'moby:authURI' ) unless $au;
+ return undef unless $au;
+ my $sn = $xref->getAttributeNode( 'serviceName' );
+ $sn = $xref->getAttributeNode( 'moby:serviceName' ) unless $sn;
+ return undef unless $sn;
+ my $XREF = MOBY::CrossReference->new(
+ type => "xref",
+ namespace => $ns->getValue,
+ id => $id->getValue,
+ authURI => $au->getValue,
+ serviceName => $sn->getValue,
+ evidence_code => $ec->getValue,
+ xref_type => $xr->getValue
+ );
+ return $XREF;
}
+#Eddie - converted
sub _makeObjectType {
- my ($xref) = @_;
- my $ns = $xref->getAttributeNode('namespace');
- $ns = $xref->getAttributeNode('moby:namespace') unless $ns;
- return undef unless $ns;
- my $id = $xref->getAttributeNode('id');
- $id = $xref->getAttributeNode('moby:id') unless $ns;
- return undef unless $id;
- my $XREF = MOBY::CrossReference->new(
- type => "object",
- namespace => $ns->getValue,
- id => $id->getValue,
- );
+ my ( $xref ) = @_;
+ my $ns = $xref->getAttributeNode( 'namespace' );
+ $ns = $xref->getAttributeNode( 'moby:namespace' ) unless $ns;
+ return undef unless $ns;
+ my $id = $xref->getAttributeNode( 'id' );
+ $id = $xref->getAttributeNode( 'moby:id' ) unless $ns;
+ return undef unless $id;
+ my $XREF = MOBY::CrossReference->new(
+ type => "object",
+ namespace => $ns->getValue,
+ id => $id->getValue,
+ );
}
-
# _rearrange stolen from BioPerl's Bio::RootI.pm
# because it is just so useful!
@@ -1653,18 +1694,17 @@
=cut
-
sub _rearrange {
-# my $dummy = shift;
- my $order = shift;
- return @_ unless (substr($_[0]||'',0,1) eq '-');
- push @_,undef unless $#_ %2;
- my %param;
- while( @_ ) {
- (my $key = shift) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
- $param{$key} = shift;
- }
- map { $_ = uc($_) } @$order; # for bug #1343, but is there perf hit here?
- return @param{@$order};
+ # my $dummy = shift;
+ my $order = shift;
+ return @_ unless ( substr( $_[0] || '', 0, 1 ) eq '-' );
+ push @_, undef unless $#_ % 2;
+ my %param;
+ while ( @_ ) {
+ ( my $key = shift ) =~ tr/a-z\055/A-Z/d; #deletes all dashes!
+ $param{$key} = shift;
+ }
+ map { $_ = uc( $_ ) } @$order; # for bug #1343, but is there perf hit here?
+ return @param{@$order};
}
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Config.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- /home/repository/moby/moby-live/Perl/MOBY/Config.pm 2004/08/24 20:43:33 1.5
+++ /home/repository/moby/moby-live/Perl/MOBY/Config.pm 2004/11/18 17:41:14 1.6
@@ -2,168 +2,152 @@
BEGIN {
}
-
-
use strict;
use Carp;
use MOBY::dbConfig;
use vars qw($AUTOLOAD);
use Text::Shellwords;
-use vars '$VERSION','@ISA','@EXPORT','$CONFIG';
-
- at ISA = qw(Exporter);
+use vars '$VERSION', '@ISA', '@EXPORT', '$CONFIG';
+ at ISA = qw(Exporter);
@EXPORT = ('$CONFIG');
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- mobycentral => [undef, 'read/write'],
- mobyobject => [undef, 'read/write'],
- mobynamespace=> [undef, 'read/write'],
- mobyservice => [undef, 'read/write'],
- mobyrelationship => [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
+ (
+ mobycentral => [ undef, 'read/write' ],
+ mobyobject => [ undef, 'read/write' ],
+ mobynamespace => [ undef, 'read/write' ],
+ mobyservice => [ undef, 'read/write' ],
+ mobyrelationship => [ 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;
+ }
}
# the expected sectionons (listed above) will have their dbCOnfig objects available
# as methods. The unexpected sections will have their dbConfig objects available
# by $dbConfig = $CONFIG->{section_title}
-
sub new {
- my ($caller, %args) = @_;
-
-#print STDERR "creating MOBY::Config\n";
+ my ( $caller, %args ) = @_;
+
+ #print STDERR "creating MOBY::Config\n";
my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $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);
+ }
+ }
+ my $file = $ENV{MOBY_CENTRAL_CONFIG};
+ ( -e $file ) || die "MOBY Configuration file $file doesn't exist $!\n";
+ chomp $file;
+ if ( ( -e $file ) && ( !( -d $file ) ) ) {
+ open IN,
+ $file
+ || die
+ "can't open MOBY Configuration file $file for unknown reasons$!\n";
+ }
+ my @sections = split /(\[\s*\S+\s*\][^\[]*)/s, join "", <IN>;
- my $self = bless {}, $class;
+ #print STDERR "split into @sections\n";
+ foreach my $section (@sections) {
- 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) }
- }
-
- my $file = $ENV{MOBY_CENTRAL_CONFIG};
- (-e $file) || die "MOBY Configuration file $file doesn't exist $!\n";
-
- chomp $file;
- if ((-e $file) && (!(-d $file))){
- open IN, $file || die "can't open MOBY Configuration file $file for unknown reasons$!\n";
- }
- my @sections = split /(\[\s*\S+\s*\][^\[]*)/s, join "", <IN>;
-#print STDERR "split into @sections\n";
- foreach my $section (@sections){
-#print STDERR "calling MOBY::dbConfig\n";
- my $dbConfig = MOBY::dbConfig->new(section => $section); # this is an object full of strings, no actual connections. It represents the information in the config file
+ #print STDERR "calling MOBY::dbConfig\n";
+ my $dbConfig =
+ MOBY::dbConfig->new( section => $section )
+ ; # this is an object full of strings, no actual connections. It represents the information in the config file
next unless $dbConfig;
my $dbname = $dbConfig->section_title;
next unless $dbname;
+
#print STDERR "setting the COnfig dbConfig for the title $dbname with object $dbConfig\n\n";
$self->{$dbname} = $dbConfig;
}
-
$CONFIG = $self;
- return $self;
-
+ return $self;
}
sub getDataAdaptor {
- my ($self, %args) = @_;
-
+ my ( $self, %args ) = @_;
my $source = $args{datasource};
$source ||= $args{source};
- $source ||="mobycentral";
-
- if ($self->{"${source}Adaptor"}){return $self->{"${source}Adaptor"}}; # read from cache
-
- my $username = $self->$source->{username}; # $self->$source returns a MOBY::dbConfig object
- my $password = $self->$source->{password};
- my $port = $self->$source->{port};
- my $dbname = $self->$source->{dbname};
- my $url = $self->$source->{url};
- my $adaptor = $self->$source->{adaptor};
-
+ $source ||= "mobycentral";
+ if ( $self->{"${source}Adaptor"} ) { return $self->{"${source}Adaptor"} }
+ ; # read from cache
+ my $username =
+ $self->$source
+ ->{username}; # $self->$source returns a MOBY::dbConfig object
+ my $password = $self->$source->{password};
+ my $port = $self->$source->{port};
+ my $dbname = $self->$source->{dbname};
+ my $url = $self->$source->{url};
+ my $adaptor = $self->$source->{adaptor};
eval "require $adaptor";
return undef if $@;
-
- my $ADAPTOR = $adaptor->new( # by default, this is queryapi::mysql
- username => $username,
- password => $password,
- port => $port,
- dbname => $dbname,
- url => $url,
- );
- if ($ADAPTOR){
- $self->{"${source}Adaptor"} = $ADAPTOR; # cache it
+ my $ADAPTOR = $adaptor->new( # by default, this is queryapi::mysql
+ username => $username,
+ password => $password,
+ port => $port,
+ dbname => $dbname,
+ url => $url,
+ );
+ if ($ADAPTOR) {
+ $self->{"${source}Adaptor"} = $ADAPTOR; # cache it
return $ADAPTOR;
} else {
- return undef
+ return undef;
}
-
}
-
-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/CrossReference.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- /home/repository/moby/moby-live/Perl/MOBY/CrossReference.pm 2003/10/25 22:21:29 1.2
+++ /home/repository/moby/moby-live/Perl/MOBY/CrossReference.pm 2004/11/18 17:41:14 1.3
@@ -1,13 +1,10 @@
package MOBY::CrossReference;
#$Id$
-
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::Client::CrossReference - a small object describing a MOBY Simple input/output article
@@ -54,7 +51,6 @@
=cut
-
=head2 type
Title : type
@@ -86,8 +82,6 @@
=cut
-
-
=head2 authURI
Title : authURI
@@ -98,7 +92,6 @@
=cut
-
=head2 serviceName
Title : serviceName
@@ -109,7 +102,6 @@
=cut
-
=head2 evidence_code
Title : evidence_code
@@ -120,7 +112,6 @@
=cut
-
=head2 xref_type
Title : xref_type
@@ -131,7 +122,6 @@
=cut
-
=head2 Object
Title : Object
@@ -141,107 +131,100 @@
=cut
-
{
- sub type {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_type};
- $self->{_type} = $type;
- return $old;
- }
- return $self->{_type};
- }
-
- sub namespace {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_namespace};
- $self->{_namespace} = $type;
- return $old;
- }
- return $self->{_namespace};
-
- }
-
- sub id {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_id};
- $self->{_id}=$type;
- return $old;
- }
- return $self->{_id};
-
- }
-
- sub authURI {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_authURI};
- $self->{_authURI}= $type;
- return $old;
- }
- return $self->{_authURI};
-
- }
-
- sub serviceName {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_serviceName};
- $self->{_serviceName}=$type;
- return $old;
- }
- return $self->{_serviceName};
-
- }
-
- sub evidence_code {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_evidenceCode};
- $self->{_evidenceCode}=$type;
- return $old;
- }
- return $self->{_evidenceCode};
- }
-
- sub xref_type {
- my ($self, $type) = @_;
- if ($type){
- my $old = $self->{_xref_type};
- $self->{_xref_type}=$type;
- return $old;
- }
- return $self->{_xref_type};
- }
+
+ sub type {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_type};
+ $self->{_type} = $type;
+ return $old;
+ }
+ return $self->{_type};
+ }
+
+ sub namespace {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_namespace};
+ $self->{_namespace} = $type;
+ return $old;
+ }
+ return $self->{_namespace};
+ }
+
+ sub id {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_id};
+ $self->{_id} = $type;
+ return $old;
+ }
+ return $self->{_id};
+ }
+
+ sub authURI {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_authURI};
+ $self->{_authURI} = $type;
+ return $old;
+ }
+ return $self->{_authURI};
+ }
+
+ sub serviceName {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_serviceName};
+ $self->{_serviceName} = $type;
+ return $old;
+ }
+ return $self->{_serviceName};
+ }
+
+ sub evidence_code {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_evidenceCode};
+ $self->{_evidenceCode} = $type;
+ return $old;
+ }
+ return $self->{_evidenceCode};
+ }
+
+ sub xref_type {
+ my ( $self, $type ) = @_;
+ if ($type) {
+ my $old = $self->{_xref_type};
+ $self->{_xref_type} = $type;
+ return $old;
+ }
+ return $self->{_xref_type};
+ }
}
sub new {
- my ($caller, %args) = @_;
-
+ my ( $caller, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
- while (my ($key, $value) = each %args){
- $self->$key($value);
- }
- return undef unless ($self->type && $self->namespace && $self->id);
- return $self;
-
+ my $self = bless {}, $class;
+ while ( my ( $key, $value ) = each %args ) {
+ $self->$key($value);
+ }
+ return undef unless ( $self->type && $self->namespace && $self->id );
+ return $self;
}
sub Object {
- my ($self) = @_;
- return "" unless ($self->namespace && $self->id);
- return "<moby:Object moby:namespace='".($self->namespace)."' moby:id='".($self->id)."'/>";
+ my ($self) = @_;
+ return "" unless ( $self->namespace && $self->id );
+ return "<moby:Object moby:namespace='"
+ . ( $self->namespace )
+ . "' moby:id='"
+ . ( $self->id ) . "'/>";
}
-
-
-sub DESTROY {}
-
+sub DESTROY { }
1;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm 2004/06/24 22:32:38 1.45
+++ /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm 2004/11/18 17:41:14 1.46
@@ -1,10 +1,8 @@
#$Id$
-
# this module needs to talk to the 'real' ontology
# server as well as the MOBY Central database
# in order to ensure that they are both in sync
-
=head1 NAME
MOBY::OntologyServer - A way for MOBY Central to query the
@@ -12,7 +10,6 @@
=cut
-
=head1 SYNOPSIS
use MOBY::OntologyServer;
@@ -65,112 +62,115 @@
=cut
-
-
package MOBY::OntologyServer;
-
use strict;
use Carp;
use vars qw($AUTOLOAD);
use DBI;
use DBD::mysql;
use MOBY::Config;
-
my $debug = 0;
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- ontology => [undef, 'read/write'],
- database => [undef, 'read/write'],
- host => [undef, 'read/write'],
- username=> [undef, 'read/write'],
- password=> [undef, 'read/write'],
- port => [undef, 'read/write'],
- dbh => [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
+ (
+ ontology => [ undef, 'read/write' ],
+ database => [ undef, 'read/write' ],
+ host => [ undef, 'read/write' ],
+ username => [ undef, 'read/write' ],
+ password => [ undef, 'read/write' ],
+ port => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $caller;
-
- my $self = bless {}, $class;
+ 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);
+ }
+ }
+ $self->ontology eq 'object' && $self->database('mobyobject');
+ $self->ontology eq 'namespace' && $self->database('mobynamespace');
+ $self->ontology eq 'service' && $self->database('mobyservice');
+ $self->ontology eq 'relationship' && $self->database('mobyrelationship');
- 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) }
- }
-
- $self->ontology eq 'object' && $self->database('mobyobject');
- $self->ontology eq 'namespace' && $self->database('mobynamespace');
- $self->ontology eq 'service' && $self->database('mobyservice');
- $self->ontology eq 'relationship' && $self->database('mobyrelationship');
+ #print STDERR "\n\nCONFIG object is $CONFIG\n\n";
+ $CONFIG ||= MOBY::Config->new;
-#print STDERR "\n\nCONFIG object is $CONFIG\n\n";
- $CONFIG ||=MOBY::Config->new;
#print STDERR "got username ",($CONFIG->{mobycentral}->{username})," for mobycentral\n";
- $self->username($CONFIG->{$self->database}->{username}) unless $self->username;
- $self->password($CONFIG->{$self->database}->{password}) unless $self->password;
- $self->port($CONFIG->{$self->database}->{port}) unless $self->port;
- $self->host($CONFIG->{$self->database}->{url}) unless $self->host;
-
- my $host = $self->host?$self->host:$ENV{MOBY_CENTRAL_URL}; chomp $host;
- my $username = $self->username?$self->username:$ENV{MOBY_CENTRAL_DBUSER}; chomp $username;
- my $password = $self->password?$self->password:$ENV{MOBY_CENTRAL_DBPASS}; chomp $password if $password; $password =~ s/\s//g if $password;
- my $port = $self->port?$self->port:$ENV{MOBY_CENTRAL_DBPORT}; chomp $port;
-
- my ($dsn) = "DBI:mysql:".($CONFIG->{$self->database}->{dbname}).":".($host).":".($port);
-
-#print STDERR "\n\nDSN was $dsn\n\n";
-
- my $dbh;
+ $self->username( $CONFIG->{ $self->database }->{username} )
+ unless $self->username;
+ $self->password( $CONFIG->{ $self->database }->{password} )
+ unless $self->password;
+ $self->port( $CONFIG->{ $self->database }->{port} ) unless $self->port;
+ $self->host( $CONFIG->{ $self->database }->{url} ) unless $self->host;
+ my $host = $self->host ? $self->host : $ENV{MOBY_CENTRAL_URL};
+ chomp $host;
+ my $username =
+ $self->username ? $self->username : $ENV{MOBY_CENTRAL_DBUSER};
+ chomp $username;
+ my $password =
+ $self->password ? $self->password : $ENV{MOBY_CENTRAL_DBPASS};
+ chomp $password if $password;
+ $password =~ s/\s//g if $password;
+ my $port = $self->port ? $self->port : $ENV{MOBY_CENTRAL_DBPORT};
+ chomp $port;
+ my ($dsn) =
+ "DBI:mysql:"
+ . ( $CONFIG->{ $self->database }->{dbname} ) . ":"
+ . ($host) . ":"
+ . ($port);
+
+ #print STDERR "\n\nDSN was $dsn\n\n";
+ my $dbh;
+
# $debug && &_LOG("connecting to db with params ",$self->database, $self->username, $self->password,"\n");
- if (defined $password){
- $dbh = DBI->connect($dsn, $username, $password, {RaiseError => 1}) or die "can't connect to database";
- } else {
- $dbh = DBI->connect($dsn, $username, undef, {RaiseError => 1}) or die "can't connect to database";
- }
-# $debug && &_LOG("CONNECTED!\n");
- if ($dbh){
- $self->dbh($dbh);
- return $self;
- } else {
- return undef
- }
+ if ( defined $password ) {
+ $dbh = DBI->connect( $dsn, $username, $password, { RaiseError => 1 } )
+ or die "can't connect to database";
+ } else {
+ $dbh = DBI->connect( $dsn, $username, undef, { RaiseError => 1 } )
+ or die "can't connect to database";
+ }
+
+ # $debug && &_LOG("CONNECTED!\n");
+ if ($dbh) {
+ $self->dbh($dbh);
+ return $self;
+ } else {
+ return undef;
+ }
}
=head2 objectExists
@@ -181,133 +181,164 @@
newLSID will return (0, $desc, $lsid)
=cut
+sub objectExists {
+ my ( $self, %args ) = @_;
+ my $term = $args{term};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $sth;
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'object' );
-sub objectExists{
- my ($self, %args) = @_;
- my $term = $args{term};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
- my $sth;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'object');
-
# if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:objecttype/)){
# return (1, "external ontology", $term);
# }
-
- if ($term =~ /^urn\:lsid/){
- $sth = $self->dbh->prepare("select object_lsid, object_type, description, authority, contact_email from object where object_lsid = ?");
- } else {
- $sth = $self->dbh->prepare("select object_lsid, object_type, description, authority, contact_email from object where object_type = ?");
- }
- $sth->execute($term);
- my ($lsid, $type, $desc, $auth, $email) = $sth->fetchrow_array;
- if ($lsid){ # if it is in there, then it has been discovered regardless of being foreign or not
- return (1,$desc,$lsid);
- } elsif (_isForeignLSID($term)){ # if not in our ontology, but is a foreign LSID, then pass it back verbatim
- return (0, "LSID $term does not exist in the biomoby.org Object Class system\n", $term);
+ if ( $term =~ /^urn\:lsid/ ) {
+ $sth =
+ $self->dbh->prepare(
+"select object_lsid, object_type, description, authority, contact_email from object where object_lsid = ?"
+ );
+ } else {
+ $sth =
+ $self->dbh->prepare(
+"select object_lsid, object_type, description, authority, contact_email from object where object_type = ?"
+ );
+ }
+ $sth->execute($term);
+ my ( $lsid, $type, $desc, $auth, $email ) = $sth->fetchrow_array;
+ if ($lsid)
+ { # if it is in there, then it has been discovered regardless of being foreign or not
+ return ( 1, $desc, $lsid );
+ } elsif ( _isForeignLSID($term) )
+ { # if not in our ontology, but is a foreign LSID, then pass it back verbatim
+ return (
+ 0,
+"LSID $term does not exist in the biomoby.org Object Class system\n",
+ $term
+ );
} else { # under all other circumstances (i.e. not a term, or a non-existent biomoby LSID) then fail
- return (0, "Object type $term does not exist in the biomoby.org Object Class system\n", '');
+ return (
+ 0,
+"Object type $term does not exist in the biomoby.org Object Class system\n",
+ ''
+ );
}
}
-
sub _isMOBYLSID {
my ($lsid) = @_;
return 1 if $lsid =~ /^urn\:lsid\:biomoby.org/;
- return 0
+ return 0;
}
-
sub _isForeignLSID {
my ($lsid) = @_;
return 0 if $lsid =~ /^urn\:lsid\:biomoby.org/;
- return 1
+ return 1;
}
-
=head2 createObject
=cut
-
sub createObject {
- my ($self, %args) = @_;
- #node => $term,
- #desc => $desc,
- #authURI => $auth,
- #contact => $email
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'object');
- return (0, "requires a object type node",'') unless ($args{node});
- return (0, "requires an authURI ",'') unless ($args{authority});
- return (0, "requires a contact email address",'') unless ($args{contact_email});
- return (0, "requires a object description",'') unless ($args{description});
- my $term = $args{node};
+ my ( $self, %args ) = @_;
+
+ #node => $term,
+ #desc => $desc,
+ #authURI => $auth,
+ #contact => $email
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'object' );
+ return ( 0, "requires a object type node", '' ) unless ( $args{node} );
+ return ( 0, "requires an authURI ", '' ) unless ( $args{authority} );
+ return ( 0, "requires a contact email address", '' )
+ unless ( $args{contact_email} );
+ return ( 0, "requires a object description", '' )
+ unless ( $args{description} );
+ my $term = $args{node};
# if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:objectclass/)){ # if it is an LSID, but not a MOBY LSID, than barf
# return (0, "can't create a term in a non-MOBY ontology!", $term);
# }
-
- my $LSID = ($args{'node'} =~ /urn\:lsid/)?$args{'node'}:$self->setURI($args{'node'});
- unless ($LSID){return (0, "Failed during creation of an LSID",'')}
-
+ my $LSID =
+ ( $args{'node'} =~ /urn\:lsid/ )
+ ? $args{'node'}
+ : $self->setURI( $args{'node'} );
+ unless ($LSID) { return ( 0, "Failed during creation of an LSID", '' ) }
my $sth;
- if ($args{'node'} =~ /^urn\:lsid/){
- $sth = $self->dbh->prepare("select object_lsid, object_type, description, authority, contact_email from object where object_lsid = ?");
- } else {
- $sth = $self->dbh->prepare("select object_lsid, object_type, description, authority, contact_email from object where object_type = ?");
- }
- $sth->execute($term);
- my ($lsid, $type, $desc, $auth, $email) = $sth->fetchrow_array;
- if ($lsid){ # if it is in there, then the object exists
- return (0,"This term already exists: $lsid",$lsid);
+ if ( $args{'node'} =~ /^urn\:lsid/ ) {
+ $sth =
+ $self->dbh->prepare(
+"select object_lsid, object_type, description, authority, contact_email from object where object_lsid = ?"
+ );
+ } else {
+ $sth =
+ $self->dbh->prepare(
+"select object_lsid, object_type, description, authority, contact_email from object where object_type = ?"
+ );
}
-
-
- $args{description} =~ s/^\s+(.*?)\s+$/$1/s;
- $args{node} =~ s/^\s+(.*?)\s+$/$1/s;
- $args{contact_email} =~ s/^\s+(.*?)\s+$/$1/s;
- $args{authority} =~ s/^\s+(.*?)\s+$/$1/s;
- $self->dbh->do(q{insert into object (object_type, object_lsid, description, authority,contact_email) values (?,?,?,?,?)},
- undef,
- ($args{'node'},
- $LSID,
- $args{'description'},
- $args{'authority'},
- $args{'contact_email'}));
-
- unless ($self->dbh->{mysql_insertid}){
- return (0, "Object creation failed for unknown reasons",'');
- }
- return (1, "Object creation succeeded",$LSID);
-
+ $sth->execute($term);
+ my ( $lsid, $type, $desc, $auth, $email ) = $sth->fetchrow_array;
+ if ($lsid) { # if it is in there, then the object exists
+ return ( 0, "This term already exists: $lsid", $lsid );
+ }
+ $args{description} =~ s/^\s+(.*?)\s+$/$1/s;
+ $args{node} =~ s/^\s+(.*?)\s+$/$1/s;
+ $args{contact_email} =~ s/^\s+(.*?)\s+$/$1/s;
+ $args{authority} =~ s/^\s+(.*?)\s+$/$1/s;
+ $self->dbh->do(
+q{insert into object (object_type, object_lsid, description, authority,contact_email) values (?,?,?,?,?)},
+ undef,
+ (
+ $args{'node'}, $LSID, $args{'description'},
+ $args{'authority'}, $args{'contact_email'}
+ )
+ );
+ unless ( $self->dbh->{mysql_insertid} ) {
+ return ( 0, "Object creation failed for unknown reasons", '' );
+ }
+ return ( 1, "Object creation succeeded", $LSID );
}
-
=head2 retrieveObject
=cut
-
sub retrieveObject {
- my ($self, %args) = @_;
+ my ( $self, %args ) = @_;
my $term = $args{'node'};
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'object');
- return (0, "requires a object type node as an argument",'') unless ($args{'node'});
- my $LSID = ($args{'node'} =~ /urn\:lsid/)?$args{'node'}:$self->getObjectURI($term);
- unless ($LSID){return (0, "Failed during creation of an LSID",'')}
- my ($id, $type, $lsid, $desc, $auth, $contact)= $self->dbh->selectrow_array(q{select object_id, object_type, object_lsid, description, authority,contact_email from object where object_lsid = ?}, undef, $LSID);
- unless ($id){return (0, "Object doesn't exist in ontology", "")}
- # my $OS = MOBY::OntologyServer->new(ontology => "relationship");
- my $sth = $self->dbh->prepare(q{select relationship_type, object_lsid, object2_articlename from object_term2term, object where object1_id = ? and object2_id = object_id});
- $sth->execute($id);
- my %rel;
- while (my ($relationship_type, $objectlsid, $article) = $sth->fetchrow_array){
- push @{$rel{$relationship_type}}, [$objectlsid, $article];
- }
- return {objectType => $lsid,
- description => $desc,
- contactEmail => $contact,
- authURI => $auth,
- Relationships => \%rel};
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'object' );
+ return ( 0, "requires a object type node as an argument", '' )
+ unless ( $args{'node'} );
+ my $LSID =
+ ( $args{'node'} =~ /urn\:lsid/ )
+ ? $args{'node'}
+ : $self->getObjectURI($term);
+ unless ($LSID) { return ( 0, "Failed during creation of an LSID", '' ) }
+ my ( $id, $type, $lsid, $desc, $auth, $contact ) =
+ $self->dbh->selectrow_array(
+q{select object_id, object_type, object_lsid, description, authority,contact_email from object where object_lsid = ?},
+ undef, $LSID
+ );
+ unless ($id) { return ( 0, "Object doesn't exist in ontology", "" ) }
+
+ # my $OS = MOBY::OntologyServer->new(ontology => "relationship");
+ my $sth =
+ $self->dbh->prepare(
+q{select relationship_type, object_lsid, object2_articlename from object_term2term, object where object1_id = ? and object2_id = object_id}
+ );
+ $sth->execute($id);
+ my %rel;
+ while ( my ( $relationship_type, $objectlsid, $article ) =
+ $sth->fetchrow_array )
+ {
+ push @{ $rel{$relationship_type} }, [ $objectlsid, $article ];
+ }
+ return {
+ objectType => $lsid,
+ description => $desc,
+ contactEmail => $contact,
+ authURI => $auth,
+ Relationships => \%rel
+ };
}
=head2 deprecateObject
@@ -315,35 +346,45 @@
=cut
sub deprecateObject {
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY",'') unless ($self->ontology eq 'object');
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY", '' ) unless ( $self->ontology eq 'object' );
+ my $term = $args{term};
- my $term = $args{term};
# if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:objectclass/)){
# return (0, "can't delete from external ontology", $term);
# }
-
- my $LSID;
- unless ($term =~ /urn\:lsid/){$LSID = $self->getObjectURI($term)} else {$LSID=$term}
- return (0, q{Object type $term cannot be resolved to an LSID},"") unless $LSID;
-
- my ($id, $lsid) = $self->dbh->selectrow_array(q{select object_id, object_lsid from object where object_lsid = ?},undef,$LSID);
- # object1_id ISA object2_id?
- my (@isa) = $self->dbh->selectrow_array(q{select * from object_term2term where object2_id = ?},undef, $id);
- if (scalar @isa){
- return (0, qq{Object type $term has object dependencies in the ontology},$lsid);
- }
-
- $self->dbh->do(q{delete from object where object_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from Object Class table failed: $self->dbh->errstr", $lsid);
- }
- $self->dbh->do(q{delete from object_term2term where object1_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from Object term2term table failed: $self->dbh->errstr", $lsid);
- }
-
- return (1,"Object $term Deleted",$lsid);
+ my $LSID;
+ unless ( $term =~ /urn\:lsid/ ) { $LSID = $self->getObjectURI($term) } else { $LSID = $term }
+ return ( 0, q{Object type $term cannot be resolved to an LSID}, "" )
+ unless $LSID;
+ my ( $id, $lsid ) =
+ $self->dbh->selectrow_array(
+ q{select object_id, object_lsid from object where object_lsid = ?},
+ undef, $LSID );
+
+ # object1_id ISA object2_id?
+ my (@isa) =
+ $self->dbh->selectrow_array(
+ q{select * from object_term2term where object2_id = ?},
+ undef, $id );
+ if ( scalar @isa ) {
+ return ( 0,
+ qq{Object type $term has object dependencies in the ontology},
+ $lsid );
+ }
+ $self->dbh->do( q{delete from object where object_id = ?}, undef, $id );
+ if ( $self->dbh->err ) {
+ return ( 0, "Delete from Object Class table failed: $self->dbh->errstr",
+ $lsid );
+ }
+ $self->dbh->do( q{delete from object_term2term where object1_id = ?},
+ undef, $id );
+ if ( $self->dbh->err ) {
+ return ( 0,
+ "Delete from Object term2term table failed: $self->dbh->errstr",
+ $lsid );
+ }
+ return ( 1, "Object $term Deleted", $lsid );
}
=head2 deleteObject
@@ -351,129 +392,193 @@
=cut
sub deleteObject {
- my $self = shift;
- $self->deprecateObject(@_);
+ my $self = shift;
+ $self->deprecateObject(@_);
}
=head2 relationshipExists
=cut
-sub relationshipExists{
- # term => $term
- # ontology => $ontology
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'relationship');
-
- my $term = lc($args{term});
- $term =~ s/^moby://; # if the term is namespaced, then remove that
-
- my $ont = $args{ontology};
- return (0, "requires both term and ontology arguments\n",'') unless (defined($term) && defined($ont));
- my $sth;
- if ($term =~ /^urn\:lsid/){
- $sth = $self->dbh->prepare("select relationship_lsid, relationship_type, description, authority, contact_email from relationship where relationship_lsid = ? and ontology=?");
- } else {
- $sth = $self->dbh->prepare("select relationship_lsid, relationship_type, description, authority, contact_email from relationship where relationship_type = ? and ontology=?");
- }
- $sth->execute($term, $ont);
- my ($lsid, $type, $desc, $auth, $email) = $sth->fetchrow_array;
- if ($lsid){
- return (1,$desc,$lsid);
- } else {
- return (0, "Relationship Type $term does not exist in the biomoby.org Relationship Type system\n",'');
- }
+sub relationshipExists {
+
+ # term => $term
+ # ontology => $ontology
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' )
+ unless ( $self->ontology eq 'relationship' );
+ my $term = lc( $args{term} );
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $ont = $args{ontology};
+ return ( 0, "requires both term and ontology arguments\n", '' )
+ unless ( defined($term) && defined($ont) );
+ my $sth;
+
+ if ( $term =~ /^urn\:lsid/ ) {
+ $sth =
+ $self->dbh->prepare(
+"select relationship_lsid, relationship_type, description, authority, contact_email from relationship where relationship_lsid = ? and ontology=?"
+ );
+ } else {
+ $sth =
+ $self->dbh->prepare(
+"select relationship_lsid, relationship_type, description, authority, contact_email from relationship where relationship_type = ? and ontology=?"
+ );
+ }
+ $sth->execute( $term, $ont );
+ my ( $lsid, $type, $desc, $auth, $email ) = $sth->fetchrow_array;
+ if ($lsid) {
+ return ( 1, $desc, $lsid );
+ } else {
+ return (
+ 0,
+"Relationship Type $term does not exist in the biomoby.org Relationship Type system\n",
+ ''
+ );
+ }
}
=head2 addObjectRelationship
=cut
-sub addObjectRelationship{
-# adds a relationship
-#subject_node => $term,
-#relationship => $reltype,
-#object_node => $objectType,
-#articleName => $articleName,
-#authority => $auth,
-#contact_email => $email
- my ($self, %args) = @_;
-
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'object');
-
- my ($subj_id, $subj_lsid, $obj_id, $obj_lsid);
- if ($args{subject_node} =~ /^urn:lsid/){
- ($subj_id, $subj_lsid) = $self->dbh->selectrow_array(q{select object_id, object_lsid from object where object_lsid = ?},undef,$args{subject_node});
+sub addObjectRelationship {
+
+ # adds a relationship
+ #subject_node => $term,
+ #relationship => $reltype,
+ #object_node => $objectType,
+ #articleName => $articleName,
+ #authority => $auth,
+ #contact_email => $email
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'object' );
+ my ( $subj_id, $subj_lsid, $obj_id, $obj_lsid );
+ if ( $args{subject_node} =~ /^urn:lsid/ ) {
+ ( $subj_id, $subj_lsid ) = $self->dbh->selectrow_array(
+ q{select object_id, object_lsid from object where object_lsid = ?},
+ undef, $args{subject_node}
+ );
} else {
- ($subj_id, $subj_lsid) = $self->dbh->selectrow_array(q{select object_id, object_lsid from object where object_type = ?},undef,$args{subject_node});
+ ( $subj_id, $subj_lsid ) = $self->dbh->selectrow_array(
+ q{select object_id, object_lsid from object where object_type = ?},
+ undef, $args{subject_node}
+ );
}
- return (0, qq{Object type $args{subject_node} does not exist in the ontology},'') unless defined $subj_id;
-
- if ($args{object_node} =~ /^urn:lsid/){
- ($obj_id, $obj_lsid) = $self->dbh->selectrow_array(q{select object_id, object_lsid from object where object_lsid = ?},undef,$args{object_node});
+ return ( 0,
+ qq{Object type $args{subject_node} does not exist in the ontology},
+ '' )
+ unless defined $subj_id;
+ if ( $args{object_node} =~ /^urn:lsid/ ) {
+ ( $obj_id, $obj_lsid ) = $self->dbh->selectrow_array(
+ q{select object_id, object_lsid from object where object_lsid = ?},
+ undef, $args{object_node}
+ );
} else {
- ($obj_id, $obj_lsid) = $self->dbh->selectrow_array(q{select object_id, object_lsid from object where object_type = ?},undef,$args{object_node});
+ ( $obj_id, $obj_lsid ) = $self->dbh->selectrow_array(
+ q{select object_id, object_lsid from object where object_type = ?},
+ undef, $args{object_node}
+ );
+ }
+ return ( 0,
+ qq{Object type $args{object_node} does not exist in the ontology},
+ '' )
+ unless defined $obj_id;
+ my (@isa) =
+ $self->dbh->selectrow_array(
+ q{select * from object_term2term where object2_id = ?},
+ undef, $subj_id );
+ if ( scalar @isa ) {
+ return (
+ 0,
+qq{Object type $args{subject_node} has existing object dependencies in the ontology. It cannot be changed.},
+ $subj_lsid
+ );
+ }
+ my $OE = MOBY::OntologyServer->new( ontology => 'relationship' );
+ my ( $success, $desc, $rel_lsid ) = $OE->relationshipExists(
+ term => $args{relationship},
+ ontology => 'object' );
+ ($success)
+ || return ( 0,
+ qq{Relationship $args{relationship} does not exist in the ontology},
+ '' );
+ $self->dbh->do(
+q{insert into object_term2term (relationship_type, object1_id, object2_id, object2_articlename) values (?,?,?,?)},
+ undef,
+ ( $rel_lsid, $subj_id, $obj_id, $args{articleName} )
+ );
+ if ( $self->dbh->{mysql_insertid} ) {
+ return ( 1, "Object relationsihp created successfully", '' );
+ } else {
+ return ( 0, "Object relationship creation failed for unknown reasons",
+ '' );
}
- return (0, qq{Object type $args{object_node} does not exist in the ontology},'') unless defined $obj_id;
-
-
- my (@isa) = $self->dbh->selectrow_array(q{select * from object_term2term where object2_id = ?},undef, $subj_id);
- if (scalar @isa){return (0, qq{Object type $args{subject_node} has existing object dependencies in the ontology. It cannot be changed.},$subj_lsid);}
-
-
- my $OE = MOBY::OntologyServer->new(ontology => 'relationship');
- my ($success, $desc, $rel_lsid) = $OE->relationshipExists(term => $args{relationship}, ontology => 'object');
- ($success) || return (0, qq{Relationship $args{relationship} does not exist in the ontology},'');
-
- $self->dbh->do(
- q{insert into object_term2term (relationship_type, object1_id, object2_id, object2_articlename) values (?,?,?,?)},
- undef,
- ($rel_lsid,$subj_id,$obj_id,$args{articleName}));
- if ($self->dbh->{mysql_insertid}){
- return (1,"Object relationsihp created successfully",'');
- } else {
- return (0, "Object relationship creation failed for unknown reasons",'');
- }
}
=head2 addServiceRelationship
=cut
+sub addServiceRelationship {
-sub addServiceRelationship{
-# adds an ISA relationship
-# fail if another object is in relation to this objevt
- #subject_node => $term,
- #relationship => $relationship,
- #predicate_node => $pred
- #authority => $auth,
- #contact_email => $email);
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'service');
- my ($sbj_id, $sbj_lsid) = $self->dbh->selectrow_array(q{select service_id, service_lsid from service where service_type = ?},undef,$args{subject_node});
- return (0, qq{Service type $args{subject_node} has object dependencies in the ontology. It can not be changed},$sbj_lsid) unless defined $sbj_id;
-
- my (@isa) = $self->dbh->selectrow_array(q{select * from service_term2term where service2_id = ?},undef, $sbj_id);
- if (scalar @isa){
- return (0, qq{Service type $args{subject_node} has object dependencies in the ontology. It can not be changed},$sbj_lsid);
- }
-
- my ($obj_id, $obj_lsid) = $self->dbh->selectrow_array(q{select service_id, service_lsid from service where service_type = ?},undef,$args{object_node}); # get ID of the related service
- defined $obj_id || return (0, qq{Service $args{object_node} does not exist in the service ontology},'');
-
- my $OE = MOBY::OntologyServer->new(ontology => 'relationship');
- my ($success, $desc, $rel_lsid) = $OE->relationshipExists(term => $args{relationship}, ontology => 'service');
- ($success) || return (0, qq{Relationship $args{relationship} does not exist in the ontology},'');
-
- $self->dbh->do(q{insert into service_term2term (relationship_type, service1_id, service2_id) values (?,?,?)},
- undef,
- ($rel_lsid,$sbj_id,$obj_id));
- if ($self->dbh->{mysql_insertid}){
- return (1,"Service relationship created successfully",'');
- } else {
- return (0, "Service relationship creation failed for unknown reasons",'');
- }
+ # adds an ISA relationship
+ # fail if another object is in relation to this objevt
+ #subject_node => $term,
+ #relationship => $relationship,
+ #predicate_node => $pred
+ #authority => $auth,
+ #contact_email => $email);
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'service' );
+ my ( $sbj_id, $sbj_lsid ) = $self->dbh->selectrow_array(
+ q{select service_id, service_lsid from service where service_type = ?},
+ undef, $args{subject_node}
+ );
+ return (
+ 0,
+qq{Service type $args{subject_node} has object dependencies in the ontology. It can not be changed},
+ $sbj_lsid
+ )
+ unless defined $sbj_id;
+ my (@isa) =
+ $self->dbh->selectrow_array(
+ q{select * from service_term2term where service2_id = ?},
+ undef, $sbj_id );
+ if ( scalar @isa ) {
+ return (
+ 0,
+qq{Service type $args{subject_node} has object dependencies in the ontology. It can not be changed},
+ $sbj_lsid
+ );
+ }
+ my ( $obj_id, $obj_lsid ) = $self->dbh->selectrow_array(
+ q{select service_id, service_lsid from service where service_type = ?},
+ undef, $args{object_node}
+ ); # get ID of the related service
+ defined $obj_id
+ || return ( 0,
+ qq{Service $args{object_node} does not exist in the service ontology},
+ '' );
+ my $OE = MOBY::OntologyServer->new( ontology => 'relationship' );
+ my ( $success, $desc, $rel_lsid ) = $OE->relationshipExists(
+ term => $args{relationship},
+ ontology => 'service' );
+ ($success)
+ || return ( 0,
+ qq{Relationship $args{relationship} does not exist in the ontology},
+ '' );
+ $self->dbh->do(
+q{insert into service_term2term (relationship_type, service1_id, service2_id) values (?,?,?)},
+ undef,
+ ( $rel_lsid, $sbj_id, $obj_id )
+ );
+ if ( $self->dbh->{mysql_insertid} ) {
+ return ( 1, "Service relationship created successfully", '' );
+ } else {
+ return ( 0, "Service relationship creation failed for unknown reasons",
+ '' );
+ }
}
=head2 serviceExists
@@ -481,29 +586,38 @@
=cut
sub serviceExists {
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'service');
- my $term = $args{term};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
-
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:servicetype/)){
- return (1, "external ontology", $term);
- }
-
- my $sth;
- if ($term =~ /^urn\:lsid/){
- $sth = $self->dbh->prepare("select service_id, service_type, service_lsid, description, authority, contact_email from service where service_lsid = ?");
- } else {
- $sth = $self->dbh->prepare("select service_id, service_type, service_lsid, description, authority, contact_email from service where service_type = ?");
- }
-
- $sth->execute($term);
- my ($id, $type, $lsid, $desc, $auth, $email) = $sth->fetchrow_array;
- if ($id){
- return (1,$desc,$lsid);
- } else {
- return (0, "Service Type $term does not exist in the biomoby.org Service Type ontology\n",'');
- }
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'service' );
+ my $term = $args{term};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:servicetype/ ) )
+ {
+ return ( 1, "external ontology", $term );
+ }
+ my $sth;
+ if ( $term =~ /^urn\:lsid/ ) {
+ $sth =
+ $self->dbh->prepare(
+"select service_id, service_type, service_lsid, description, authority, contact_email from service where service_lsid = ?"
+ );
+ } else {
+ $sth =
+ $self->dbh->prepare(
+"select service_id, service_type, service_lsid, description, authority, contact_email from service where service_type = ?"
+ );
+ }
+ $sth->execute($term);
+ my ( $id, $type, $lsid, $desc, $auth, $email ) = $sth->fetchrow_array;
+ if ($id) {
+ return ( 1, $desc, $lsid );
+ } else {
+ return (
+ 0,
+"Service Type $term does not exist in the biomoby.org Service Type ontology\n",
+ ''
+ );
+ }
}
=head2 createServiceType
@@ -511,203 +625,257 @@
=cut
sub createServiceType {
- my ($self, %args) = @_;
- #node => $term,
- #descrioption => $desc,
- #authority => $auth,
- #contact_email => $email);
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'service');
- return (0, "requires a object type node",'') unless ($args{node});
- return (0, "requires an authURI ",'') unless ($args{authority});
- return (0, "requires a contact email address",'') unless ($args{contact_email});
- return (0, "requires a object description",'') unless ($args{description});
- my $term = $args{node};
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:servicetype/)){ # if it is an LSID, but not a MOBY LSID, than barf
- return (0, "can't create a term in a non-MOBY ontology!", $term);
- }
-
- my $LSID = ($args{'node'} =~ /urn\:lsid/)?$args{'node'}:$self->setURI($args{'node'});
- unless ($LSID){return (0, "Failed during creation of an LSID",'')}
-
- $self->dbh->do(q{insert into service (service_type, service_lsid, description, authority,contact_email) values (?,?,?,?,?)},
- undef,
- ($args{'node'},
- $LSID,
- $args{'description'},
- $args{'authority'},
- $args{'contact_email'}));
-
-
- unless ($self->dbh->{mysql_insertid}){
- return (0, "Service creation failed for unknown reasons",'');
- }
- return (1, "Service creation succeeded",$LSID);
+ my ( $self, %args ) = @_;
+ #node => $term,
+ #descrioption => $desc,
+ #authority => $auth,
+ #contact_email => $email);
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'service' );
+ return ( 0, "requires a object type node", '' ) unless ( $args{node} );
+ return ( 0, "requires an authURI ", '' ) unless ( $args{authority} );
+ return ( 0, "requires a contact email address", '' )
+ unless ( $args{contact_email} );
+ return ( 0, "requires a object description", '' )
+ unless ( $args{description} );
+ my $term = $args{node};
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:servicetype/ ) )
+ { # if it is an LSID, but not a MOBY LSID, than barf
+ return ( 0, "can't create a term in a non-MOBY ontology!", $term );
+ }
+ my $LSID =
+ ( $args{'node'} =~ /urn\:lsid/ )
+ ? $args{'node'}
+ : $self->setURI( $args{'node'} );
+ unless ($LSID) { return ( 0, "Failed during creation of an LSID", '' ) }
+ $self->dbh->do(
+q{insert into service (service_type, service_lsid, description, authority,contact_email) values (?,?,?,?,?)},
+ undef,
+ (
+ $args{'node'}, $LSID, $args{'description'},
+ $args{'authority'}, $args{'contact_email'}
+ )
+ );
+ unless ( $self->dbh->{mysql_insertid} ) {
+ return ( 0, "Service creation failed for unknown reasons", '' );
+ }
+ return ( 1, "Service creation succeeded", $LSID );
}
=head2 deleteServiceType
=cut
-
sub deleteServiceType {
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'service');
- my $term = $args{term};
-
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:servicetype/)){
- return (0, "can't delete from external ontology", $term);
- }
-
- my $LSID;
- unless ($term =~ /^urn:lsid:biomoby.org:servicetype/){$LSID = $self->getServiceURI($term)} else {$LSID=$term}
- return (0, q{Service type $term cannot be resolved to an LSID in the MOBY ontologies},"") unless $LSID;
-
- my ($id, $lsid) = $self->dbh->selectrow_array(q{select service_id, service_lsid from service where service_lsid = ?}, undef, $LSID);
-
- if (!defined $id){
- return (0, q{Service type $term does not exist in the ontology},$lsid);
- }
- # service1_id ISA service2_id?
- my (@isa) = $self->dbh->selectrow_array(q{select * from service_term2term where service2_id = ?},undef, $id);
- if (scalar @isa){
- return (0, qq{Service type $term has dependencies in the ontology},$lsid);
- }
-
- $self->dbh->do(q{delete from service where service_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from Service Type table failed: $self->dbh->errstr", $lsid);
- }
- $self->dbh->do(q{delete from service_term2term where service1_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from Service Type Term2Term table failed: $self->dbh->errstr", $lsid);
- }
-
- return (1,"Service Type $term Deleted",$lsid);
-}
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'service' );
+ my $term = $args{term};
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:servicetype/ ) )
+ {
+ return ( 0, "can't delete from external ontology", $term );
+ }
+ my $LSID;
+ unless ( $term =~ /^urn:lsid:biomoby.org:servicetype/ ) {
+ $LSID = $self->getServiceURI($term);
+ } else {
+ $LSID = $term;
+ }
+ return (
+ 0,
+q{Service type $term cannot be resolved to an LSID in the MOBY ontologies},
+ ""
+ )
+ unless $LSID;
+ my ( $id, $lsid ) = $self->dbh->selectrow_array(
+ q{select service_id, service_lsid from service where service_lsid = ?},
+ undef, $LSID
+ );
+ if ( !defined $id ) {
+ return ( 0, q{Service type $term does not exist in the ontology},
+ $lsid );
+ }
+ # service1_id ISA service2_id?
+ my (@isa) =
+ $self->dbh->selectrow_array(
+ q{select * from service_term2term where service2_id = ?},
+ undef, $id );
+ if ( scalar @isa ) {
+ return ( 0, qq{Service type $term has dependencies in the ontology},
+ $lsid );
+ }
+ $self->dbh->do( q{delete from service where service_id = ?}, undef, $id );
+ if ( $self->dbh->err ) {
+ return ( 0, "Delete from Service Type table failed: $self->dbh->errstr",
+ $lsid );
+ }
+ $self->dbh->do( q{delete from service_term2term where service1_id = ?},
+ undef, $id );
+ if ( $self->dbh->err ) {
+ return (
+ 0,
+"Delete from Service Type Term2Term table failed: $self->dbh->errstr",
+ $lsid
+ );
+ }
+ return ( 1, "Service Type $term Deleted", $lsid );
+}
=head2 namespaceExists
=cut
-
sub namespaceExists {
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'namespace');
- my $term = $args{term};
- $term =~ s/^moby://; # if the term is namespaced, then remove that
-
- my $sth;
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:namespacetype/)){
- return (1, "external ontology", $term);
- }
-
- if ($term =~ /^urn:lsid:biomoby.org:namespacetype/){
- $sth = $self->dbh->prepare("select namespace_id, namespace_type, namespace_lsid,description, authority, contact_email from namespace where namespace_lsid = ?");
- } else {
- $sth = $self->dbh->prepare("select namespace_id, namespace_type, namespace_lsid,description, authority, contact_email from namespace where namespace_type = ?");
- }
- $sth->execute($term);
- my ($id, $type, $lsid,$desc, $auth, $email) = $sth->fetchrow_array;
- if ($id){
- return (1,$desc,$lsid);
- } else {
- return (0, "Namespace Type $term does not exist in the biomoby.org Namespace Type ontology\n",'');
- }
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' )
+ unless ( $self->ontology eq 'namespace' );
+ my $term = $args{term};
+ $term =~ s/^moby://; # if the term is namespaced, then remove that
+ my $sth;
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:namespacetype/ ) )
+ {
+ return ( 1, "external ontology", $term );
+ }
+ if ( $term =~ /^urn:lsid:biomoby.org:namespacetype/ ) {
+ $sth =
+ $self->dbh->prepare(
+"select namespace_id, namespace_type, namespace_lsid,description, authority, contact_email from namespace where namespace_lsid = ?"
+ );
+ } else {
+ $sth =
+ $self->dbh->prepare(
+"select namespace_id, namespace_type, namespace_lsid,description, authority, contact_email from namespace where namespace_type = ?"
+ );
+ }
+ $sth->execute($term);
+ my ( $id, $type, $lsid, $desc, $auth, $email ) = $sth->fetchrow_array;
+ if ($id) {
+ return ( 1, $desc, $lsid );
+ } else {
+ return (
+ 0,
+"Namespace Type $term does not exist in the biomoby.org Namespace Type ontology\n",
+ ''
+ );
+ }
}
=head2 createNamespace
=cut
-
sub createNamespace {
- my ($self, %args) = @_;
- #node => $term,
- #descrioption => $desc,
- #authority => $auth,
- #contact_email => $email);
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'namespace');
- return (0, "requires a namespace type node",'') unless ($args{node});
- return (0, "requires an authURI ",'') unless ($args{authority});
- return (0, "requires a contact email address",'') unless ($args{contact_email});
- return (0, "requires a object description",'') unless ($args{description});
- my $term = $args{node};
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:namespacetype/)){ # if it is an LSID, but not a MOBY LSID, than barf
- return (0, "can't create a term in a non-MOBY ontology!", $term);
- }
-
- my $LSID = ($args{'node'} =~ /urn\:lsid/)?$args{'node'}:$self->setURI($args{'node'});
- unless ($LSID){return (0, "Failed during creation of an LSID",'')}
-
- $self->dbh->do(q{insert into namespace (namespace_type, namespace_lsid,description, authority,contact_email) values (?,?,?,?,?)},
- undef,
- ($args{'node'},
- $LSID,
- $args{'description'},
- $args{'authority'},
- $args{'contact_email'}));
-
-
- unless ($self->dbh->{mysql_insertid}){
- return (0, "Namespace creation failed for unknown reasons",'');
- }
- return (1, "Namespace creation succeeded",$LSID);
+ my ( $self, %args ) = @_;
+
+ #node => $term,
+ #descrioption => $desc,
+ #authority => $auth,
+ #contact_email => $email);
+ return ( 0, "WRONG ONTOLOGY!", '' )
+ unless ( $self->ontology eq 'namespace' );
+ return ( 0, "requires a namespace type node", '' ) unless ( $args{node} );
+ return ( 0, "requires an authURI ", '' ) unless ( $args{authority} );
+ return ( 0, "requires a contact email address", '' )
+ unless ( $args{contact_email} );
+ return ( 0, "requires a object description", '' )
+ unless ( $args{description} );
+ my $term = $args{node};
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:namespacetype/ ) )
+ { # if it is an LSID, but not a MOBY LSID, than barf
+ return ( 0, "can't create a term in a non-MOBY ontology!", $term );
+ }
+ my $LSID =
+ ( $args{'node'} =~ /urn\:lsid/ )
+ ? $args{'node'}
+ : $self->setURI( $args{'node'} );
+ unless ($LSID) { return ( 0, "Failed during creation of an LSID", '' ) }
+ $self->dbh->do(
+q{insert into namespace (namespace_type, namespace_lsid,description, authority,contact_email) values (?,?,?,?,?)},
+ undef,
+ (
+ $args{'node'}, $LSID, $args{'description'},
+ $args{'authority'}, $args{'contact_email'}
+ )
+ );
+ unless ( $self->dbh->{mysql_insertid} ) {
+ return ( 0, "Namespace creation failed for unknown reasons", '' );
+ }
+ return ( 1, "Namespace creation succeeded", $LSID );
}
=head2 deleteNamespace
=cut
-
sub deleteNamespace {
- my ($self, %args) = @_;
- return (0, "WRONG ONTOLOGY!",'') unless ($self->ontology eq 'namespace');
- my $term = $args{term};
- my $LSID;
- unless ($term =~ /urn\:lsid/){$LSID = $self->getNamespaceURI($term)} else {$LSID=$term}
- return (0, q{Namespace type $term cannot be resolved to an LSID},"") unless $LSID;
-
- if ($term =~ /^urn:lsid/ && !($term =~ /^urn:lsid:biomoby.org:namespacetype/)){
- return (0, "cannot delete a term from an external ontology", $term);
- }
-
- my ($id, $lsid) = $self->dbh->selectrow_array(q{select namespace_id, namespace_lsid from namespace where namespace_lsid = ?},undef,$LSID);
- unless ($id){return (0, q{Namespace type $term does not exist in the ontology},$lsid)}
-
- # service1_id ISA service2_id?
- my (@isa) = $self->dbh->selectrow_array(q{select * from namespace_term2term where namespace2_id = ?},undef, $id);
- if (scalar @isa){
- return (0, qq{Namespace type $term has dependencies in the ontology},$lsid);
- }
-
- $self->dbh->do(q{delete from namespace where namespace_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from namespace table failed: $self->dbh->errstr", $lsid);
- }
- $self->dbh->do(q{delete from namespace_term2term where namespace1_id = ?}, undef,$id );
- if ($self->dbh->err){
- return (0, "Delete from namespace term2term table failed: $self->dbh->errstr", $lsid);
- }
-
- return (1,"Namespace Type $term Deleted",$lsid);
+ my ( $self, %args ) = @_;
+ return ( 0, "WRONG ONTOLOGY!", '' )
+ unless ( $self->ontology eq 'namespace' );
+ my $term = $args{term};
+ my $LSID;
+ unless ( $term =~ /urn\:lsid/ ) { $LSID = $self->getNamespaceURI($term) } else { $LSID = $term }
+ return ( 0, q{Namespace type $term cannot be resolved to an LSID}, "" )
+ unless $LSID;
+ if ( $term =~ /^urn:lsid/
+ && !( $term =~ /^urn:lsid:biomoby.org:namespacetype/ ) )
+ {
+ return ( 0, "cannot delete a term from an external ontology", $term );
+ }
+ my ( $id, $lsid ) = $self->dbh->selectrow_array(
+q{select namespace_id, namespace_lsid from namespace where namespace_lsid = ?},
+ undef, $LSID
+ );
+ unless ($id) {
+ return ( 0, q{Namespace type $term does not exist in the ontology},
+ $lsid );
+ }
+
+ # service1_id ISA service2_id?
+ my (@isa) =
+ $self->dbh->selectrow_array(
+ q{select * from namespace_term2term where namespace2_id = ?},
+ undef, $id );
+ if ( scalar @isa ) {
+ return ( 0, qq{Namespace type $term has dependencies in the ontology},
+ $lsid );
+ }
+ $self->dbh->do( q{delete from namespace where namespace_id = ?},
+ undef, $id );
+ if ( $self->dbh->err ) {
+ return ( 0, "Delete from namespace table failed: $self->dbh->errstr",
+ $lsid );
+ }
+ $self->dbh->do( q{delete from namespace_term2term where namespace1_id = ?},
+ undef, $id );
+ if ( $self->dbh->err ) {
+ return (
+ 0,
+ "Delete from namespace term2term table failed: $self->dbh->errstr",
+ $lsid
+ );
+ }
+ return ( 1, "Namespace Type $term Deleted", $lsid );
}
=head2 retrieveAllServiceTypes
=cut
-
sub retrieveAllServiceTypes {
- my ($self) = @_;
- my $types = $self->dbh->selectall_arrayref(q{select service_type, description from service});
- my @types = @{$types};
- my %response;
- foreach (@types){
- $response{$_->[0]} = $_->[1];
- }
- return \%response;
+ my ($self) = @_;
+ my $types =
+ $self->dbh->selectall_arrayref(
+ q{select service_type, description from service});
+ my @types = @{$types};
+ my %response;
+ foreach (@types) {
+ $response{ $_->[0] } = $_->[1];
+ }
+ return \%response;
}
=head2 retrieveAllNamespaceTypes
@@ -715,14 +883,16 @@
=cut
sub retrieveAllNamespaceTypes {
- my ($self) = @_;
- my $types = $self->dbh->selectall_arrayref(q{select namespace_type, description from namespace});
- my @types = @{$types};
- my %response;
- foreach (@types){
- $response{$_->[0]} = $_->[1];
- }
- return \%response;
+ my ($self) = @_;
+ my $types =
+ $self->dbh->selectall_arrayref(
+ q{select namespace_type, description from namespace});
+ my @types = @{$types};
+ my %response;
+ foreach (@types) {
+ $response{ $_->[0] } = $_->[1];
+ }
+ return \%response;
}
=head2 retrieveAllObjectClasses
@@ -730,16 +900,17 @@
=cut
sub retrieveAllObjectClasses {
- my ($self) = @_;
- my $types = $self->dbh->selectall_arrayref(q{select object_type, description from object});
- my @types = @{$types};
- my %response;
- foreach (@types){
- $response{$_->[0]} = $_->[1];
- }
- return \%response;
+ my ($self) = @_;
+ my $types =
+ $self->dbh->selectall_arrayref(
+ q{select object_type, description from object});
+ my @types = @{$types};
+ my %response;
+ foreach (@types) {
+ $response{ $_->[0] } = $_->[1];
+ }
+ return \%response;
}
-
*retrieveAllObjectTypes = \&retrieveAllObjectClasses;
*retrieveAllObjectTypes = \&retrieveAllObjectClasses;
@@ -748,10 +919,13 @@
=cut
sub getObjectCommonName {
- my ($self, $URI) = @_;
- return undef unless $URI =~ /urn\:lsid/;
- my ($name) = $self->dbh->selectrow_array(q{select object_type from object where object_lsid = ?}, undef, $URI);
- return $name?$name:$URI;
+ my ( $self, $URI ) = @_;
+ return undef unless $URI =~ /urn\:lsid/;
+ my ($name) =
+ $self->dbh->selectrow_array(
+ q{select object_type from object where object_lsid = ?},
+ undef, $URI );
+ return $name ? $name : $URI;
}
=head2 getNamespaceCommonName
@@ -759,22 +933,27 @@
=cut
sub getNamespaceCommonName {
- my ($self, $URI) = @_;
- return undef unless $URI =~ /urn\:lsid/;
- my ($name) = $self->dbh->selectrow_array(q{select namespace_type from namespace where namespace_lsid = ?}, undef, $URI);
- return $name?$name:$URI;
+ my ( $self, $URI ) = @_;
+ return undef unless $URI =~ /urn\:lsid/;
+ my ($name) =
+ $self->dbh->selectrow_array(
+ q{select namespace_type from namespace where namespace_lsid = ?},
+ undef, $URI );
+ return $name ? $name : $URI;
}
=head2 getServiceCommonName
=cut
-
sub getServiceCommonName {
- my ($self, $URI) = @_;
- return undef unless $URI =~ /urn\:lsid/;
- my ($name) = $self->dbh->selectrow_array(q{select service_type from service where service_lsid = ?}, undef, $URI);
- return $name?$name:$URI;
+ my ( $self, $URI ) = @_;
+ return undef unless $URI =~ /urn\:lsid/;
+ my ($name) =
+ $self->dbh->selectrow_array(
+ q{select service_type from service where service_lsid = ?},
+ undef, $URI );
+ return $name ? $name : $URI;
}
=head2 getServiceURI
@@ -782,10 +961,13 @@
=cut
sub getServiceURI {
- my ($self, $term) = @_;
- return $term if $term =~ /urn\:lsid/;
- my ($id) = $self->dbh->selectrow_array(q{select service_lsid from service where service_type = ?},undef,$term);
- return $id;
+ my ( $self, $term ) = @_;
+ return $term if $term =~ /urn\:lsid/;
+ my ($id) =
+ $self->dbh->selectrow_array(
+ q{select service_lsid from service where service_type = ?},
+ undef, $term );
+ return $id;
}
=head2 getObjectURI
@@ -793,10 +975,13 @@
=cut
sub getObjectURI {
- my ($self, $term) = @_;
- return $term if $term =~ /urn\:lsid/;
- my ($id) = $self->dbh->selectrow_array(q{select object_lsid from object where object_type = ?},undef,$term);
- return $id;
+ my ( $self, $term ) = @_;
+ return $term if $term =~ /urn\:lsid/;
+ my ($id) =
+ $self->dbh->selectrow_array(
+ q{select object_lsid from object where object_type = ?},
+ undef, $term );
+ return $id;
}
=head2 getNamespaceURI
@@ -804,22 +989,27 @@
=cut
sub getNamespaceURI {
- my ($self, $term) = @_;
- return $term if $term =~ /urn\:lsid/;
- my ($id) = $self->dbh->selectrow_array(q{select namespace_lsid from namespace where namespace_type = ?},undef,$term);
- return $id;
+ my ( $self, $term ) = @_;
+ return $term if $term =~ /urn\:lsid/;
+ my ($id) =
+ $self->dbh->selectrow_array(
+ q{select namespace_lsid from namespace where namespace_type = ?},
+ undef, $term );
+ return $id;
}
-
=head2 getNamespaceURI
=cut
sub getRelationshipURI {
- my ($self, $ontology, $term) = @_;
- return $term if $term =~ /urn\:lsid/;
- my ($id) = $self->dbh->selectrow_array(q{select relationship_lsid from relationship where relationship_type = ? and ontology = ?},undef,$term, $ontology);
- return $id;
+ my ( $self, $ontology, $term ) = @_;
+ return $term if $term =~ /urn\:lsid/;
+ my ($id) = $self->dbh->selectrow_array(
+q{select relationship_lsid from relationship where relationship_type = ? and ontology = ?},
+ undef, $term, $ontology
+ );
+ return $id;
}
=head2 getRelationshipTypes
@@ -827,16 +1017,18 @@
=cut
sub getRelationshipTypes {
- my ($self, %args) = @_;
- my $ontology = $args{'ontology'};
- my $OS = MOBY::OntologyServer->new(ontology => "relationship");
-
- my $defs = $OS->dbh->selectall_arrayref(q{select relationship_lsid, relationship_type, authority, description from relationship where ontology = ?}, undef, $ontology);
- my %result;
- foreach (@{$defs}){
- $result{$_->[0]} = [$_->[1], $_->[2], $_->[3]];
- }
- return \%result;
+ my ( $self, %args ) = @_;
+ my $ontology = $args{'ontology'};
+ my $OS = MOBY::OntologyServer->new( ontology => "relationship" );
+ my $defs = $OS->dbh->selectall_arrayref(
+q{select relationship_lsid, relationship_type, authority, description from relationship where ontology = ?},
+ undef, $ontology
+ );
+ my %result;
+ foreach ( @{$defs} ) {
+ $result{ $_->[0] } = [ $_->[1], $_->[2], $_->[3] ];
+ }
+ return \%result;
}
=head2 Relationships
@@ -844,44 +1036,56 @@
=cut
sub Relationships {
- # this entire subroutine assumes that there is NOT multiple parenting!!
- my ($self, %args) = @_;
- my $ontology = $args{ontology}?$args{ontology}:$self->ontology;
- my $term = $args{term};
- my $relationship = $args{relationship};
- my $direction = $args{direction}?$args{direction}:'root';
- my $expand = $args{expand}?1:0;
-
- return unless ($ontology && $term && (($ontology eq 'service') || ($ontology eq 'object')));
- # convert $term into an LSID if it isn't already
- if ($ontology eq 'service'){
- $term = $self->getServiceURI($term);
- } elsif ($ontology eq 'object'){
- $term = $self->getObjectURI($term);
- }
- my %results;
- while (($term ne 'urn:lsid:biomoby.org:objectclass:Object') && ($term ne 'urn:lsid:biomoby.org:servicetype:Service')){
- my $defs = $self->_doRelationshipsQuery($ontology, $term, $relationship, $direction);
- my $lsid; my $rel;
- foreach (@{$defs}){
- $lsid = $_->[0];
- $rel = $_->[1];
- $debug && _LOG("\t\tADDING RELATIONSHIP $_ : $lsid to $rel\n");
- push @{$results{$rel}}, $lsid;
- }
- last unless ($expand);
- last unless ($direction eq "root"); # if we aren't going to root, then be careful or we'll loop infnitely
- $term = $lsid; # this entire subroutine assumes that there is NOT multiple parenting...
- }
- return \%results; #results(relationship} = [lsid1, lsid2, lsid3]
+
+ # this entire subroutine assumes that there is NOT multiple parenting!!
+ my ( $self, %args ) = @_;
+ my $ontology = $args{ontology} ? $args{ontology} : $self->ontology;
+ my $term = $args{term};
+ my $relationship = $args{relationship};
+ my $direction = $args{direction} ? $args{direction} : 'root';
+ my $expand = $args{expand} ? 1 : 0;
+ return
+ unless ( $ontology
+ && $term
+ && ( ( $ontology eq 'service' ) || ( $ontology eq 'object' ) ) );
+
+ # convert $term into an LSID if it isn't already
+ if ( $ontology eq 'service' ) {
+ $term = $self->getServiceURI($term);
+ } elsif ( $ontology eq 'object' ) {
+ $term = $self->getObjectURI($term);
+ }
+ my %results;
+ while ( ( $term ne 'urn:lsid:biomoby.org:objectclass:Object' )
+ && ( $term ne 'urn:lsid:biomoby.org:servicetype:Service' ) )
+ {
+ my $defs = $self->_doRelationshipsQuery( $ontology, $term,
+ $relationship, $direction );
+ my $lsid;
+ my $rel;
+ foreach ( @{$defs} ) {
+ $lsid = $_->[0];
+ $rel = $_->[1];
+ $debug
+ && _LOG("\t\tADDING RELATIONSHIP $_ : $lsid to $rel\n");
+ push @{ $results{$rel} }, $lsid;
+ }
+ last unless ($expand);
+ last
+ unless ( $direction eq "root" )
+ ; # if we aren't going to root, then be careful or we'll loop infnitely
+ $term = $lsid
+ ; # this entire subroutine assumes that there is NOT multiple parenting...
+ }
+ return \%results; #results(relationship} = [lsid1, lsid2, lsid3]
}
sub _doRelationshipsQuery {
- my ($self, $ontology, $term, $relationship, $direction) = @_;
- my $defs;
- if ($direction eq 'root'){
- unless (defined $relationship){
- $defs = $self->dbh->selectall_arrayref("
+ my ( $self, $ontology, $term, $relationship, $direction ) = @_;
+ my $defs;
+ if ( $direction eq 'root' ) {
+ unless ( defined $relationship ) {
+ $defs = $self->dbh->selectall_arrayref( "
select distinct s2.${ontology}_lsid, relationship_type from
${ontology}_term2term as t2t,
$ontology as s1,
@@ -889,9 +1093,9 @@
where
s1.${ontology}_id = t2t.${ontology}1_id and
s2.${ontology}_id = t2t.${ontology}2_id and
- s1.${ontology}_lsid = ?", undef, $term); # ")
- } else {
- $defs = $self->dbh->selectall_arrayref("
+ s1.${ontology}_lsid = ?", undef, $term ); # ")
+ } else {
+ $defs = $self->dbh->selectall_arrayref( "
select distinct s2.${ontology}_lsid, relationship_type from
${ontology}_term2term as t2t,
$ontology as s1,
@@ -900,11 +1104,11 @@
relationship_type = ? and
s1.${ontology}_id = t2t.${ontology}1_id and
s2.${ontology}_id = t2t.${ontology}2_id and
- s1.${ontology}_lsid = ?", undef, $relationship, $term); # ")
- }
- } else {
- unless (defined $relationship){
- $defs = $self->dbh->selectall_arrayref("
+ s1.${ontology}_lsid = ?", undef, $relationship, $term ); # ")
+ }
+ } else {
+ unless ( defined $relationship ) {
+ $defs = $self->dbh->selectall_arrayref( "
select distinct s2.${ontology}_lsid, relationship_type from
${ontology}_term2term as t2t,
$ontology as s1,
@@ -912,9 +1116,9 @@
where
s1.${ontology}_id = t2t.${ontology}1_id and
s2.${ontology}_id = t2t.${ontology}2_id and
- s2.${ontology}_lsid = ?", undef, $term); # ")
- } else {
- $defs = $self->dbh->selectall_arrayref("
+ s2.${ontology}_lsid = ?", undef, $term ); # ")
+ } else {
+ $defs = $self->dbh->selectall_arrayref( "
select distinct s2.${ontology}_lsid, relationship_type from
${ontology}_term2term as t2t,
$ontology as s1,
@@ -923,10 +1127,10 @@
relationship_type = ? and
s1.${ontology}_id = t2t.${ontology}1_id and
s2.${ontology}_id = t2t.${ontology}2_id and
- s2.${ontology}_lsid = ?", undef, $relationship, $term); # ")
- }
- }
- return $defs;
+ s2.${ontology}_lsid = ?", undef, $relationship, $term ); # ")
+ }
+ }
+ return $defs;
}
=head2 setURI
@@ -934,82 +1138,102 @@
=cut
sub setURI {
- my ($self, $id) = @_;
- my $URI;
- # $id = lc($id);
- if ($self->ontology eq 'object'){
- $URI = "urn:lsid:biomoby.org:objectclass:$id"
- } elsif ($self->ontology eq 'namespace'){
- $URI = "urn:lsid:biomoby.org:namespacetype:$id"
- } elsif ($self->ontology eq 'service'){
- $URI = "urn:lsid:biomoby.org:servicetype:$id"
- } elsif ($self->ontology eq 'relationship'){
- $URI = "urn:lsid:biomoby.org:relationshiptype:$id"
- } else {
- $URI = 0
- }
- return $URI;
-}
+ my ( $self, $id ) = @_;
+ my $URI;
+ # $id = lc($id);
+ if ( $self->ontology eq 'object' ) {
+ $URI = "urn:lsid:biomoby.org:objectclass:$id";
+ } elsif ( $self->ontology eq 'namespace' ) {
+ $URI = "urn:lsid:biomoby.org:namespacetype:$id";
+ } elsif ( $self->ontology eq 'service' ) {
+ $URI = "urn:lsid:biomoby.org:servicetype:$id";
+ } elsif ( $self->ontology eq 'relationship' ) {
+ $URI = "urn:lsid:biomoby.org:relationshiptype:$id";
+ } else {
+ $URI = 0;
+ }
+ return $URI;
+}
=head2 traverseDAG
=cut
sub traverseDAG {
- my ($self, $term, $direction) = @_;
- my $ontology = $self->ontology;
- return {} unless $ontology;
- return {} unless $term;
- $direction="root" unless ($direction);
- return {} unless (($direction eq 'root') || ($direction eq 'leaves'));
- if ($ontology eq 'service'){
- $term = $self->getServiceURI($term);
- } elsif ($ontology eq 'object'){
- $term = $self->getObjectURI($term);
- }
- return {} unless $term =~ /^urn\:lsid/; # now its a URI
-
- my $relhash = $self->getRelationshipTypes(ontology => $ontology); # get teh types of relationships for the object/service ontology
- return {} unless $relhash;
- my @rels = keys %{$relhash}; #@rels is the list of relationship types for that ontology
- my %relationships;
- foreach my $relationship (@rels){
- my %IDS;
- my $OS = MOBY::OntologyServer->new(ontology => 'relationship');
- my $reluri = $OS->getRelationshipURI($ontology, $relationship); # get the URI for that relationship type if it ins't already a URI
- $IDS{$term} = "untestedroot"; # mark the one in-hand as being untested
- while (grep /untested/, (values %IDS)){ # now, while there are untested services in our list...
- foreach my $termthingy(keys %IDS){ # start parsing through the current list (hash keys)
- $debug && _LOG("testing $relationship of $termthingy\n");
- next if ($IDS{$termthingy} eq "tested"); # if it has been tested already then move on
- my $lsids = $self->Relationships(term => $termthingy, relationship => $relationship, direction => $direction); # get the related terms for this type; this should return a single hash value
- if ($IDS{$termthingy} =~ /root/){ # here is where we remove self
- delete $IDS{$termthingy};
- $debug && _LOG("deleting $termthingy\n");
- } else {
- $debug && _LOG("marking $termthingy as TESTED\n");
- $IDS{$termthingy} = "tested"; # mark the current one as now being "done"
- }
- #${$lsids}{relationshiptype}=[lsid, lsid, lsid];
- foreach my $lsid(@{$lsids->{$relationship}}){ # go through the related terms
- $debug && _LOG("found $lsid as relationship");
- next if (defined $IDS{$lsid}); # if we have already seen that term, skip it
- $debug && _LOG("setting $lsid as untested\n");
- $IDS{$lsid} = "untested" # otherwise add it to the list and loop again.
- }
- }
- }
- my @IDS = keys %IDS;
- $relationships{$relationship} = \@IDS; # and associate them all with the current relationship type
- }
- return \%relationships;
+ my ( $self, $term, $direction ) = @_;
+ my $ontology = $self->ontology;
+ return {} unless $ontology;
+ return {} unless $term;
+ $direction = "root" unless ($direction);
+ return {} unless ( ( $direction eq 'root' ) || ( $direction eq 'leaves' ) );
+ if ( $ontology eq 'service' ) {
+ $term = $self->getServiceURI($term);
+ } elsif ( $ontology eq 'object' ) {
+ $term = $self->getObjectURI($term);
+ }
+ return {} unless $term =~ /^urn\:lsid/; # now its a URI
+ my $relhash =
+ $self->getRelationshipTypes( ontology => $ontology )
+ ; # get teh types of relationships for the object/service ontology
+ return {} unless $relhash;
+ my @rels = keys
+ %{$relhash}; #@rels is the list of relationship types for that ontology
+ my %relationships;
+ foreach my $relationship (@rels) {
+ my %IDS;
+ my $OS = MOBY::OntologyServer->new( ontology => 'relationship' );
+ my $reluri =
+ $OS->getRelationshipURI( $ontology, $relationship )
+ ; # get the URI for that relationship type if it ins't already a URI
+ $IDS{$term} = "untestedroot"; # mark the one in-hand as being untested
+ while ( grep /untested/, ( values %IDS ) )
+ { # now, while there are untested services in our list...
+ foreach my $termthingy ( keys %IDS )
+ { # start parsing through the current list (hash keys)
+ $debug && _LOG("testing $relationship of $termthingy\n");
+ next
+ if ( $IDS{$termthingy} eq "tested" )
+ ; # if it has been tested already then move on
+ my $lsids = $self->Relationships(
+ term => $termthingy,
+ relationship => $relationship,
+ direction => $direction
+ )
+ ; # get the related terms for this type; this should return a single hash value
+ if ( $IDS{$termthingy} =~ /root/ )
+ { # here is where we remove self
+ delete $IDS{$termthingy};
+ $debug && _LOG("deleting $termthingy\n");
+ } else {
+ $debug && _LOG("marking $termthingy as TESTED\n");
+ $IDS{$termthingy} =
+ "tested"; # mark the current one as now being "done"
+ }
+
+ #${$lsids}{relationshiptype}=[lsid, lsid, lsid];
+ foreach my $lsid ( @{ $lsids->{$relationship} } )
+ { # go through the related terms
+ $debug && _LOG("found $lsid as relationship");
+ next
+ if ( defined $IDS{$lsid} )
+ ; # if we have already seen that term, skip it
+ $debug && _LOG("setting $lsid as untested\n");
+ $IDS{$lsid} =
+ "untested" # otherwise add it to the list and loop again.
+ }
+ }
+ }
+ my @IDS = keys %IDS;
+ $relationships{$relationship} =
+ \@IDS; # and associate them all with the current relationship type
+ }
+ return \%relationships;
}
-
-
sub _LOG {
return unless $debug;
+
#print join "\n", @_;
#print "\n---\n";
#return;
@@ -1018,37 +1242,31 @@
print LOG "\n---\n";
close LOG;
}
-
-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/authority.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /home/repository/moby/moby-live/Perl/MOBY/authority.pm 2003/05/07 19:20:27 1.1
+++ /home/repository/moby/moby-live/Perl/MOBY/authority.pm 2004/11/18 17:41:14 1.2
@@ -1,12 +1,9 @@
#!/usr/bin/perl -w
-
package MOBY::authority;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::authority - a lightweight connection to the
@@ -37,104 +34,102 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- authority_id => [undef, 'read/write'],
- authority_common_name => [undef, 'read/write'],
- authority_uri => [undef, 'read/write'],
- contact_email => [undef, 'read/write'],
- dbh => [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_id => [ undef, 'read/write' ],
+ authority_common_name => [ undef, 'read/write' ],
+ authority_uri => [ undef, 'read/write' ],
+ contact_email => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
- my $dbh = $self->dbh;
- my ($authority_id, $common, $uri, $contact) = $dbh->selectrow_array(q{select authority_id, authority_common_name,authority_uri,contact_email from authority where authority_uri = ?},undef,$self->authority_uri);
- unless ($authority_id){
- $dbh->do(q{insert into authority (authority_common_name, authority_uri, contact_email) values (?,?,?)}, undef,($self->authority_common_name, $self->authority_uri, $self->contact_email));
- $self->authority_id($dbh->{mysql_insertid});
- } else {
- $self->authority_id($authority_id);
- }
-
- 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);
+ }
+ }
+ my $dbh = $self->dbh;
+ my ( $authority_id, $common, $uri, $contact ) = $dbh->selectrow_array(
+q{select authority_id, authority_common_name,authority_uri,contact_email from authority where authority_uri = ?},
+ undef, $self->authority_uri
+ );
+ unless ($authority_id) {
+ $dbh->do(
+q{insert into authority (authority_common_name, authority_uri, contact_email) values (?,?,?)},
+ undef,
+ (
+ $self->authority_common_name, $self->authority_uri,
+ $self->contact_email
+ )
+ );
+ $self->authority_id( $dbh->{mysql_insertid} );
+ } else {
+ $self->authority_id($authority_id);
+ }
+ 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/central_db_connection.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- /home/repository/moby/moby-live/Perl/MOBY/central_db_connection.pm 2004/06/24 22:32:38 1.5
+++ /home/repository/moby/moby-live/Perl/MOBY/central_db_connection.pm 2004/11/18 17:41:14 1.6
@@ -1,7 +1,6 @@
package MOBY::central_db_connection;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
use MOBY::Config;
@@ -37,121 +36,105 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- db_connect_object => ["MOBY::mysql", 'read/write'],
- datasource => ['mobycentral', 'read/write'],
- #username => ["mobycentral", 'read/write'],
- #password => ["mobycentral", 'read/write'],
- #dbname => ["mobycentral", 'read/write'],
- #host => ["localhost", 'read/write'],
- #port => [3306, 'read/write'],
- dbh => [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 db_connect_object {
- my ($self, $attr) = @_;
- $self->{db_connect_object} = $attr if defined $attr;
- return $self->{db_connect_object}
- }
-
- sub dbh {
- my ($self, $attr) = @_;
- $self->{dbh} = $attr if defined $attr;
- return $self->{dbh}
- }
-}
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ db_connect_object => [ "MOBY::mysql", 'read/write' ],
+ datasource => [ 'mobycentral', 'read/write' ],
+
+ #username => ["mobycentral", 'read/write'],
+ #password => ["mobycentral", 'read/write'],
+ #dbname => ["mobycentral", 'read/write'],
+ #host => ["localhost", 'read/write'],
+ #port => [3306, 'read/write'],
+ dbh => [ 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 db_connect_object {
+ my ( $self, $attr ) = @_;
+ $self->{db_connect_object} = $attr if defined $attr;
+ return $self->{db_connect_object};
+ }
+
+ sub dbh {
+ my ( $self, $attr ) = @_;
+ $self->{dbh} = $attr if defined $attr;
+ return $self->{dbh};
+ }
+}
sub new {
- my ($caller, %args) = @_;
-
+ my ( $caller, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
+ 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);
+ }
+ }
+ $CONFIG ||= MOBY::Config->new;
- $CONFIG ||= MOBY::Config->new;
-
# getting the dbh is bad bad bad!!!
- my $dbh = $CONFIG->getDataAdaptor(datasource => 'mobycentral')->dbh;
-
- $self->dbh($dbh);
+ my $dbh = $CONFIG->getDataAdaptor( datasource => 'mobycentral' )->dbh;
+ $self->dbh($dbh);
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/collection_input.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- /home/repository/moby/moby-live/Perl/MOBY/collection_input.pm 2004/06/24 22:32:38 1.2
+++ /home/repository/moby/moby-live/Perl/MOBY/collection_input.pm 2004/11/18 17:41:14 1.3
@@ -1,12 +1,9 @@
package MOBY::collection_input;
use strict;
use Carp;
-use XML::DOM;
use MOBY::Config;
-
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::collection_input - a lightweight connection to the
@@ -38,114 +35,95 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- collection_input_id => [undef, 'read/write'],
- article_name => [undef, 'read/write'],
- service_instance_id => [undef, 'read/write'],
- dbh => [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
+ (
+ collection_input_id => [ undef, 'read/write' ],
+ article_name => [ undef, 'read/write' ],
+ service_instance_id => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
-
+ 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 $id = $self->WRITE;
$self->collection_input_id($id) if defined $id;
- return $self;
-
+ return $self;
}
sub WRITE {
my ($self) = @_;
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral');
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' );
my $id = $adaptor->insert_collection_input(
- service_instance => $self->service_instance_id,
- article_name => $self->article_name,
- );
-
- return $id;
+ service_instance => $self->service_instance_id,
+ article_name => $self->article_name, );
+ return $id;
}
-
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/collection_output.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- /home/repository/moby/moby-live/Perl/MOBY/collection_output.pm 2004/06/24 22:32:38 1.2
+++ /home/repository/moby/moby-live/Perl/MOBY/collection_output.pm 2004/11/18 17:41:14 1.3
@@ -1,14 +1,10 @@
#!/usr/bin/perl -w
-
package MOBY::collection_output;
use strict;
use Carp;
-use XML::DOM;
use MOBY::Config;
-
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::collection_output - a lightweight connection to the
@@ -38,115 +34,95 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- collection_output_id => [undef, 'read/write'],
- article_name => [undef, 'read/write'],
- service_instance_id => [undef, 'read/write'],
- dbh => [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
+ (
+ collection_output_id => [ undef, 'read/write' ],
+ article_name => [ undef, 'read/write' ],
+ service_instance_id => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
-
+ 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 $id = $self->WRITE;
$self->collection_output_id($id) if defined $id;
- return $self;
-
+ return $self;
}
sub WRITE {
my ($self) = @_;
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral');
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' );
my $id = $adaptor->insert_collection_output(
- service_instance => $self->service_instance_id,
- article_name => $self->article_name,
- );
-
- return $id;
+ service_instance => $self->service_instance_id,
+ article_name => $self->article_name, );
+ return $id;
}
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/dbConfig.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- /home/repository/moby/moby-live/Perl/MOBY/dbConfig.pm 2004/07/09 00:21:53 1.3
+++ /home/repository/moby/moby-live/Perl/MOBY/dbConfig.pm 2004/11/18 17:41:14 1.4
@@ -1,149 +1,135 @@
package MOBY::dbConfig;
-
use strict;
use Carp;
use vars qw($AUTOLOAD);
use Text::Shellwords;
-
{
+
#Encapsulated class data
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- section_title => [undef, 'read/write'],
- username => [undef, 'read/write'],
- password => [undef, 'read/write'],
- dbname => [undef, 'read/write'],
- port => [undef, 'read/write'],
- proxy => [undef, 'read/write'],
- adaptor => ["MOBY::Adaptor::moby::queryapi::mysql", 'read/write'],
- url => [undef, 'read/write'],
- section => [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
+ (
+ section_title => [ undef, 'read/write' ],
+ username => [ undef, 'read/write' ],
+ password => [ undef, 'read/write' ],
+ dbname => [ undef, 'read/write' ],
+ port => [ undef, 'read/write' ],
+ proxy => [ undef, 'read/write' ],
+ adaptor => [ "MOBY::Adaptor::moby::queryapi::mysql", 'read/write' ],
+ url => [ undef, 'read/write' ],
+ section => [ 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 database_title {
- my ($self, $val) = @_;
+ sub database_title {
+ my ( $self, $val ) = @_;
$self->section_title($val) if $val;
return $self->section_title;
- }
-
+ }
}
# this object will contain the full hash of what is in the config file, even if
# the key/value pairs are not expected. Only the expected key/value pairs will be available as
# methods, however (i.e. those in the _standard_keys hash above)
-
sub new {
- my ($caller, %args) = @_;
+ 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) }
- }
+ 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);
+ }
+ }
+ my $key;
- my $key;
#eval {$key = $self->_readSections($self->section);};
- $key = $self->_readSections($self->section);
- #if ($@){die "MOBY Configuration file is misconfigured: dbConfig line 71\n";}
-#print STDERR "I received the key $key\n";
- return undef unless $key;
- return undef unless $key =~ /\S/;
-#print STDERR "returning the dbConfig object for database title $key\n";
- $self->section_title($key);
-
- return $self;
+ $key = $self->_readSections( $self->section );
+ #if ($@){die "MOBY Configuration file is misconfigured: dbConfig line 71\n";}
+ #print STDERR "I received the key $key\n";
+ return undef unless $key;
+ return undef unless $key =~ /\S/;
+
+ #print STDERR "returning the dbConfig object for database title $key\n";
+ $self->section_title($key);
+ return $self;
}
sub _readSections {
- my ($self, $section) = @_;
+ my ( $self, $section ) = @_;
my $key;
- my @lines = split "\n", $section;
- while (my $l = shift @lines){
- chomp $l;
- next unless $l;
- next if $l=~/\s*\#/; # ignore comments
- next unless $l =~ /\S/; # ignore pure whitespace;
-#print STDERR "reading line $l\n";
- if ($l=~/\[(\w+)\]/){
- $key = $1;
- while (my $l2 = shift @lines){
- chomp $l2;
- last unless ($l2 =~ /\S/);
- my @terms = shellwords($l2);
- last unless (scalar @terms > 2);
- $self->{$terms[0]} = $terms[2];
- }
- }
- }
-#print STDERR "returning key $key with terms ",(keys %{$self->{$key}})," \n";
- return $key; # will be undef if this was not a valid section
-}
-
+ my @lines = split "\n", $section;
+ while ( my $l = shift @lines ) {
+ chomp $l;
+ next unless $l;
+ next if $l =~ /\s*\#/; # ignore comments
+ next unless $l =~ /\S/; # ignore pure whitespace;
+
+ #print STDERR "reading line $l\n";
+ if ( $l =~ /\[(\w+)\]/ ) {
+ $key = $1;
+ while ( my $l2 = shift @lines ) {
+ chomp $l2;
+ last unless ( $l2 =~ /\S/ );
+ my @terms = shellwords($l2);
+ last unless ( scalar @terms > 2 );
+ $self->{ $terms[0] } = $terms[2];
+ }
+ }
+ }
-sub DESTROY {}
+ #print STDERR "returning key $key with terms ",(keys %{$self->{$key}})," \n";
+ return $key; # will be undef if this was not a valid section
+}
+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/mysql.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /home/repository/moby/moby-live/Perl/MOBY/mysql.pm 2003/05/07 19:20:27 1.1
+++ /home/repository/moby/moby-live/Perl/MOBY/mysql.pm 2004/11/18 17:41:14 1.2
@@ -1,12 +1,9 @@
#!/usr/bin/perl -w
-
package MOBY::mysql;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::mysql - makes a MYSQL database connection.
@@ -39,92 +36,77 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- );
-
- #_____________________________________________________________
-
- # 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
+ ();
+
+ #_____________________________________________________________
+ # 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, $dbname, $username, $password, $host, $port) = @_;
-my $debug = 0;
+ my ( $caller, $dbname, $username, $password, $host, $port ) = @_;
+ my $debug = 0;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my $self = bless {}, $class;
-
+ my $self = bless {}, $class;
my ($dsn) = "DBI:mysql:$dbname:$host:$port";
-
-
- $debug && &_LOG("connecting to db with params $dbname, $username, $password\n");
- my $dbh = DBI->connect($dsn, $username, $password, {RaiseError => 1}) or die "can't connect to database";
+ $debug
+ && &_LOG("connecting to db with params $dbname, $username, $password\n");
+ my $dbh = DBI->connect( $dsn, $username, $password, { RaiseError => 1 } )
+ or die "can't connect to database";
$debug && &_LOG("CONNECTED!\n");
$self->databasehandle($dbh);
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/secondary_input.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /home/repository/moby/moby-live/Perl/MOBY/secondary_input.pm 2004/06/16 01:15:30 1.1
+++ /home/repository/moby/moby-live/Perl/MOBY/secondary_input.pm 2004/11/18 17:41:14 1.2
@@ -1,12 +1,9 @@
#!/usr/bin/perl -w
-
package MOBY::secondary_input;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::secondary_input - a lightweight connection to the
@@ -36,140 +33,122 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- secondary_input_id => [undef, 'read/write'],
- default_value => [undef, 'read/write'],
- maximum_value => [undef, 'read/write'],
- minimum_value => [undef, 'read/write'],
- enum_value => [undef, 'read/write'],
- datatype => [undef, 'read/write'],
- article_name => [undef, 'read/write'],
- service_instance_id => [undef, 'read/write'],
- dbh => [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
+ (
+ secondary_input_id => [ undef, 'read/write' ],
+ default_value => [ undef, 'read/write' ],
+ maximum_value => [ undef, 'read/write' ],
+ minimum_value => [ undef, 'read/write' ],
+ enum_value => [ undef, 'read/write' ],
+ datatype => [ undef, 'read/write' ],
+ article_name => [ undef, 'read/write' ],
+ service_instance_id => [ undef, 'read/write' ],
+ dbh => [ 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 _dbh {
- my ($self) = @_;
-
- my $central_connect = MOBY::central_db_connection->new();
- $self->dbh($central_connect->dbh);
+ my ($self) = @_;
+ my $central_connect = MOBY::central_db_connection->new();
+ $self->dbh( $central_connect->dbh );
return $central_connect->dbh;
-
}
sub new {
- my ($caller, %args) = @_;
-
+ my ( $caller, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
+ 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 $datatype = $self->datatype;
- unless (($datatype =~ /Integer/) || ($datatype =~ /Float/) || ($datatype =~ /String/) || ($datatype =~ /DateTime/)){
- return undef
+ unless ( ( $datatype =~ /Integer/ )
+ || ( $datatype =~ /Float/ )
+ || ( $datatype =~ /String/ )
+ || ( $datatype =~ /DateTime/ ) )
+ {
+ return undef;
}
-
my $id = $self->WRITE;
$self->secondary_input_id($id) if defined $id;
- return $self;
-
+ return $self;
}
sub WRITE {
my ($self) = @_;
my $dbh = $self->_dbh;
- $dbh->do(q{insert into secondary_input (default_value,maximum_value,minimum_value,enum_value,datatype,article_name,service_instance_id) values (?,?,?,?,?,?,?)},
- undef,
- ($self->default_value,
- $self->maximum_value,
- $self->minimum_value,
- $self->enum_value,
- $self->datatype,
- $self->article_name,
- $self->service_instance_id,
- )
- );
- my $id=$dbh->{mysql_insertid};
- return $id;
+ $dbh->do(
+q{insert into secondary_input (default_value,maximum_value,minimum_value,enum_value,datatype,article_name,service_instance_id) values (?,?,?,?,?,?,?)},
+ undef,
+ (
+ $self->default_value, $self->maximum_value,
+ $self->minimum_value, $self->enum_value,
+ $self->datatype, $self->article_name,
+ $self->service_instance_id,
+ )
+ );
+ my $id = $dbh->{mysql_insertid};
+ return $id;
}
-
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/service_instance.pm,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- /home/repository/moby/moby-live/Perl/MOBY/service_instance.pm 2004/07/30 00:40:09 1.8
+++ /home/repository/moby/moby-live/Perl/MOBY/service_instance.pm 2004/11/18 17:41:14 1.9
@@ -1,9 +1,7 @@
package MOBY::service_instance;
-
use SOAP::Lite;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
use MOBY::central_db_connection;
use MOBY::OntologyServer;
@@ -49,405 +47,420 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- service_instance_id => [undef, 'read/write'],
- category => [undef, 'read/write'],
- servicename => [undef, 'read/write'],
- _authority => [undef, 'read/write'], # the authority object
- service_type => [undef, 'read/write'],
- service_type_uri => [undef, 'read/write'],
- authority => [undef, 'read/write'],
- authority_uri => [undef, 'read/write'],
- signatureURL => [undef, 'read/write'],
- url => [undef, 'read/write'],
- inputs => [undef, 'read/write'],
- outputs => [undef, 'read/write'],
- secondaries => [undef, 'read/write'],
- contact_email => [undef, 'read/write'],
- authoritative => [0, 'read/write'],
- description => [undef, 'read/write'],
- registry => ['MOBY_Central', 'read/write'],
- test => [0, 'read/write'], # toggles create or test_existence behaviour
- );
-
- #_____________________________________________________________
-
- # 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 service_name { # give them a break if they chose service_name or servicename as the parameter
- my ($self, $val) = @_;
- if (defined $val){
- if (defined $self->{servicename}){
- return undef # you are not allowed to change it once it has been set!
- } else {
- $self->{servicename} = $val;
- }
- }
- return $self->{servicename}
- }
-
- sub category {
- my ($self, $val) = @_;
- if ((defined $val) && $self->category){return undef}
- (defined $val) && ($self->{category} = $val);
- return $self->{category}
- }
- sub service_type {
- my ($self, $val) = @_;
- if (defined $val && $self->service_type){return undef}
- (defined $val) && ($self->{service_type} = $val);
- return $self->{service_type}
- }
- sub url{
- my ($self, $val) = @_;
- if (defined $val && $self->url){return undef}
- (defined $val) && ($self->{url} = $val);
- return $self->{url}
- }
- sub signatureURL{
- my ($self, $val) = @_;
- if (defined $val && $self->signatureURL){return undef}
- (defined $val) && ($self->{signatureURL} = $val);
- return $self->{signatureURL}
- }
- sub contact_email {
- my ($self, $val) = @_;
- if (defined $val && $self->contact_email){return undef}
- (defined $val) && ($self->{contact_email} = $val);
- return $self->{contact_email}
- }
- sub description {
- my ($self, $val) = @_;
- if (defined $val && $self->description){return undef}
- (defined $val) && ($self->{description} = $val);
- return $self->{description}
- }
-
+ my %_attr_data = # DEFAULT ACCESSIBILITY
+ (
+ service_instance_id => [ undef, 'read/write' ],
+ category => [ undef, 'read/write' ],
+ servicename => [ undef, 'read/write' ],
+ _authority => [ undef, 'read/write' ], # the authority object
+ service_type => [ undef, 'read/write' ],
+ service_type_uri => [ undef, 'read/write' ],
+ authority => [ undef, 'read/write' ],
+ authority_uri => [ undef, 'read/write' ],
+ signatureURL => [ undef, 'read/write' ],
+ url => [ undef, 'read/write' ],
+ inputs => [ undef, 'read/write' ],
+ outputs => [ undef, 'read/write' ],
+ secondaries => [ undef, 'read/write' ],
+ contact_email => [ undef, 'read/write' ],
+ authoritative => [ 0, 'read/write' ],
+ description => [ undef, 'read/write' ],
+ registry => [ 'MOBY_Central', 'read/write' ],
+ test => [ 0, 'read/write' ]
+ , # toggles create or test_existence behaviour
+ );
+
+ #_____________________________________________________________
+ # 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 service_name
+ { # give them a break if they chose service_name or servicename as the parameter
+ my ( $self, $val ) = @_;
+ if ( defined $val ) {
+ if ( defined $self->{servicename} ) {
+ return
+ undef # you are not allowed to change it once it has been set!
+ } else {
+ $self->{servicename} = $val;
+ }
+ }
+ return $self->{servicename};
+ }
+
+ sub category {
+ my ( $self, $val ) = @_;
+ if ( ( defined $val ) && $self->category ) { return undef }
+ ( defined $val ) && ( $self->{category} = $val );
+ return $self->{category};
+ }
+
+ sub service_type {
+ my ( $self, $val ) = @_;
+ if ( defined $val && $self->service_type ) { return undef }
+ ( defined $val ) && ( $self->{service_type} = $val );
+ return $self->{service_type};
+ }
+
+ sub url {
+ my ( $self, $val ) = @_;
+ if ( defined $val && $self->url ) { return undef }
+ ( defined $val ) && ( $self->{url} = $val );
+ return $self->{url};
+ }
+
+ sub signatureURL {
+ my ( $self, $val ) = @_;
+ if ( defined $val && $self->signatureURL ) { return undef }
+ ( defined $val ) && ( $self->{signatureURL} = $val );
+ return $self->{signatureURL};
+ }
+
+ sub contact_email {
+ my ( $self, $val ) = @_;
+ if ( defined $val && $self->contact_email ) { return undef }
+ ( defined $val ) && ( $self->{contact_email} = $val );
+ return $self->{contact_email};
+ }
+
+ sub description {
+ my ( $self, $val ) = @_;
+ if ( defined $val && $self->description ) { return undef }
+ ( defined $val ) && ( $self->{description} = $val );
+ return $self->{description};
+ }
+
sub dbh {
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral')->dbh;
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor =
+ $CONFIG->getDataAdaptor( datasource => 'mobycentral' )->dbh;
}
+
sub adaptor {
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral');
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' );
}
}
#sub _dbh {
# my ($self) = @_;
-#
+#
# my $central_connect = MOBY::central_db_connection->new();
# $self->dbh($central_connect->dbh);
#}
-
sub new {
- my ($caller, %args) = @_;
-
+ my ( $caller, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $caller;
+ return $caller if $caller_is_obj;
+ my $class = $caller_is_obj || $caller;
my $proxy;
-
- my ($self) = bless {}, $class;
+ 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);
+ }
+ }
- 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) }
- }
-# category => $Category,
-# servicename => $serviceName,
-# service_type => $serviceType,
-# authority_uri => $AuthURI,
-# url => $URL,
-# contact_email => $contactEmail,
-# authoritative => $authoritativeService,
-# description => $desc,
-#
- return undef unless $self->authority_uri;
- return undef unless $self->servicename;
-
- #$self->_dbh();
- #return undef unless $self->dbh;
- #my $dbh = $self->dbh;
-
- if ($self->test){ return $self->service_instance_exists}
-
- $self->authority($self->_get_authority()); # this might not be necessary - it simply converts auth_uri to auth_id and v.v.?
- # it actually is necessary for the moment. We need to put the logic of determining
- # service id into the mysql.pm module!!
-
- if ($self->service_type){
- my $OE = MOBY::OntologyServer->new(ontology => 'service');
- my ($success, $message, $servicetypeURI) = $OE->serviceExists(term => $self->service_type);
- unless (($success || (($self->service_type =~ /urn:lsid/i) && !($self->service_type =~ /urn:lsid:biomoby.org/i)))){return undef}
- ($self->service_type =~ /urn:lsid/)?$self->service_type_uri($self->service_type):$self->service_type_uri($servicetypeURI);
- }
-
- my $existing_service = $self->adaptor->query_service_instance (servicename => $self->servicename, authURI => $self->authority_uri);
-
-
-
- if (($existing_service) # if it exists, you are not allowed to have passed anything other than service name and authorityURI
- && ((defined $self->category)
- || (defined $self->service_type)
- || (defined $self->url)
- || (defined $self->contact_email)
- || (defined $self->description))){
- return -1; # no no no, not alowed to do that! I will not give you an object
- } elsif ($existing_service){ # if service exists, then instantiate it from the database retrieval we just did
- $self->service_instance_id($existing_service->{'serviceid'});
- $self->category($existing_service->{'category'});
- $self->service_type($existing_service->{'servicetype'});
- $self->url($existing_service->{'url'});
- $self->contact_email($existing_service->{'email'});
- $self->description($existing_service->{'desc'});
- $self->authority($existing_service->{'authURI'});
- $self->signatureURL($existing_service->{'signatureURL'});
-
- $self->{__exists__} = 1; # this service already existed
- } elsif (!($existing_service) # if it doesn't exist
- && (defined $self->category) # and you have given me things I need to create it
- && (defined $self->service_type)
- && (defined $self->url)
- && (defined $self->contact_email)
- && (defined $self->description))
- { # then create it de novo if we have enough information
+ # category => $Category,
+ # servicename => $serviceName,
+ # service_type => $serviceType,
+ # authority_uri => $AuthURI,
+ # url => $URL,
+ # contact_email => $contactEmail,
+ # authoritative => $authoritativeService,
+ # description => $desc,
+ #
+ return undef unless $self->authority_uri;
+ return undef unless $self->servicename;
+
+ #$self->_dbh();
+ #return undef unless $self->dbh;
+ #my $dbh = $self->dbh;
+ if ( $self->test ) { return $self->service_instance_exists }
+ $self->authority( $self->_get_authority() )
+ ; # this might not be necessary - it simply converts auth_uri to auth_id and v.v.?
+ # it actually is necessary for the moment. We need to put the logic of determining
+ # service id into the mysql.pm module!!
+ if ( $self->service_type ) {
+ my $OE = MOBY::OntologyServer->new( ontology => 'service' );
+ my ( $success, $message, $servicetypeURI ) =
+ $OE->serviceExists( term => $self->service_type );
+ unless (
+ (
+ $success
+ || ( ( $self->service_type =~ /urn:lsid/i )
+ && !( $self->service_type =~ /urn:lsid:biomoby.org/i ) )
+ )
+ )
+ {
+ return undef;
+ }
+ ( $self->service_type =~ /urn:lsid/ )
+ ? $self->service_type_uri( $self->service_type )
+ : $self->service_type_uri($servicetypeURI);
+ }
+ my $existing_service = $self->adaptor->query_service_instance(
+ servicename => $self->servicename,
+ authURI => $self->authority_uri );
+ if (
+ ($existing_service
+ ) # if it exists, you are not allowed to have passed anything other than service name and authorityURI
+ && ( ( defined $self->category )
+ || ( defined $self->service_type )
+ || ( defined $self->url )
+ || ( defined $self->contact_email )
+ || ( defined $self->description ) )
+ )
+ {
+ return
+ -1; # no no no, not alowed to do that! I will not give you an object
+ } elsif ($existing_service)
+ { # if service exists, then instantiate it from the database retrieval we just did
+ $self->service_instance_id( $existing_service->{'serviceid'} );
+ $self->category( $existing_service->{'category'} );
+ $self->service_type( $existing_service->{'servicetype'} );
+ $self->url( $existing_service->{'url'} );
+ $self->contact_email( $existing_service->{'email'} );
+ $self->description( $existing_service->{'desc'} );
+ $self->authority( $existing_service->{'authURI'} );
+ $self->signatureURL( $existing_service->{'signatureURL'} );
+ $self->{__exists__} = 1; # this service already existed
+ } elsif (
+ !($existing_service) # if it doesn't exist
+ && (
+ defined $self->category
+ ) # and you have given me things I need to create it
+ && ( defined $self->service_type )
+ && ( defined $self->url )
+ && ( defined $self->contact_email )
+ && ( defined $self->description )
+ )
+ { # then create it de novo if we have enough information
my $id = $self->adaptor->insert_service_instance(
- category => $self->category,
- servicename => $self->servicename,
- service_type_uri => $self->service_type_uri,
- authority_id => $self->authority_id,
- url => $self->url,
- contact_email => $self->contact_email,
- authoritative => $self->authoritative,
- description => $self->description,
- signatureURL => $self->signatureURL,
- );
-
- $self->service_instance_id($id);
- $self->{__exists__} = 1; # this service now exists
- } else { # if it doesn't exist, and you havne't given me anyting I need to create it, then bail out
- return undef;
- }
- return $self;
-
+ category => $self->category,
+ servicename => $self->servicename,
+ service_type_uri => $self->service_type_uri,
+ authority_id => $self->authority_id,
+ url => $self->url,
+ contact_email => $self->contact_email,
+ authoritative => $self->authoritative,
+ description => $self->description,
+ signatureURL => $self->signatureURL,
+ );
+ $self->service_instance_id($id);
+ $self->{__exists__} = 1; # this service now exists
+ } else { # if it doesn't exist, and you havne't given me anyting I need to create it, then bail out
+ return undef;
+ }
+ return $self;
}
sub DELETE_THYSELF {
- my ($self) = @_;
- my $dbh = $self->dbh;
- unless ($self->{__exists__}){
- return undef
- }
- $CONFIG ||=MOBY::Config->new;
-
- $dbh->do(q{delete from service_instance where service_instance_id = ?},undef,$self->service_instance_id);
- $dbh->do(q{delete from simple_input where service_instance_id = ?},undef,$self->service_instance_id);
- $dbh->do(q{delete from simple_output where service_instance_id = ?},undef,$self->service_instance_id);
- my $sth = $dbh->prepare(q{select collection_input_id from collection_input where service_instance_id = ?});
- $sth->execute($self->service_instance_id);
- while (my ($id) = $sth->fetchrow_array){
- $dbh->do(q{delete from simple_input where collection_input_id = ?},undef,$id);
- }
- $sth = $dbh->prepare(q{select collection_output_id from collection_output where service_instance_id = ?});
- $sth->execute($self->service_instance_id);
- while (my ($id) = $sth->fetchrow_array){
- $dbh->do(q{delete from simple_output where collection_output_id = ?},undef,$id);
- }
- $dbh->do(q{delete from collection_input where service_instance_id = ?},undef,$self->service_instance_id);
- $dbh->do(q{delete from collection_output where service_instance_id = ?},undef,$self->service_instance_id);
- $dbh->do(q{delete from secondary_input where service_instance_id=?}, undef, $self->service_instance_id);
- return 1;
+ my ($self) = @_;
+ my $dbh = $self->dbh;
+ unless ( $self->{__exists__} ) {
+ return undef;
+ }
+ $CONFIG ||= MOBY::Config->new;
+ $dbh->do( q{delete from service_instance where service_instance_id = ?},
+ undef, $self->service_instance_id );
+ $dbh->do( q{delete from simple_input where service_instance_id = ?},
+ undef, $self->service_instance_id );
+ $dbh->do( q{delete from simple_output where service_instance_id = ?},
+ undef, $self->service_instance_id );
+ my $sth =
+ $dbh->prepare(
+q{select collection_input_id from collection_input where service_instance_id = ?}
+ );
+ $sth->execute( $self->service_instance_id );
+ while ( my ($id) = $sth->fetchrow_array ) {
+ $dbh->do( q{delete from simple_input where collection_input_id = ?},
+ undef, $id );
+ }
+ $sth =
+ $dbh->prepare(
+q{select collection_output_id from collection_output where service_instance_id = ?}
+ );
+ $sth->execute( $self->service_instance_id );
+ while ( my ($id) = $sth->fetchrow_array ) {
+ $dbh->do( q{delete from simple_output where collection_output_id = ?},
+ undef, $id );
+ }
+ $dbh->do( q{delete from collection_input where service_instance_id = ?},
+ undef, $self->service_instance_id );
+ $dbh->do( q{delete from collection_output where service_instance_id = ?},
+ undef, $self->service_instance_id );
+ $dbh->do( q{delete from secondary_input where service_instance_id=?},
+ undef, $self->service_instance_id );
+ return 1;
}
-
sub authority_id {
- my ($self) = @_;
- return $self->authority->authority_id;
+ my ($self) = @_;
+ return $self->authority->authority_id;
}
sub service_instance_exists {
- my ($self) = @_;
- my $dbh = $self->dbh;
- my $authority;
- my ($id) = $dbh->selectrow_array(q{select authority_id from authority where authority_uri = ?},undef,$self->authority_uri);
- return undef unless $id;
- my ($svc) = $dbh->selectrow_array(q{select service_instance_id from service_instance where authority_id = ? and servicename = ?}, undef, ($id, $self->servicename));
- return $svc;
-}
-
-
-sub _get_authority { # there's somethign fishy here... the authority.pm object already knows about authority_id and authorty_uri, doens't it?
- my ($self) = @_;
- my $dbh = $self->dbh;
- my $authority;
- my ($id,$name,$uri,$email) = $dbh->selectrow_array(q{select authority_id, authority_common_name, authority_uri, contact_email from authority where authority_uri = ?},undef,$self->authority_uri);
- if (defined $id){
- $authority = MOBY::authority->new(
- dbh => $self->dbh,
- authority_id => $id,
- authority_uri => $uri,
- contact_email => $email,
- );
- } else {
- $authority = MOBY::authority->new(
- dbh => $self->dbh,
- authority_uri => $self->authority_uri,
- contact_email => $self->contact_email,
- );
- }
- return $authority;
+ my ($self) = @_;
+ my $dbh = $self->dbh;
+ my $authority;
+ my ($id) =
+ $dbh->selectrow_array(
+ q{select authority_id from authority where authority_uri = ?},
+ undef, $self->authority_uri );
+ return undef unless $id;
+ my ($svc) = $dbh->selectrow_array(
+q{select service_instance_id from service_instance where authority_id = ? and servicename = ?},
+ undef,
+ ( $id, $self->servicename )
+ );
+ return $svc;
+}
+
+sub _get_authority
+{ # there's somethign fishy here... the authority.pm object already knows about authority_id and authorty_uri, doens't it?
+ my ($self) = @_;
+ my $dbh = $self->dbh;
+ my $authority;
+ my ( $id, $name, $uri, $email ) = $dbh->selectrow_array(
+q{select authority_id, authority_common_name, authority_uri, contact_email from authority where authority_uri = ?},
+ undef, $self->authority_uri
+ );
+ if ( defined $id ) {
+ $authority = MOBY::authority->new(
+ dbh => $self->dbh,
+ authority_id => $id,
+ authority_uri => $uri,
+ contact_email => $email,
+ );
+ } else {
+ $authority = MOBY::authority->new(
+ dbh => $self->dbh,
+ authority_uri => $self->authority_uri,
+ contact_email => $self->contact_email,
+ );
+ }
+ return $authority;
}
sub add_simple_input {
- my ($self, %a) = @_;
-
-# validate here... one day...
+ my ( $self, %a ) = @_;
+ # validate here... one day...
my $simple = MOBY::simple_input->new(
- object_type_uri => $a{'object_type_uri'},
- namespace_type_uris => $a{'namespace_type_uris'},
- article_name => $a{'article_name'},
- service_instance_id => $self->service_instance_id,
- collection_input_id => $a{'collection_input_id'}
- );
-
- push @{$self->{inputs}}, $simple;
+ object_type_uri => $a{'object_type_uri'},
+ namespace_type_uris => $a{'namespace_type_uris'},
+ article_name => $a{'article_name'},
+ service_instance_id => $self->service_instance_id,
+ collection_input_id => $a{'collection_input_id'}
+ );
+ push @{ $self->{inputs} }, $simple;
return $simple->simple_input_id;
}
-
sub add_simple_output {
- my ($self, %a) = @_;
-
-# validate here... one day...
+ my ( $self, %a ) = @_;
+ # validate here... one day...
my $simple = MOBY::simple_output->new(
- object_type_uri => $a{'object_type_uri'},
- namespace_type_uris => $a{'namespace_type_uris'},
- article_name => $a{'article_name'},
- service_instance_id => $self->service_instance_id,
- collection_output_id => $a{'collection_output_id'}
- );
-
- push @{$self->{outputs}}, $simple;
+ object_type_uri => $a{'object_type_uri'},
+ namespace_type_uris => $a{'namespace_type_uris'},
+ article_name => $a{'article_name'},
+ service_instance_id => $self->service_instance_id,
+ collection_output_id => $a{'collection_output_id'}
+ );
+ push @{ $self->{outputs} }, $simple;
return $simple->simple_output_id;
}
-
sub add_collection_input {
- my ($self, %a) = @_;
-
-# validate here... one day...
+ my ( $self, %a ) = @_;
+ # validate here... one day...
my $coll = MOBY::collection_input->new(
- article_name => $a{'article_name'},
- service_instance_id => $self->service_instance_id,
- );
-
- push @{$self->{inputs}}, $coll;
+ article_name => $a{'article_name'},
+ service_instance_id => $self->service_instance_id, );
+ push @{ $self->{inputs} }, $coll;
return $coll->collection_input_id;
}
-
sub add_collection_output {
- my ($self, %a) = @_;
-
-# validate here... one day...
+ my ( $self, %a ) = @_;
+ # validate here... one day...
my $coll = MOBY::collection_output->new(
- article_name => $a{'article_name'},
- service_instance_id => $self->service_instance_id,
- );
-
- push @{$self->{outputs}}, $coll;
+ article_name => $a{'article_name'},
+ service_instance_id => $self->service_instance_id, );
+ push @{ $self->{outputs} }, $coll;
return $coll->collection_output_id;
}
-
sub add_secondary_input {
- my ($self, %a) = @_;
-
-# validate here... one day...
+ my ( $self, %a ) = @_;
+ # validate here... one day...
my $sec = MOBY::secondary_input->new(
- default_value => $a{'default_value'},
- maximum_value => $a{'maximum_value'},
- minimum_value => $a{'minimum_value'},
- enum_value => $a{'enum_value'},
- datatype => $a{'datatype'},
- article_name => $a{'article_name'},
- service_instance_id => $self->service_instance_id,
- );
-
- push @{$self->{inputs}}, $sec;
- return $sec->secondary_input_id;
-
+ default_value => $a{'default_value'},
+ maximum_value => $a{'maximum_value'},
+ minimum_value => $a{'minimum_value'},
+ enum_value => $a{'enum_value'},
+ datatype => $a{'datatype'},
+ article_name => $a{'article_name'},
+ service_instance_id => $self->service_instance_id,
+ );
+ push @{ $self->{inputs} }, $sec;
+ return $sec->secondary_input_id;
}
-
-
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/service_type.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /home/repository/moby/moby-live/Perl/MOBY/service_type.pm 2003/05/07 19:20:27 1.1
+++ /home/repository/moby/moby-live/Perl/MOBY/service_type.pm 2004/11/18 17:41:14 1.2
@@ -1,12 +1,9 @@
#!/usr/bin/perl -w
-
package MOBY::service_type;
use strict;
use Carp;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::service_type - a lightweight connection to the
@@ -35,97 +32,81 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- service_type_id=> [undef, 'read/write'],
- rdf_definition => [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_type_id => [ undef, 'read/write' ],
+ rdf_definition => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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;
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/simple_input.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- /home/repository/moby/moby-live/Perl/MOBY/simple_input.pm 2004/06/24 22:32:38 1.4
+++ /home/repository/moby/moby-live/Perl/MOBY/simple_input.pm 2004/11/18 17:41:14 1.5
@@ -1,13 +1,10 @@
#!/usr/bin/perl -w
-
package MOBY::simple_input;
use strict;
use Carp;
-use XML::DOM;
use MOBY::Config;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::simple_input - a lightweight connection to the
@@ -40,120 +37,102 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- simple_input_id => [undef, 'read/write'],
- object_type_uri => [undef, 'read/write'],
- namespace_type_uris => [undef, 'read/write'],
- article_name => [undef, 'read/write'],
- service_instance_id => [undef, 'read/write'],
- collection_input_id => [undef, 'read/write'],
- dbh => [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
+ (
+ simple_input_id => [ undef, 'read/write' ],
+ object_type_uri => [ undef, 'read/write' ],
+ namespace_type_uris => [ undef, 'read/write' ],
+ article_name => [ undef, 'read/write' ],
+ service_instance_id => [ undef, 'read/write' ],
+ collection_input_id => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
+ 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 $id = $self->WRITE;
$self->simple_input_id($id) if defined $id;
- return $self;
-
+ return $self;
}
-
sub WRITE {
my ($self) = @_;
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral');
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' );
my $id = $adaptor->insert_simple_input(
- object_type_uri => $self->object_type_uri,
- namespace_type_uris => $self->namespace_type_uris,
- article_name => $self->article_name,
- service_instance_id => $self->service_instance_id,
- collection_input_id => $self->collection_input_id,
- );
-
- return $id;
+ object_type_uri => $self->object_type_uri,
+ namespace_type_uris => $self->namespace_type_uris,
+ article_name => $self->article_name,
+ service_instance_id => $self->service_instance_id,
+ collection_input_id => $self->collection_input_id,
+ );
+ return $id;
}
-
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/simple_output.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- /home/repository/moby/moby-live/Perl/MOBY/simple_output.pm 2004/06/24 22:32:38 1.3
+++ /home/repository/moby/moby-live/Perl/MOBY/simple_output.pm 2004/11/18 17:41:15 1.4
@@ -1,13 +1,10 @@
#!/usr/bin/perl -w
-
package MOBY::simple_output;
use strict;
use Carp;
use MOBY::Config;
-use XML::DOM;
use vars qw($AUTOLOAD @ISA);
-
=head1 NAME
MOBY::simple_output - a lightweight connection to the
@@ -39,120 +36,102 @@
=cut
-
{
+
# Encapsulated:
# DATA
-
#___________________________________________________________
#ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- simple_output_id => [undef, 'read/write'],
- object_type_uri => [undef, 'read/write'],
- namespace_type_uris => [undef, 'read/write'],
- article_name => [undef, 'read/write'],
- service_instance_id => [undef, 'read/write'],
- collection_output_id => [undef, 'read/write'],
- dbh => [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
+ (
+ simple_output_id => [ undef, 'read/write' ],
+ object_type_uri => [ undef, 'read/write' ],
+ namespace_type_uris => [ undef, 'read/write' ],
+ article_name => [ undef, 'read/write' ],
+ service_instance_id => [ undef, 'read/write' ],
+ collection_output_id => [ undef, 'read/write' ],
+ dbh => [ 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, %args ) = @_;
my $caller_is_obj = ref($caller);
- return $caller if $caller_is_obj;
- my $class = $caller_is_obj || $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) }
- }
-
+ 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 $id = $self->WRITE;
$self->simple_output_id($id) if defined $id;
- return $self;
-
+ return $self;
}
sub WRITE {
my ($self) = @_;
- $CONFIG ||=MOBY::Config->new; # exported by Config.pm
- my $adaptor = $CONFIG->getDataAdaptor(datasource => 'mobycentral');
+ $CONFIG ||= MOBY::Config->new; # exported by Config.pm
+ my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' );
my $id = $adaptor->insert_simple_output(
- object_type_uri => $self->object_type_uri,
- namespace_type_uris => $self->namespace_type_uris,
- article_name => $self->article_name,
- service_instance_id => $self->service_instance_id,
- collection_output_id => $self->collection_output_id,
- );
-
- return $id;
+ object_type_uri => $self->object_type_uri,
+ namespace_type_uris => $self->namespace_type_uris,
+ article_name => $self->article_name,
+ service_instance_id => $self->service_instance_id,
+ collection_output_id => $self->collection_output_id,
+ );
+ return $id;
}
-
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