view release on metacpan or  search on metacpan

lib/Astro/SIMBAD/Client.pm  view on Meta::CPAN

    # 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	=> {
	    query	=> 2,
	},
    );

    sub _deprecation_notice {
	my ( undef, $type, $name, $repl ) = @_;	# Invocant unused
	$deprecate{$type} or return;

lib/Astro/SIMBAD/Client.pm  view on Meta::CPAN

#	$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
by setting key 'clear' to any true value.

When specifying a string for a hash-valued attribute, it must be of
the form 'key=value'. For example,

 $simbad->set (format => 'txt=%MAIN_ID\n');

does the same thing as the previous example. Specifying the key name
without an = sign deletes the key (e.g. set (format => 'txt')).

The Astro::SIMBAD::Client class has the following attributes:

=over

=item autoload

This Boolean attribute determines whether setting the parser should
attempt to autoload its package.

The default is 1 (i.e. true).