File Coverage

blib/lib/Astro/Catalog/Transport/REST.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

package Astro::Catalog::Transport::REST;

=head1 NAME

Astro::Catalog::Transport::REST - A base class for REST query modules

=head1 SYNOPSIS

  use base qw/ Astro::Catalog::Transport::REST /;


=head1 DESCRIPTION

This class forms a base class for all the REST based query classes provided
in the C distribution (eg C).

=cut

# L O A D   M O D U L E S --------------------------------------------------

use 5.006;
use strict;
use warnings;
use warnings::register;
use base qw/ Astro::Catalog::Query /;
use vars qw/ $VERSION /;

use LWP::UserAgent;
use Net::Domain qw(hostname hostdomain);
use File::Spec;
use Carp;

# generic catalog objects
use Astro::Catalog;
use Astro::Catalog::Star;

$VERSION = "4.31";

=head1 REVISION

$Id: REST.pm,v 1.7 2004/03/03 00:50:15 cavanagh Exp $

=head1 METHODS

=head2 Constructor

=over 4

=item B

Create a new instance from a hash of options

  $q = new Astro::Catalog::Transport::REST( Coords    => new Astro::Coords(),
				            Radius    => $radius,
				            Bright    => $magbright,
				            Faint     => $magfaint,
				            Sort      => $sort_type,
				            Number    => $number_out );

returns a reference to an query object. Must only called from
sub-classed constructors.

RA and Dec are also allowed but are deprecated (since with only
RA/Dec the coordinates must always be supplied as J2000 space-separated
sexagesimal format).

=cut

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  # bless the query hash into the class
  my $block = bless { OPTIONS   => {},
		      COORDS    => undef,
                      URL       => undef,
                      QUERY     => undef,
                      USERAGENT => undef,
                      BUFFER    => undef }, $class;

  # Configure the object [even if there are no args]
  $block->configure( @_ );

  return $block;

}

=item B

The LWP user agent mediating the web transaction.

  $ua = $q->useragent();

Created automatically the first time it is requested.

=cut

sub useragent {
  my $self = shift;
  if (@_) {
     my $ua = shift;
     croak "Must be a LWP::UserAgent"
       unless UNIVERSAL::isa($ua, "LWP::UserAgent");
     $self->{USERAGENT} = $ua;
   } else {
     # If we have no UA but we have requested one, create it ourself
     # This overcomes a chicken and egg situation if a subclass
     # wants to go out on the net during object instantiation
     # before configure() has been called

     # Setup the LWP::UserAgent
     my $ua = new LWP::UserAgent( timeout => 30 );

     $self->useragent( $ua );
     $ua->agent( $self->_default_useragent_id );

     # Grab Proxy details from local environment
     $ua->env_proxy();

   }
  return $self->{USERAGENT};
}

=item B

Returns an Astro::Catalog object resulting from the specific query.

   $catalog = $q->querydb();

=cut

sub querydb {
  my $self = shift;

  # call the private method to make the actual query
  $self->_make_query();

  # check for failed connect
  return undef unless defined $self->{BUFFER};

  # return catalog
  return $self->_parse_query();

}

=item B

Return (or set) the current proxy for the catalog request.

   $usno->proxy( 'http://wwwcache.ex.ac.uk:8080/' );
   $proxy_url = $usno->proxy();

=cut

sub proxy {
   my $self = shift;

   # grab local reference to user agent
   my $ua = $self->useragent;

   if (@_) {
      my $proxy_url = shift;
      $ua->proxy('http', $proxy_url );
   }

   # return the current proxy
   return $ua->proxy('http');

}

=item B

Return (or set) the current timeout in seconds for the request.

   $usno->timeout( 30 );
   $proxy_timeout = $usno->timeout();

Default is 30 seconds.

=cut

sub timeout {
   my $self = shift;

   # grab local reference to user agent
   my $ua = $self->useragent;

   if (@_) {
      my $time = shift;
      $ua->timeout( $time );
   }

   # return the current timeout
   return $ua->timeout();

}

=item B

The URL formed to build up a query. Made up of a root host name
(that can be set using the C method) and a fixed suffix that
specifies the path to the service (CGI or otherwise). This query URL
does not include the arguments to the CGI script (but will include
the question mark if appropriate).

  $query_url = $q->query();
  $q->query_url( 'http://www.blah.org/cgi-bin/xxx.pl?');

Care must be taken when setting this value.

The argument is not validated. There may also need to be a new method
that returns the full URL including arguments.

If no value has been supplied, a default will be returned.

=cut

sub query_url {
  my $self = shift;
  if (@_) {
    $self->{QUERY} = shift;
  }
  if (defined $self->{QUERY}) {
    return $self->{QUERY};
  } else {
    return "http://". $self->url .
      "/" . $self->_default_url_path;
  }

  return $self->{QUERY};
}

=item B

Return the current remote host for the query (the full URL
can be returned using the C method).

   $host = $q->url();

Can also be used to set the root host for the URL (ie the
machine name but no path component)

   $q->url( "archive.eso.org" );

if not defined the default URL is used (specified in the sub class).
This method should really be called C.

Returns the default host name specified by the particular subclass
if a value has not been defined.

=cut

sub url {
  my $self = shift;

  # SETTING URL
  if (@_) {

    # set the url option
    my $base_url = shift;
    $self->{URL} = $base_url;
    if( defined $base_url ) {
       $self->query_url("http://$base_url/" .
			$self->_default_url_path );
    }
  }

  # RETURNING remote host
  if (defined $self->{URL}) {
    return $self->{URL};
  } else {
    return $self->_default_remote_host();
  }
}

=item B

Returns the user agent tag sent by the module to the server.

   $agent_tag = $q->agent();

The user agent tag can not be set by this method.

=cut

sub agent {
  my $self = shift;
  return $self->useragent->agent();
}

=back

=begin __PRIVATE_METHODS__

=head2 Private methods

These methods are for internal use only.

=over 4

=item B<_default_remote_host>

The default host name to use to build up the full URL.
Must be specified in a sub-class.

  $host = $q->_default_remote_host();

=cut

sub _default_remote_host {
  croak "default remote host must be specified in subclass\n";
}

=item B<_default_url_path>

The path information after the host in the remote URL.
Must be overridden in a subclass.

=cut

sub _default_url_path {
  croak "default url path information must be subclassed\n";
}

=item B<_default_useragent_id>

Default user agent ID used to declare the agent to the remote server.
Default format is

  __PACKAGE__/$VERSION ($HOST.$DOMAIN)

This can be overridden in a subclass if necessary.

=cut

sub _default_useragent_id {
  my $self = shift;
  my $HOST = hostname();
  my $DOMAIN = hostdomain();
  my $package = ref($self);
  my $pack_version;
  {
    # Need a symbolic reference
    no strict 'refs';
    $pack_version = ${ $package."::VERSION" };
  }
  $pack_version = 'UNKNOWN' unless defined $pack_version;
  return "Astro::Catalog::REST/$pack_version ($HOST.$DOMAIN)";
}


=item B<_make_query>

Private function used to make an query. Should not be called directly,
since it does not parse the results. Instead use the querydb()
method.

=cut

sub _make_query {
   my $self = shift;

   # clean out the buffer
   $self->{BUFFER} = "";

   # Build the query URL
   my $URL = $self->_build_query();

   # Run the actual HTTP query
   # and get the retrieved buffer
   $self->{BUFFER} = $self->_fetch_url( $URL );

   return;
}

=item B<_fetch_url>

Simple wrapper around LWP to retrieve content from a remote
URL and return it as a single string.

 $result = $q->_fetch_url( $URL );

=cut

sub _fetch_url {
  my $self = shift;
  my $URL = shift;

  # grab the user agent
  my $ua = $self->useragent;

  # build request
  my $request = new HTTP::Request('GET', $URL);

  # grab page from web
  my $reply = $ua->request($request);

  # Look at the result to see if it worked
  if ( ${$reply}{"_rc"} eq 200 ) {
    # stuff the page contents into the buffer
    return  ${$reply}{"_content"};
  } else {
    croak("Error ${$reply}{_rc}: Failed to establish network connection using url $URL");
  }

}

=item B<_build_query>

Build the URL to be sent to the remote service. The default method
concatenates the C along with all the defined query options
combined using key=value pairs separated by &.

  $url = $q->_build_query();

If the URL can not be built simply by concatenation (eg it requires
token replacement), then a subclassed method will be required.

=cut

sub _build_query {
  my $self = shift;

  # grab the base URL
  my $URL = $self->query_url;
  my $options = "";

  # loop round all the options keys and build the query
  my %allow = $self->_get_allowed_options;

  # Translate options
  my %translated = $self->_translate_options();

  foreach my $key ( keys %translated) {
    $options .= "&$key=". $translated{$key}
      if defined $translated{$key};
  }

  # Remove the leading ampersand from the options list because
  # it can cause some forms to fail.
  $options =~ s/^&//;

  # build final query URL
  $URL = $URL . $options;

  return $URL;
}

=back

=head1 COPYRIGHT

Copyright (C) 2001 University of Exeter. All Rights Reserved.
Some modifications copyright (C) 2003 Particle Physics and Astronomy
Research Council. All Rights Reserved.

This program was written as part of the eSTAR project and is free software;
you can redistribute it and/or modify it under the terms of the GNU Public
License.

=head1 AUTHORS

Alasdair Allan [e-mail],
Tim Jenness [e-mail]

=cut

# L A S T  O R D E R S ------------------------------------------------------

1;