[MOBY-guts] biomoby commit
Mark Wilkinson
mwilkinson at dev.open-bio.org
Tue Jan 28 21:51:45 UTC 2003
Tue Jan 28 16:51:45 EST 2003
Update of /home/repository/moby/moby-live/Perl/Central/MOBY
In directory dev:/tmp/cvs-serv19891/Perl/Central/MOBY
Modified Files:
Central.pm
Removed Files:
Registration.pm
Log Message:
A total rewrite of the MOBY Central interface, along with a rewrite of the Perl client-side wrapper. MOBY Central is no longer object oriented (->new method is deprecated), all messages are XML objects rather than Perl objects, some additional methods have been added to deregister namespaces and service types, i fixed some of the SQL logic that was faulty, and i cleaned up the return data so that it is consistent from call to call. i have fixed the various client scripts here in the Perl repository, but I have not yet fixed the CGI-based client running at CBR Halifax, nor have I updated the public MOBY::Central with this new code. I will do that within the next 24 hours - in the meantime, you may well find that everything is broken. Once everything is uploaded and tweaked I will update the documentation on the BioMOBY website to reflect the new API. In the meantime, you can get the latest documentation from Perldoc or pod2html.
moby-live/Perl/Central/MOBY Central.pm,1.1,1.2 Registration.pm,1.2,NONE
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/Central/MOBY/Central.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- /tmp/T0NoaO5M 2003-01-28 16:51:45.620008916 -0500
+++ /tmp/T1OoaO5M 2003-01-28 16:51:45.630005781 -0500
@@ -10,51 +10,28 @@
use vars qw($AUTOLOAD);
use DBI;
use DBD::mysql;
-use MOBY::Registration;
+use XML::DOM;
+#use MOBY::Registration;
my $debug = 1;
-if ($debug){open (OUT, ">/tmp/CentralRegistryLogOut.txt") || die "cant open logfile\n";close OUT;}
+if ($debug){open (OUT, ">/tmp/CentralRegistryLogOut.txt") || die "cant open logfile\n";print OUT "created logfile\n";close OUT;}
-
-{
- #Encapsulated class data
-
- #___________________________________________________________
- #ATTRIBUTES
- my %_attr_data = # DEFAULT ACCESSIBILITY
- (
- config => ["./MOBY/central.cfg", '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];
- }
+=head1 SYNOPSIS
- # List of names of all specified object attributes
- sub _standard_keys {
- keys %_attr_data;
- }
+If you are a Perl user, you should be using the
+MOBY::Client:Central module to talk to MOBY-Central
-}
+If you need to connect directly, here is how it
+is done in perl 5.6 and 5.6.1. It wont work
+in Perl 5.8... sorry. Look how MOBY::Client::Cent
+does it if you want to use Perl 5.8
-=head1 SYNOPSIS
-
--------------------------------------
SERVER-SIDE
@@ -70,21 +47,37 @@
CLIENT-SIDE
use SOAP::Lite +autodispatch =>
- proxy => 'http://192.168.1.9/cgi-bin/MOBY-Central.pl',
+ proxy => 'http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY-Central.pl',
on_fault => sub {
my($soap, $res) = @_;
die ref $res ? $res->faultstring : $soap->transport->status, "\n";
};
my $Central = MOBY::Central->new;
- my $reg = $Central->registerService(
- "RetrieveSeq", # serviceName
- "retrieve", # serviceType
- 'mwilkinson at gene.pbi.nrc.ca', # Authority URI
- ["GenbankID"], # input objects
- ["Sequence"], # output objects
- "http://bioinfo.pbi.nrc.ca/cgi-bin/GetSeq.pl", # URL to the service script
- "retrieves a sequence based on a genbank accession input", # service description
+ my $reg = $Central->registerService("
+ <registerService>
+ <serviceName>YourServiceNameHere</serviceName>
+ <serviceType>YourServiceTypeHere</serviceType>
+ <authURI>your.URI.here</authURI>
+ <inputObjects>
+ <input>
+ <objectType>ObjectType1</objectType>
+ <namespaceType>NamespaceType1</namespaceType>
+ </input>
+ <input>
+ <objectType>ObjectType2</objectType>
+ <namespaceType>NamespaceType2</namespaceType>
+ </input>
+ </inputObjects>
+ <outputObjects>
+ <objectType>ObjectType1</objectType>
+ <objectType>ObjectType2</objectType>
+ </outputObjects>
+ <URL>http://URL.to.your/Service.pl</URL>
+ <description><![CDATA[
+ human readable description of your service]]>
+ </description>
+ </registerService>"
);
print "success ", $reg->success;
print "\nerror_message ", $reg->error_message;
@@ -104,11 +97,50 @@
=head1 AUTHORS
-Mark Wilkinson (mwilkinson at gene.pbi.nrc.ca)
-Plant Biotechnology Institute, National Research Council of Canada.
+Mark Wilkinson (markw at illuminae.com)
BioMOBY Project: http://www.biomoby.org
+=cut
+
+
+=head1 Registration XML Object
+
+This is sent back to you for all registration and
+deregistration calls
+
+ <MOBYRegistration>
+ <success>$success</success>
+ <id>$id</id>
+ <message><![CDATA[$message]]></message>
+ </MOBYRegistration>
+
+
+success is a boolean indicating a
+successful or a failed registration
+
+id is the deregistration ID of your registered
+object or service to use in a deregister call.
+
+message will contain any additional information
+such as the reason for failure.
+
+
+=cut
+
+
+sub Registration {
+ my ( $details) = @_;
+ my $id = $details->{registration_id};
+ my $success = $details->{success};
+ my $message = $details->{error_message};
+
+ return "<MOBYRegistration>
+ <id>$id</id>
+ <success>$success</success>
+ <message><![CDATA[$message]]></message>
+ </MOBYRegistration>";
+}
=cut
@@ -119,17 +151,7 @@
=head2 new
Title : new
- Usage : my $MOBY = MOBY::Central->new(config => $config_filename)
- Function : connect to MOBY-Central
- Returns : MOBY::Central object
- Args : config - optional, default "./MOBY/central.cfg"
- This file location is relative to the CGI script that calls
- this module, not to this module itself!!
- File contains:
- MOBY Central Database IP Address\n
- Database Name\n
- Username\n
- Password\n
+ Usage : deprecated
=cut
@@ -137,32 +159,14 @@
sub new {
my ($caller, %args) = @_;
-
- my $caller_is_obj = ref($caller);
- my $class = $caller_is_obj || $caller;
-
- my $self = bless {}, $class;
- &_LOG("Initializing");
-
- foreach my $attrname ( $self->_standard_keys ) {
- &_LOG("examining attribute $attrname");
- if (exists $args{$attrname}) {
- $self->{$attrname} = $args{$attrname} }
- elsif ($caller_is_obj) {
- $self->{$attrname} = $caller->{$attrname} }
- else {
- $self->{$attrname} = $self->_default_for($attrname) }
- &_LOG($self->config);
- }
-
- return $self;
-
+ print STDERR "\nuse of MOBY::Central->new is deprecated\n";
+ return 1;
}
sub _dbAccess {
- my ($self) = @_;
- my $filename = $self->config;
- open (IN, $filename) || die "can't open config file $filename: $!";
+ my $filename = "./MOBY/central.cfg";# $self->config;
+ &_LOG("trying to open file $filename\n");
+ open (IN, $filename) || die "can't open configuration file $filename: $!";
my $url = <IN>; chomp $url;
my $dbname = <IN>; chomp $dbname;
my $username = <IN>; chomp $username;
@@ -177,79 +181,88 @@
my %sth;
# queries required for registration
- $sth{check_object} = $dbh->prepare("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
- $sth{check_namespace} = $dbh->prepare("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Namespace'");
- $sth{check_service_type} = $dbh->prepare("select OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and O.id = OE.ontology_id and O.name = 'MOBY_Service'");
- $sth{insert_service} = $dbh->prepare("insert into Service (service_name, service_type_id, auth_uri, url, description, registration_identifier) values (?,?,?,?,?,?)");
- $sth{insert_parameter} = $dbh->prepare("insert into ServiceParameter (service_id, ontologyentry_id, type) values (?,?,?)");
+ $sth{check_object} = ("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
+ $sth{check_namespace} = ("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Namespace'");
+ $sth{check_service_type} = ("select OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and O.id = OE.ontology_id and O.name = 'MOBY_Service'");
+ $sth{check_service} = ("select S.id from Service as S where auth_uri = ? and service_name = ?");
+ $sth{insert_service} = ("insert into Service (service_name, service_type_id, auth_uri, url, description, registration_identifier) values (?,?,?,?,?,?)");
+ $sth{insert_parameter} = ("insert into ServiceParameter (service_id, ontologyentry_id, type) values (?,?,?)");
# queries required for Deregistration
- $sth{service_id} = $dbh->prepare("Select id from Service where registration_identifier = ?");
- $sth{remove_service} = $dbh->prepare("DELETE FROM Service where id = ?");
- $sth{remove_service_params} = $dbh->prepare("delete from ServiceParameter where service_id = ?");
+ $sth{service_id} = ("Select id from Service where registration_identifier = ?");
+ $sth{remove_service} = ("DELETE FROM Service where id = ?");
+ $sth{remove_service_params} = ("delete from ServiceParameter where service_id = ?");
# queries required for getServiceByType
- $sth{get_service_type_id} = $dbh->prepare("Select id from OntologyEntry where term = ?");
- $sth{get_service_hierarchy_list} = $dbh->prepare("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
- $sth{get_server_parameters} = $dbh->prepare("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 = ?");
+ $sth{get_service_type_id} = ("Select id from OntologyEntry where term = ?");
+ $sth{get_service_hierarchy_list} = ("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
+ $sth{get_server_parameters} = ("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 = ?");
# queries required for _traverseObjectDAG
- $sth{get_object_type_id} = $dbh->prepare("Select id from OntologyEntry where term = ?");
- $sth{get_object_parent_list} = $dbh->prepare("Select ontologyentry1_id from Term2Term where ontologyentry2_id = ?");
- $sth{get_object_child_list} = $dbh->prepare("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
+ $sth{get_object_type_id} = ("Select id from OntologyEntry where term = ?");
+ $sth{get_object_parent_list} = ("Select ontologyentry1_id from Term2Term where ontologyentry2_id = ?");
+ $sth{get_object_child_list} = ("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
# retrieveServiceProviders
- $sth{return_service_providers} = $dbh->prepare("Select distinct auth_uri from Service");
+ $sth{return_service_providers} = ("Select distinct auth_uri from Service");
#retrieveServiceNames
- $sth{return_service_names} = $dbh->prepare("select service_name, auth_uri from Service");
+ $sth{return_service_names} = ("select service_name, auth_uri from Service");
#retrieveServiceTypes
- $sth{return_service_types} = $dbh->prepare("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
+ $sth{return_service_types} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
#retrieveObjectNames
- $sth{retrieve_object_names} = $dbh->prepare("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
+ $sth{retrieve_object_names} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
#retrieveNamespaces
- $sth{retrieve_namespaces} = $dbh->prepare("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
+ $sth{retrieve_namespaces} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
#registerObject
- $sth{check_object_registration} = $dbh->prepare("select OE.accession, OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
- $sth{get_last_object_accession} = $dbh->prepare("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object'");
- $sth{register_object} = $dbh->prepare("insert into OntologyEntry (term, accession, ontology_id, description, authority, is_obselete) values (?,?,?,?,?, 'n')");
- $sth{deprecate_object} = $dbh->prepare("update OntologyEntry set is_obselete = 'y' where id=?");
- $sth{clobber_object} = $dbh->prepare("update OntologyEntry set term=?, ontology_id = ?, description = ?, authority=? where id = ?");
- $sth{register_object_xsd} = $dbh->prepare("insert into Object (ontologyentry_id, name, xsd) values (?,?,?)");
- $sth{clobber_object_xsd} = $dbh->prepare("update Object set name = ?, xsd = ? where ontologyentry_id = ?");
- $sth{register_object_relationship} = $dbh->prepare("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
+ $sth{check_object_registration} = ("select OE.accession, OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
+ $sth{get_last_object_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object'");
+ $sth{register_object} = ("insert into OntologyEntry (term, accession, ontology_id, description, authority, is_obselete) values (?,?,?,?,?, 'n')");
+ $sth{deprecate_object} = ("update OntologyEntry set is_obselete = 'y' where id=?");
+ $sth{clobber_object} = ("update OntologyEntry set term=?, ontology_id = ?, description = ?, authority=? where id = ?");
+ $sth{register_object_xsd} = ("insert into Object (ontologyentry_id, name, xsd) values (?,?,?)");
+ $sth{clobber_object_xsd} = ("update Object set name = ?, xsd = ? where ontologyentry_id = ?");
+ $sth{register_object_relationship} = ("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
#deregisterObject
- $sth{validate_object_deregistration} = $dbh->prepare("SELECT COUNT(S.id) FROM Service as S, OntologyEntry as OE, Ontology as O, ServiceParameter as SP where S.id = SP.service_id and SP.ontologyentry_id = OE.id and OE.ontology_id=O.id and O.name='MOBY_Object' and OE.accession=?");
- $sth{get_object_id} = $dbh->prepare("Select OE.id from OntologyEntry as OE, Ontology as O where OE.accession = ? and OE.ontology_id = O.id and O.name='MOBY_Object'");
- $sth{deregister_object_relationships} = $dbh->prepare("delete from Term2Term where ontologyentry1_id = ? or ontologyentry2_id = ?");
- $sth{deregister_object_xsd} = $dbh->prepare("delete from Object where ontologyentry_id=?");
- $sth{deregister_object} = $dbh->prepare("delete from OntologyEntry where id=?");
-
-
+ $sth{validate_object_deregistration} = ("SELECT COUNT(S.id) FROM Service as S, OntologyEntry as OE, Ontology as O, ServiceParameter as SP where S.id = SP.service_id and SP.ontologyentry_id = OE.id and OE.ontology_id=O.id and O.name='MOBY_Object' and OE.accession=?");
+ $sth{get_object_id} = ("Select OE.id from OntologyEntry as OE, Ontology as O where OE.accession = ? and OE.ontology_id = O.id and O.name='MOBY_Object'");
+ $sth{deregister_object_relationships} = ("delete from Term2Term where ontologyentry1_id = ? or ontologyentry2_id = ?");
+ $sth{deregister_object_xsd} = ("delete from Object where ontologyentry_id=?");
+ $sth{deregister_object} = ("delete from OntologyEntry where id=?");
+
+ #deregisterService
+ $sth{validate_service_deregistration} = ("SELECT COUNT(S.id) FROM Service as S, OntologyEntry as OE, Ontology as O, ServiceParameter as SP where S.id = SP.service_id and SP.ontologyentry_id = OE.id and OE.ontology_id=O.id and O.name='MOBY_Service' and OE.accession=?");
+ $sth{get_service_id} = ("Select OE.id from OntologyEntry as OE, Ontology as O where OE.accession = ? and OE.ontology_id = O.id and O.name='MOBY_Service'");
+ $sth{deregister_service_relationships} = ("delete from Term2Term where ontologyentry1_id = ? or ontologyentry2_id = ?");
+ $sth{deregister_service} = ("delete from OntologyEntry where id=?");
+
+ #deregisterNamespace
+ $sth{validate_namespace_deregistration} = ("SELECT COUNT(S.id) FROM Service as S, OntologyEntry as OE, Ontology as O, ServiceParameter as SP where S.id = SP.service_id and SP.ontologyentry_id = OE.id and OE.ontology_id=O.id and O.name='MOBY_Namespace' and OE.accession=?");
+ $sth{get_namespace_id} = ("Select OE.id from OntologyEntry as OE, Ontology as O where OE.accession = ? and OE.ontology_id = O.id and O.name='MOBY_Namespace'");
+ $sth{deregister_namespace} = ("delete from OntologyEntry where id=?");
+
#registernamespace
- $sth{get_last_namespace_accession} = $dbh->prepare("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
- $sth{get_existing_namespace_accession} = $dbh->prepare("select accession from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace' AND OE.term=? and OE.authority = ?");
- $sth{register_namespace} = $dbh->prepare("insert into OntologyEntry (term, authority, description, ontology_id, accession) values (?,?,?,?,?)");
- $sth{update_namespace} = $dbh->prepare("update OntologyEntry set term = ?, authority = ?, description = ? where ontology_id = ? and accession = ?");
+ $sth{get_last_namespace_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
+ $sth{get_existing_namespace_accession} = ("select accession from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace' AND OE.term=? and OE.authority = ?");
+ $sth{register_namespace} = ("insert into OntologyEntry (term, authority, description, ontology_id, accession) values (?,?,?,?,?)");
+ $sth{update_namespace} = ("update OntologyEntry set term = ?, authority = ?, description = ? where ontology_id = ? and accession = ?");
#registerServicetype
- $sth{check_service_registration} = $dbh->prepare("select OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Service'");
- $sth{get_last_service_accession} = $dbh->prepare("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
- $sth{register_service_type} = $dbh->prepare("insert into OntologyEntry (term, accession, ontology_id, description) values (?,?,?,?)");
- $sth{register_service_relationship} = $dbh->prepare("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
+ $sth{check_service_registration} = ("select OE.id, OE.accession from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Service'");
+ $sth{get_last_service_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
+ $sth{register_service_type} = ("insert into OntologyEntry (term, accession, ontology_id, description) values (?,?,?,?)");
+ $sth{register_service_relationship} = ("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
#retrieveObject
- $sth{retrieve_all_objects} = $dbh->prepare("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
- $sth{retrieve_one_object} = $dbh->prepare("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' AND OE.term =? and OE.is_obselete = 'n'");
-
- &_LOG("statement handles created\n");
+ $sth{retrieve_all_objects} = ("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
+ $sth{retrieve_one_object} = ("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' AND OE.term =? and OE.is_obselete = 'n'");
return ($dbh, \%sth);
}
@@ -258,49 +271,66 @@
=head2 registerObject
Title : registerObject
- Usage : $REG = $MOBY->registerObject($term, $desc, $xsd, \@ISA, $auth, $clobber)
+ Usage : $REG = $MOBY->registerObject($InputXML)
Function : register a new Object type, and its relationships, or modify existing
- Returns : MOBY::Registration object; registration_id is the objects accession number
- Args : (in order)
- $term : the name of the Object
- $desc : a human-readable description of the object
- $xsd : an xsd string describing the object structure
- i.e. everything between (excluding) the <xs:schema/> tags
- \@ISA : list ref of the names of the Parent Object types (or empty listref)
- $auth : a URI to the registrar of this object
- $clobber: 0,1,2: 0 = DON'T ; 1 = deprecate and re-register ; 2 = overwrite
+ Returns : Registration XML object; registration_id is the new object's accession number
+
+ InputXML :
+ <registerObject>
+ <objectType>NewObjectType</objectType>
+ <description><![CDATA[
+ human readable description
+ of data type]]></description>
+ <ISA>
+ <objectType>ExistingObjectType</objectType>
+ <objectType>ExistingObjectType</objectType>
+ </ISA>
+ <authURI>Your.URI.here</authURI>
+ <clobber>1 | 0</clobber>
+ <xsd><![CDATA[
+ the XSD for the new object goes here]]>
+ </xsd>
+ </registerObject>
+ OutputXML : see registration object XML
=cut
sub registerObject {
- my ($self, $term, $desc, $xsd, $ISA, $auth, $clobber) = @_;
+ my ($pkg, $payload) = @_;
- unless ($term && $desc && $xsd && $auth){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Term, Description, and XSD are all required parameters ",
- registration_id => "",
- );
+ $debug && &_LOG("\n\npayload\n**********************\n$payload\n***********************\n\n");
+ my ($term, $desc, $xsd, $ISA, $auth, $clobber) = &_registerObjectPayload($payload);
+
+ unless (defined $term && defined $desc && defined $xsd && defined $auth){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Term, Description, authURI and XSD are all required parameters ",
+ registration_id => "",
+ });
return $reg;
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
# check that it doesn't already exist
- $sth{check_object_registration}->execute($term);
- my ($existing_acc, $existing_id) = $sth{check_object_registration}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{check_object_registration});
+ $sth->execute($term);
+ my ($existing_acc, $existing_id) = $sth->fetchrow_array;
if ($existing_acc){
if ($clobber == 1){
- $sth{deprecate_object}->execute($existing_id);
+ my $sth = $dbh->prepare($sth{deprecate_object});
+ $sth->execute($existing_id);
} elsif ($clobber == 2) { # this is a REAL clobber, it overwrites
# do nothing here for the moment
} else {
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Object Type $term already exists",
- registration_id => "$existing_acc",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Object Type $term already exists",
+ registration_id => "$existing_acc",
+ });
return $reg;
}
}
@@ -309,15 +339,17 @@
if ($clobber ==2){
$last_acc = $existing_acc;
} else {
- $sth{get_last_object_accession}->execute;
- $last_acc = $sth{get_last_object_accession}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_last_object_accession});
+ $sth->execute;
+ $last_acc = $sth->fetchrow_array;
}
unless ($last_acc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "unable to determine last object accession number, or unable to find object you wish to clobber",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "unable to determine last object accession number, or unable to find object you wish to clobber",
+ registration_id => "",
+ });
return $reg;
}
@@ -326,40 +358,47 @@
my $new_acc = sprintf "%06u", $acc;
my $obj_id;
unless ($clobber ==2){
- $sth{register_object}->execute($term, $new_acc, 1, $desc, $auth);
+ my $sth = $dbh->prepare($sth{register_object});
+ $sth->execute($term, $new_acc, 1, $desc, $auth);
$obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Failed to register object for unknown reason",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Failed to register object for unknown reason",
+ registration_id => "",
+ });
return $reg;
}
} else {
- $sth{clobber_object}->execute($term, 1, $desc, $auth, $existing_id);
+ my $sth = $dbh->prepare($sth{clobber_object});
+ $sth->execute($term, 1, $desc, $auth, $existing_id);
$obj_id = $existing_id;
}
unless ($clobber == 2){
- $sth{register_object_xsd}->execute($obj_id, $term, $xsd);
+ my $sth = $dbh->prepare($sth{register_object_xsd});
+ $sth->execute($obj_id, $term, $xsd);
} else {
- $sth{clobber_object_xsd}->execute($term, $xsd, $obj_id);
+ my $sth = $dbh->prepare($sth{clobber_object_xsd});
+ $sth->execute($term, $xsd, $obj_id);
}
if ($ISA){
my @ISA = @{$ISA};
my @isa_ids;
foreach my $isa(@ISA){
- $sth{check_object_registration}->execute($isa);
- my ($isa_id) = $sth{check_object_registration}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{check_object_registration});
+ $sth->execute($isa);
+ my ($isa_id) = $sth->fetchrow_array;
unless ($isa_id){
$dbh->do("delete from OntologyEntry where id = $obj_id");
$dbh->do("delete from Object where ontologyentry_id = $obj_id");
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "ISA Object Type '$isa' was not registered",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "ISA Object Type '$isa' was not registered",
+ registration_id => "",
+ });
return $reg;
}
push @isa_ids, $isa_id;
@@ -369,137 +408,213 @@
}
foreach (@isa_ids){
- $sth{register_object_relationship}->execute($_, $obj_id, 1);
+ my $sth = $dbh->prepare($sth{register_object_relationship});
+ $sth->execute($_, $obj_id, 1);
}
}
- my $reg = MOBY::Registration->new(success => 1,
- error_message => "",
- registration_id => $new_acc,
- );
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $new_acc,
+ });
return $reg;
}
+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 'registerObject');
+
+ my $term = &_nodeTextContent($Object, "objectType");
+ my $desc = &_nodeTextContent($Object, "description");
+ my $authURI = &_nodeTextContent($Object, "authURI");
+ my $clobber = &_nodeTextContent($Object, "clobber");
+ my $xsd = &_nodeTextContent($Object, "xsd");
+ my @ISA = &_nodeArrayContent($Object, "ISA");
+ return ($term, $desc, $xsd, \@ISA, $authURI, $clobber);
+}
+
+
+
=head2 deregisterObject
Title : deregisterObject
- Usage : $REG = $MOBY->deregisterObject($registration_id)
+ Usage : $REG = $MOBY->deregisterObject($inputXML)
Function : de-register an Object type, and its relationships
- Returns : MOBY::Registration object; registration_id was the acc of the
- de-registered object.
- Args : $registration_id (this is the object's accession number)
+ Returns : MOBY Registration XML object; registration_id was the acc of the
+ now de-registered object.
Notes : THIS WILL FAIL IF ANY SERVICES DEPEND ON THAT OBJECT (IN/OUT)!
+ Use the accession number returned when you registered that object
+
+ inputXML :
+ <deregisterObject>
+ <objectAcc>000016</objectAcc>
+ </deregisterObject>
+
+ ouptutXML : see Registration XML object
=cut
sub deregisterObject {
- my ($self, $acc) = @_;
+ my ($pkg, $payload) = @_;
+
+ unless ($payload){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Message Format Incorrect",
+ registration_id => "",
+ });
+ return $reg;
+ }
+ my ($acc) = &_deregisterObjectPayload($payload);
+ &_LOG("object accession $acc\n");
unless ($acc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Must include an accession number to deregister",
- registration_id => "$acc",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Must include an accession number to deregister an object",
+ registration_id => "",
+ });
return $reg;
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{validate_object_deregistration}->execute($acc);
- my ($invalid) = $sth{validate_object_deregistration}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{validate_object_deregistration});
+ $sth->execute($acc);
+ my ($invalid) = $sth->fetchrow_array;
if ($invalid){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "This object has Service dependancies and may not be deregistered",
- registration_id => "$acc",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "This object has Service dependancies ($invalid) and may not be deregistered",
+ registration_id => "$acc",
+ });
return $reg;
}
- $sth{get_object_id}->execute($acc);
- my ($id) = $sth{get_object_id}->fetchrow_array;
+ $sth = $dbh->prepare($sth{get_object_id});
+ $sth->execute($acc);
+ my ($id) = $sth->fetchrow_array;
unless (defined $id){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Object does not exist",
- registration_id => "$acc",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Object does not exist",
+ registration_id => "$acc",
+ });
return $reg;
}
- $sth{deregister_object_relationships}->execute($id, $id);
- $sth{deregister_object_xsd}->execute($id);
- $sth{deregister_object}->execute($id);
+ $sth = $dbh->prepare($sth{deregister_object_relationships});
+ $sth->execute($id, $id);
+ $sth = $dbh->prepare($sth{deregister_object_xsd});
+ $sth->execute($id);
+ $sth = $dbh->prepare($sth{deregister_object});
+ $sth->execute($id);
- my $reg = MOBY::Registration->new(success => 1,
- error_message => "",
- registration_id => $acc,
- );
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $acc,
+ });
return $reg;
}
+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 'deregisterObject');
+
+ return &_nodeTextContent($Object, "objectAcc");
+}
+
=head2 registerServiceType
Title : registerServiceType
- Usage : $REG = $MOBY->registerServiceType($term, $desc, \@ISA)
+ Usage : $REG = $MOBY->registerServiceType($inputXML)
Function : register a new Service type, and its relationships
- Returns : MOBY::Registration object
- Args : (in order)
- $term : the name of the Service Type
- $desc : a human-readable description of the service type
- \@ISA : list-ref of the names of the Parent Service Types (optional)
+ Returns : MOBY Registration XML object
+ inputXML :
+ <registerServiceType>
+ <serviceType>NewServiceType</serviceType>
+ <description>
+ <![CDATA[ human description of service type here]]>
+ </description>
+ <ISA>
+ <serviceType>ExistingServiceType</serviceType>
+ <serviceType>ExistingServiceType</serviceType>
+ </ISA>
+ </registerServiceType>
+ outputXML : see Registration XML object
=cut
sub registerServiceType {
- my ($self, $term, $desc, $ISA) = @_;
+ my ($pkg, $payload) = @_;
+
+ my ($term, $desc, $ISA) = &_registerServiceTypePayload($payload);
unless ($term && $desc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Term and Description are both required parameters",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Term and Description are both required parameters",
+ registration_id => "",
+ });
return $reg;
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{check_service_registration}->execute($term);
- my ($existing_id) = $sth{check_service_registration}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{check_service_registration});
+ $sth->execute($term);
+ my ($existing_id, $acc) = $sth->fetchrow_array;
if ($existing_id){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Service Type $term already exists",
- registration_id => "$existing_id",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Service Type $term already exists",
+ registration_id => "$acc",
+ });
return $reg;
}
- $sth{get_last_service_accession}->execute;
- my ($last_acc) = $sth{get_last_service_accession}->fetchrow_array;
+ $sth = $dbh->prepare($sth{get_last_service_accession});
+ $sth->execute;
+ my ($last_acc) = $sth->fetchrow_array;
unless ($last_acc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "unable to determine last service accession number",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "unable to determine last service accession number",
+ registration_id => "",
+ });
return $reg;
}
- my $acc = (($last_acc =~ /0*(\d+)/) && $1);
+ $acc = (($last_acc =~ /0*(\d+)/) && $1);
$acc++;
my $new_acc = sprintf "%06u", $acc;
- $sth{register_service_type}->execute($term, $new_acc, 2, $desc);
+ $sth = $dbh->prepare($sth{register_service_type});
+ $sth->execute($term, $new_acc, 2, $desc);
my $obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Failed to register service type for unknown reason",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Failed to register service type for unknown reason",
+ registration_id => "",
+ });
return $reg;
}
@@ -507,42 +622,169 @@
my @ISA = @{$ISA};
my @isa_ids;
foreach my $isa(@ISA){
- $sth{check_service_registration}->execute($isa);
- my ($isa_id) = $sth{check_service_registration}->fetchrow_array;
+ $sth = $dbh->prepare($sth{check_service_registration});
+ $sth->execute($isa);
+ my ($isa_id, $acc) = $sth->fetchrow_array;
unless ($isa_id){
$dbh->do("delete from OntologyEntry where id = '$obj_id'");
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "ISA Service Type '$isa' is not registered",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "ISA Service Type '$isa' is not registered",
+ registration_id => "",
+ });
return $reg;
}
push @isa_ids, $isa_id;
} # all are valid registered types, so now register them as ISA
foreach (@isa_ids){
- $sth{register_service_relationship}->execute($_, $obj_id, 1);
+ my $sth = $dbh->prepare($sth{register_service_relationship});
+ $sth->execute($_, $obj_id, 1);
}
}
- my $reg = MOBY::Registration->new(success => 1,
- error_message => "",
- registration_id => $new_acc,
- );
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $new_acc,
+ });
return $reg;
}
+sub _registerServiceTypePayload {
+ my ($payload) = @_;
+ &_LOG("_registerServiceTypePayload payload=$payload\n");
+ my $Parser = new XML::DOM::Parser;
+ my $doc = $Parser->parse($payload);
+ my $Object = $doc->getDocumentElement();
+ my $obj = $Object->getTagName;
+ return undef unless ($obj eq 'registerServiceType');
+
+ my $type = &_nodeTextContent($Object, "serviceType");
+ my $desc = &_nodeTextContent($Object, "description");
+ my @ISA = &_nodeArrayContent($Object, "ISA");
+ &_LOG("got $type, $desc, @ISA from registerServiceTypePayload\n");
+ return ($type, $desc, \@ISA);
+
+}
+
+
+
+
+=head2 deregisterServiceType
+
+ Title : deregisterServiceType
+ Usage : $REG = $MOBY->deregisterServiceType($inputXML)
+ Function : de-register a Service type, and its relationships
+ Returns : MOBY Registration XML object; registration_id was the acc of the
+ now de-registered service.
+ Notes : THIS WILL FAIL IF ANY SERVICES EXIST OF THAT SERVICE TYPE!
+ Use the accession number returned when you registered that ServiceType
+
+ inputXML :
+ <deregisterServiceType>
+ <serviceTypeAcc>000016</serviceTypeAcc>
+ </deregisterServiceType>
+
+ ouptutXML : see Registration XML object
+
+
+=cut
+
+
+sub deregisterServiceType {
+ my ($pkg, $payload) = @_;
+
+ unless ($payload){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Message Format Incorrect",
+ registration_id => "",
+ });
+ return $reg;
+ }
+
+ my ($acc) = &_deregisterServiceTypePayload($payload);
+ $debug && &_LOG("deregister serviceType accession $acc\n");
+ unless ($acc){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Must include an accession number to deregister a serviceType",
+ registration_id => "",
+ });
+ return $reg;
+ }
+
+ my ($dbh, $sth_hash) = &_dbAccess;
+ my %sth = %{$sth_hash};
+
+ my $sth = $dbh->prepare($sth{validate_service_deregistration});
+ $sth->execute($acc);
+ my ($invalid) = $sth->fetchrow_array;
+ if ($invalid){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "This serviceType is currently used by $invalid existing Services and thus may not be deregistered",
+ registration_id => "$acc",
+ });
+ return $reg;
+ }
+ $sth = $dbh->prepare($sth{get_service_id});
+ $sth->execute($acc);
+ my ($id) = $sth->fetchrow_array;
+ unless (defined $id){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Service with accession $acc does not exist",
+ registration_id => "$acc",
+ });
+ return $reg;
+ }
+
+
+ $sth = $dbh->prepare($sth{deregister_service_relationships});
+ $sth->execute($id, $id);
+ $sth = $dbh->prepare($sth{deregister_service});
+ $sth->execute($id);
+
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $acc,
+ });
+ return $reg;
+}
+
+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, "serviceTypeAcc");
+}
+
+
+
=head2 registerNamespace
Title : registerNamespace
- Usage : $REG = $MOBY->registerNamespace($ns, $auth, $desc, $clobber)
+ Usage : $REG = $MOBY->registerNamespace($inputXML)
Function : register a new Namespace
- Returns : MOBY::Registration object
- Args : (in order)
- $ns : a namespace identifier
- $auth : a url/uri describing the owner of the namespace
- $desc : the description of that namespace's function
- $clobber : must take value "clobber" in order to overwrite existing entry
+ Returns : MOBY Registration XML object
+ inputXML :
+ <registerNamespace>
+ <namespaceType>NewNamespaceHere</namespaceType>
+ <authURI>Your.URI.here</authURI>
+ <description>
+ <![CDATA[human readable description]]>
+ </description>
+ <clobber>1 | 0</clobber>
+ </registerNamespace>
+
+ outputXML : see Registration XML object
=cut
@@ -550,99 +792,206 @@
sub registerNamespace {
- my ($self, $term, $auth, $desc, $clobber) = @_;
+ my ($pkg, $payload) = @_;
+ my ($term, $auth, $desc, $clobber) = &_registerNamespacePayload($payload);
unless ($term && $desc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Namespace identifier and description are required parameters",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Namespace identifier and description are required parameters",
+ registration_id => "",
+ });
return $reg;
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{get_existing_namespace_accession}->execute($term, $auth);
- my ($existing_acc) = $sth{get_existing_namespace_accession}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_existing_namespace_accession});
+ $sth->execute($term, $auth);
+ my ($existing_acc) = $sth->fetchrow_array;
if ($clobber ne "clobber" && $existing_acc) {
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "This namespace already exists",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "This namespace already exists",
+ registration_id => $existing_acc,
+ });
return $reg;
}
if ($clobber eq "clobber" && $existing_acc){
# update record
- $sth{update_namespace}->execute($term, $auth, $desc, 3, $existing_acc);
- my $reg = MOBY::Registration->new(success => 1,
- error_message => "",
- registration_id => $existing_acc,
- );
+ my $sth = $dbh->prepare($sth{update_namespace});
+ $sth->execute($term, $auth, $desc, 3, $existing_acc);
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $existing_acc,
+ });
return $reg;
} else {
# create new record
- $sth{get_last_namespace_accession}->execute;
- my ($last_acc) = $sth{get_last_namespace_accession}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_last_namespace_accession});
+ $sth->execute;
+ my ($last_acc) = $sth->fetchrow_array;
unless ($last_acc){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "unable to determine last service accession number",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "unable to determine last service accession number",registration_id => "",
+ });
return $reg;
}
my $acc = (($last_acc =~ /0*(\d+)/) && $1);
$acc++;
my $new_acc = sprintf "%06u", $acc;
- $sth{register_namespace}->execute($term, $auth, $desc, 3, $new_acc);
+ $sth = $dbh->prepare($sth{register_namespace});
+ $sth->execute($term, $auth, $desc, 3, $new_acc);
my $obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "Failed to register new namespace for unknown reason",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Failed to register new namespace for unknown reason",registration_id => "",
+ });
return $reg;
}
- my $reg = MOBY::Registration->new(success => 1,
- error_message => "",
- registration_id => $new_acc,
- );
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $new_acc,
+ });
return $reg;
}
}
+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 $clobber = &_nodeTextContent($Object, "clobber");
+
+ return ($type, $authURI, $desc, $clobber);
+
+}
+
+
+=head2 deregisterNamespace
+
+ Title : deregisterNamespace
+ Usage : $REG = $MOBY->deregisterNamespace($inputXML)
+ Function : de-register a Namespace
+ Returns : MOBY Registration XML object; registration_id was the acc of the
+ now de-registered Namespace.
+ Notes : THIS WILL FAIL IF ANY SERVICES EXIST WITHIN THAT NAMESPACE TYPE!
+ Use the accession number returned when you registered that namespaceType
+
+ inputXML :
+ <deregisterNamespace>
+ <namespaceAcc>000016</namespaceAcc>
+ </deregisterNamespace>
+
+ ouptutXML : see Registration XML object
+
+
+=cut
+
+
+sub deregisterNamespace {
+ my ($pkg, $payload) = @_;
+
+ unless ($payload){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Message Format Incorrect",
+ registration_id => "",
+ });
+ return $reg;
+ }
+
+ my ($acc) = &_deregisterNamespacePayload($payload);
+ $debug && &_LOG("deregister namespaceType accession $acc\n");
+ unless ($acc){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Must include an accession number to deregister a Namespace",
+ registration_id => "",
+ });
+ return $reg;
+ }
+
+ my ($dbh, $sth_hash) = &_dbAccess;
+ my %sth = %{$sth_hash};
+
+ my $sth = $dbh->prepare($sth{validate_namespace_deregistration});
+ $sth->execute($acc);
+ my ($invalid) = $sth->fetchrow_array;
+ if ($invalid){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "This namespaceType is currently used by $invalid existing Services and thus may not be deregistered",
+ registration_id => "$acc",
+ });
+ return $reg;
+ }
+ $sth = $dbh->prepare($sth{get_namespace_id});
+ $sth->execute($acc);
+ my ($id) = $sth->fetchrow_array;
+ unless (defined $id){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Namespace with accession $acc does not exist",
+ registration_id => "$acc",
+ });
+ return $reg;
+ }
+
+
+ $sth = $dbh->prepare($sth{deregister_namespace});
+ $sth->execute($id);
+
+ my $reg = &Registration({
+ success => 1,
+ error_message => "",
+ registration_id => $acc,
+ });
+ return $reg;
+}
+
+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, "namespaceAcc");
+}
+
+
+
+
+
+
+
=head2 registerService
Title : registerService
- Usage : $REG = $MOBY->registerService(@args)
+ Usage : $REG = $MOBY->registerService($inputXML)
Function : register a new MOBY Service
- Returns : MOBY::Registration object
- Args : (in order, all are required)
- $serviceName : chosen by the service provider (eg. MyBlast)
- this MUST be unique within all services at that URL,
- and is the name of the SOAP object method call
- that transacts the service.
- $serviceType : the name of the Parent Object type (from ontology)
- $AuthURI : location of service homepage with info about service & providor
- \@INS : a listref of zero or more MOBY object types (from ontology)
- accepted by this service as input.
- See Notes for additional important
- details.
- \@OUTS : a listref of zero or more MOBY object types (from ontology)
- accepted by this service as input.
- See Notes for additional important
- details.
- \@NameSpaces : a listref of zero or more namespaces (from controlled vocab)
- that this service knows about (eg. knows about GenBank/ID's)
- $URL : the full URL of the service (including script name)
- $desc : a human-readable description of the service
+ Returns : MOBY Registration XML object
Notes : 1) serviceName, AuthURI combination must be unique in database
2) @in/@out why lists? Often a MOBY Service will accept a single
MOBY object type as input and provide a single MOBY object
@@ -659,33 +1008,60 @@
relationship to each other; a list of input query-lists must be sent as a
list of collections.
+ inputXML :
+ <registerService>
+ <serviceName>YourServiceNameHere</serviceName>
+ <serviceType>YourServiceTypeHere</serviceType>
+ <authURI>your.URI.here</authURI>
+ <inputObjects>
+ <input>
+ <objectType>ObjectType1</objectType>
+ <namespaceType>NamespaceType1</namespaceType>
+ </input>
+ <input>
+ <objectType>ObjectType2</objectType>
+ <namespaceType>NamespaceType2</namespaceType>
+ </input>
+ </inputObjects>
+ <outputObjects>
+ <objectType>ObjectType1</objectType>
+ <objectType>ObjectType2</objectType>
+ </outputObjects>
+ <URL>http://URL.to.your/Service.pl</URL>
+ <description><![CDATA[
+ human readable description of your service]]>
+ </description>
+ </registerService>
=cut
sub registerService {
- my ($self, $serviceName, $serviceType, $AuthURI, $INS, $OUTS, $NS, $URL, $desc) = @_;
-
+ my ($pkg, $payload) = @_;
+ my ($serviceName, $serviceType, $AuthURI, $INS, $OUTS, $NSS, $URL, $desc) = &_registerServicePayload($payload);
unless ($serviceName && $serviceType && $AuthURI && $INS && $OUTS && $URL && $desc){ # throw error if parameter missing
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "not all required parameters present",
- registration_id => "",
- );
+ $debug && &_LOG("$serviceName && $serviceType && $AuthURI && $INS && $OUTS && $URL && $desc");
+ my $reg = &Registration({
+ success => 0,
+ error_message => "not all required parameters present",
+ registration_id => "",
+ });
return $reg;
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my @IN = @{$INS};
my @OUT = @{$OUTS};
- my @NS = @{$NS};
+ my @NS = @{$NSS};
unless ((scalar @IN) && (scalar @OUT)){ # throw error if parameter missing
- my $reg = MOBY::Registration->new(success => 0,
- error_message => "must include at least one input and one output object type",
- registration_id => "",
- );
+ my $reg = &Registration({
+ success => 0,
+ error_message => "must include at least one input and one output object type",
+ registration_id => "",
+ });
return $reg;
}
@@ -694,52 +1070,56 @@
}
foreach my $IN(@IN){
- $sth{check_object}->execute($IN);
- my ($valid) = $sth{check_object}->fetchrow_array; # returns the index number, might be zero
+ my $sth = $dbh->prepare($sth{check_object});
+ $sth->execute($IN);
+ my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 0,
error_message => "Input object $IN is not recognized as a valid MOBY_Object in the registry. Object may be deprecated.\n",
registration_id => "",
- );
+ });
return $reg;
}
}
foreach my $OUT(@OUT){
- $sth{check_object}->execute($OUT);
- my ($valid) = $sth{check_object}->fetchrow_array; # returns the index number, might be zero
+ my $sth = $dbh->prepare($sth{check_object});
+ $sth->execute($OUT);
+ my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 0,
error_message => "Output object $OUT is not recognized as a valid MOBY_Object in the registry. Object may be deprecated.\n",
registration_id => "",
- );
+ });
return $reg;
}
}
foreach my $NS(@NS){
next if ($NS eq "any");
- $sth{check_namespace}->execute($NS);
- my ($valid) = $sth{check_namespace}->fetchrow_array; # returns the index number, might be zero
+ my $sth = $dbh->prepare($sth{check_namespace});
+ $sth->execute($NS);
+ my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 0,
error_message => "Output object $NS is not recognized as a valid MOBY_Namespace in the registry\n",
registration_id => "",
- );
+ });
return $reg;
}
}
- $sth{check_service_type}->execute($serviceType);
- my ($service_type_id) = $sth{check_service_type}->fetchrow_array; # might return 0 as a valid table id
+ my $sth = $dbh->prepare($sth{check_service_type});
+ $sth->execute($serviceType);
+ my ($service_type_id) = $sth->fetchrow_array; # might return 0 as a valid table id
unless (defined $service_type_id){
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 0,
error_message => "Service Type $serviceType is not recognized as a valid MOBY_Service type in the registry\n",
registration_id => "",
- );
+ });
return $reg;
}
@@ -748,57 +1128,118 @@
for (my $x = 1; $x <=50; ++$x){
$reg_id .= int((rand) * 8) + 1;
}
-
- $sth{insert_service}->execute($serviceName,$service_type_id, $AuthURI, $URL, $desc, $reg_id);
+ $sth = $dbh->prepare($sth{check_service});
+ $sth->execute($AuthURI, $serviceName);
+ my ($existing_service) = $sth->fetchrow_array; # returns the index number, might be zero
+ if (defined $existing_service){
+ my $reg = &Registration({
+ success => 0,
+ error_message => "Service Type $serviceName is already registered in the $AuthURI namespace. Registration failed.\n",
+ registration_id => "",
+ });
+ return $reg;
+ }
+
+ $sth = $dbh->prepare($sth{insert_service});
+ $sth->execute($serviceName,$service_type_id, $AuthURI, $URL, $desc, $reg_id);
my $service_id = $dbh->{mysql_insertid};
foreach my $IN(@IN){
- $sth{check_object}->execute($IN);
- my ($ontologyentry_id) = $sth{check_object}->fetchrow_array; # returns the index number, might be zero
- $sth{insert_parameter}->execute($service_id, $ontologyentry_id, "in");
+ my $sth = $dbh->prepare($sth{check_object});
+ $sth->execute($IN);
+ my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
+ $sth = $dbh->prepare($sth{insert_parameter});
+ $sth->execute($service_id, $ontologyentry_id, "in");
}
foreach my $OUT(@OUT){
- $sth{check_object}->execute($OUT);
- my ($ontologyentry_id) = $sth{check_object}->fetchrow_array; # returns the index number, might be zero
- $sth{insert_parameter}->execute($service_id, $ontologyentry_id, "out");
+ my $sth = $dbh->prepare($sth{check_object});
+ $sth->execute($OUT);
+ my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
+ $sth = $dbh->prepare($sth{insert_parameter});
+ $sth->execute($service_id, $ontologyentry_id, "out");
}
foreach my $NS(@NS){ # may be "any"
- $sth{check_namespace}->execute($NS);
- my ($ontologyentry_id) = $sth{check_namespace}->fetchrow_array; # returns the index number, might be zero
- $sth{insert_parameter}->execute($service_id, $ontologyentry_id, "ns");
+ my $sth = $dbh->prepare($sth{check_namespace});
+ $sth->execute($NS);
+ my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
+ $sth = $dbh->prepare($sth{insert_parameter});
+ $sth->execute($service_id, $ontologyentry_id, "ns");
}
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $reg_id,
- );
+ });
return $reg; # and return it.
}
+
+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 $name = &_nodeTextContent($Object, "serviceName");
+ my $type = &_nodeTextContent($Object, "serviceType");
+ my $authURI = &_nodeTextContent($Object, "authURI");
+
+ my $inputRoot = $Object->getElementsByTagName("inputObjects")->item(0);
+
+ my @OUTS = &_nodeArrayContent($Object, "outputObjects");
+ my $URL = &_nodeTextContent($Object, "URL");
+ my $desc = &_nodeTextContent($Object, "description");
+
+# YES, I KNOW! This part throws away the association
+# Between objects and their namespace, but we have no
+# way to represent that in the database yet anyway
+# so poop on it!
+
+ my @types = $inputRoot->getElementsByTagName("objectType");
+ my @namespaces = $inputRoot->getElementsByTagName("namespaceType");
+ my (@INS, @NSS);
+ foreach (@types){
+ my @child2 = $_->getChildNodes;
+ foreach (@child2){
+ #print $_->getNodeTypeName, "\t", $_->toString,"\n";
+ next unless $_->getNodeType == TEXT_NODE;
+ push @INS, $_->toString;
+ }
+ }
+ foreach (@namespaces){
+ my @child2 = $_->getChildNodes;
+ foreach (@child2){
+ #print $_->getNodeTypeName, "\t", $_->toString,"\n";
+ next unless $_->getNodeType == TEXT_NODE;
+ push @NSS, $_->toString;
+ }
+ }
+
+ return ($name, $type, $authURI, \@INS, \@OUTS, \@NSS, $URL, $desc);
+}
+
+
+
=head2 registerServiceWSDL
Title : NOT YET IMPLEMENTED
- Usage : $REG = $MOBY->registerServiceType($serviceType, $WSDL)
- Function : register a new Service type, and its relationships, via WSDL
- Returns : MOBY::Registration object
- Args : (in order)
- $serviceType : the name of the Service Type (from ontology)
- $WSDL : a WSDL document describing your service
- (must be compatible with the MOBY ontologies)
+ Usage :
=cut
sub registerServiceWSDL {
- my ($self, $serviceType, $wsdl) = @_;
- my $reg = MOBY::Registration->new(
+ my ( $pkg, $serviceType, $wsdl) = @_;
+ my $reg = &Registration({
success => 0,
error_message => "not yet implemented\n",
registration_id => "",
- );
+ });
return $reg;
}
@@ -807,10 +1248,15 @@
=head2 deregisterService
Title : deregisterService
- Usage : $REG = $MOBY->deregisterService($reg_id)
+ Usage : $REG = $MOBY->deregisterService($inputXML)
Function : deregister a Service
- Returns : $REG object
- Args : $REG->registration_id of registered service
+ Returns : $REG object
+ inputXML :
+ <deregisterService>
+ <serviceID>234233343233443483784782929710874234</serviceID>
+ </deregisterService>
+
+ ouptutXML : see Registration XML object
=cut
@@ -818,68 +1264,88 @@
sub deregisterService {
- my ($self, $reg_id) = @_;
+ my ($pkg, $payload) = @_;
+ &_LOG("\nstarting deregistration\n");
+ my ($reg_id) = &_deregisterServicePayload($payload);
unless ($reg_id){
- my $reg = MOBY::Registration->new(
+ my $reg = &Registration({
success => 0,
error_message => "must provide a registration id number\n",
- registration_id => "",
- );
+ registration_id => 0,
+ });
}
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{service_id}->execute($reg_id);
- my ($sid) = $sth{service_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{service_id});
+ $sth->execute($reg_id);
+ my ($sid) = $sth->fetchrow_array;
return 0 unless $sid;
- $sth{remove_service}->execute($sid);
- $sth{remove_service_params}->execute($sid);
- return MOBY::Registration->new(
+ $sth = $dbh->prepare($sth{remove_service});
+ $sth->execute($sid);
+ $sth = $dbh->prepare($sth{remove_service_params});
+ $sth->execute($sid);
+ return &Registration({
success => 1,
error_message => "",
- registration_id => "",
- );
+ registration_id => 0,
+ });
+}
+
+sub _deregisterServicePayload {
+ my ($payload) = @_;
+ &_LOG("deregisterService payload: ",($payload),"\n");
+ my $Parser = new XML::DOM::Parser;
+ my $doc = $Parser->parse($payload);
+ my $Object = $doc->getDocumentElement();
+ my $obj = $Object->getTagName;
+ return undef unless ($obj eq 'deregisterService');
+ return &_nodeTextContent($Object, "serviceID");
}
=head2 locateServiceByType
Title : locateServiceByType
- Usage : $services = $MOBY->locateServiceByType($serviceType, $max, $expand)
+ Usage : $services = $MOBY->locateServiceByType($inputXML)
Function : get the service names/descriptions for a particular type of Service
(and child-types)
Returns : XML (see below)
- Args : (in order)
- $serviceType : the name of the Service Type (from ontology)
- $max_return : optional - how many WSDL documents to return at maximum
- $expand : optional - boolean, default 1, expand ontology
- to include child service-types
- XML : <Services>
- <Service authURI="authority.info.here" serviceName="MyService">
- <ServiceType>Service_Ontology_Term</ServiceType>
- <OutputObject>Object_Ontology_Term</OutputObject>
- <Description><![CDATA[free text description here]]></Description>
- </Service>
- ...
- ...
- </Services>
+ inputXML :
+ <locateServiceByType>
+ <serviceType>ServiceType</serviceType>
+ <fullServices>1 | 0</fullServices>
+ <locateServiceByType>
+
+ outputXML :
+ <Services>
+ <Service authURI="authority.info.here" serviceName="MyService">
+ <ServiceType>Service_Ontology_Term</ServiceType>
+ <OutputObject>Object_Ontology_Term</OutputObject>
+ <Description><![CDATA[free text description here]]></Description>
+ </Service>
+ ...
+ ...
+ </Services>
=cut
sub locateServiceByType {
- my ($self, $serviceType, $max_return,$full_services) = @_;
+ my ($pkg, $payload) = @_;
+ my ($serviceType, $full_services) = &_locateServiceByTypePayload($payload);
return undef unless $serviceType;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my @ServiceIDs;
if ($full_services){ # we need this service type and all child types
- @ServiceIDs = $self->_traverseServiceDAG($serviceType, $sth_hash);
+ @ServiceIDs = &_traverseServiceDAG($dbh,$serviceType, $sth_hash);
} else { # we need only the service type of this element
- $sth{get_service_type_id}->execute($serviceType);
- @ServiceIDs = $sth{get_service_type_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_service_type_id});
+ $sth->execute($serviceType);
+ @ServiceIDs = $sth->fetchrow_array;
}
# keys %ServiceIDs now contains the index number of all service types down the hierarchy from where we started (inclusive)
@@ -907,40 +1373,59 @@
and OEtype.ontology_id = O.id
and OEout.id = SPout.ontologyentry_id
and O.name='MOBY_Service'
- and OEtype.id in (".(join "'", @ServiceIDs).") ";
+ and OEtype.id in (".join (",", map {"\"".$_."\""} @ServiceIDs).") ";
- return $self->_getValidServices($dbh, $sth_hash, $query, $max_return);
+ return &_getValidServices($dbh, $sth_hash, $query);
}
+sub _locateServiceByTypePayload {
+ 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 'locateServiceByType');
+ my $type = &_nodeTextContent($Object, "serviceType");
+ my $expand = &_nodeTextContent($Object, "fullServices");
+ return ($type, $expand);
+}
+
=head2 locateServiceByInput
Title : locateServiceByInput
- Usage : $services = $MOBY->locateServiceByInput(@args)
+ Usage : $services = $MOBY->locateServiceByInput($inputXML)
Function : get the names/descriptions for services that use certain INPUT's
Returns : XML (see below)
- Args : (in order - must pass undef if you skip any)
- \@INs : listref of input Object types (
- currently connected by OR, but this will change)
- \@Namespaces : optional - restrict to those who handle these
- namespaces (eg. GenBank ID)
- $serviceType : optional - restrict to Service Type
- (from ontology)
- $AuthURI : optional - restrict to only these
- service providors
- $max_return : optional - restrict number returned
- $full_objects: boolean, default 1, traverse Object ontology
- $full_service: boolean, default 1, traverse Service ontology
- XML : <Services>
- <Service authURI="authority.info.here" serviceName="MyService">
- <ServiceType>Service_Ontology_Term</ServiceType>
- <OutputObject>Object_Ontology_Term</OutputObject>
- <Description><![CDATA[free text description here]]></Description>
- </Service>
- ...
- ...
- </Services>
+ inputXML :
+ <locateServiceByInput>
+ <inputObjects>
+ <input>
+ <objectType>ObjectType1</objectType>
+ <namespaceType>NamespaceType1</namespaceType>
+ </input>
+ <input>
+ <objectType>ObjectType2</objectType>
+ <namespaceType>NamespaceType2</namespaceType>
+ </input>
+ </inputObjects>
+ <serviceType>ServiceTypeTerm</serviceType>
+ <authURI>http://desired.service.provider</authURI>
+ <fullObjects>1|0</fullObjects>
+ <fullServices>1|0</fullServices>
+ <locateServiceByInput>
+
+ outputXML :
+ <Services>
+ <Service authURI="authority.info.here" serviceName="MyService">
+ <ServiceType>Service_Ontology_Term</ServiceType>
+ <OutputObject>Object_Ontology_Term</OutputObject>
+ <Description><![CDATA[free text description here]]></Description>
+ </Service>
+ ...
+ ...
+ </Services>
=cut
@@ -948,46 +1433,50 @@
sub locateServiceByInput {
- my ($self, $INs, $NSs, $serviceType, $AuthURI, $max_return, $full_objects, $full_services) = @_;
+ my ($pkg, $payload) = @_;
+ my ($serviceType, $AuthURI, $INs, $NSs, $full_objects, $full_services) = &_locateServiceByInputPayload($payload);
unless (defined $full_objects){$full_objects = 1}
unless (defined $full_services){$full_services = 1}
- #&_LOG("RECEIVED PARAMS: \n", join "\n", at _);
+ $debug && &_LOG("RECEIVED PARAMS: \n", join "\n", at _);
+
+ push @{$NSs}, "any"; # 'any' is a valid namespace for all service searches
return undef unless $INs;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
if ($serviceType && $full_services){ # we need this service type and all child types
- @ServiceIDs = $self->_traverseServiceDAG($serviceType, $sth_hash);
+ @ServiceIDs = &_traverseServiceDAG($dbh, $serviceType, $sth_hash);
} elsif ($serviceType) { # we need only the service type of this element
- $sth{get_service_type_id}->execute($serviceType);
- @ServiceIDs = $sth{get_service_type_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_service_type_id});
+ $sth->execute($serviceType);
+ @ServiceIDs = $sth->fetchrow_array;
}
my (@ObjectIDs, %ObjectIDs);
if ($full_objects){ # we need this Object type and all parent types
foreach (@{$INs}){
- &_LOG("traversing DAG for $_");
- foreach ($self->_traverseObjectDAG($_, $sth_hash, 'p')){
- &_LOG("found $_ in DAG");
+ $debug && &_LOG("traversing DAG for $_");
+ foreach (&_traverseObjectDAG($dbh, $_, $sth_hash, 'p')){
+ $debug && &_LOG("found $_ in DAG");
$ObjectIDs{$_}=1;
}
}
@ObjectIDs = keys %ObjectIDs;
} else { # we need only the Object type of the elements we were sent
foreach (@{$INs}){
- $sth{get_object_type_id}->execute($_);
- push @ObjectIDs, $sth{get_object_type_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_object_type_id});
+ $sth->execute($_);
+ push @ObjectIDs, $sth->fetchrow_array;
}
}
- &_LOG("INs @{$INs} ::: @ObjectIDs\n");
- if ($NSs){&_LOG("NSs @{$NSs} \n")};
- if ($serviceType){&_LOG("Servicetypes $serviceType, @ServiceIDs\n")};
-
+ $debug && &_LOG("INs @{$INs} ::: @ObjectIDs\n");
+ if ($NSs){$debug && &_LOG("NSs @{$NSs} \n")};
+ if ($serviceType){$debug && &_LOG("Servicetypes $serviceType, @ServiceIDs\n")};
my $query = "
Select
@@ -997,69 +1486,101 @@
S.description,
OEtype.term
from
- Service as S,
+ Service as S,
OntologyEntry as OEtype,
OntologyEntry as OEin,
OntologyEntry as OEout,
ServiceParameter as SPout,
- ServiceParameter as SPin,
+ ServiceParameter as SPin,
OntologyEntry as OEns,
ServiceParameter as SPns
where
OEin.is_obselete = 'n'
and OEout.is_obselete = 'n'
- and OEout.id = SPout.ontologyentry_id
- and SPout.service_id = S.id
and S.service_type_id = OEtype.id
- and SPin.service_id = S.id
- and SPin.service_id = SPns.service_id
- and SPout.service_id = SPns.service_id
- and OEin.id = SPin.ontologyentry_id
- and OEns.id = SPns.ontologyentry_id
- and SPin.type = 'in'
- and SPns.type = 'ns'
and SPout.type = 'out'
- and OEin.id in (". join (",", map {"\"".$_."\""} @ObjectIDs).") ";
- if ($NSs && ${$NSs}[0]){ # must have at least one element
- $query .= "
- and OEns.term in (". join (",", map {"\"".$_."\""} (@{$NSs}, "any")).") ";
- }
+ and SPout.service_id = S.id
+ and SPout.ontologyentry_id = OEout.id
+ and SPin.type = 'in'
+ and SPin.service_id = S.id
+ and SPin.ontologyentry_id = OEin.id
+ and SPns.type = 'ns'
+ and SPns.service_id = S.id
+ and SPns.ontologyentry_id=OEns.id
+ and OEin.id in (". join (",", map {"\"".$_."\""} @ObjectIDs).")
+ and OEns.term in (". join (",", map {"\"".$_."\""} @{$NSs}).") ";
if ($serviceType){ $query .= "and (S.service_type_id in (".(join ',', @ServiceIDs).")) "} # service type is a DAG, so get all relevant types
if ($AuthURI){ $query .= "and (S.auth_uri = '$AuthURI') "}
_LOG("*************************\ Query is: $query\n****************************");
- return $self->_getValidServices($dbh, $sth_hash, $query, $max_return);
+ return &_getValidServices($dbh, $sth_hash, $query);
}
+sub _locateServiceByInputPayload {
+
+ 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 'locateServiceByInput');
+ my $type = &_nodeTextContent($Object, "serviceType");
+ my $authURI = &_nodeTextContent($Object, "authURI");
+ my $fullObjects = &_nodeTextContent($Object, "fullObjects");
+ my $fullServices = &_nodeTextContent($Object, "fullServices");
+
+ my $x = $Object->getElementsByTagName("inputObjects");
+ my @types = $x->item(0)->getElementsByTagName("objectType");
+ my @namespaces = $x->item(0)->getElementsByTagName("namespaceType");
+ my (@INS, @NSS);
+ foreach (@types){
+ my @child2 = $_->getChildNodes;
+ foreach (@child2){
+ #print $_->getNodeTypeName, "\t", $_->toString,"\n";
+ next unless $_->getNodeType == TEXT_NODE;
+ push @INS, $_->toString;
+ }
+ }
+ foreach (@namespaces){
+ my @child2 = $_->getChildNodes;
+ foreach (@child2){
+ #print $_->getNodeTypeName, "\t", $_->toString,"\n";
+ next unless $_->getNodeType == TEXT_NODE;
+ push @NSS, $_->toString;
+ }
+ }
+
+ return ($type, $authURI, \@INS, \@NSS, $fullObjects, $fullServices);
+}
=head2 locateServiceByOutput
Title : locateServiceByOutput
- Usage : $services = $MOBY->locateServiceByOutput(@args)
+ Usage : $services = $MOBY->locateServiceByOutput($inputXML)
Function : get the names/descriptions for services that use certain INPUT's
Returns : XML (see below)
- Args : (in order)
- $OUT : output Object type
- \@Namespaces : optional - restrict to those who handle these namespaces (eg. GenBank ID)
- $serviceType : optional - restrict to Service Type (from ontology)
- $AuthURI : optional - restrict to only these service providors
- $max_return : optional - restrict number returned
- $full_objects: boolean, default 1, expand output object ontology
- to retrieve this type, and all child types
- $full_service: boolean, default 1, expand service ontology
- to retrieve this type and all child types
- XML : <Services>
- <Service authURI="authority.info.here" serviceName="MyService">
- <ServiceType>Service_Ontology_Term</ServiceType>
- <OutputObject>Object_Ontology_Term</OutputObject>
- <Description><![CDATA[free text description here]]></Description>
- </Service>
- ...
- ...
- </Services>
+ inputXML :
+ <locateServiceByOutput>
+ <objectType>ObjectType</objectType>
+ <serviceType>ServiceTypeTerm</serviceType>
+ <authURI>http://desired.service.provider</authURI>
+ <fullObjects>1|0</fullObjects>
+ <fullServices>1|0</fullServices>
+ <locateServiceByOutput>
+
+ outputXML :
+ <Services>
+ <Service authURI="authority.info.here" serviceName="MyService">
+ <ServiceType>Service_Ontology_Term</ServiceType>
+ <OutputObject>Object_Ontology_Term</OutputObject>
+ <Description><![CDATA[free text description here]]></Description>
+ </Service>
+ ...
+ ...
+ </Services>
@@ -1068,41 +1589,44 @@
sub locateServiceByOutput {
- my ($self, $OUT, $NSs, $serviceType, $AuthURI, $max_return, $full_objects, $full_services) = @_;
+ my ($pkg, $payload) = @_;
+ my ($serviceType, $AuthURI, $OUT, $full_objects, $full_services) = &_locateServiceByOutputPayload($payload);
unless (defined $full_objects){$full_objects = 1}
unless (defined $full_services){$full_services = 1}
&_LOG("RECEIVED PARAMS", @_);
# this one has to be generated dynamically...
return undef unless $OUT;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
if ($serviceType && $full_services){ # we need this service type and all child types
&_LOG("Traversing Service DAG");
- @ServiceIDs = $self->_traverseServiceDAG($serviceType, $sth_hash);
+ @ServiceIDs = &_traverseServiceDAG($dbh, $serviceType, $sth_hash);
} elsif ($serviceType) { # we need only the service type of this element
&_LOG("NOT Traversing Service DAG");
- $sth{get_service_type_id}->execute($serviceType);
- @ServiceIDs = $sth{get_service_type_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_service_type_id});
+ $sth->execute($serviceType);
+ @ServiceIDs = $sth->fetchrow_array;
}
&_LOG("FINISHED Traversing Service DAG");
my (@ObjectIDs, %ObjectIDs);
if ($full_objects){ # we need this Object type and all parent types
&_LOG("traversing Object DAG for $OUT");
- foreach ($self->_traverseObjectDAG($OUT, $sth_hash, 'c')){
+ foreach (&_traverseObjectDAG($dbh, $OUT, $sth_hash, 'c')){
&_LOG("found $_ in Object DAG");
$ObjectIDs{$_}=1;
}
@ObjectIDs = keys %ObjectIDs;
} else { # we need only the Object type of the elements we were sent
- $sth{get_object_type_id}->execute($OUT);
- push @ObjectIDs, $sth{get_object_type_id}->fetchrow_array;
+ my $sth = $dbh->prepare($sth{get_object_type_id});
+ $sth->execute($OUT);
+ push @ObjectIDs, $sth->fetchrow_array;
}
&_LOG("OUT $OUT ::: @ObjectIDs\n");
- if ($NSs){&_LOG("NSs @{$NSs} \n")};
+# if ($NSs){&_LOG("NSs @{$NSs} \n")};
if ($serviceType){&_LOG("Servicetypes $serviceType, @ServiceIDs\n")};
my $query = "
@@ -1133,27 +1657,52 @@
and SPout.type = 'out'
and SPns.type = 'ns'
and OEout.id in (". join (",", map {"\"".$_."\""} @ObjectIDs).") ";
- if ($NSs && ${$NSs}[0]){ # must have at least one element
- $query .= "
- and OEns.term in (". join (",", map {"\"".$_."\""} @{$NSs}).") ";
- }
+ #if ($NSs && ${$NSs}[0]){ # must have at least one element
+ # $query .= "
+ # and OEns.term in (". join (",", map {"\"".$_."\""} @{$NSs}).") ";
+ #}
if ($serviceType){ $query .= "and (S.service_type_id in (".(join ',', @ServiceIDs).")) "} # service type is a DAG, so get all relevant types
if ($AuthURI){ $query .= "and (S.auth_uri = '$AuthURI') "}
_LOG("*************************\ Query is: $query\n****************************");
- return $self->_getValidServices($dbh, $sth_hash, $query, $max_return);
+ return &_getValidServices($dbh, $sth_hash, $query);
+
+}
+
+
+sub _locateServiceByOutputPayload {
+
+ 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 'locateServiceByOutput');
+ my $type = &_nodeTextContent($Object, "serviceType");
+ my $authURI = &_nodeTextContent($Object, "authURI");
+ my $fullObjects = &_nodeTextContent($Object, "fullObjects");
+ my $fullServices = &_nodeTextContent($Object, "fullServices");
+ my $output = &_nodeTextContent($Object, "objectType");
+ return ($type, $authURI, $output, $fullObjects, $fullServices);
}
+
=head2 retrieveService
Title : retrieveService
- Usage : $WSDL = $MOBY->locateService($AuthURI, $servicename)
+ Usage : $WSDL = $MOBY->locateService($inputXML)
Function : get the WSDL descriptions for services with this service name
- Returns : XMNL (see below)
- Args : $AuthURI, $serviceName as returned by the locate* calls
- XML : <Service><![CDATA[WSDL document here]]</Service>
+ Returns : XML (see below)
+ inputXML :
+ <retrieveService>
+ <authURI>http://service.provider.URI</authURI>
+ <serviceName>DesiredServiceName</serviceName>
+ <retrieveService>
+
+ outputXML :
+ <Service><![CDATA[WSDL document here]]</Service>
=cut
@@ -1161,10 +1710,11 @@
sub retrieveService {
- my ($self, $AuthURI, $serviceName) = @_;
+ my ($pkg, $payload) = @_;
+ my ($AuthURI, $serviceName) = &_retrieveServicePayload($payload);
unless ($AuthURI && $serviceName){return "<Services/>"}
my $wsdls;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
@@ -1180,7 +1730,7 @@
where
service_name = '$serviceName'
and S.auth_uri = '$AuthURI'";
- my $wsdl = $self->_getServiceWSDL($dbh, $sth_hash, $query);
+ my $wsdl = &_getServiceWSDL($dbh, $sth_hash, $query);
if ($wsdl){
$wsdls .= "<Service><![CDATA[$wsdl]]></Service>\n";
}
@@ -1190,6 +1740,21 @@
}
+
+sub _retrieveServicePayload {
+
+ 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 'retrieveService');
+ my $authURI = &_nodeTextContent($Object, "authURI");
+ my $serviceName = &_nodeTextContent($Object, "serviceName");
+ return ($authURI, $serviceName);
+}
+
+
=head2 retrieveServiceProviders
Title : retrieveServiceProviders
@@ -1197,22 +1762,24 @@
Function : get the list of all provider's AuthURI's
Returns : XML (see below)
Args : none
- XML : <ServiceProviders>
- <ServiceProvider name="authority.info.here"/>
- ...
- ...
- </ServiceProviders>
+ XML :
+ <ServiceProviders>
+ <ServiceProvider name="authority.info.here"/>
+ ...
+ ...
+ </ServiceProviders>
=cut
sub retrieveServiceProviders {
- my ($self) = @_;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($pkg) = @_;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{return_service_providers}->execute;
+ my $sth = $dbh->prepare($sth{return_service_providers});
+ $sth->execute;
my $providers = "<ServiceProviders>\n";
- while (my ($prov) = $sth{return_service_providers}->fetchrow_array){
+ while (my ($prov) = $sth->fetchrow_array){
$providers .= "<ServiceProvider name='$prov'/>\n";
}
$providers .= "</ServiceProviders>\n";
@@ -1227,24 +1794,25 @@
(N.B. NOT service types!)
Returns : XML (see below)
Args : none
- XML : <ServiceNames>
- <ServiceName name="serviceName" authURI='authority.info.here'/>
- ...
- ...
- </ServiceNames>
+ XML :
+ <ServiceNames>
+ <ServiceName name="serviceName" authURI='authority.info.here'/>
+ ...
+ ...
+ </ServiceNames>
=cut
sub retrieveServiceNames {
- my ($self) = shift;
- my $obj = shift;
- &_LOG("now self is $self and obj is $obj\n");
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($pkg) = shift;
+
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{return_service_names}->execute;
+ my $sth = $dbh->prepare($sth{return_service_names});
+ $sth->execute;
my $names = "<ServiceNames>\n";
- while (my ($name, $auth) = $sth{return_service_names}->fetchrow_array){
+ while (my ($name, $auth) = $sth->fetchrow_array){
$names .= "<ServiceName name='$name' authURI='$auth'/>\n";
}
$names .= "</ServiceNames>\n";
@@ -1259,25 +1827,27 @@
Function : get the list of all registered service types
Returns : XML (see below)
Args : none
- XML : <ServiceTypes>
- <ServiceType name="serviceName">
- <Description><![CDATA[free text description here]]></Description>
- </ServiceType>
- ...
- ...
- </ServiceNames>
+ XML :
+ <ServiceTypes>
+ <ServiceType name="serviceName">
+ <Description><![CDATA[free text description here]]></Description>
+ </ServiceType>
+ ...
+ ...
+ </ServiceNames>
=cut
sub retrieveServiceTypes {
- my ($self) = @_;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($pkg) = @_;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{return_service_types}->execute;
+ my $sth = $dbh->prepare($sth{return_service_types});
+ $sth->execute;
my $types = "<ServiceTypes>\n";
- while (my ($serv, $desc) = $sth{return_service_types}->fetchrow_array){
+ while (my ($serv, $desc) = $sth->fetchrow_array){
$types .= "<ServiceType name='$serv'>\n<Description><![CDATA[$desc]]></Description>\n</ServiceType>\n";
}
$types .= "</ServiceTypes>\n";
@@ -1292,24 +1862,26 @@
Function : get the list of all registered Object types
Returns : XML (see below)
Args : none
- XML : <ObjectNames>
- <ObjectName name="objectName">
- <Description><![CDATA[free text description here]]></Description>
- </ObjectName>
- ...
- ...
- </ObjectNames>
+ XML :
+ <ObjectNames>
+ <ObjectName name="objectName">
+ <Description><![CDATA[free text description here]]></Description>
+ </ObjectName>
+ ...
+ ...
+ </ObjectNames>
=cut
sub retrieveObjectNames {
- my ($self) = @_;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($pkg) = @_;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{retrieve_object_names}->execute;
+ my $sth = $dbh->prepare($sth{retrieve_object_names});
+ $sth->execute;
my $obj = "<ObjectNames>\n";
- while (my ($name, $desc) = $sth{retrieve_object_names}->fetchrow_array){
+ while (my ($name, $desc) = $sth->fetchrow_array){
$obj .= "<Object name='$name'>\n<Description><![CDATA[$desc]]></Description>\n</Object>\n";
}
$obj .= "</ObjectNames>\n";
@@ -1324,24 +1896,26 @@
Function : get the list of all registered Object types
Returns : XML (see below)
Args : none
- XML : <Namespaces>
- <Namespace name="namespace">
- <Description><![CDATA[free text description here]]></Description>
- </Namespace>
- ...
- ...
- </Namespaces>
+ XML :
+ <Namespaces>
+ <Namespace name="namespace">
+ <Description><![CDATA[free text description here]]></Description>
+ </Namespace>
+ ...
+ ...
+ </Namespaces>
=cut
sub retrieveNamespaces {
- my ($self) = @_;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($pkg) = @_;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
- $sth{retrieve_namespaces}->execute;
+ my $sth = $dbh->prepare($sth{retrieve_namespaces});
+ $sth->execute;
my $ns = "<Namespaces>\n";
- while (my ($namespace, $desc) = $sth{retrieve_namespaces}->fetchrow_array){
+ while (my ($namespace, $desc) = $sth->fetchrow_array){
$ns .= "<Namespace name='$namespace'>\n<Description><![CDATA[$desc]]></Description>\n</Namespace>\n";
}
$ns .="</Namespaces>";
@@ -1353,38 +1927,47 @@
=head2 retrieveObject
Title : retrieveObject
- Usage : $objects = $MOBY->retrieveObjectNames($name | "all")
+ Usage : $objects = $MOBY->retrieveObject($name | "all")
Function : get the object xsd
Returns : XML (see below)
Args : $name - object name (from ontology) or "all" to get all objects
- XML : <Objects>
- <Object name="namespace">
- <Schema><![CDATA[XSD schema fragment here]]></Schema>
- </Object>
- ...
- ...
- </Objects>
+
+ inputXML :
+ <retrieveObject>
+ <type>ObjectType | all</type>
+ <retrieveObject>
+
+ outputXML :
+ <Objects>
+ <Object name="namespace">
+ <Schema><![CDATA[XSD schema fragment here]]></Schema>
+ </Object>
+ ...
+ ...
+ </Objects>
=cut
sub retrieveObject {
- my ($self, $param) = @_;
+ my ( $pkg,$param) = @_;
my $response;
- my ($dbh, $sth_hash) = $self->_dbAccess;
+ my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
$response = "<Objects>\n";
if (lc($param) eq "all"){
- $sth{retrieve_all_objects}->execute;
- while (my ($obj, $xsd) = $sth{retrieve_all_objects}->fetchrow_array){
+ my $sth = $dbh->prepare($sth{retrieve_all_objects});
+ $sth->execute;
+ while (my ($obj, $xsd) = $sth->fetchrow_array){
$response .= "<Object name='$obj'>\n";
$response .= "<Schema><![CDATA[$xsd]]></Schema>\n";
$response .= "</Object>\n";
}
} else{
- $sth{retrieve_one_object}->execute($param);
- while (my ($obj, $xsd) = $sth{retrieve_one_object}->fetchrow_array){
+ my $sth = $dbh->prepare($sth{retrieve_one_object});
+ $sth->execute($param);
+ while (my ($obj, $xsd) = $sth->fetchrow_array){
$response .= "<Object name='$obj'>\n";
$response .= "<Schema><![CDATA[$xsd]]></Schema>\n";
$response .= "</Object>\n";
@@ -1400,6 +1983,9 @@
=head1 Internal Object Methods
+=cut
+
+
=head2 _getValidServices
Title : _getValidServices
@@ -1412,8 +1998,9 @@
sub _getValidServices {
- my ($self, $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);
$this_query->execute;
my $response;
@@ -1444,7 +2031,7 @@
sub _getServiceWSDL {
- my ($self, $dbh, $sth_hash, $query) = @_;
+ my ( $dbh, $sth_hash, $query) = @_;
my %sth = %{$sth_hash};
my $this_query = $dbh->prepare($query);
$this_query->execute;
@@ -1453,9 +2040,10 @@
$wsdl =~ s/^\n//gs;
close WSDL;
my ($id, $serviceName, $AuthURI, $URL, $desc) =$this_query->fetchrow_array();
- $sth{get_server_parameters}->execute($id);
+ my $sth = $dbh->prepare($sth{get_server_parameters});
+ $sth->execute($id);
my (@in, @out);
- while (my ($Object, $xsd, $in_out) = $sth{get_server_parameters}->fetchrow_array()){
+ while (my ($Object, $xsd, $in_out) = $sth->fetchrow_array()){
if ($in_out eq "in"){push @in, [$Object, $xsd]}
else {push @out, [$Object, $xsd]}
}
@@ -1478,7 +2066,7 @@
=head2 _traverseServiceDAG
Title : _traverseServiceDAG
- Usage : @valid = $MOBY->_traverseServiceDAG($serviceType, $sth_hash)
+ Usage : @valid = $MOBY->_traverseServiceDAG($dbh, $serviceType, $sth_hash)
Function : starting from $serviceType, find all child services non-redundantly
by traversing the DAG.
Returns : list of Service.id database entries.
@@ -1488,11 +2076,12 @@
sub _traverseServiceDAG {
- my ($self, $serviceType, $sth_hash) = @_;
+ my ( $dbh, $serviceType, $sth_hash) = @_;
my %sth = %{$sth_hash};
my %ServiceIDs;
- $sth{get_service_type_id}->execute($serviceType);
- my ($root_id) = $sth{get_service_type_id}->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...
@@ -1501,9 +2090,10 @@
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
- $sth{get_service_hierarchy_list}->execute($service); # execute the query for child nodes
+ 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{get_service_hierarchy_list}->fetchrow_array){ # now get each of the child nodes
+ 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
}
@@ -1516,7 +2106,7 @@
=head2 _traverseObjectDAG
Title : _traverseObjectDAG
- Usage : @valid = $MOBY->_traverseObjectDAG($objectType, $sth_hash, "p|c")
+ Usage : @valid = $MOBY->_traverseObjectDAG( $dbh, $objectType, $sth_hash, "p|c")
Function : from $objectType, find all parent/child objects non-redundantly
by traversing the DAG.
Returns : list of Object.id database entries.
@@ -1527,15 +2117,22 @@
sub _traverseObjectDAG {
- my ($self, $objectType, $sth_hash, $dir) = @_;
+ my ( $dbh, $objectType, $sth_hash, $dir) = @_;
my %sth = %{$sth_hash};
my %ObjectIDs;
- $sth{get_object_type_id}->execute($objectType);
- my ($root_id) = $sth{get_object_type_id}->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;
- my $sth;
- if ($dir eq "p"){_LOG("getting parents");$sth = $sth{get_object_parent_list}}
- else {_LOG("getting children");$sth = $sth{get_object_child_list}}
+
+ if ($dir eq "p"){
+ _LOG("getting parents");
+ $sth = $dbh->prepare($sth{get_object_parent_list});
+ }
+ else {
+ _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...
@@ -1555,42 +2152,46 @@
return keys %ObjectIDs;
}
+sub _nodeTextContent {
+ # will get text of **all** child $node from the given $DOM
+ # regardless of their depth!!
+ my ($DOM, $node) = @_;
+ &_LOG("_nodeTextContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
+ my $x = $DOM->getElementsByTagName($node);
+ my @child = $x->item(0)->getChildNodes;
+ my $content;
+ foreach (@child){
+ &_LOG($_->getNodeTypeName, "\t", $_->toString,"\n");
+ next unless $_->getNodeType == TEXT_NODE;
+ $content = $_->toString;
+ }
+ return $content;
+}
-sub AUTOLOAD {
- no strict "refs";
- my ($self, $newval) = @_;
-
- $AUTOLOAD =~ /.*::(\w+)/;
-
- my $attr=$1;
- if ($self->_accessible($attr,'write')) {
-
- *{$AUTOLOAD} = sub {
- if (defined $_[1]) { $_[0]->{$attr} = $_[1] }
- return $_[0]->{$attr};
- }; ### end of created subroutine
-
-### this is called first time only
- if (defined $newval) {
- $self->{$attr} = $newval
- }
- 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";
+sub _nodeArrayContent {
+ # will get array content of all child $node from given $DOM
+ # regardless of depth!
+ my ($DOM, $node) = @_;
+ &_LOG("_nodeArrayContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
+ my @result;
+ my $x = $DOM->getElementsByTagName($node);
+ my @child = $x->item(0)->getChildNodes;
+ foreach (@child){
+ next unless $_->getNodeType == ELEMENT_NODE;
+ my @child2 = $_->getChildNodes;
+ foreach (@child2){
+ #print $_->getNodeTypeName, "\t", $_->toString,"\n";
+ next unless $_->getNodeType == TEXT_NODE;
+ push @result, $_->toString;
+ }
+ }
+ return @result;
}
sub DESTROY {}
sub _LOG {
- return unless $debug;
+ #return unless $debug;
open LOG, ">>/tmp/CentralRegistryLogOut.txt" or die "can't open logfile $!\n";
print LOG join "\n", @_;
print LOG "\n---\n";
rcsdiff: /home/repository/moby/moby-live/Perl/Central/MOBY/RCS/Registration.pm,v: No such file or directory
More information about the MOBY-guts
mailing list