File Coverage

blib/lib/Astro/SIMBAD/Client.pm

Criterion	Covered	Total	%
statement	227	378	60.0
branch	80	226	35.4
condition	17	39	43.5
subroutine	39	54	72.2
pod	15	15	100.0
total	378	712	53.0

=head1 NAME

Astro::SIMBAD::Client - Fetch astronomical data from SIMBAD 4.

=head1 SYNOPSIS

 use Astro::SIMBAD::Client;
 my $simbad = Astro::SIMBAD::Client->new ();
 print $simbad->query (id => 'Arcturus');

=head1 NOTICE

As of release 0.027_01 the SOAP interface is deprecated. The University
of Strasbourg has announced at
L that this
interface will not be maintained after April 1 2014, and that
B.

Because the SOAP interface is still sort of functional (except for
VO-format queries) as of June 4 2014, I have revised the transition plan
announced with the release of 0.027_01 on October 28 2014.

What I have done as of version 0.031_01 is to add attribute
C. This was false by default. If this attribute is
true, the C method and friends, instead of issuing a SOAP
request to the SIMBAD server, will instead construct an equivalent
script query, and issue that. The deprecation warning will not be issued
if C is true, since the SOAP interface is not
being used.

As of March 22 2021, SOAP queries started returning 404. Because of
this, I have made the default of C true. Well,
actually I have made it the Boolean inverse of environment variable
L. This is
mostly for my benefit, so I can see if SOAP has come back.

If SOAP still has not come back after six months, SOAP queries will
become fatal, as will setting C to a false value.

Eventually the SOAP code will be removed. In the meantime all tests are
skipped unless C 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. B
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 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 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.047';

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' );
---\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
pm:\n
  - %PM(A)\n
  - %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:\n%IDLIST[  - '%*'\n]
EOD

#	Documentation errors/omissions:
#	%PLX:
#	     P = something. Yields '2' for Arcturus
#	%SP: is really %sptype
#	     B = bibcode? Yields '~' for Arcturus
#	     N = don't know -- yields 'S' for Arcturus
#	     Q = quality? Yields 'C' for Arcturus
#	     S = spectral type

use constant FORMAT_VO_BASIC => join ',', qw{
    id(NAME|1) otype ra(d) dec(d) plx_value pmra pmdec rv_value z_value
    sp_type flux(B) flux(V)};
    # Note that idlist was documented at one point as being the
    # VOTable equivalent of %IDLIST. But it is no longer documented,
    # and never returned anything but '

my %static = (
    autoload => 1,
    debug => 0,
    delay => 3,
    emulate_soap_queries	=> ! $ENV{ASTRO_SIMBAD_CLIENT_USE_SOAP},
    format => {
	txt => FORMAT_TXT_YAML_BASIC,
	vo => FORMAT_VO_BASIC,
	script => '',
    },
    parser => {
	txt => '',
	vo => '',
	script => '',
    },
    post => 1,
    # lc(...) per https://tools.ietf.org/html/rfc3986#section-3.1
    scheme => lc( $ENV{ASTRO_SIMBAD_CLIENT_SCHEME} || 'http' ),
##    server => 'simbad.u-strasbg.fr',
    server => $ENV{ASTRO_SIMBAD_CLIENT_SERVER} || 'simbad.u-strasbg.fr',
    type => 'txt',
    url_args => {},
    verbatim => 0,
);

if ( my $msg = _is_scheme_valid(
	$static{scheme},
	q,
    ) ) {
    carp $msg;
    $static{scheme} = 'http';
}

=item $simbad = Astro::SIMBAD::Client->new ();

This method instantiates an Astro::SIMBAD::Client object. Any arguments will be
passed to the set() method once the object is instantiated.

=cut

# The set() method does the unpacking. CAVEAT: do _NOT_ modify the
# contents of @_, as this will be seen by the caller. Modifying @_
# itself is fine.
sub new {	## no critic (RequireArgUnpacking)
    my $class = shift;
    $class = ref $class if ref $class;
    my $self = bless {}, $class;
    $self->set (%static, @_);
    return $self;
}

=item $string = $simbad->agent ();

This method retrieves the user agent string used to identify this
package in queries to SIMBAD. This string will be the default string for
LWP::UserAgent, with this package name and version number appended in
parentheses. This method is exposed for the curious.

=cut

{
    my $agent_string;
    sub agent {
	return ($agent_string ||= join (' ', LWP::UserAgent->_agent,
	    __PACKAGE__ . '/' . $VERSION));
    }
}

=item @attribs = $simbad->attributes ();

This method retrieves the names of all public attributes, in
alphabetical order. It can be called as a static method, or
even as a subroutine.

=cut

sub attributes {
    return wantarray ? sort keys %static : [sort keys %static]
}

=item $value = $simbad->get ($attrib);

This method retrieves the current value of the named
L. It can be called as a static method to
retrieve the default value.

=cut

sub get {
    my $self = shift;
    croak "Error - First argument must be an @{[__PACKAGE__]} object"
	unless eval {$self->isa(__PACKAGE__)};
    $self = \%static unless ref $self;
    my $name = shift;
    croak "Error - Attribute '$name' is unknown"
	unless exists $static{$name};
    return $self->{$name};
}

=item $result = Parse_TXT_Simple ($data);

This subroutine (B method) parses the given text data under the
assumption that it was generated using FORMAT_TXT_SIMPLE_BASIC or
something similar. The data is expected to be formatted as follows:

A line consisting of exactly '---' separates objects.

Data appear on lines that look like

 name: data

and are parsed into a hash keyed by the given name. If the line ends
with a comma, it is assumed to contain multiple items, and the data
portion of the line is split on the commas; the resultant hash value
is a list reference.

The user would normally not call this directly, but specify it as the
parser for 'txt'-type queries:

 $simbad->set (parser => {txt => 'Parse_TXT_Simple'});

=cut

sub Parse_TXT_Simple {
    my $text = shift;
    my $obj = {};
    my @data;
    foreach (split '\s*\n', $text) {
	next unless $_;
	if (m/^-+$/) {
	    $obj = {};
	    push @data, $obj;
	} else {
	    my ($name, $val) = split ':\s*', $_;
	    $val =~ s/,$// and $val = [split ',', $val];
	    $obj->{$name} = $val;
	}
    }
    return @data;
}

=item $result = Parse_VO_Table ($data);

This subroutine (B method) parses the given VOTable data,
returning a list of anonymous hashes describing the data. The $data
value is split on '
VOTables back (rather than a parse error) if that is what the input
contains.

This is B a full-grown VOTable parser capable of handling
the full spec (see L).
It is oriented toward returning ETABLEDATAE contents, and the
metadata that can reasonably be associated with those contents.

B that as of version 0.026_01, the requisite modules
to support VO format are B required. If you need VO format you will
need to install L or L

The return is a list of anonymous hashes, one per ETABLEE. Each
hash contains two keys:

  {data} is the data contained in the table, and
  {meta} is the metadata for the table.

The {meta} element for the table is a reference to a list of data
gathered from the ETABLEE tag. Element zero is the tag name
('TABLE'), and element 1 is a reference to a hash containing the
attributes of the ETABLEE tag. Subsequent elements if any
represent metadata tags in the order encountered in the parse.

The {data} contains an anonymous list, each element of which is a row of
data from the ETABLEDATAE element of the ETABLEE, in the
order encountered by the parse. Each row is a reference to a list of
anonymous hashes, which represent the individual data of the row, in the
order encountered by the parse. The data hashes contain two keys:

 {value} is the value of the datum with undef for '~', and
 {meta} is a reference to the metadata for the datum.

The {meta} element for a datum is a reference to the metadata tag that
describes that datum. This will be an anonymous list, of which element 0
is the tag ('FIELD'), element 1 is a reference to a hash containing that
tag's attributes, and subsequent elements will be the contents of the
tag (typically including a reference to the list representing the
EDESCRIPTIONE tag for that FIELD).

All values are returned as provided by the XML parser; no further
decoding is done. Specifically, the datatype and arraysize attributes
are ignored.

This parser is based on XML::Parser.

The user would normally not call this directly, but specify it as the
parser for 'vo'-type queries:

 $simbad->set (parser => {vo => 'Parse_VO_Table'});

=cut

{	# Begin local symbol block.

    my $xml_parser;

    # TODO get rid of XML::Parser::Lite when you get rid of SOAP
    foreach (qw{XML::Parser XML::Parser::Lite}) {
	eval { _load_module( $_ ); 1 } or next;
	$xml_parser = $_;
	last;
    }

    sub Parse_VO_Table {
	my $data = shift;

	defined $xml_parser
	    or croak 'Error - No XML parser available. Need XML::Parser or XML::Parser::Lite';

	my $root;
	my @tree;
	my @table;
	my @to_strip;

#	Arguments:
#	Init ($class)
#	Start ($class, $tag, $attr => $value ...)
#	Char ($class, $text)
#	End ($class, $tag)
#	Final ($class)

	my $psr = $xml_parser->new (
	    Handlers => {
		Init => sub {
		    $root = [];
		    @tree = ($root);
		    @table = ();
		},
		Start => sub {
		    shift;
		    my $tag = shift;
		    my $item = [$tag, {@_}];
		    push @{$tree[-1]}, $item;
		    push @tree, $item;
		},
		Char => sub {
		    push @{$tree[-1]}, $_[1];
		},
		End => sub {
		    my $tag = $_[1];
		    die < 1;
Error - Unmatched end tag
eod
		    die <
Error - End tag  does not match start tag <$tree[-1][0]>
eod

#	From here to the end of the subroutine is devoted to detecting
#	the