Astro-SIMBAD-Client
view release on metacpan or search on metacpan
lib/Astro/SIMBAD/Client.pm view on Meta::CPAN
Eventually the SOAP code will be removed. In the meantime all tests are
skipped unless C<ASTRO_SIMBAD_CLIENT_USE_SOAP> is true, and are marked
TODO. Support of SOAP by this module will be on a best-effort basis;
that is, if I can make it work without a huge amount of work I will --
otherwise SOAP will become unsupported.
=head1 DESCRIPTION
This package implements several query interfaces to version 4 of the
SIMBAD on-line astronomical database, as documented at
L<http://simbad.u-strasbg.fr/simbad4.htx>. B<This package will not work
with SIMBAD version 3.> Its primary purpose is to obtain SIMBAD data,
though some rudimentary parsing functionality also exists.
There are three ways to access these data.
- URL queries are essentially page scrapers, but their use is
documented, and output is available as HTML, text, or VOTable. URL
queries are implemented by the url_query() method.
- Scripts may be submitted using the script() or script_file() methods.
The former takes as its argument the text of the script, the latter
takes a file name.
- Queries may be made using the web services (SOAP) interface. The
query() method implements this, and queryObjectByBib,
queryObjectByCoord, and queryObjectById have been provided as
convenience methods. As of version 0.027_01, SOAP queries are
deprecated. See the L<NOTICE|/NOTICE> section above for the deprecation
schedule.
Astro::SIMBAD::Client is object-oriented, with the object supplying not
only the URL scheme and SIMBAD server name, but the default format and
output type for URL and web service queries.
A simple command line client application is also provided, as are
various examples in the F<eg> directory.
=head2 Methods
The following methods should be considered public:
=over 4
=cut
package Astro::SIMBAD::Client;
# We require Perl 5.008 because of MailTools, used by SOAP::Lite.
# Otherwise it would be 5.006 because of 'our'.
use 5.008;
use strict;
use warnings;
use Carp;
use LWP::UserAgent;
use LWP::Protocol;
use HTTP::Request::Common qw{POST};
use Scalar::Util 1.01 qw{looks_like_number};
use URI::Escape ();
# use XML::DoubleEncodedEntities;
# use Astro::SIMBAD::Client::WSQueryInterfaceService;
use constant HAVE_DOUBLE_ENCODED => do {
local $@ = undef;
eval { ## no critic (RequireCheckingReturnValueOfEval)
require XML::DoubleEncodedEntities;
1;
};
};
use constant ARRAY_REF => ref [];
use constant CODE_REF => ref sub {};
my $have_time_hires;
BEGIN {
$have_time_hires = eval {
require Time::HiRes;
Time::HiRes->import (qw{time sleep});
1;
};
*_escape_uri = URI::Escape->can( 'uri_escape_utf8' )
|| URI::Escape->can( 'uri_escape' )
|| sub { return $_[0] };
}
our $VERSION = '0.048';
our @CARP_NOT = qw{Astro::SIMBAD::Client::WSQueryInterfaceService};
# TODO replace this with s///r if we ever get to the point where we
# require Perl 5.13.2 or greater.
sub _strip_returns {
my ( $data ) = @_;
$data =~ s/ \n //smxg;
return $data;
}
use constant FORMAT_TXT_SIMPLE_BASIC => _strip_returns( <<'EOD' );
---\n
name: %IDLIST(NAME|1)\n
type: %OTYPE\n
long: %OTYPELIST\n
ra: %COO(d;A)\n
dec: %COO(d;D)\n
plx: %PLX(V)\n
pmra: %PM(A)\n
pmdec: %PM(D)\n
radial: %RV(V)\n
redshift: %RV(Z)\n
spec: %SP(S)\n
bmag: %FLUXLIST(B)[%flux(F)]\n
vmag: %FLUXLIST(V)[%flux(F)]\n
ident: %IDLIST[%*,]
EOD
use constant FORMAT_TXT_YAML_BASIC => _strip_returns( <<'EOD' );
lib/Astro/SIMBAD/Client.pm view on Meta::CPAN
onto the end of the URL and a GET is done.
=cut
{ # Begin local symbol block.
my %type_map = ( # Map SOAP type parameter to URL output.format.
txt => 'ASCII',
vo => 'VOTable',
);
my %type_unmap = reverse %type_map;
# Perl::Critic objects to the use of @_ (rather than values
# unpacked from it) but the parity check lets me give a less
# unfriendly error message. CAVEAT: do NOT modify the contents
# of @_, since this will be seen by the caller. Modifying @_
# itself is fine.
sub url_query { ## no critic (RequireArgUnpacking)
@_ % 2 and croak <<eod;
Error - url_query needs an even number of arguments after the query
type.
eod
my ($self, $query, %args) = @_;
### my $debug = $self->get ('debug');
my $dflt = $self->get ('url_args');
foreach my $key (keys %$dflt) {
exists ($args{$key}) or $args{$key} = $dflt->{$key};
}
unless ($args{'output.format'}) {
my $type = $self->get ('type');
$args{'output.format'} = $type_map{$type} || $type;
}
my $resp = $self->_retrieve( "simbad/sim-$query", \%args );
my $rslt = $resp->content();
HAVE_DOUBLE_ENCODED
and $rslt = XML::DoubleEncodedEntities::decode( $rslt );
my $parser;
if (my $type = $type_unmap{$args{'output.format'}}) {
$parser = $self->_get_parser ($type);
return wantarray ? ($parser->($rslt)) : [$parser->($rslt)]
if $parser;
}
return $rslt;
}
} # End local symbol block.
########################################################################
#
# Utility routines
#
# __build_url
#
# Builds a URL based on the currently-set scheme and server, and
# the fragment provided as an argument. If the fragment is an
# HTTP::Request object it is simply returned.
sub __build_url {
my ( $self, $fragment ) = @_;
defined $fragment
or $fragment = '';
eval { $fragment->isa( 'HTTP::Request' ) }
and return $fragment;
$fragment =~ s< \A / ><>smx; # Defensive programming
return sprintf '%s://%s/%s', $self->get( 'scheme' ),
$self->get( 'server' ), $fragment;
}
# _callers_caller();
#
# Returns the name of the subroutine that called the caller.
# Results undefined if not called from a subroutine nested at
# least two deep.
sub _callers_caller {
my $inx = 1;
my $caller;
foreach ( 1 .. 2 ) {
do {
$caller = ( caller $inx++ )[3]
} while '(eval)' eq $caller;
}
return $caller;
}
# $self->_delay
#
# Delays the desired amount of time before issuing the next
# query.
{
my %last;
sub _delay {
my $self = shift;
my $last = $last{$self->{server}} ||= 0;
if ((my $delay = $last + $self->{delay} - time) > 0) {
sleep ($delay);
}
return ($last{$self->{server}} = time);
}
}
# $self->_deprecation_notice( $type, $name );
#
# This method centralizes deprecation. Type is 'attribute' or
# 'method'. Deprecation is driven of the %deprecate hash. Values
# are:
# false - no warning
# 1 - warn on first use
# 2 - warn on each use
# 3 - die on each use.
#
# $self->_deprecation_in_progress( $type, $name )
#
# This method returns true if the deprecation is in progress. In
# practice this means the %deprecate value is defined.
# This is currently unused and commented out
{
my %deprecate = (
method => {
lib/Astro/SIMBAD/Client.pm view on Meta::CPAN
#
# This subroutine returns an LWP::UserAgent object with its agent
# string set to the default, with our class name and version
# appended in parentheses.
sub _get_user_agent {
my $ua = LWP::UserAgent->new (
);
## $ua->agent ($ua->_agent . ' (' . __PACKAGE__ . ' ' . $VERSION .
## ')');
$ua->agent (&agent);
return $ua;
}
# ($package, $subroutine) = $self->_parse_subroutine_name ($name);
#
# This method parses the given name, and returns the package name
# in which the subroutine is defined and the subroutine name. If
# the $name is a bare subroutine name, the package is the calling
# package unless that package contains no such subroutine but
# $self->can($name) is true, in which case the package is
# ref($self).
#
# If called in scalar context, the package is returned.
sub _parse_subroutine_name {
my ($self, $parser) = @_;
my @parts = split '::', $parser;
my $code = pop @parts;
my $pkg = join '::', @parts;
unless ($pkg) {
my %tried = (__PACKAGE__, 1);
my $inx = 1;
while ($pkg = (caller ($inx++))[0]) {
next if $tried{$pkg};
$tried{$pkg} = 1;
last if $pkg->can ($code);
}
$pkg = ref $self if !$pkg && $self->can ($code);
defined $pkg or croak <<eod;
Error - '$parser' yields undefined package name.
eod
@parts = split '::', $pkg;
}
return wantarray ? ($pkg, $code) : $pkg;
}
# my $resp = $self->_retrieve( $fragment, \%args );
#
# Build a URL from the contents of the 'scheme' and 'server'
# attributes, and the given fragment, and retrieve the data from
# that URL. The \%args argument is optional.
#
# The return is an HTTP::Response object. If the response is
# indicates that the request is unsuccessful we croak with the URL
# (if that can be retrieved) and the status line.
#
# The details depend on the arguments and the state of the
# invocant as follows:
#
# If $url is an HTTP::Request object, it is executed and the
# response returned. Otherwise
#
# If \%args is present and not empty, and the 'post' attribute is
# true, an HTTP post() request is done to the URL, sending the
# data. Otherwise
#
# If there are arguments they are appended to the URL, and an HTTP
# get() is done to the URL.
sub _retrieve {
my ($self, $fragment, $args) = @_;
my $url = $self->__build_url( $fragment );
$args ||= {};
my $debug = $self->get ('debug');
my $ua = _get_user_agent ();
$self->_delay ();
my $resp;
if (eval {$url->isa('HTTP::Request')}) {
$debug
and print 'Debug ', _callers_caller(), 'executing ',
$url->as_string, "\n";
$resp = $ua->request ($url);
} elsif ($self->get ('post') && %$args) {
if ($debug) {
print 'Debug ', _callers_caller(), " posting to $url\n";
foreach my $key (sort keys %$args) {
print " $key => $args->{$key}\n";
}
}
$resp = $ua->post ($url, $args);
} else {
my $join = '?';
foreach my $key (sort keys %$args) {
$url .= $join . _escape_uri( $key ) . '=' . _escape_uri (
$args->{$key} );
$join = '&';
}
$debug
and print 'Debug ', _callers_caller(), " getting from $url\n";
$resp = $ua->get( $url );
}
$debug
and print 'Debug - request: ', $resp->request()->as_string(), "\n";
$resp->is_success()
and return $resp;
my $rq = $resp->request()
or croak $resp->status_line();
my $u = $rq->uri();
croak "$u: ", $resp->status_line();
}
1;
__END__
=back
=head2 Attributes
The Astro::SIMBAD::Client attributes are documented below. The type of
the attribute is given after the attribute name, in parentheses. The
types are:
boolean - a true/false value (in the Perl sense);
hash - a reference to one or more key/value pairs;
integer - an integer;
string - any characters.
Hash values may be specified either as hash references or as strings.
When a hash value is set, the given value updates the hash rather than
replacing it. For example, specifying
$simbad->set (format => {txt => '%MAIN_ID\n'});
does not affect the value of the vo format. If a key is set to the
null value, it deletes the key. All keys in the hash can be deleted
( run in 0.881 second using v1.01-cache-2.11-cpan-39bf76dae61 )