[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.12, Wed Nov 25 21:58:39 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;  
     use Carp;  
     use ErrorMessage;  
     no warnings qw(once);  
9    
10  =head1 Annotation Clearinghouse Server Helper Object  =head1 Annotation Clearinghouse Server Helper Object
11    
# Line 70  Line 66 
66  sub new {  sub new {
67      # Get the parameters.      # Get the parameters.
68      my ($class, %options) = @_;      my ($class, %options) = @_;
69      # Turn off YAML compression, which causes problems with our hash keys.      # Compute the URL.
70      $YAML::CompressSeries = 0;      $options{url} = "http://servers.nmpdr.org/ach/server.cgi" if ! defined $options{url};
71      # Get the options.      # Construct the subclass.
72      my $url = $options{url} || "http://servers.nmpdr.org/ach/server.cgi";      return $class->SUPER::new(ACH => %options);
     my $singleton = $options{singleton} || 0;  
     # Create the fields of the object. Note that if we're in localhost mode,  
     # the user agent is actually a SAP object.  
     my $server_url = $url;  
     my $ua;  
     if ($server_url ne 'localhost') {  
         require LWP::UserAgent;  
         $ua = LWP::UserAgent->new();  
         $ua->timeout(20 * 60);  
     } else {  
         require "ACH.pm";  
         $ua = ACH->new();  
73      }      }
     # Create the server object.  
     my $retVal = {  
                     server_url => $server_url,  
                     ua => $ua,  
                     singleton => $singleton,  
                  };  
     # Bless it.  
     bless $retVal, $class;  
     # Get the list of permitted methods from the server.  
     my $methodList = $retVal->_call_method(methods => []);  
     # Convert it to a hash and store it in this object.  
     $retVal->{methodHash} = { map { $_ => 1 } @$methodList };  
     # Return the object.  
     return $retVal;  
 }  
   
 =head3 AUTOLOAD  
   
     my $result = $server->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  
 object or its parent. The parameters are usually specified as a hash, and the  
 result is a scalar or object reference. In some cases the parameters are a list.  
 To deistinguish between the two cases, all hash keys must begin with hyphens.  
   
 If an error occurs, 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, a list reference, 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];  
             }  
         }  
     }  
     # Declare the return variable.  
     my $retVal;  
     # Get the method name.  
     my $function = $AUTOLOAD;  
     # Strip off the stuff before the method name.  
     $function =~ s/.+:://;  
     # Validate the method name.  
     if (! $self->{methodHash}{$function}) {  
         die "Method \"$function\" not supported.";  
     } else {  
         # Call the method.  
         $retVal = $self->_call_method($function, $args);  
         # We have our result. Adjust for singleton mode.  
         if ($self->{singleton} && ref $retVal 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 { }  
   
 =head2 Utility Methods  
   
 =head3 _call_method  
   
     my $result = $server->_call_method($method, $args);  
   
 Call the specified method on the server with the specified arguments and  
 return the result. The arguments must already be packaged as a hash or  
 list reference. This method is the heart of the AUTOLOAD method, and is  
 provided as a utility for specialized methods that can't use the AUTOLOAD  
 facility.  
   
 =over 4  
   
 =item method  
   
 Name of the server function being invoked.  
   
 =item args  
   
 Argument object to pass to the function.  
   
 =item RETURN  
   
 Returns a hash or list reference with the function results.  
   
 =back  
   
 =cut  
   
 sub _call_method {  
     # Get the parameters.  
     my ($self, $method, $args) = @_;  
     # Declare the return variable.  
     my $retVal;  
     # Get our user agent.  
     my $ua = $self->{ua};  
     # Determine the type.  
     if (ref $ua eq 'LWP::UserAgent') {  
         # Here we're going to a server. Compute the argument document.  
         my $argString = YAML::Dump($args);  
         # Request the function from the server.  
         my $content = $self->_send_request(function => $method, args => $argString,  
                                            source => __PACKAGE__);  
         $retVal = YAML::Load($content);  
     } else {  
         # Here we're calling a local method.  
         $retVal = eval("\$ua->$method(\$args)");  
         # Check for an error.  
         if ($@) {  
             die "Package error: $@";  
         }  
     }  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 _send_request  
   
     my $result = $server->_send_request(%parms);  
   
 Send a request to the server. This method must not be called in localhost  
 mode. If an error occurs, this method will die; otherwise, the content of  
 the response will be passed back as the result.  
   
 =over 4  
   
 =item parms  
   
 Hash of CGI parameters to send to the server.  
   
 =item RETURN  
   
 Returns the string returned by the server in response to the request.  
   
 =back  
   
 =cut  
   
 sub _send_request {  
     # Get the parameters.  
     my ($self, %parms) = @_;  
     # Get the user agent.  
     my $ua = $self->{ua};  
     # Request the function from the server. Note that the hash is actually passed  
     # as a list reference.  
   
     #  
     # retries is the set of retry wait times in seconds we should use. when  
     # we run out the call will fail.  
     #  
   
     my @retries = (1, 2, 5, 10, 20, 60, 60, 60, 60, 60, 60);  
     my %codes_to_retry =  map { $_ => 1 } qw(110 408 502 503 504 200) ;  
     my $response;  
     while (1)  
     {  
         $response = $ua->post($self->{server_url}, [ %parms ]);  
         if ($response->is_success)  
         {  
             my $retVal = $response->content;  
             return $retVal;  
         }  
   
         #  
         # If this is not one of the error codes we retry for, or if we  
         # are out of retries, fail immediately  
         #  
         my $code = $response->code;  
         if (!$codes_to_retry{$code} || @retries == 0)  
         {  
             if ($ENV{SAS_DEBUG}) {  
                 confess $response->content;  
             } else {  
                 confess $response->status_line;  
             }  
         }  
   
         #  
         # otherwise, sleep & loop.  
         #  
         my $retry_time = shift(@retries);  
         print STDERR "Request failed with code=$code, sleeping $retry_time and retrying\n";  
         sleep($retry_time);  
   
     }  
   
     #  
     # Should never get here.  
     #  
 }  
   
74    
75  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3