package SSserver; # # This is a SAS Component # use LWP::UserAgent; use YAML; use ErrorMessage; no warnings qw(once); use strict; =head1 Subsystem Server Helper Object =head2 Description This module is used to call the Subsystem Server, which is a special-purpose server for manipulating subsystem data from the Sapling database. Each Subsystem Server function corresponds to a method of this object. This package deliberately uses no internal SEED packages or scripts, only common PERL modules. The fields in this object are as follows. =over 4 =item server_url The URL used to request data from the subsystem server. =item ua The user agent for communication with the server. =item singleton Indicates whether or not results are to be returned in singleton mode. In singleton mode, if the return document is a hash reference with only one entry, the entry value is returned rather than the hash. =back =cut =head3 new my $ss = SSserver->new(%options); Construct a new server object. The following options are supported. =over 4 =item url URL for the server. This option is required. =item singleton (optional) If TRUE, results from methods will be returned in singleton mode. In singleton mode, if a single result comes back, it will come back as a scalar rather than as a hash value accessible via an incoming ID. =back =cut sub new { # Get the parameters. my ($class, %options) = @_; # Turn off YAML compression, which causes problems with our hash keys. $YAML::CompressSeries = 0; # Get the options. my $url = $options{url} || ""; 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 ""; $ua = SS->new(); } # 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. my $response = $ua->post($self->{server_url}, [ %parms ]); # Get the response content. my $retVal = $response->content; # Fail if there was an error. if (! $response->is_success) { die ErrorMessage->new($retVal, $response->status_line); } # Return the result. return $retVal; } 1;