view release on metacpan or  search on metacpan

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

attribute: if true a POST is done; otherwise all arguments are tacked
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	=> {
	    query	=> 2,
	},
    );

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

    my %error;
    my %rslt;
    sub _load_module {
	my  ($module) = @_;
	exists $error{$module} and croak $error{$module};
	exists $rslt{$module} and return $rslt{$module};
	$rslt{$module} = eval "require $module";
	$@ and croak ($error{$module} = $@);
	return $rslt{$module};
    }
}	# End local symbol block.

#	$ua = _get_user_agent ();
#
#	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