[Bio] / FigKernelPackages / ACHserver.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/ACHserver.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6, Wed Sep 30 15:33:23 2009 UTC revision 1.13, Mon Nov 30 11:45:22 2009 UTC
# Line 5  Line 5 
5  # This is a SAS Component  # This is a SAS Component
6  #  #
7  use strict;  use strict;
8  use LWP::UserAgent;      use base qw(ClientThing);
 use YAML;  
9    
10  =head1 Annotation Clearinghouse Server Helper Object  =head1 Annotation Clearinghouse Server Helper Object
11    
# Line 43  Line 42 
42    
43  =head3 new  =head3 new
44    
45      my $ach = ACHserver->new(%options);      my $ss = ACHserver->new(%options);
46    
47  Construct a new ACHserver object. The following options are supported.  Construct a new server object. The
48    following options are supported.
49    
50  =over 4  =over 4
51    
52  =item url  =item url
53    
54  URL for the ACH server. This option may be used to redirect requests to a  URL for the server. This option is required.
 test version of the server, or to an older server script.  
55    
56  =item singleton  =item singleton (optional)
57    
58  If TRUE, results from methods will be returned in singleton mode. In singleton  If TRUE, results from methods will be returned in singleton mode. In singleton
59  mode, if a single result comes back, it will come back as a scalar rather than  mode, if a single result comes back, it will come back as a scalar rather than
# Line 67  Line 66 
66  sub new {  sub new {
67      # Get the parameters.      # Get the parameters.
68      my ($class, %options) = @_;      my ($class, %options) = @_;
69      # Get the options.      # Compute the URL.
70      my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";      $options{url} = "http://servers.nmpdr.org/ach/server.cgi" if ! defined $options{url};
71      my $singleton = $options{singleton} || 0;      # Construct the subclass.
72      # Create the fields of the object.      return $class->SUPER::new(ACH => %options);
     my $server_url = $url;  
     my $ua = LWP::UserAgent->new();  
     # Create the SAPserver object.  
     my $retVal = {  
                     server_url => $server_url,  
                     ua => $ua,  
                     singleton => $singleton,  
                  };  
     # Bless and return it.  
     bless $retVal, $class;  
     return $retVal;  
 }  
   
 =head2 Public Methods  
   
 All L<ACH/Primary Methods> are also methods of this object.  
   
 =head3 AUTOLOAD  
   
     my $result = $ach->method(%args);  
   
 Call a function on the server. Any method call on this object (other than  
 the constructor) is translated into a request against the server. This  
 enables us to add new server functions without requiring an update to this  
 module. The parameters are specified as a hash, and the result is a scalar  
 or object reference. If an error occurred, we will throw an exception.  
   
 =cut  
   
 # This variable will contain the method name.  
 our $AUTOLOAD;  
   
 sub AUTOLOAD {  
     # Get the parameters. We do some fancy dancing to allow the user to pass  
     # in a hash, a list, or a hash reference.  
     my $self = shift @_;  
     my $args = $_[0];  
     if (defined $args) {  
         if (scalar @_ gt 1) {  
             # Here we have multiple arguments. We check the first one for a  
             # leading hyphen.  
             if ($args =~ /^-/) {  
                 # This means we have hash-form parameters.  
                 my %args = @_;  
                 $args = \%args;  
             } else {  
                 # This means we have list-form parameters.  
                 my @args = @_;  
                 $args = \@args;  
             }  
         } else {  
             # Here we have a single argument. If it's a scalar, we convert it  
             # to a singleton list.  
             if (! ref $args) {  
                 $args = [$args];  
             }  
73          }          }
     }  
     # Declare the return variable.  
     my $retVal;  
     # Get the method name.  
     my $function = $AUTOLOAD;  
     # Strip off the stuff before the method name.  
     $function =~ s/.+:://;  
     # Compute the argument document.  
     my $argString = YAML::Dump($args);  
     # Get our user agent.  
     my $ua = $self->{ua};  
     # Request the function from the server.  
     my $response = $ua->post($self->{server_url},  
                              [function => $function, args => $argString,  
                               source => __PACKAGE__ ]);  
     # Get the response content.  
     my $content = $response->content;  
     if (! $response->is_success) {  
         die "Server error " . $response->status_line . "\n$content";  
     } else {  
         $retVal = YAML::Load($content);  
         # Figure out what we got back.  
         my $returnType = ref $retVal;  
         if ($returnType) {  
             if ($returnType eq 'ErrorDocument') {  
                 # Here an error occurred, so we throw an exception using the  
                 # error message.  
                 die $retVal->{message};  
             } elsif ($self->{singleton} && $returnType eq 'HASH' &&  
                      scalar(keys %$retVal) <= 1) {  
                 # Here we're in singleton mode and we got a single result,  
                 # so we dereference a bit to make it easier for the user  
                 # to access it.  
                 ($retVal) = values %$retVal;  
             }  
         }  
     }  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 DESTROY  
   
     $ss->DESTROY();  
   
 This method has no function. It's purpose is to keep the destructor from  
 being caught by the autoload processing.  
   
 =cut  
   
 sub DESTROY { }  
   
74    
75  1;  1;

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.13

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3