Parent Directory
| 
Revision Log
Revision 1.3 - (view) (download) (as text)
| 1 : | parrello | 1.1 | #!/usr/bin/perl -w |
| 2 : | |||
| 3 : | # | ||
| 4 : | # Copyright (c) 2003-2006 University of Chicago and Fellowship | ||
| 5 : | # for Interpretations of Genomes. All Rights Reserved. | ||
| 6 : | # | ||
| 7 : | # This file is part of the SEED Toolkit. | ||
| 8 : | # | ||
| 9 : | # The SEED Toolkit is free software. You can redistribute | ||
| 10 : | # it and/or modify it under the terms of the SEED Toolkit | ||
| 11 : | # Public License. | ||
| 12 : | # | ||
| 13 : | # You should have received a copy of the SEED Toolkit Public License | ||
| 14 : | # along with this program; if not write to the University of Chicago | ||
| 15 : | # at info@ci.uchicago.edu or the Fellowship for Interpretation of | ||
| 16 : | # Genomes at veronika@thefig.info or download a copy from | ||
| 17 : | # http://www.theseed.org/LICENSE.TXT. | ||
| 18 : | # | ||
| 19 : | |||
| 20 : | package SAPserver; | ||
| 21 : | |||
| 22 : | use strict; | ||
| 23 : | use LWP::UserAgent; | ||
| 24 : | use YAML; | ||
| 25 : | |||
| 26 : | =head1 Sapling Server Helper Object | ||
| 27 : | |||
| 28 : | =head2 Introduction | ||
| 29 : | |||
| 30 : | This module is used to call the sapling server, which is a general-purpose | ||
| 31 : | server for extracting data from the Sapling database. Each Sapling server | ||
| 32 : | function correspond to a method of this object. | ||
| 33 : | |||
| 34 : | parrello | 1.2 | This package deliberately uses no internal SEED packages or scripts, only common |
| 35 : | PERL modules. | ||
| 36 : | |||
| 37 : | parrello | 1.1 | The fields in this object are as follows. |
| 38 : | |||
| 39 : | =over 4 | ||
| 40 : | |||
| 41 : | =item server_url | ||
| 42 : | |||
| 43 : | The URL used to request data from the sapling server. | ||
| 44 : | |||
| 45 : | =item ua | ||
| 46 : | |||
| 47 : | The user agent for communication with the server. | ||
| 48 : | |||
| 49 : | =back | ||
| 50 : | |||
| 51 : | =cut | ||
| 52 : | |||
| 53 : | =head3 new | ||
| 54 : | |||
| 55 : | my $ss = SAPserver->new(%options); | ||
| 56 : | |||
| 57 : | Construct a new SAPserver object. The following options are supported. | ||
| 58 : | |||
| 59 : | =over 4 | ||
| 60 : | |||
| 61 : | =item url | ||
| 62 : | |||
| 63 : | URL for the sapling server. This option may be used to redirect requests to a | ||
| 64 : | test version of the server, or to an older server script. | ||
| 65 : | |||
| 66 : | =back | ||
| 67 : | |||
| 68 : | =cut | ||
| 69 : | |||
| 70 : | sub new { | ||
| 71 : | # Get the parameters. | ||
| 72 : | my ($class, %options) = @_; | ||
| 73 : | # Get the options. | ||
| 74 : | my $url = $options{url} || "http://servers.nmpdr.org/sap/server.cgi"; | ||
| 75 : | # Create the fields of the object. | ||
| 76 : | my $server_url = $url; | ||
| 77 : | my $ua = LWP::UserAgent->new(); | ||
| 78 : | # Create the SAPserver object. | ||
| 79 : | my $retVal = { | ||
| 80 : | server_url => $server_url, | ||
| 81 : | ua => $ua, | ||
| 82 : | }; | ||
| 83 : | # Bless and return it. | ||
| 84 : | bless $retVal, $class; | ||
| 85 : | return $retVal; | ||
| 86 : | } | ||
| 87 : | |||
| 88 : | =head2 Public Methods | ||
| 89 : | |||
| 90 : | =head3 AUTOLOAD | ||
| 91 : | |||
| 92 : | my $result = $ss->method(%args); | ||
| 93 : | |||
| 94 : | Call a function on the server. Any method call on this object (other than | ||
| 95 : | the constructor) is translated into a request against the server. This | ||
| 96 : | enables us to add new server functions without requiring an update to this | ||
| 97 : | module. The parameters are specified as a hash, and the result is a scalar | ||
| 98 : | parrello | 1.2 | or object reference. If an error occurred, we will throw an exception. |
| 99 : | parrello | 1.1 | |
| 100 : | =cut | ||
| 101 : | |||
| 102 : | # This variable will contain the method name. | ||
| 103 : | our $AUTOLOAD; | ||
| 104 : | |||
| 105 : | sub AUTOLOAD { | ||
| 106 : | # Get the parameters. | ||
| 107 : | my ($self, %args) = @_; | ||
| 108 : | # Declare the return variable. | ||
| 109 : | my $retVal; | ||
| 110 : | # Get the method name. | ||
| 111 : | my $function = $AUTOLOAD; | ||
| 112 : | parrello | 1.3 | # Strip off the stuff before the method name. |
| 113 : | parrello | 1.1 | $function =~ s/.+:://; |
| 114 : | # Compute the argument document. | ||
| 115 : | my $argString = YAML::Dump(\%args); | ||
| 116 : | # Get our user agent. | ||
| 117 : | my $ua = $self->{ua}; | ||
| 118 : | # Request the function from the server. | ||
| 119 : | my $response = $ua->post($self->{server_url}, | ||
| 120 : | [function => $function, args => $argString]); | ||
| 121 : | # Get the response content. | ||
| 122 : | my $content = $response->content; | ||
| 123 : | if (! $response->is_success) { | ||
| 124 : | parrello | 1.2 | die "Server error " . $response->status_line . "\n$content"; |
| 125 : | parrello | 1.1 | } else { |
| 126 : | $retVal = YAML::Load($content); | ||
| 127 : | # Figure out what we got back. | ||
| 128 : | my $returnType = ref $retVal; | ||
| 129 : | if ($returnType && $returnType eq 'ErrorDocument') { | ||
| 130 : | parrello | 1.2 | die $retVal->{message}; |
| 131 : | parrello | 1.1 | } |
| 132 : | } | ||
| 133 : | # Return the result. | ||
| 134 : | return $retVal; | ||
| 135 : | } | ||
| 136 : | |||
| 137 : | =head3 DESTROY | ||
| 138 : | |||
| 139 : | $ss->DESTROY(); | ||
| 140 : | |||
| 141 : | This method has no function. It's purpose is to keep the destructor from | ||
| 142 : | being caught by the autoload processing. | ||
| 143 : | |||
| 144 : | =cut | ||
| 145 : | |||
| 146 : | sub DESTROY { } | ||
| 147 : | |||
| 148 : | |||
| 149 : | parrello | 1.2 | 1; |
| MCS Webmaster | ViewVC Help |
| Powered by ViewVC 1.0.3 |