lib/MOBY/Client/Central.pm

   1 #$Id: Central.pm,v 1.133 2006/02/08 22:47:28 fgibbons Exp $
   2 package MOBY::Client::Central;
   3 use SOAP::Lite;
   4
   5 #use SOAP::Lite + trace;  # for debugging
   6 use strict;
   7 use Carp;
   8 use XML::LibXML;
   9 use MOBY::MobyXMLConstants;
  10 use MOBY::Client::ServiceInstance;
  11 use MOBY::Client::Registration;
  12 use MOBY::Client::SimpleArticle;
  13 use MOBY::Client::CollectionArticle;
  14 use MOBY::Client::SecondaryArticle;
  15 use MOBY::Client::OntologyServer;
  16 use vars qw($AUTOLOAD @ISA $MOBY_server $MOBY_uri);
  17
  18 =head1 NAME
  19
  20 MOBY::Client::Central - a client side wrapper for MOBY Central
  21
  22 =cut
  23
  24 =head1 SYNOPSIS
  25
  26  use MOBY::Client::Central;
  27  my $Central = MOBY::Client::Central->new();
  28
  29  my ($Services, $REG) = $Central->findService(
  30             input =>[
  31               [DNASequence => ['NCBI_gi', 'NCBI_Acc']],
  32                 ],
  33                 expandObjects => 1
  34                 );
  35  unless ($Services){
  36          print "Service discovery failed with the following errror: ";
  37          print $REG->message;
  38          end
  39  }
  40  foreach my $SERVICE(@{$Services}){
  41     print "Service Name: ", $SERVICE->name, "\n";
  42     print "Service Provider: ", $SERVICE->authority,"\n";
  43
  44  }
  45
  46 =cut
  47
  48 =head1 DESCRIPTION
  49
  50 Client side "wrapper" for communicating with
  51 the MOBY::Central registry.
  52
  53 Used to do various read-only transactions with MOBY-Central.  Parses
  54 MOBY::Central XML output into Perlish lists, hashes, and objects.  This should
  55 be sufficient for most or all MOBY Client activities written in Perl.
  56
  57
  58 =cut
  59
  60
  61 =head1 AUTHORS
  62
  63 Mark Wilkinson (markw@illuminae.com)
  64
  65 BioMOBY Project:  http://www.biomoby.org
  66
  67
  68 =cut
  69
  70 =head1 METHODS
  71
  72
  73
  74 =head2 new
  75
  76  Usage     :    my $MOBY = MOBY::Client::Central->new(Registries => \%regrefs)
  77  Function  :    connect to one or more MOBY-Central
  78                 registries for searching
  79  Returns   :    MOBY::Client::Central object
  80
  81  ENV & PROXY : you can set environment variables to change the defaults.
  82              By default, a call to 'new' will initialize MOBY::Client::Central
  83              to connect to the MOBY Central registry at:
  84              http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY05/mobycentral.pl
  85              If you wish to chose another registry by default, or if you need
  86              to set up additional connection details (e.g. PROXY) then you may
  87              set the following environment variables to whatever you
  88              require:
  89              MOBY_SERVER  (default http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY05/mobycentral.pl)
  90              MOBY_URI     (default http://mobycentral.cbr.nrc.ca/MOBY/Central)
  91              MOBY_PROXY   (no default)
  92
  93  Args      :    Registries - optional.
  94                            - takes the form
  95                               {$NAME1 => {
  96                                     URL => $URL,
  97                                     URI => $URI,
  98                                     PROXY => $proxy_server},
  99                                $NAME2 => {
 100                                     URL => $URL,
 101                                     URI => $URI,
 102                                     PROXY => $proxy_server},
 103                                 }
 104                             - by default this becomes
 105                             {mobycentral => {
 106                                  URL => 'http://mobycentral.cbr.nrc.ca/cgi-bin/MOBY05/mobycentral.pl',
 107                                  URI => 'http://mobycentral.cbr.nrc.ca/MOBY/Central'}
 108                              }
 109  Discussion:    Each registry must have a different
 110                 NAME.  If you have more than one
 111                 registry with the same NAME, only
 112                 one will be used.  You can NAME them
 113                 however you please - this is for
 114                 internal reference only.  You will
 115                 make subsequent calls on one or more
 116                 of these registries by NAME, or by
 117                 default on all registries.
 118  Notes     :    BE CAREFUL WITH OBJECT/SERVICE
 119                 REGISTRATION!! YOU WILL REGISTER
 120                 IN EVERY MOBY-CENTRAL YOU HAVE
 121                 NAMED!  If you do not host a MOBY::Central
 122                 database locally, or don't know
 123                 better,then don't use any arguments
 124                 at all, and everything should work
 125
 126
 127 =cut
 128
 129 my $debug = 0;
 130 if ($debug) {
 131         open( OUT, ">/tmp/CentralLogOut.txt" )
 132           || die "cant open logfile CentralLogOut.txt $!\n";
 133         close OUT;
 134 }
 135 {
 136
 137         # Encapsulated:
 138         # DATA
 139         #___________________________________________________________
 140         #ATTRIBUTES
 141         my %_attr_data =    #                                   DEFAULT         ACCESSIBILITY
 142           (
 143                 Connections             => [ undef,         'read/write' ],
 144                 default_MOBY_servername => [ 'mobycentral', 'read/write' ],
 145                 default_MOBY_server     => [
 146 'http://mobycentral.icapture.ubc.ca/cgi-bin/MOBY05/mobycentral.pl',
 147                         'read/write'
 148                 ],
 149                 default_MOBY_uri =>
 150                   [ 'http://mobycentral.icapture.ubc.ca/MOBY/Central', 'read/write' ],
 151                 default_MOBY_proxy  => [ undef,  'read/write' ],
 152                 default_MOBY_type   => [ 'soap', 'read/write' ],
 153                 Registries          => [ undef,  'read/write' ],
 154                 multiple_registries => [ undef,  'read/write' ],
 155
 156 # SWITCH TO THESE FOR A LOCAL MOBY CENTRAL REGISTRY
 157 #default_MOBY_server    => ['http://localhost/cgi-bin/MOBY-Central.pl',         'read/write'],
 158 #default_MOBY_uri               => ['http://localhost/MOBY/Central',                            'read/write'],
 159           );
 160
 161         #_____________________________________________________________
 162         # METHODS, to operate on encapsulated class data
 163         # Is a specified object attribute accessible in a given mode
 164         sub _accessible {
 165                 my ( $self, $attr, $mode ) = @_;
 166                 return 0 unless ( $mode && $_attr_data{$attr} );
 167                 $_attr_data{$attr}[1] =~ /$mode/;
 168         }
 169
 170         # Classwide default value for a specified object attribute
 171         sub _default_for {
 172                 my ( $self, $attr ) = @_;
 173                 $_attr_data{$attr}[0];
 174         }
 175
 176         # List of names of all specified object attributes
 177         sub _standard_keys {
 178                 keys %_attr_data;
 179         }
 180
 181         sub Connection {
 182                 my ( $self, $desired ) = @_;
 183                 if ($desired) {
 184                         while ( my ( $name, $type, $connect ) =
 185                                 ( @{ $self->Connections->[0] } ) )
 186                         {
 187                                 return ( $type, $connect ) if $name eq $desired;
 188                         }
 189                 }
 190                 else {
 191                         my ( $name, $type, $connect ) = @{ $self->Connections->[0] };
 192                         return ( $type, $connect );
 193                 }
 194                 return ( undef, undef );
 195         }
 196 }
 197
 198 sub _call {
 199
 200 # this method replaces the former calls directly
 201 # to teh SOAP_Connection, to give more flexibility
 202 # in how that call is made
 203 #  most subroutines in here do the following:
 204 #    $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
 205 # or $payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
 206 # so intercept that and figure out if we are actually making a SOAP call or not
 207 # and determine which registry it is
 208         my ( $self, $reg, $method, @params ) = @_;
 209         $reg = $self->default_MOBY_servername if $reg eq "default";
 210         $reg = $self->default_MOBY_servername if !$reg;
 211         my ( $type, $connect ) = $self->Connection($reg);
 212         return "<result>EXECUTION ERROR - registry $reg not found</result>"
 213           unless ( $type && $connect );
 214         my $param = join "", @params;    # must be a single message!
 215         if ( lc($type) eq "get" ) {
 216
 217                 #print STDERR "executing CGI call\n";
 218                 use LWP::UserAgent;
 219                 my $ua = LWP::UserAgent->new;
 220                 use CGI;
 221                 $param =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
 222                 my $paramstring = "?action=$method";
 223                 $paramstring .= ";payload=$param" if $param;
 224                 my $req = HTTP::Request->new( GET => $connect . $paramstring );
 225                 my $res = $ua->request($req);
 226                 if ( $res->is_success ) {
 227                         return $res->content;
 228                 }
 229                 else {
 230                         return
 231 "<result>EXECUTION ERROR - unsuccessful call to MOBY Central registry named '$reg'</result>";
 232                 }
 233         }
 234         else {
 235
 236                 #print STDERR "executing SOAP call\n";
 237                 my @payload = $connect->call( $method => $param )->paramsall;
 238                 return @payload;
 239         }
 240 }
 241
 242 sub new {
 243   my ( $caller, %args ) = @_;
 244   my $caller_is_obj = ref($caller);
 245   return $caller if $caller_is_obj;
 246   my $class = $caller_is_obj || $caller;
 247   my $proxy;
 248   my $self = bless {}, $class;
 249   foreach my $attrname ( $self->_standard_keys ) {
 250     if ( exists $args{$attrname} ) {
 251       $self->{$attrname} = $args{$attrname};
 252     }
 253     elsif ($caller_is_obj) {
 254       $self->{$attrname} = $caller->{$attrname};
 255     }
 256     else {
 257       $self->{$attrname} = $self->_default_for($attrname);
 258     }
 259   }
 260   $self->Connections( [] );    # initialize;
 261
 262   # if user has set up preferred servers, then use those by default
 263   $self->default_MOBY_server( $ENV{MOBY_SERVER} ) if $ENV{MOBY_SERVER};
 264   $self->default_MOBY_uri( $ENV{MOBY_URI} )       if $ENV{MOBY_URI};
 265   $self->default_MOBY_type( $ENV{MOBY_TYPE} )     if $ENV{MOBY_TYPE};
 266   $self->default_MOBY_proxy( $ENV{MOBY_PROXY} )   if $ENV{MOBY_PROXY};
 267   if ( $self->Registries ) {
 268     my $regno = 0;
 269     my %reg   = %{ $self->Registries };
 270     while ( my ( $name, $acc ) = each %reg ) {
 271       $regno++;            # count how many registries we have in total
 272       my $url  = $acc->{URL}  ? $acc->{URL}  : $self->default_MOBY_server;
 273       my $uri  = $acc->{URI}  ? $acc->{URI}  : $self->default_MOBY_uri;
 274       my $type = $acc->{TYPE} ? $acc->{TYPE} : $self->default_MOBY_type;
 275       my $proxy = $acc->{PROXY} ? $acc->{PROXY} : $self->default_MOBY_proxy;
 276       $type ||= 'soap';
 277       if ( lc($type) eq "get" ) {
 278         push @{ $self->Connections }, [ $name, $type, $url ];
 279       }
 280       else {
 281         my @soapargs;
 282         if ($proxy) {
 283           @soapargs = ( $url, proxy => [ 'http' => $proxy ] );
 284         }
 285         else {
 286           @soapargs = ($url);
 287         }
 288         push @{ $self->Connections },
 289           [
 290            $name, $type,
 291            SOAP::Lite->proxy(@soapargs)->uri($uri)->on_fault(
 292                              sub {
 293                                my ( $soap, $res ) = @_;
 294                                die ref $res
 295                                  ? ("\nConnection to MOBY Central at '$uri' died because:\n\t" . $res->faultstring)
 296                                    : ("Failed with status:" . $soap->transport->status),
 297                                      "\n ERROR ERROR ERROR\n";
 298                              }
 299                                                             )
 300           ];
 301       }
 302     } # Done iterating over multiple registries
 303     $self->multiple_registries( $regno - 1 )
 304       ; # one is not "multiple", it is just a change in default -> set to "false" if only one
 305   }
 306   else { # no registries specified
 307     $self->multiple_registries(0);
 308     if ( lc( $self->default_MOBY_type ) eq "get" ) {
 309       push @{ $self->Connections },
 310         [
 311          $self->default_MOBY_servername, $self->default_MOBY_type,
 312          $self->default_MOBY_server
 313         ];
 314     }
 315     else {
 316       $self->Registries(
 317                         {
 318                          $self->default_MOBY_servername => {
 319                                                             URL => $self->default_MOBY_server,
 320                                                             URI => $self->default_MOBY_uri
 321                                                            }
 322                         }
 323                        );
 324       my @soapargs;
 325       if ( $self->default_MOBY_proxy ) {
 326         @soapargs = (
 327                      $self->default_MOBY_server,
 328                      proxy => [ 'http' => $self->default_MOBY_proxy ]
 329                     );
 330       }
 331       else {
 332         @soapargs = ( $self->default_MOBY_server );
 333       }
 334       push @{ $self->Connections },
 335         [
 336          $self->default_MOBY_servername,
 337          $self->default_MOBY_type,
 338          SOAP::Lite->proxy(@soapargs)->uri( $self->default_MOBY_uri )
 339          ->on_fault(
 340                     sub {
 341                       my ( $soap, $res ) = @_;
 342                       die ref $res
 343                         ? ("\nConnection to default MOBY Central died because:\n\t" . $res->faultstring)
 344                           : ("Failed with status:" . $soap->transport->status),
 345                             "\n ERROR ERROR ERROR\n";
 346                     }
 347                    )
 348         ];
 349     }
 350   }
 351   return undef unless $self->Connection();    # gotta have at least one...
 352   return $self;
 353 }
 354
 355 =head2 registerObject  a.k.a registerObjectClass
 356
 357  Usage     :    $REG = $MOBY->registerObject(%args)
 358  Usage     :    $REG = $MOBY->registerObjectClass(%args)
 359  Function  :    register a new type of MOBY Object
 360  Returns   :    MOBY::Registration object
 361  Args      :    objectType => "the name of the Object"
 362                 description => "a human-readable description of the object"
 363                 contactEmail => "your@email.address"
 364                 authURI => "URI of the registrar of this object"
 365                 Relationships => {
 366                     relationshipType1 => [
 367                         {object      => Object1,
 368                          articleName => ArticleName1},
 369                         {object      => Object2,
 370                          articleName => ArticleName2}
 371                     ],
 372                     relationshipType2 => [
 373                         {object      => Object3,
 374                          articleName => ArticleName3}
 375                     ]
 376                 }
 377
 378 =cut
 379
 380 sub registerObjectClass {
 381         my ( $self, %a ) = @_;
 382         return $self->registerObject(%a);
 383 }
 384
 385 sub registerObject {
 386         my ( $self, %a ) = @_;
 387         return $self->errorRegXML(
 388                 "Function not allowed when querying multiple registries")
 389           if $self->multiple_registries;
 390         return $self->errorRegXML(
 391 "Contact email address (contactEmail parameter) is required for object registration"
 392           )
 393           if ( !$a{contactEmail} );
 394         my $term = $a{'objectType'} || "";
 395         my $desc = $a{'description'} || "";
 396         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
 397                 $desc = $1;
 398         }
 399         my $contactEmail = $a{'contactEmail'} || "";
 400         my $authURI = $a{'authURI'} || "";
 401         my %Relationships = %{ $a{'Relationships'} };
 402         my $clobber       = $a{'Clobber'} ? $a{'Clobber'} : 0;
 403         my $message       = "<registerObjectClass>
 404         <objectType>$term</objectType>
 405         <Description><![CDATA[$desc]]></Description>
 406         <authURI>$authURI</authURI>
 407         <contactEmail>$contactEmail</contactEmail>
 408         <Clobber>$clobber</Clobber>\n";
 409
 410         while ( my ( $type, $objlistref ) = each %Relationships ) {
 411                 $message .= "<Relationship relationshipType='$type'>\n";
 412                 foreach my $objnamepair ( @{$objlistref} ) {
 413                         my $object  = $objnamepair->{object};
 414                         my $article = $objnamepair->{articleName};
 415                         return $self->errorRegXML(
 416                                 "Object name missing from one of your $type relationships")
 417                           unless ($object);
 418                         $article ||= "";
 419                         $message .=
 420                           "<objectType articleName='$article'>$object</objectType>\n";
 421                 }
 422                 $message .= "</Relationship>\n";
 423         }
 424         $message .= "</registerObjectClass>";
 425
 426 #       my $return = $self->SOAP_connection->call(registerObjectClass => ($message))->paramsall;
 427         my ($return) = $self->_call( 'default', 'registerObjectClass', $message );
 428         return ( $self->parseRegXML($return) );
 429 }
 430
 431 =head2 deregisterObject a.k.a. deregisterObjectClass
 432
 433  Usage     :    $REG = $MOBY->deregisterObject(%args)
 434  Usage     :    $REG = $MOBY->deregisterObjectClass(%args)
 435  Function  :    deregister a MOBY Object
 436  Returns   :    MOBY::Registration object
 437  Args      :    objectType => $objectName (from Object ontology)
 438
 439
 440 =cut
 441
 442 sub deregisterObjectClass {
 443         my ( $self, %a ) = @_;
 444         return $self->deregisterObject(%a);
 445 }
 446
 447 sub deregisterObject {
 448         my ( $self, %a ) = @_;
 449         return $self->errorRegXML(
 450                 "Function not allowed when querying multiple registries")
 451           if $self->multiple_registries;
 452         my $id = $a{'objectType'} || "";
 453         my $message = "
 454                 <deregisterObjectClass>
 455                         <objectType>$id</objectType>
 456                 </deregisterObjectClass>";
 457
 458 #       my $return = $self->SOAP_connection->call(deregisterObjectClass => ($message))->paramsall;
 459         my ($return) = $self->_call( 'default', 'deregisterObjectClass', $message );
 460         return ( $self->parseRegXML($return) );
 461 }
 462
 463
 464
 465 =head2 registerServiceType
 466
 467  Usage     :    $REG = $MOBY->registerServiceType(%args)
 468  Function  :    register a new MOBY Service type
 469  Returns   :    MOBY::Registration object
 470  Args      :    serviceType        => $serviceType
 471                 description => "human readable description"
 472                 Relationships => {$relationshipType1 => \@services,
 473                                   $relationshipType2 => \@services}
 474                 contactEmail => "your@email.address.here"
 475                 authURI => "your.authority.info"
 476
 477 =cut
 478
 479 sub registerServiceType {
 480         my ( $self, %a ) = @_;
 481         return $self->errorRegXML(
 482                 "Function not allowed when querying multiple registries")
 483           if $self->multiple_registries;
 484         my $type = $a{'serviceType'} || "";
 485         my $desc = $a{'description'};
 486         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
 487                 $desc = $1;
 488         }
 489         $desc ||= "";
 490         my $email = $a{'contactEmail'} || "";
 491         my $auth = $a{'authURI'} || "";
 492         my %Relationships = %{ $a{'Relationships'} };
 493         my $message       = "
 494                 <registerServiceType>
 495                         <serviceType>$type</serviceType>
 496                         <Description><![CDATA[$desc]]></Description>
 497                         <contactEmail>$email</contactEmail>
 498                         <authURI>$auth</authURI>\n";
 499
 500         while ( my ( $type, $servlistref ) = each %Relationships ) {
 501                 $message .= "<Relationship relationshipType='$type'>\n";
 502                 foreach my $servicetype ( @{$servlistref} ) {
 503                         $message .= "<serviceType>$servicetype</serviceType>\n";
 504                 }
 505                 $message .= "</Relationship>\n";
 506         }
 507         $message .= "</registerServiceType>";
 508
 509 #       my $return = $self->SOAP_connection->call(registerServiceType => ($message))->paramsall;
 510         my ($return) = $self->_call( 'default', 'registerServiceType', $message );
 511         return ( $self->parseRegXML($return) );
 512 }
 513
 514 =head2 deregisterServiceType
 515
 516  Usage     :    $REG = $MOBY->deregisterServiceType(%args)
 517  Function  :    deregister a deprecated MOBY Service Type
 518  Returns   :    MOBY::Registration object
 519  Args      :    serviceType => $serviceType (from ontology)
 520
 521
 522 =cut
 523
 524 sub deregisterServiceType {
 525         my ( $self, %a ) = @_;
 526         return $self->errorRegXML(
 527                 "Function not allowed when querying multiple registries")
 528           if $self->multiple_registries;
 529         my $id = $a{'serviceType'} || "";
 530         my $message = "
 531                 <deregisterServiceType>
 532                         <serviceType>$id</serviceType>
 533                 </deregisterServiceType>";
 534
 535 #       my $return = $self->SOAP_connection->call(deregisterServiceType => ($message))->paramsall;
 536         my ($return) = $self->_call( 'default', 'deregisterServiceType', $message );
 537         return ( $self->parseRegXML($return) );
 538 }
 539
 540 =head2 registerNamespace
 541
 542  Usage     :    $REG = $MOBY->registerNamespace(%args)
 543  Function  :    register a new Namespace
 544  Returns   :    MOBY::Registration object
 545  Args      :    namespaceType => $namespaceType (required)
 546                 authURI => your.authority.URI (required)
 547                 description => "human readable description of namespace" (required)
 548                 contactEmail => "your@address.here" (required)
 549
 550
 551 =cut
 552
 553 sub registerNamespace {
 554         my ( $self, %a ) = @_;
 555         return $self->errorRegXML(
 556                 "Function not allowed when querying multiple registries")
 557           if $self->multiple_registries;
 558         my $type = $a{'namespaceType'} || "";
 559         my $authURI = $a{'authURI'} || "";
 560         my $desc = $a{'description'};
 561         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
 562                 $desc = $1;
 563         }
 564         $desc ||= "";
 565         my $contact = $a{'contactEmail'} || "";
 566         my $message = "
 567                 <registerNamespace>
 568                         <namespaceType>$type</namespaceType>
 569                         <Description><![CDATA[$desc]]></Description>
 570                         <authURI>$authURI</authURI>
 571                         <contactEmail>$contact</contactEmail>
 572                 </registerNamespace>";
 573
 574 #       my $return = $self->SOAP_connection->call(registerNamespace => ($message))->paramsall;
 575         my ($return) = $self->_call( 'default', 'registerNamespace', $message );
 576         return ( $self->parseRegXML($return) );
 577 }
 578
 579 =head2 deregisterNamespace
 580
 581  Usage     :    $REG = $MOBY->deregisterNamespace(%args)
 582  Function  :    deregister a deprecated MOBY Namespace
 583  Returns   :    MOBY::Registration object
 584  Args      :    namespaceType => $mynamespaceType (from ontology)
 585
 586
 587 =cut
 588
 589 sub deregisterNamespace {
 590         my ( $self, %a ) = @_;
 591         return $self->errorRegXML(
 592                 "Function not allowed when querying multiple registries")
 593           if $self->multiple_registries;
 594         my $id = $a{'namespaceType'} || "";
 595         my $message = "
 596                 <deregisterNamespace>
 597                         <namespaceType>$id</namespaceType>
 598                 </deregisterNamespace>";
 599
 600 #       my $return = $self->SOAP_connection->call(deregisterNamespace => ($message))->paramsall;
 601         my ($return) = $self->_call( 'default', 'deregisterNamespace', $message );
 602         return ( $self->parseRegXML($return) );
 603 }
 604
 605 =head2 registerService
 606
 607  Usage     :    $REG = $MOBY->registerService(%args)
 608  Function  :    register a new MOBY Service instance
 609  Returns   :    MOBY::Registration object
 610  Common Required Args :
 611
 612      serviceName  => $serviceName,
 613      serviceType  => $serviceType,
 614      authURI      => $authURI,
 615      contactEmail => "your@mail.address",
 616      description => $human_readable_description,
 617      category  =>  "moby" | "cgi" | "wsdl" (currently only moby and wsdl supported)
 618      URL    =>  $URL_TO_SERVICE  (or URL to WSDL document for wsdl-type services)
 619
 620     input:      listref; (articleName may be undef)
 621             input =>[
 622                      [articleName1,[objType1 => \@namespaces]], # Simple
 623                      [articleName2,       [[objType2 => \@namespaces]]], # collection of one object type
 624                      [articleName3,[[objType3 => \@namespaces],
 625                                     [objType4 => \@namespaces]]] # collection of multiple object types
 626                     ]
 627
 628
 629     output:  listref; (articleName may be undef)
 630             output =>[
 631                  [articleName1,[objType1 => \@namespaces]], # Simple
 632                  [articleName2,[[objType2 => \@namespaces]]], # collection of one object type
 633                  [articleName3,[[objType3 => \@namespaces],
 634                                 [objType4 => \@namespaces]]] # collection of multiple object types
 635                   ]
 636
 637     secondary: hashref
 638             secondary => {parametername1 => {
 639                            datatype => TYPE,
 640                            default => DEFAULT,
 641                            max => MAX,
 642                            min => MIN,
 643                            enum => [one, two]},
 644                           parametername2 => {
 645                            datatype => TYPE,
 646                            default => DEFAULT,
 647                            max => MAX,
 648                            min => MIN,
 649                            enum => [one, two]}
 650                           }
 651
 652
 653
 654 =cut
 655
 656 sub registerService {
 657         my ( $self, %a ) = @_;
 658         return $self->errorRegXML(
 659                 "Function not allowed when querying multiple registries")
 660           if $self->multiple_registries;
 661         my $name = $a{serviceName} || "";
 662         my $type = $a{serviceType} || "";
 663         my $authURI = $a{authURI} || "";
 664         my $email = $a{contactEmail} || "";
 665         my $URL = $a{URL} || "";
 666         my $desc = $a{description} || "";
 667
 668         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
 669                 $desc = $1;
 670         }
 671         my $signatureURL = $a{signatureURL} || "";
 672         my $Category = lc( $a{category} );
 673         chomp $Category;
 674         $Category ||= "";
 675
 676         #____________call RDFagent__________________________________________________
 677         if ( $signatureURL ne "" ) {
 678                 my $ch = 0;
 679                 my $sign_req;
 680                 foreach $sign_req ( $name, $type, $authURI, $email, $URL, $desc,
 681                         $Category )
 682                 {
 683                         if ( $sign_req ne "" ) {
 684                                 $ch = 1;
 685
 686                         }
 687                 }
 688                 if ( $ch == 0 ) {
 689                         # print "call Agent\n";
 690                         my $message = "
 691         <registerService>
 692                 <Category></Category>
 693                 <serviceName></serviceName>
 694                 <serviceType></serviceType>
 695                 <Description></Description>
 696                 <signatureURL>$signatureURL</signatureURL>
 697                 <URL></URL>
 698                 <authURI></authURI>
 699                 <contactEmail></contactEmail>
 700        </registerService>";
 701                         my ($return) =
 702                           $self->_call( 'default', 'registerService', $message );
 703                         return ( $self->parseRegXML($return) );
 704
 705                 }
 706         }
 707
 708 #____________________________________________________________________________________________
 709         return $self->errorRegXML(
 710 "Only 'moby' and 'wsdl' Service Categories are currently allowed - you gave me $Category"
 711           )
 712           unless ( ( $Category eq 'moby' ) || ( $Category eq 'wsdl' ) );
 713         return $self->errorRegXML(
 714 "All Fields Required:  serviceName, serviceType, authURI, contactEmail, URL, description, Category, input, output, secondary"
 715           )
 716           unless ( $name
 717                 && $type
 718                 && $authURI
 719                 && $email
 720                 && $URL
 721                 && $desc
 722                 && $Category );
 723         my $message = "
 724                 <registerService>
 725                         <Category>$Category</Category>
 726                         <serviceName>$name</serviceName>
 727                         <serviceType>$type</serviceType>
 728                         <Description><![CDATA[$desc]]></Description>
 729                         <signatureURL>$signatureURL</signatureURL>
 730                         <URL>$URL</URL>
 731                         <authURI>$authURI</authURI>
 732                         <contactEmail>$email</contactEmail>";
 733
 734         if ( $Category eq "moby" || $Category eq 'soap' ) {
 735                 my %SEC;
 736                 if ( $a{'secondary'} && ( ref( $a{'secondary'} ) eq 'HASH' ) ) {
 737                         %SEC = %{ $a{secondary} };
 738                 }
 739                 elsif ( $a{'secondary'} && ( ref( $a{'secondary'} ) ne 'HASH' ) ) {
 740                         return $self->errorRegXML(
 741                                 "invalid structure of secondary parameters.  Expected hashref."
 742                         );
 743                 }
 744                 my %funkyhash = ( Input => $a{input}, Output => $a{output} );
 745                 while ( my ( $inout, $param ) = each %funkyhash ) {
 746                         my $inout_lc    = lc($inout);
 747                         my @ALLARTICLES = @{$param};
 748                         $message .= "<${inout_lc}Objects><${inout}>\n";
 749
 750 #               input =>[
 751 #                                       [articleName1,[objType1 => \@namespaces]], # Simple
 752 #                    [articleName2,       [[objType2 => \@namespaces]]], # collection of one object type
 753 #                    [articleName3,[[objType3 => \@namespaces],
 754 #                                   [objType4 => \@namespaces]]] # collection of multiple object types (THIS IS NOW ILLEGAL!)
 755 #                    ]
 756                         foreach my $article (@ALLARTICLES) {
 757                                 my ( $articleName, $def ) = @{$article};
 758                                 $articleName ||= "";
 759                                 my @Objects;    #
 760                                 unless ( ref($def) eq 'ARRAY') { # $def = [objType => \@ns]  or $def=[[objType => \@ns]]
 761                                         return $self->errorRegXML("invalid structure of $inout objects, expected SINGLE arrayref for article $articleName as required by the 0.86 API");
 762                                 }
 763                                 my @objectdefs;
 764                                 if ( ( ref $def->[0] ) eq 'ARRAY' ) {    # collection $def->[0] = [objType => \@ns]
 765                                             # def= [[objType2 => [ns3, ns4...]], ...]
 766                                         $message .= "<Collection articleName='$articleName'>\n";
 767                                         if (scalar(@{$def->[0]} > 2)){
 768                                           return $self->errorRegXML("invalid structure of $inout objects.  Collections may not have more than one Simple content type as per API version 0.86");
 769                                         }
 770                                         @objectdefs = @{$def};
 771                                         if (scalar(@objectdefs) > 1){
 772                                           return $self->errorRegXML("invalid structure of $inout objects.  Collections may not have more than one Simple content type as per API version 0.86");
 773                                         }
 774                                 } else {    # Simple $def->[0] = objType
 775                                   # def = [objType1 => [ns1, ns2...]],
 776                                   @objectdefs = ($def);
 777                                 }
 778                                 foreach my $objectdef (@objectdefs) {
 779                                         if ( ref( $def->[0] ) eq 'ARRAY' ) {
 780                                                 $message .= "<Simple>\n";
 781                                         }
 782                                         else {
 783                                                 $message .= "<Simple articleName='$articleName'>\n";
 784                                         }
 785                                         my ( $type, $Namespaces ) = @{$objectdef};
 786                                         $type ||= "";
 787                                         $message .= "<objectType>$type</objectType>\n";
 788                                         unless ( ref($Namespaces) eq 'ARRAY' ) {
 789                                                 return $self->errorRegXML(
 790 "invalid structure of $inout namespaces for object $type in article $articleName; expected arrayref"
 791                                                 );
 792                                         }
 793                                         foreach my $ns ( @{$Namespaces} ) {
 794                                                 $message .= "<Namespace>$ns</Namespace>\n";
 795                                         }
 796                                         $message .= "</Simple>\n";
 797                                 }
 798                                 if ( ref( $def->[0] ) eq  'ARRAY' ) {
 799                                         $message .= "</Collection>\n";
 800                                 }
 801                         }
 802                         $message .= "</${inout}></${inout_lc}Objects>\n";
 803                 }
 804
 805                 #               secondary => {parametername1 => {datatype => TYPE,
 806                 #                                                                               default => DEFAULT,
 807                 #                                                                               max => MAX,
 808                 #                                                                               min => MIN,
 809                 #                                                                               enum => [one, two]},
 810                 #                                       parametername2 => {datatype => TYPE,
 811                 #                                                                               default => DEFAULT,
 812                 #                                                                               max => MAX,
 813                 #                                                                               min => MIN,
 814                 #                                                                               enum => [one, two]}
 815                 #                                         }
 816                 #
 817                 $message .= "<secondaryArticles>\n";
 818                 while ( my ( $param, $desc ) = each %SEC ) {
 819                         unless ( ref($desc) eq 'HASH' ) {
 820                                 return $self->errorRegXML( "invalid structure of secondary article $param; expected hashref of limitations"
 821                                 );
 822                         }
 823                         my %data     = %{$desc};
 824                         my $default  = defined($data{default})?$data{default}:"";
 825                         my $max      = defined($data{max})?$data{max}:"";
 826                         my $min      = defined($data{min})?$data{min}:"";
 827                         my $datatype = $data{datatype} || "";
 828                         my $enums    = $data{enum} || [];
 829                         unless ($datatype) {
 830                                 return $self->errorRegXML("a secondaryArticle must contain at least a datatype value in secondary article $param"
 831                                 );
 832                         }
 833                         unless ( $datatype =~ /Integer|Float|String|DateTime/ )
 834                         {
 835                                 return $self->errorRegXML("a secondaryArticle must have a datatype of Integer, Float, String, or DateTime"
 836                                 );
 837                         }
 838                         unless ( ref($enums) eq 'ARRAY' ) {
 839                                 return $self->errorRegXML("invalid structure of enum limits in secondary article $param; expected arrayref"
 840                                 );
 841                         }
 842                         my @enums = @{$enums};
 843                         $message .= "<Parameter articleName='$param'>\n";
 844                         $message .= "<default>$default</default>\n";
 845                         $message .= "<datatype>$datatype</datatype>\n";
 846                         $message .= "<max>$max</max>\n";
 847                         $message .= "<min>$min</min>\n";
 848                         foreach (@enums) {
 849                                 $message .= "<enum>$_</enum>\n";
 850                         }
 851                         $message .= "</Parameter>\n";
 852                 }
 853                 $message .= "</secondaryArticles>\n";
 854                 $message .= "</registerService>";
 855         }
 856         else {
 857                 return $self->errorRegXML(
 858 "only 'moby' and 'wsdl' service types are allowed to be registered at this time."
 859                 );
 860         }
 861
 862 #elsif ($Category eq "cgi") {
 863 #               my $IN = $a{input};
 864 #               $message .= "
 865 #               <inputObjects>
 866 #                       <Input><![CDATA[$IN]]></Input>
 867 #               </inputObjects>
 868 #       </registerService>";
 869 #} else {
 870 #               $message .= "
 871 #       </registerService>";
 872 #}
 873 #unless ($message =~ /\<\/registerService/){ return MOBY::Registration->new(
 874 #       success => "0",
 875 #       error_messsage => "missing parameters or other failure leading to incorrectly formatted XML",
 876 #       registration_id => "0")};
 877 #       print STDERR $message;
 878         $debug && &_LOG(" message\n\n$message\n\n");
 879
 880 #       my $return = $self->SOAP_connection->call(registerService => ($message))->paramsall;
 881         my ($return) = $self->_call( 'default', 'registerService', $message );
 882
 883 #       return ( $self->parseRegXML( $return ) );
 884 #_______call a new version RDFbuilder (by Eddie Kawas) _________________________________________
 885         my $reg = $self->parseRegXML($return);
 886
 887 #  if ($reg->success == 1){
 888 #  require LWP::UserAgent;
 889 #
 890 #     my $ua = LWP::UserAgent->new;
 891 #         my $url='http://mobycentral.cbr.nrc.ca:8090/servlets/forms/getSignatureResponse?domain='.$authURI.'&serviceName='.$name;
 892 #
 893 #        my $response = $ua->get($url);
 894 #        my $rdf = $response->content;
 895 #        print "$rdf\n";
 896 #}
 897
 898         return $reg;
 899
 900 #_______________________________________________________________________________________________
 901
 902 }
 903
 904 =head2 registerServiceWSDL
 905
 906  Usage     :    Needs documentation
 907
 908 =cut
 909
 910 sub registerServiceWSDL {
 911         my ( $self, %a ) = @_;
 912         return $self->errorRegXML(
 913                 "Function not allowed when querying multiple registries")
 914           if $self->multiple_registries;
 915         my $message = "";
 916
 917 #       my $return = $self->SOAP_connection->call(registerServiceWSDL => ($message))->paramsall;
 918         my ($return) = $self->_call( 'default', 'registerServiceWSDL', $message );
 919
 920         return ( $self->parseRegXML($return) );
 921 }
 922
 923 =head2 deregisterService
 924
 925  Usage     :    $REG = $MOBY->deregisterService(%args)
 926  Function  :    deregister a registered MOBY Service
 927  Returns   :    MOBY::Registration object
 928  Args      :    serviceName => $serviceID, authURI => $authority
 929
 930
 931 =cut
 932
 933 sub deregisterService {
 934         my ( $self, %a ) = @_;
 935         return $self->errorRegXML(
 936                 "Function not allowed when querying multiple registries")
 937           if $self->multiple_registries;
 938         my $name = $a{'serviceName'};
 939         my $auth = $a{'authURI'};
 940         ( defined($name) && defined($auth) ) || return (
 941                 &parseRegXML( "
 942                 <MOBYRegistration>
 943                         <id></id>
 944                         <success>0</success>
 945                         <message><![CDATA[you did not pass a valid service Identifier]]></message>
 946                 </MOBYRegistration>" )
 947         );
 948         my $message = "
 949                 <deregisterService>
 950                         <serviceName>$name</serviceName>
 951                         <authURI>$auth</authURI>
 952                 </deregisterService>";
 953
 954 #       my $return = $self->SOAP_connection->call(deregisterService => ($message))->paramsall;
 955         my ($return) = $self->_call( 'default', 'deregisterService', $message );
 956         return ( $self->parseRegXML($return) );
 957 }
 958
 959 =head2  findService
 960
 961  Usage     :    ($ServiceInstances, $RegObject) = $MOBY->findService(%args)
 962  Function  :    Find services that match certain search criterion
 963  Returns   :    ON SUCCESS: arrayref of MOBY::Client::ServiceInstance objects, and undef
 964                                 ON FAILURE: undef, and a MOBY::Registration object indicating the reason for failure
 965  Args      :
 966          Registry  => which registry do you want to search (optional)
 967      serviceName  => $serviceName,  (optional)
 968      serviceType  => $serviceType,  (optional)
 969      authURI      => $authURI,      (optional)
 970      authoritative => 1,    (optional)
 971      category  =>  "moby" | "cgi" | "soap" (currently only moby supported)    (optional)
 972      expandObjects => 1,    (optional)
 973      expandServices => 1,    (optional)
 974      URL    =>  $URL_TO_SERVICE    (optional)
 975      keywords => [kw1, kw2, kw3]    (optional)
 976      input =>[    (optional)
 977               [objType1 => [ns1, ns2...]], # Simple
 978               [[objType2 => [ns3, ns4...]]], # collection of one object type
 979               [[objType3 => [ns3, ns4...]],
 980                [objType4 => [ns5, ns6...]]], # collection of multiple object types
 981               ]
 982      output =>[    (optional)
 983                [objType1 => [ns1, ns2...]], # Simple
 984                [[objType2 => [ns3, ns4...]]], # collection of one object type
 985                [[objType3 => [ns3, ns4...]],
 986                 [objType4 => [ns5, ns6...]]], # collection of multiple object types
 987               ]
 988
 989
 990 =cut
 991
 992 sub findService {
 993         my ( $self, %a ) = @_;
 994         my $reg = ( $a{Registry} ) ? $a{Registry} : $self->default_MOBY_servername;
 995         my $id = $a{'serviceID'};
 996         my $servicename = $a{'serviceName'} || "";
 997         my $authoritative = $a{'authoritative'} || 0;
 998         my $serviceType = $a{'serviceType'} || "";
 999         my $authURI = $a{'authURI'} || "";
1000         my $category = $a{'category'} || "moby";
1001         my $exObj = $a{'expandObjects'} || 0;
1002         my $exServ = $a{'expandServices'} || 0;
1003         my $kw = $a{'keywords'} || [];
1004         ref($kw) eq 'ARRAY' || return (
1005                 undef,
1006                 $self->errorRegXML(
1007                         "invalid structure of keywords.  Expected arrayref"
1008                 )
1009         );
1010         my @kw      = @{$kw};
1011         my $message = "<findService>\n";
1012         defined($authoritative)
1013           && ( $message .= "<authoritative>$authoritative</authoritative>\n" );
1014         $category    && ( $message .= "<Category>$category</Category>\n" );
1015         $serviceType && ( $message .= "<serviceType>$serviceType</serviceType>\n" );
1016         $servicename && ( $message .= "<serviceName>$servicename</serviceName>\n" );
1017         $authURI     && ( $message .= "<authURI>$authURI</authURI>\n" );
1018         defined($exObj)
1019           && ( $message .= "<expandObjects>$exObj</expandObjects> \n" );
1020         defined($exServ)
1021           && ( $message .= "<expandServices>$exServ</expandServices>\n" );
1022
1023         if ( scalar(@kw) ) {
1024                 $message .= "   <keywords>\n";
1025                 foreach my $kwd (@kw) {
1026                         $message .= "<keyword>$kwd</keyword>\n";
1027                 }
1028                 $message .= "</keywords>\n";
1029         }
1030
1031         #$a{input} = [[]] unless (defined $a{input});
1032         #$a{output} = [[]] unless (defined $a{output});
1033         if ( defined $a{input} && ( ref( $a{input} ) ne 'ARRAY' ) ) {
1034                 return (
1035                         undef,
1036                         $self->errorRegXML(
1037 "invalid structure of input objects, expected arrayref for input"
1038                         )
1039                 );
1040         }
1041         if ( defined $a{output} && ( ref( $a{output} ) ne 'ARRAY' ) ) {
1042                 return (
1043                         undef,
1044                         $self->errorRegXML(
1045 "invalid structure of output objects, expected arrayref for output"
1046                         )
1047                 );
1048         }
1049         my %funkyhash;
1050         $funkyhash{Input}  = $a{input}  if ( defined $a{input} );
1051         $funkyhash{Output} = $a{output} if ( defined $a{output} );
1052
1053   #input =>[
1054   #         [objType1 => [ns1, ns2...]], # Simple
1055   #         [[objType2 => [ns3, ns4...]]], # collection of one object type
1056   #         [[objType3 => [ns3, ns4...]],
1057   #          [objType4 => [ns5, ns6...]]], # collection of multiple object types
1058   #         ]
1059         while ( my ( $inout, $param ) = each %funkyhash ) {
1060                 die "no inout parameter from teh funkyhash" unless defined $inout;
1061                 die "no param parameter from teh funkyhash" unless defined $param;
1062                 die "param parameter should be a listref"
1063                   unless ( ref($param) eq 'ARRAY' );
1064                 my $inout_lc = lc($inout);
1065                 my @PARAM    = @{$param};
1066                 $message .= "<${inout_lc}Objects><${inout}>\n";
1067                 foreach my $param (@PARAM) {
1068                         unless ( ref($param) eq 'ARRAY' ) {
1069                                 return (
1070                                         undef,
1071                                         $self->errorRegXML(
1072 "invalid structure of $inout objects, expected arrayref of class and \@namespaces"
1073                                         )
1074                                 );
1075                         }
1076                         my ( $class, $namespaces ) = @{$param};
1077                         die "no class part of param " unless defined $class;
1078
1079                         #warn "no namespace part of the param" unless defined $namespaces;
1080                         my @objectdefs;
1081                         if ( ref $class  eq 'ARRAY' ) {    # collection
1082                                 $message .= "<Collection>\n";
1083                                 @objectdefs = $class;
1084                         }
1085                         else {                                 # Nipple
1086                                 @objectdefs = ($param);
1087                         }
1088                         foreach my $objectdef (@objectdefs) {
1089                                 $message .= "<Simple>\n";
1090                                 my ( $type, $Namespaces ) = @{$objectdef};
1091                                 die "type is missing from objectdef " unless $type;
1092                                 $message .= "<objectType>$type</objectType>\n";
1093                                 if ( defined($Namespaces)
1094                                         && ( ref($Namespaces) ne 'ARRAY' ) )
1095                                 {
1096                                         return (
1097                                                 undef,
1098                                                 $self->errorRegXML(
1099 "invalid structure of $inout namespaces for object $type; expected arrayref"
1100                                                 )
1101                                         );
1102                                 }
1103                                 foreach my $ns ( @{$Namespaces} ) {
1104                                         next unless $ns;
1105                                         $message .= "<Namespace>$ns</Namespace>\n";
1106                                 }
1107                                 $message .= "</Simple>\n";
1108                         }
1109                         if ( ref($class) eq 'ARRAY' ) {
1110                                 $message .= "</Collection>\n";
1111                         }
1112                 }
1113                 $message .= "</${inout}></${inout_lc}Objects>\n";
1114         }
1115         $message .= "</findService>\n";
1116
1117 #       my $return = $self->SOAP_connection($reg)->call('findService' => ($message))->paramsall;
1118         my ($return) = $self->_call( $reg, 'findService', $message );
1119         return ( $self->_parseServices( $reg, $return ), undef );
1120 }
1121
1122 =head2 retrieveService
1123
1124  Usage     :    $WSDL = $MOBY->retrieveService($ServiceInstance)
1125  Function  :    get the WSDL definition of the service with this name/authority URI
1126  Returns   :    a WSDL string
1127  Args      :    The ServiceInstance object for that service (from findService call)
1128
1129 =cut
1130
1131 sub retrieveService {
1132         my ( $self, $SI ) = @_;
1133         return undef unless $SI && $SI->isa('MOBY::Client::ServiceInstance');
1134         my $auth = $SI->authority;
1135         my $name = $SI->name;
1136         my $reg  = $SI->registry;
1137         return undef unless ( $auth && $name && $self->Connection($reg) );
1138         my $message = "
1139         <retrieveService>
1140         " . ( $SI->XML ) . "
1141         </retrieveService>";
1142
1143         my ($return) = $self->_call( $reg, 'retrieveService', $message );
1144         my $parser = XML::LibXML->new();
1145         my $doc   = $parser->parse_string($return);
1146         my $de    = $doc->getDocumentElement;
1147         my @child = $de->childNodes;
1148         my $content;
1149         foreach (@child) {
1150                 $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" );
1151                 if ( $_->nodeType == TEXT_NODE ) {
1152                         $content .= $_->nodeValue;    #else try $_->textContent
1153                 }
1154                 else {
1155                         $content .= $_->toString;
1156                 }
1157         }
1158         $content =~ s/^\n//gs;
1159         $content =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1160
1161         return $content;
1162 }
1163
1164
1165 =head2 retrieveResourceURLs
1166
1167  Usage     :    $names = $MOBY->retrieveResourceURLs()
1168  Function  :    get a hash of the URL's for each of the MOBY ontologies
1169  Returns   :    hashref to the following hash
1170                 $names{Ontology} = [URL1, URL2,...]
1171  Args      :    none
1172
1173 =cut
1174
1175 sub retrieveResourceURLs {
1176         my ($self, %args) = shift;
1177         my $reg = $args{registry};
1178         $reg = $reg ? $reg : $self->default_MOBY_servername;
1179         return undef unless ( $self->Connection($reg) );
1180         my ($return) = $self->_call( $reg, 'retrieveResourceURLs', "" );
1181         my $parser = XML::LibXML->new();
1182         my $doc        = $parser->parse_string($return);
1183         my $root       = $doc->getDocumentElement;
1184         my $urls_list = $root->childNodes;
1185         my %urls;
1186         for ( my $x = 1 ; $x <= $urls_list->size() ; $x++ ) {
1187                 next unless $urls_list->get_node($x)->nodeType == ELEMENT_NODE;
1188                 my $ontology = $urls_list->get_node($x)->getAttributeNode('name')->getValue;
1189                 my $url = $urls_list->get_node($x)->getAttributeNode('url')->getValue;
1190                 push @{ $urls{$ontology} }, $url
1191         }
1192         return \%urls;
1193 }
1194
1195
1196 =head2 retrieveServiceNames
1197
1198  Usage     :    $names = $MOBY->retrieveServiceNames(%args)
1199  Function  :    get a (redundant) list of all registered service names
1200                 (N.B. NOT service types!)
1201  Returns   :    hashref to the following hash
1202                 $names{$AuthURI} = [serviceName_1, serviceName_2, serviceName3...]
1203  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1204                 as_lsid => $boolean: return service names as their corresponding LSID's (default off)
1205
1206 =cut
1207
1208 sub retrieveServiceNames {
1209         my ($self, %args) = @_;
1210         my $reg = $args{registry};
1211         my $aslsid = $args{as_lsid};
1212
1213         $reg = $reg ? $reg : $self->default_MOBY_servername;
1214         return undef unless ( $self->Connection($reg) );
1215
1216 #    my $return = $self->SOAP_connection($reg)->call('retrieveServiceNames' => (@_))->paramsall;
1217         my ($return) = $self->_call( $reg, 'retrieveServiceNames', "" );
1218         my $parser = XML::LibXML->new();
1219         my $doc        = $parser->parse_string($return);
1220         my $root       = $doc->getDocumentElement;
1221         my $names_list = $root->childNodes;
1222         my %servicenames;
1223         for ( my $x = 1 ; $x <= $names_list->size() ; $x++ ) {
1224                 next unless $names_list->get_node($x)->nodeType == ELEMENT_NODE;
1225                 my $name =
1226                   $names_list->get_node($x)->getAttributeNode('name')->getValue;
1227                 my $auth =
1228                   $names_list->get_node($x)->getAttributeNode('authURI')->getValue;
1229                 my $lsid = $names_list->get_node($x)->getAttributeNode('lsid');
1230                 if ($lsid){
1231                     $lsid = $lsid->getValue;
1232                 } else {
1233                     $lsid = $name;
1234                 }
1235                 $lsid ||=$name;
1236                 push @{ $servicenames{$auth} }, $aslsid?$lsid:$name;
1237         }
1238         return \%servicenames;
1239 }
1240
1241 =head2 retrieveServiceProviders
1242
1243  Usage     :    @URIs = $MOBY->retrieveServiceProviders([$reg_name])
1244  Function  :    get the list of all provider's AuthURI's
1245  Returns   :    list of service provider URI strings
1246  Args      :    $reg_name:  name of registry you wish to retrieve from (optional)
1247
1248 =cut
1249
1250 sub retrieveServiceProviders {
1251         my ($self) = shift;
1252         my $reg = shift;
1253         $reg = $reg ? $reg : $self->default_MOBY_servername;
1254         return undef unless ( $self->Connection($reg) );
1255
1256 #       my $return    = $self->SOAP_connection($reg)->call('retrieveServiceProviders' => (@_))->paramsall;
1257         my ($return) = $self->_call( $reg, 'retrieveServiceProviders', "" );
1258         my $parser = XML::LibXML->new();
1259         my $doc       = $parser->parse_string($return);
1260         my $root      = $doc->getDocumentElement;
1261         my $providers = $root->childNodes;
1262         my @serviceproviders;
1263         for ( my $x = 1 ; $x <= $providers->size() ; $x++ ) {
1264                 next unless $providers->get_node($x)->nodeType == ELEMENT_NODE;
1265                 push @serviceproviders,
1266                   $providers->get_node($x)->getAttributeNode('name')->getValue;
1267         }
1268         return @serviceproviders;
1269 }
1270
1271 =head2 retrieveServiceTypes
1272
1273  Usage     :    $types = $MOBY->retrieveServiceTypes(%args)
1274  Function  :    get the list of all registered service types
1275  Returns   :    hashref of $types{$type} = $definition
1276  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1277                 as_lsid  => $boolean:  return the $type as its corresponding LSID (defualt off)
1278
1279 =cut
1280
1281 sub retrieveServiceTypes {
1282         my ($self, %args) = shift;
1283         my $reg = $args{registry};
1284         my $as_lsid = $args{as_lsid};
1285
1286         $reg = $reg ? $reg : $self->default_MOBY_servername;
1287         return undef unless ( $self->Connection($reg) );
1288
1289 #       my $return = $self->SOAP_connection($reg)->call('retrieveServiceTypes' => (@_))->paramsall;
1290         my ($return) = $self->_call( $reg, 'retrieveServiceTypes', "" );
1291         my $parser = XML::LibXML->new();
1292         my $doc   = $parser->parse_string($return);
1293         my $root  = $doc->getDocumentElement;
1294         my $types = $root->childNodes;
1295         my %servicetypes;
1296         for ( my $x = 1 ; $x <= $types->size() ; $x++ ) {
1297                 next unless $types->get_node($x)->nodeType == ELEMENT_NODE;
1298                 my $type = $types->get_node($x)->getAttributeNode('name')->getValue;
1299                 my $lsid = $types->get_node($x)->getAttributeNode('lsid');
1300                 if ($lsid){
1301                     $lsid = $lsid->getValue;
1302                 } else {
1303                     $lsid = $type;
1304                 }
1305                 my $desc;
1306                 for
1307                   my $elem ( $types->get_node($x)->getElementsByTagName('Description') )
1308                 {
1309                         $desc = $elem->firstChild->toString;
1310                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1311                                 $desc = $1;
1312                         }
1313                 }
1314                 $desc =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1315                 $servicetypes{$as_lsid?$lsid:$type} = $desc;
1316         }
1317         return \%servicetypes;
1318 }
1319
1320
1321 =head2 retrieveServiceTypesFull
1322
1323  Usage     :    $types = $MOBY->retrieveServiceTypesFull(%args)
1324  Function  :    get all details of all service types
1325  Returns   :    hashref of $types{$type} = {definition => "definition",
1326                                             authURI  => "authority.uri.here",
1327                                             contactEmail => "email@addy.here"}
1328  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1329                 as_lsid  => $boolean:  return the $type as its corresponding LSID (defualt off)
1330
1331 =cut
1332
1333
1334 sub retrieveServiceTypesFull {
1335         my ($self, %args) = shift;
1336         my $reg = $args{registry};
1337         my $as_lsid = $args{as_lsid};
1338
1339         $reg = $reg ? $reg : $self->default_MOBY_servername;
1340         return undef unless ( $self->Connection($reg) );
1341
1342 #       my $return = $self->SOAP_connection($reg)->call('retrieveServiceTypes' => (@_))->paramsall;
1343         my ($return) = $self->_call( $reg, 'retrieveServiceTypes', "" );
1344         my $parser = XML::LibXML->new();
1345         my $doc   = $parser->parse_string($return);
1346         my $root  = $doc->getDocumentElement;
1347         my $types = $root->childNodes;
1348         my %servicetypes;
1349         for ( my $x = 1 ; $x <= $types->size() ; $x++ ) {
1350                 next unless $types->get_node($x)->nodeType == ELEMENT_NODE;
1351                 my $type = $types->get_node($x)->getAttributeNode('name')->getValue;
1352                 my $lsid = $types->get_node($x)->getAttributeNode('lsid');
1353                 if ($lsid){
1354                     $lsid = $lsid->getValue;
1355                 } else {
1356                     $lsid = $type;
1357                 }
1358                 my ($desc, $auth, $email);
1359                 for
1360                   my $elem ( $types->get_node($x)->getElementsByTagName('Description') )
1361                 {
1362                         $desc = $elem->firstChild->toString;
1363                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1364                                 $desc = $1;
1365                         }
1366                 }
1367                 for
1368                   my $elem ( $types->get_node($x)->getElementsByTagName('authURI') )
1369                 {
1370                         $auth = $elem->firstChild->toString;
1371                         if ( $auth =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1372                                 $auth = $1;
1373                         }
1374                 }
1375                 for
1376                   my $elem ( $types->get_node($x)->getElementsByTagName('contactEmail') )
1377                 {
1378                         $email = $elem->firstChild->toString;
1379                         if ( $email =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1380                                 $email = $1;
1381                         }
1382                 }
1383                 $desc =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;  # somehow these CDATA elements are nested sometimes???
1384                 $servicetypes{$as_lsid?$lsid:$type} = {Description => $desc, authURI => $auth, contactEmail => $email};
1385         }
1386         return \%servicetypes;
1387 }
1388
1389
1390 =head2 retrieveObjectNames
1391
1392  Usage     :    $names = $MOBY->retrieveObjectNames(%args)
1393  Function  :    get the list of all registered Object types
1394  Returns   :    hashref of hash:
1395                 $names{$name} = $definition
1396  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1397                 as_lsid  => $boolean:  return $name as its correspnding LSID (optional default off)
1398
1399 =cut
1400
1401 sub retrieveObjectNames {
1402         my ($self, %args) = @_;
1403         my $reg = $args{registry};
1404         my $as_lsid = $args{as_lsid};
1405         $reg = $reg ? $reg : $self->default_MOBY_servername;
1406         return undef unless ( $self->Connection($reg) );
1407         my ($return) = $self->_call( $reg, 'retrieveObjectNames', "" );
1408         my $parser = XML::LibXML->new();
1409         my $doc     = $parser->parse_string($return);
1410         my $root    = $doc->getDocumentElement;
1411         my $obnames = $root->childNodes;
1412         my %objectnames;
1413         for ( my $x = 1 ; $x <= $obnames->size() ; $x++ ) {
1414                 next unless $obnames->get_node($x)->nodeType == ELEMENT_NODE;
1415                 my $name = $obnames->get_node($x)->getAttributeNode('name')->getValue;
1416                 my $lsid = $obnames->get_node($x)->getAttributeNode('lsid');
1417                 if ($lsid){
1418                     $lsid = $lsid->getValue;
1419                 } else {
1420                     $lsid = $name;
1421                 }
1422                 my $desc;
1423                 for my $elem (
1424                         $obnames->get_node($x)->getElementsByTagName('Description') )
1425                 {
1426                         $desc = $elem->firstChild->toString;
1427                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1428                                 $desc = $1;
1429                         }
1430                 }
1431                 $desc =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1432                 $objectnames{$as_lsid?$lsid:$name} = $desc;
1433         }
1434         return \%objectnames;
1435 }
1436
1437
1438 =head2 retrieveObjectDefinition
1439
1440  Usage     : $DEF = $MOBY->retrieveObjectDefinition(objectType => $objectType)
1441  Function  : retrieve the $XML that was used to register an object and its relationships
1442  Returns   : hashref, identical to the hash sent during Object registration, plus
1443              an additional XML hash key that contains the actual XML containing
1444              the object definition as sent by MOBY Central (used for a visual
1445              overview, rather than parsing all of the hash keys)
1446              objectType => "the name of the Object"
1447              objectLSID => "urn:lsid:..."
1448              description => "a human-readable description of the object"
1449              contactEmail => "your@email.address"
1450              authURI => "URI of the registrar of this object"
1451              Relationships => {
1452                relationshipType1 => [
1453                  {object      => Object1,
1454                   articleName => ArticleName1,
1455                   lsid        => lsid1},
1456                  {object      => Object2,
1457                   articleName => ArticleName2,
1458                   lsid        => lsid2}
1459                ],
1460                relationshipType2 => [
1461                  {object      => Object3,
1462                   articleName => ArticleName3,
1463                   lsid        => lsid3}
1464                ]
1465              }
1466              XML => <....XML of object registration.../>
1467
1468  Args      : objectType =>  the name or LSID URI for an object
1469
1470 =cut
1471
1472 sub retrieveObjectDefinition {
1473         my ( $self, %a ) = @_;
1474         my $id = $a{objectType};
1475         return $self->errorRegXML(
1476                 "Function not allowed when querying multiple registries")
1477           if $self->multiple_registries;
1478         my %def;
1479         return \%def unless $id;
1480         my $message = "
1481                 <retrieveObjectDefinition>
1482                         <objectType>$id</objectType>
1483                 </retrieveObjectDefinition>";
1484         my ($return) =
1485           $self->_call( 'default', 'retrieveObjectDefinition', $message );
1486         return \%def unless $return;
1487         my ( $term, $lsid, $desc, $relationships, $email, $authURI ) =
1488           &_ObjectDefinitionPayload($return);
1489         $def{objectType}    = $term;
1490         $def{objectLSID}    = $lsid;
1491         $def{description}   = $desc;
1492         $def{contactEmail}  = $email;
1493         $def{authURI}       = $authURI;
1494         $def{Relationships} = $relationships;
1495         $def{XML}           = $return;
1496         return ( \%def );
1497 }
1498
1499 sub _ObjectDefinitionPayload {
1500         my ($payload) = @_;
1501         my $Parser    = XML::LibXML->new();
1502         my $doc       = $Parser->parse_string($payload);
1503         my $Object    = $doc->getDocumentElement();
1504         my $obj       = $Object->nodeName;
1505         return undef unless ( $obj eq 'retrieveObjectDefinition' );
1506         my $term = &_nodeTextContent( $Object,  "objectType" );
1507         my $lsid = &_nodeAttributeValue( $Object, "objectType", "lsid");
1508         my $desc = &_nodeCDATAContent( $Object, "Description" );
1509         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1510                 $desc = $1;
1511         }
1512         my $authURI = &_nodeTextContent( $Object, "authURI" );
1513         my $email   = &_nodeTextContent( $Object, "contactEmail" );
1514         my %att_value;
1515         my %relationships;
1516         my $x                = $doc->getElementsByTagName("Relationship");
1517         my $no_relationships = $x->size();
1518         for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) { #get_node starts at one
1519                 my $relationshipType =
1520                   $x->get_node($n)->getAttributeNode('relationshipType')
1521                   ;    # may or may not have a name
1522                 if ($relationshipType) {
1523                         $relationshipType = $relationshipType->getValue();
1524                 }
1525                 else {
1526                         return
1527                           "FAILED! must include a relationshipType in every relationship\n";
1528                 }
1529                 my @child = $x->get_node($n)->childNodes;
1530                 foreach (@child) {
1531                         next unless $_->nodeType == ELEMENT_NODE;
1532                         my $article =
1533                           $_->getAttributeNode('articleName');  # may or may not have a name
1534                         my $rlsid =
1535                           $_->getAttributeNode('lsid');  # may or may not have a name
1536                         if ($article) { $article = $article->getValue() }
1537                         if ($rlsid) { $rlsid = $rlsid->getValue() }
1538
1539                         my @child2 = $_->childNodes;
1540                         foreach (@child2) {
1541
1542                                 #print getNodeTypeName($_), "\t", $_->toString,"\n";
1543                                 next unless $_->nodeType == TEXT_NODE;
1544                                 push @{ $relationships{$relationshipType} },
1545                                         { object => $_->toString,
1546                                           articleName => $article,
1547                                           lsid => $rlsid };
1548                         }
1549                 }
1550         }
1551         return ( $term, $lsid, $desc, \%relationships, $email, $authURI );
1552 }
1553
1554
1555
1556 =head2 retrieveNamespaces
1557
1558  Usage     :    $ns = $MOBY->retrieveNamespaces(%args)
1559  Function  :    get the list of all registered Namespace types
1560  Returns   :    hashref of hash:
1561                 $ns{$namespace} = $definition
1562  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1563                 as_lsid  => $boolean:  retrieve $namespace as its corresponding LSID (default off)
1564
1565 =cut
1566
1567 sub retrieveNamespaces {
1568         my ($self, %args) = shift;
1569         my $reg = $args{registry};
1570         $reg = $reg ? $reg : $self->default_MOBY_servername;
1571         return undef unless ( $self->Connection($reg) );
1572         my $as_lsid = $args{as_lsid};
1573
1574         my ($return) = $self->_call( $reg, 'retrieveNamespaces', "" );
1575         my $parser = XML::LibXML->new();
1576         my $doc    = $parser->parse_string($return);
1577         my $root   = $doc->getDocumentElement;
1578         my $namesp = $root->childNodes;
1579         my %namespaces;
1580         for ( my $x = 1 ; $x <= $namesp->size() ; $x++ ) {
1581                 next unless $namesp->get_node($x)->nodeType == ELEMENT_NODE;
1582                 my $ns = $namesp->get_node($x)->getAttributeNode('name')->getValue;
1583                 my $lsid = $namesp->get_node($x)->getAttributeNode('lsid');
1584                 if ($lsid){
1585                     $lsid = $lsid->getValue;
1586                 } else {
1587                     $lsid = $ns;
1588                 }
1589                 my $desc;
1590                 for my $elem (
1591                         $namesp->get_node($x)->getElementsByTagName('Description') )
1592                 {
1593                         $desc = $elem->firstChild;
1594                         $desc = $desc ? $desc->toString : "";
1595                         $desc ||="";
1596                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1597                                 $desc = $1;
1598                         }
1599                 }
1600 #               $desc =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1601                 $namespaces{$as_lsid?$lsid:$ns} = $desc;
1602         }
1603         return \%namespaces;
1604 }
1605
1606 =head2 retrieveNamespacesFull
1607
1608  Usage     :    $ns = $MOBY->retrieveNamespaces(%args)
1609  Function  :    get all details about all namespaces
1610  Returns   :    hashref of hash:
1611                 $ns{$namespace} = {Definition => $definition,
1612                                    authURI => $authority,
1613                                    contactEmail => $email}
1614  Args      :    registry => $reg_name:  name of registry you wish to retrieve from (optional)
1615                 as_lsid  => $boolean:  retrieve $namespace as its corresponding LSID (default off)
1616
1617 =cut
1618
1619 sub retrieveNamespacesFull {
1620         my ($self, %args) = shift;
1621         my $reg = $args{registry};
1622         $reg = $reg ? $reg : $self->default_MOBY_servername;
1623         return undef unless ( $self->Connection($reg) );
1624         my $as_lsid = $args{as_lsid};
1625
1626         my ($return) = $self->_call( $reg, 'retrieveNamespaces', "" );
1627         my $parser = XML::LibXML->new();
1628         my $doc    = $parser->parse_string($return);
1629         my $root   = $doc->getDocumentElement;
1630         my $namesp = $root->childNodes;
1631         my %namespaces;
1632         for ( my $x = 1 ; $x <= $namesp->size() ; $x++ ) {
1633                 next unless $namesp->get_node($x)->nodeType == ELEMENT_NODE;
1634                 my $ns = $namesp->get_node($x)->getAttributeNode('name')->getValue;
1635                 my $lsid = $namesp->get_node($x)->getAttributeNode('lsid');
1636                 if ($lsid){
1637                     $lsid = $lsid->getValue;
1638                 } else {
1639                     $lsid = $ns;
1640                 }
1641                 my ($desc, $auth, $email);
1642                 for my $elem (
1643                         $namesp->get_node($x)->getElementsByTagName('Description') )
1644                 {
1645                         $desc = $elem->firstChild;
1646                         $desc = $desc ? $desc->toString : "";
1647                         $desc ||="";
1648                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1649                                 $desc = $1;
1650                         }
1651                 }
1652                 for my $elem (
1653                         $namesp->get_node($x)->getElementsByTagName('authURI') )
1654                 {
1655                         $auth = $elem->firstChild;
1656                         $auth = $auth ? $auth->toString : "";
1657                         $auth ||="";
1658                         if ( $auth =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1659                                 $auth = $1;
1660                         }
1661                 }
1662                 for my $elem (
1663                         $namesp->get_node($x)->getElementsByTagName('contactEmail') )
1664                 {
1665                         $email = $elem->firstChild;
1666                         $email = $email ? $email->toString : "";
1667                         $email ||="";
1668                         if ( $email =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1669                                 $email = $1;
1670                         }
1671                 }
1672                 $namespaces{$as_lsid?$lsid:$ns} = {Description => $desc, authURI => $auth, contactEmail => $email};
1673         }
1674         return \%namespaces;
1675 }
1676
1677
1678 =head2 retrieveObject
1679
1680  Usage     :    $objects = $MOBY->retrieveObjectNames(%args)
1681  Function  :    get the object xsd
1682  Returns   :    hashref of hash:
1683                 $objects{$name} = $W3C_XML_Schema_string
1684  Args      :    registry => $reg - name of MOBY Central you want to use (must pass undef otherwise)
1685                 objectType => $name - object name (from ontology) or undef to get all objects
1686                 as_lsid => $boolean - return $name as its corresponding LSID (default off)
1687
1688 =cut
1689
1690 sub retrieveObject {
1691         my ($self, %args)  = shift;
1692         my ($reg)   = $args{registry};
1693         my $type    = $args{objectType};
1694         my $as_lsid = $args{as_lsid};
1695         my $message = "
1696         <retrieveObject>
1697                  <objectType>$type</objectType>
1698         </retrieveObject>";
1699         $reg = $reg ? $reg : $self->default_MOBY_servername;
1700         return undef unless ( $self->Connection($reg) );
1701
1702         my ($return) = $self->_call( $reg, 'retrieveObject', $message );
1703         my $parser = XML::LibXML->new();
1704         my $doc     = $parser->parse_string($return);
1705         my $root    = $doc->getDocumentElement;
1706         my $objects = $root->childNodes;
1707         my %objects;
1708         for ( my $x = 1 ; $x <= $objects->size() ; $x++ ) {
1709                 next unless $objects->get_node($x)->nodeType == ELEMENT_NODE;
1710                 my $name = $objects->get_node($x)->getAttributeNode('name')->getValue;
1711                 my $lsid = $objects->get_node($x)->getAttributeNode('lsid');
1712                 if ($lsid){
1713                     $lsid = $lsid->getValue;
1714                 } else {
1715                     $lsid = $name;
1716                 }
1717                 my $desc;
1718                 for my $elem ( $objects->get_node($x)->getElementsByTagName('Schema') )
1719                 {
1720                         $desc = $elem->firstChild->nodeValue;
1721                         if ( $desc =~ /<!\[CDATA\[((?>[^\]]+))\]\]>/ ) {
1722                                 $desc = $1;
1723                         }
1724                 }
1725                 $desc =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1726                 $objects{$name} = $desc;
1727         }
1728         return \%objects;
1729 }
1730
1731 =head2 Relationships
1732
1733  Usage     :    $def = $MOBY->Relationships(%args)
1734  Function  :    traverse and return the relationships in the ontology
1735  Returns   :    hashref of
1736                 FOR SERVICES:
1737                         $hash{'isa'}=[{lsid => $lsid, term => 'termy'},...]
1738                 FOR OBJECTS:
1739                         $hash{relationship_type}=[{lsid => $lsid, articleName => 'thingy', term => 'termy'},...]
1740  Args      :    EITHER serviceType => $term_or_lsid
1741                 OR     objectType => $term_or_lsid
1742                 Relationships => \@relationship_types (optional, 'all' if parameter is missing)
1743                 Registry => $registry_name  (optional)
1744                 expandRelationships => [1/0] (optional)
1745
1746 =cut
1747
1748 sub Relationships {
1749         my ( $self, %args ) = @_;
1750         my $object  = $args{'objectType'};
1751         my $service = $args{'serviceType'};
1752         my $expand  = $args{'expandRelationships'};
1753         $expand = $args{'expandRelationship'}
1754           unless defined($expand);    # be forgiving of typos
1755         my @relationships;
1756         @relationships = @{ $args{'Relationships'} }
1757           if ( $args{'Relationships'}
1758                 && ( ref( $args{'Relationships'} ) eq 'ARRAY' ) );
1759         push @relationships, 'isa' unless $relationships[0];  # need to have at least one relationship
1760         my $reg = $args{'Registry'};
1761         my $m;
1762         my $payload;
1763         return {} unless ( $object || $service );
1764
1765         if ($object) {
1766                 $m = "
1767                 <Relationships>
1768             <objectType>$object</objectType>\n";
1769                 foreach (@relationships) {
1770                         $m .= "<relationshipType>$_</relationshipType>\n";
1771                 }
1772                 $m .= "<expandRelationship>1</expandRelationship>\n" if $expand;
1773                 $m .= "</Relationships>";
1774                 $reg = $reg ? $reg : $self->default_MOBY_servername;
1775                 return undef unless ( $self->Connection($reg) );
1776
1777 #$payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
1778                 ($payload) = $self->_call( $reg, 'Relationships', $m );
1779         }
1780         elsif ($service) {
1781                 $m = "
1782                 <Relationships>
1783             <serviceType>$service</serviceType>\n";
1784                 foreach (@relationships) {
1785                         $m .= "<relationshipType>$_</relationshipType>\n";
1786                 }
1787                 $m .= "<expandRelationship>1</expandRelationship>\n" if $expand;
1788                 $m .= "</Relationships>";
1789                 $reg = $reg ? $reg : $self->default_MOBY_servername;
1790                 return undef unless ( $self->Connection($reg) );
1791
1792 #               $payload = $self->SOAP_connection($reg)->call('Relationships' => ($m))->paramsall;
1793                 ($payload) = $self->_call( $reg, 'Relationships', $m );
1794         }
1795         return &_relationshipsPayload($payload);
1796 }
1797
1798
1799 sub _relationshipsPayload {
1800         my ($payload) = @_;
1801         return undef unless $payload;
1802         my %att_value;
1803         my %relationships;
1804         my $Parser           = XML::LibXML->new();
1805         my $doc              = $Parser->parse_string($payload);
1806         my $x                = $doc->getElementsByTagName("Relationship");
1807         my $no_relationships = $x->size();
1808         for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) {
1809                 my $relationshipType = $x->get_node($n)->getAttributeNode('relationshipType');    # may or may not have a name
1810                 if ($relationshipType) {
1811                         $relationshipType = $relationshipType->getValue();
1812                 } else {
1813                         return "FAILED! must include a relationshipType in every relationship\n";
1814                 }
1815                 my @child = $x->get_node($n)->childNodes;
1816                 foreach my $child(@child) {
1817                         my ($lsid, $article, $term) = ("", "", "");
1818                         next unless $child->nodeType == ELEMENT_NODE;
1819                         my $lsidattr = $child->getAttributeNode('lsid');    # may or may not have a name
1820                         if ($lsidattr) {
1821                                 $lsid = $lsidattr->getValue();
1822                         }
1823                         my $ARTattr = $child->getAttributeNode('articleName');    # may or may not have a name
1824                         if ($ARTattr) {
1825                                 $article = $ARTattr->getValue();
1826                         }
1827                         my %info;
1828                         $info{lsid} = $lsid;
1829                         ($info{articleName} = $article) if $article;
1830                         my @child2 = $child->childNodes;
1831                         foreach my $child2(@child2) {
1832                                 next unless $child2->nodeType == TEXT_NODE;
1833                                 $info{term} = $child2->toString;
1834                                 push @{ $relationships{$relationshipType} }, \%info;
1835                         }
1836                 }
1837         }
1838         return \%relationships;
1839 }
1840
1841 =head2 ISA
1842
1843  Usage     :    $def = $MOBY->ISA($class1, $class2)
1844  Function  :    a pre-canned use of the Relationships function
1845                 to quickly get an answer to whether class1 ISA class2
1846  Returns   :    Boolean
1847  Args      :    $class1  - an Object ontology term or LSID
1848                 $class2 - an Object ontology term or LSID
1849
1850 =cut
1851
1852 sub ISA {
1853         my ( $self, $class1, $class2 ) = @_;
1854         return 1
1855           if ( ( $class1 eq $class2 )
1856                 || ( "moby:$class1" eq $class2 )
1857                 || ( $class1        eq "moby:$class2" ) );
1858         my $lsid1 = $self->ObjLSID($class1);
1859         my $lsid2 = $self->ObjLSID($class2);
1860         return 0 unless $lsid1 && $lsid2;
1861         my @lsids;
1862         unless ( @lsids = $self->ISA_CACHE($lsid1) ) {
1863                 my $resp = $self->Relationships(
1864                         objectType         => $lsid1,
1865                         expandRelationship => 1,
1866                         Relationships      => ['isa']
1867                 );
1868                 my $lsids = $resp->{'isa'};
1869                 map {push @lsids, $self->ObjLSID($_->{lsid})} @$lsids;  # convert to LSID
1870                 $self->ISA_CACHE( $lsid1,  [@lsids] );
1871                 $self->ISA_CACHE( $class1, [@lsids] );
1872                 my @hold = @lsids;
1873                 while ( shift @hold ) {
1874                         $self->ISA_CACHE( $_, [@hold] );
1875                         if ( $_ =~ /^urn:lsid:biomoby.org.\w+\.(\S+)/ ) {
1876                                 $self->ISA_CACHE( $1, [@lsids] );
1877                         }
1878                 }
1879         }
1880         foreach (@lsids) {
1881             return 1 if $_ eq $lsid2;
1882         }
1883         return 0;
1884 }
1885
1886 =head2 DUMP
1887
1888  Usage     :    ($mobycentral, $mobyobject, $mobyservice, $mobynamespace, $mobyrelationship) = $MOBY->DUMP(['registry'])
1889  Function  :    DUMP the mysql for the current MOBY Central database
1890  Returns   :    text
1891  Args      :    $reg - name of MOBY Central you want to use if not default
1892
1893
1894 =cut
1895
1896 sub DUMP {
1897         my ($self) = shift;
1898         my ($reg)  = shift;
1899         my $type   = shift;
1900         $reg = $reg ? $reg : $self->default_MOBY_servername;
1901         return undef unless ( $self->Connection($reg) );
1902
1903         #       return $self->SOAP_connection($reg)->call('DUMP')->paramsall;
1904         my ($SQLs) = $self->_call( $reg, 'DUMP_MySQL', "" );
1905         my (
1906                 $mobycentral,   $mobyobject, $mobyservice,
1907                 $mobynamespace, $mobyrelationship
1908           )
1909           = @{$SQLs};
1910         return (
1911                 $mobycentral,   $mobyobject, $mobyservice,
1912                 $mobynamespace, $mobyrelationship
1913         );
1914 }
1915 *DUMP_MySQL = \&DUMP;
1916 *DUMP_MySQL = \&DUMP;
1917
1918 sub _parseServices {
1919         my ( $self, $Registry, $XML ) = @_;
1920         my $Parser   = XML::LibXML->new();
1921         my $doc      = $Parser->parse_string($XML);
1922         my $Object   = $doc->getDocumentElement();
1923         my $Services = $Object->getElementsByTagName("Service");
1924         my $num      = $Services->size();
1925         my @Services;
1926         for ( my $x = 1 ; $x <= $num ; $x++ ) {
1927                 my $Service       = $Services->get_node($x);
1928                 my $AuthURI       = $Service->getAttributeNode('authURI')->getValue;
1929                 my $servicename   = $Service->getAttributeNode('serviceName')->getValue;
1930                 my $lsid          = $Service->getAttributeNode('lsid');
1931                 if ($lsid){
1932                     $lsid = $lsid->getValue;
1933                 } else {
1934                     $lsid = "";
1935                 }
1936                 my $Type          = &_nodeTextContent( $Service, 'serviceType' );
1937                 my $authoritative = &_nodeTextContent( $Service, 'authoritative' );
1938                 my $contactEmail  = &_nodeTextContent( $Service, 'contactEmail' );
1939                 my $URL           = &_nodeTextContent( $Service, 'URL' );
1940
1941                 #my $Output = &_nodeTextContent($Service, 'outputObject');
1942                 my $Description = &_nodeCDATAContent( $Service, 'Description' );
1943                 $Description =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
1944                 my $cat = &_nodeTextContent( $Service, 'Category' );
1945                 my @INPUTS;
1946                 my @OUTPUTS;
1947                 foreach my $inout ( "Input", "Output" ) {
1948                         my $xPuts =
1949                           $Service->getElementsByTagName($inout)
1950                           ;    # there should only be one, but... who knows what
1951                         for my $in ( 1 .. $xPuts->size() ) {
1952                                 my $current = $xPuts->get_node($in);
1953                                 foreach my $child ( $current->childNodes )
1954                                 {    # child nodes will be either "Simple" or "Complex" tagnames
1955                                         next unless $child->nodeType == ELEMENT_NODE;
1956                                         my $THIS;
1957                                         if ( $child->nodeName eq "Simple" ) {
1958                                                 $THIS =
1959                                                   MOBY::Client::SimpleArticle->new( XML_DOM => $child );
1960                                         }
1961                                         elsif ( $child->nodeName eq "Collection" ) {
1962                                                 $THIS =
1963                                                   MOBY::Client::CollectionArticle->new(
1964                                                         XML_DOM => $child );
1965                                         }
1966                                         else {
1967                                                 next;
1968                                         }
1969                                         if ( $inout eq "Input" ) {
1970                                                 push @INPUTS, $THIS;
1971                                         }
1972                                         else {
1973                                                 push @OUTPUTS, $THIS;
1974                                         }
1975                                 }
1976                         }
1977                 }
1978                 my @SECONDARIES;
1979                 my $secs =
1980                   $Service->getElementsByTagName("secondaryArticles")
1981                   ;    # there should only be one, but... who knows what
1982                 for my $in ( 1 .. $secs->size() ) {
1983                         my $current = $secs->get_node($in);
1984                         foreach my $param ( $current->childNodes )
1985                         {    # child nodes will be "Parameter" tag names
1986                                 next
1987                                   unless $param->nodeType == ELEMENT_NODE
1988                                   && $param->nodeName eq "Parameter";
1989                                 my $THIS;
1990                                 $THIS =
1991                                   MOBY::Client::SecondaryArticle->new( XML_DOM => $param );
1992                                 push @SECONDARIES, $THIS;
1993                         }
1994                 }
1995                 my $Instance = MOBY::Client::ServiceInstance->new(
1996                         authority     => $AuthURI,
1997                         authoritative => $authoritative,
1998                         URL           => $URL,
1999                         LSID            => $lsid,
2000                         contactEmail  => $contactEmail,
2001                         name          => $servicename,
2002                         type          => $Type,
2003                         category      => $cat,
2004                         input         => \@INPUTS,
2005                         output        => \@OUTPUTS,
2006                         secondary     => \@SECONDARIES,
2007                         description   => $Description,
2008                         registry      => $Registry,
2009                         XML           => $Service->toString,
2010                 );
2011                 push @Services, $Instance;
2012         }
2013         return \@Services;
2014 }
2015
2016 #        my ($e, $m, $lsid) = $OS->objectExists(term => $_);
2017
2018 =head2 ObjLSID
2019
2020 =cut
2021
2022 sub ObjLSID {
2023         my ( $self, $term ) = @_;
2024         return undef unless $term;
2025         my $lsid;
2026         if ( $lsid = $self->LSID_CACHE($term) ) {
2027                 return $lsid;
2028         }
2029         else {
2030                 my $os = MOBY::Client::OntologyServer->new;
2031                 my ( $s, $m, $tlsid ) = $os->objectExists( term => $term );
2032                 if ($tlsid) {
2033                         $self->LSID_CACHE( $term,  $tlsid );    # link both the term
2034                         $self->LSID_CACHE( $tlsid, $tlsid );    # and the lsid to itself
2035                         return $tlsid;
2036                 }
2037                 else {
2038                         return undef;
2039                 }
2040         }
2041 }
2042
2043 =head2 LSID_CACHE
2044
2045  Usage     :    $lsid = $MOBY->LSID_CACHE($term, $lsid)
2046  Function  :    get/set LSID from the cache
2047  Returns   :    lsid as a scalar
2048  Args      :    the term for which you have/want an lsid,
2049                 and optionally the lsid to set.
2050
2051 =cut
2052
2053 sub LSID_CACHE {
2054         my ( $self, $term, $lsid ) = @_;
2055         if ( $term && $lsid ) {
2056                 $self->{LSID_CACHE}->{$term} = $lsid;
2057                 return $self->{LSID_CACHE}->{$term};
2058         }
2059         elsif ($term) {
2060                 return $self->{LSID_CACHE}->{$term};
2061         }
2062         else {
2063                 return undef;
2064         }
2065 }
2066
2067 =head2 ISA_CACHE
2068
2069  Usage     : @lsids = $MOBY->ISA_CACHE($lsid, \@isas)
2070  Function  : get/set the ISA relationships in the cache
2071  Returns   : list of ISA relationships.  The ISA list
2072              is IN ORDER from, excluding the term itself, to
2073              root Object. Base Object returns an empty list.
2074  Args      : The LSID for which you have/want the ISA parentage,
2075              and optionally the parentage listref to set.
2076  Note      : WHAT COMES BACK ARE LSIDs!!!
2077
2078 =cut
2079
2080 sub ISA_CACHE {
2081         my ( $self, $desiredterm, $isas ) = @_;
2082         my $term = $desiredterm;
2083         return (undef) if $isas && ( ref($isas) ne 'ARRAY');
2084         if ( $term && $isas ) {
2085                 my @isalsids;
2086                 foreach (@$isas){
2087                     my $lsid = $self->ObjLSID($_);
2088                     next unless ($lsid =~ /^urn\:lsid/);
2089                     push @isalsids, $lsid;
2090                 }
2091                 $self->{ISA_CACHE}->{$desiredterm} = [(@isalsids)];  # can't assign a listreference or it will empty itself!
2092                 while ( my $term = shift(@isalsids) ) {  # traverse down and flatten the list
2093                         $self->{ISA_CACHE}->{$term} = [(@isalsids)];
2094                 }
2095                 return @{ $self->{ISA_CACHE}->{$desiredterm} };
2096         }
2097         elsif ( $term && $self->{ISA_CACHE}->{$desiredterm} ) {
2098                 return @{ $self->{ISA_CACHE}->{$desiredterm} };
2099         }
2100         else {
2101                 return ();
2102         }
2103 }
2104
2105 sub parseRegXML {
2106
2107         #<MOBYRegistration>
2108         #       <id>$id</id>
2109         #       <success>$success</success>
2110         #       <message><![CDATA[$message]]></message>
2111         #</MOBYRegistration>
2112         my ( $self, $xml ) = @_;
2113         my $Parser = XML::LibXML->new();
2114
2115         #print STDERR $xml;
2116         my $doc    = $Parser->parse_string($xml);
2117         my $Object = $doc->getDocumentElement();
2118         my $obj    = $Object->nodeName;
2119         return undef unless ( $obj eq 'MOBYRegistration' );
2120         my $id      = &_nodeTextContent( $Object,  'id' );
2121         my $success = &_nodeTextContent( $Object,  'success' );
2122         my $message = &_nodeCDATAContent( $Object, 'message' );
2123
2124         #print STDERR "******$message******\n";
2125         my $RDF = &_nodeRawContent( $Object, 'RDF' );
2126         my $reg = MOBY::Client::Registration->new(
2127                 success         => $success,
2128                 message         => $message,
2129                 registration_id => $id,
2130                 RDF             => $RDF,
2131                 id              => $id
2132         );
2133         return $reg;
2134 }
2135
2136 sub errorRegXML {
2137         my ( $self, $message ) = @_;
2138         my $reg = MOBY::Client::Registration->new(
2139                 success         => 0,
2140                 message         => $message,
2141                 registration_id => -1,
2142         );
2143         return $reg;
2144 }
2145
2146 sub _nodeCDATAContent {
2147
2148         # will get text of **all** child $node from the given $DOM
2149         # regardless of their depth!!
2150         my ( $DOM, $node ) = @_;
2151         my $x = $DOM->getElementsByTagName($node);
2152         unless ( $x->get_node(1) ) { return }
2153         my @child = $x->get_node(1)->childNodes;
2154         my $content;
2155         foreach (@child) {
2156
2157                 #print getNodeTypeName($_), "\t", $_->toString,"\n";
2158                 next
2159                   unless ( ( $_->nodeType == TEXT_NODE )
2160                         || ( $_->nodeType == CDATA_SECTION_NODE ) );
2161                 $content = $_->textContent;
2162         }
2163         $content ||= "";
2164         $content =~ s/<!\[CDATA\[((?>[^\]]+))\]\]>/$1/gs;
2165         return $content;
2166 }
2167
2168 sub _nodeTextContent {
2169
2170         # will get text of **all** child $node from the given $DOM
2171         # regardless of their depth!!
2172         my ( $DOM, $node ) = @_;
2173         my $x = $DOM->getElementsByTagName($node);
2174         unless ( $x->get_node(1) ) { return }
2175         my @child = $x->get_node(1)->childNodes;
2176         my $content;
2177         foreach (@child) {
2178
2179                 #print getNodeTypeName($_), "\t", $_->toString,"\n";
2180                 next
2181                   unless ( ( $_->nodeType == TEXT_NODE )
2182                         || ( $_->nodeType == CDATA_SECTION_NODE ) );
2183                 $content = $_->textContent;
2184         }
2185         return $content;
2186 }
2187
2188 sub _nodeAttributeValue {
2189
2190         my ( $DOM, $node, $attr ) = @_;
2191         return "" unless $attr;
2192         my $x = $DOM->getElementsByTagName($node);
2193         unless ( $x->get_node(1) ) { return "" }
2194         my $n = $x->get_node(1);
2195         my $nodemap = $n->attributes($attr);  # XML::LibXML::NamedNodeMap - the worst documented (i.e. undocumented) piece of code ever written!  You have to read the source to figure out the interface...
2196         my $attrnode = $nodemap->getNamedItem($attr);
2197         my $attrval = $attrnode?($attrnode->value):"";
2198         return $attrval;
2199 }
2200
2201 sub _nodeRawContent {
2202
2203         # will get XML of **all** child $node from the given $DOM
2204         # regardless of their depth!!
2205         my ( $DOM, $node ) = @_;
2206         my $x = $DOM->getElementsByTagName($node);
2207         unless ( $x->get_node(1) ) { return }
2208         my @child = $x->get_node(1)->childNodes;
2209         my $content;
2210         foreach (@child) {
2211
2212                 #print getNodeTypeName($_), "\t", $_->toString,"\n";
2213                 #        next unless $_->nodeType == TEXT_NODE;
2214                 $content .= $_->toString;
2215         }
2216         return $content;
2217 }
2218
2219 sub _nodeArrayContent {
2220
2221         # will get array content of all child $node from given $DOM
2222         # regardless of depth!
2223         my ( $DOM, $node ) = @_;
2224         $debug && &_LOG( "_nodeArrayContext received DOM:  ",
2225                 $DOM->toString, "\nsearching for node $node\n" );
2226         my @result;
2227         my $x     = $DOM->getElementsByTagName($node);
2228         my @child = $x->get_node(1)->childNodes;
2229         foreach (@child) {
2230                 next unless $_->nodeType == ELEMENT_NODE;
2231                 my @child2 = $_->childNodes;
2232                 foreach (@child2) {
2233
2234                         #print getNodeTypeName($_), "\t", $_->toString,"\n";
2235                         next
2236                           unless ( ( $_->nodeType == TEXT_NODE )
2237                                 || ( $_->nodeType == CDATA_SECTION_NODE ) );
2238                         push @result, $_->textContent;
2239                 }
2240         }
2241         return @result;
2242 }
2243
2244 sub AUTOLOAD {
2245         no strict "refs";
2246         my ( $self, $newval ) = @_;
2247         $AUTOLOAD =~ /.*::(\w+)/;
2248         my $attr = $1;
2249         if ( $self->_accessible( $attr, 'write' ) ) {
2250                 *{$AUTOLOAD} = sub {
2251                         if ( defined $_[1] ) { $_[0]->{$attr} = $_[1] }
2252                         return $_[0]->{$attr};
2253                 };    ### end of created subroutine
2254 ###  this is called first time only
2255                 if ( defined $newval ) {
2256                         $self->{$attr} = $newval;
2257                 }
2258                 return $self->{$attr};
2259         }
2260         elsif ( $self->_accessible( $attr, 'read' ) ) {
2261                 *{$AUTOLOAD} = sub {
2262                         return $_[0]->{$attr};
2263                 };    ### end of created subroutine
2264                 return $self->{$attr};
2265         }
2266
2267         # Must have been a mistake then...
2268         croak "No such method: $AUTOLOAD";
2269 }
2270 sub DESTROY { }
2271
2272 sub _LOG {
2273         return unless $debug;
2274         open LOG, ">>/tmp/CentralLogOut.txt" or die "can't open logfile $!\n";
2275         print LOG join "\n", @_;
2276         print LOG "\n---\n";
2277         close LOG;
2278 }
2279 1;