File Coverage

blib/lib/Astro/NED/Query.pm

Criterion	Covered	Total	%
statement	101	132	76.5
branch	23	52	44.2
condition	8	15	53.3
subroutine	18	26	69.2
pod	13	13	100.0
total	163	238	68.4

# --8<--8<--8<--8<--
#
# Copyright (C) 2007 Smithsonian Astrophysical Observatory
#
# This file is part of Astro::NED::Query
#
# Astro::NED::Query is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
# -->8-->8-->8-->8--

package Astro::NED::Query;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.31';

use autouse Carp => qw/ croak carp confess /;

use WWW::Mechanize;

use constant NED_URL => 'http://nedwww.ipac.caltech.edu/index.html';

#---------------------------------------------------------------------------


# this is designed to be invoked by a subclass.
sub new
{
  my ( $class, %fields ) = @_;
  $class = ref $class || $class;

  croak( __PACKAGE__, '->new: illegal call to abstract base class' )
    if $class eq __PACKAGE__;

  my $self = bless {}, $class;

  # grab top level page
  $self->{_ua} = WWW::Mechanize->new();
  $self->{_ua}->get( NED_URL );

  croak( $class, '->new: error accessing NED: ',
	 $self->{_ua}->res->status_line )
    if $self->{_ua}->res->is_error;

  $self->_init;
  $self->save_as_defaults;

  # process fields
  while( my ( $key, $value ) = each %fields )
  {
    croak( $class, "->new unknown attribute: `$key'" )
      unless defined $self->field($key);
    $self->set( $key, $value );
  }

  return $self;
}

sub _init
{
    my ( $self ) = @_;
    croak( ref $self, ': internal implementation error; _init undefined' );
}


sub field {

    my ( $self, $key ) = @_;

    return exists $self->Field->{$key} ? $self->Field->{$key} : undef;
}


#---------------------------------------------------------------------------


sub set
{
  my ( $self, $name, $value ) = @_;

  confess( ref $self, '->set: Wrong number of arguments' )
    unless 3 == @_;

  if ( defined ( my $field = $self->field($name) ) )
  {
    eval {
      $self->{_ua}->field( $field, $value );
    };
    croak( ref $self, "->set($name):  illegal value" )
      if $@;
  }
  else
  {
    $self->{$name} = $value;
  }

  return;
}

sub get
{
  my ( $self, $name ) = @_;

  confess( ref $self, '->get: Wrong number of arguments' )
    unless defined $name;

  my $field = $self->field($name);

  return defined($field)
     ? $self->{_ua}->current_form->value( $field )
     : $self->{$name};
}

#---------------------------------------------------------------------------

# map between Multiple values and form inputs.

#  HTML::Table creates a separate input for each value in a checkbox
#  or option.  this routine creates a hash matching the values to the
#  input to make it easier to set the inputs.  In some cases a single
#  logical list of options is split into several so the GUI looks
#  cleaner. this will merge them.

sub _setupMultiple
{
  my ( $self, $type, $alias, @names  ) = @_;

  my %input;

  foreach my $name ( @names )
  {
    $name = qr/^$name$/ unless 'Regexp' eq ref $name;

    foreach my $input ( $self->{_ua}->current_form->inputs )
    {
      next unless defined $input->name &&
	            $input->name =~ /$name/ && $input->type eq $type;

      my @value = grep { defined $_ } $input->possible_values;
      croak( ref $self, "->setupMultiple: ($name,$type) multivalued multiple\n" )
	if @value > 1;
      $input{$value[0]} = $input;
    }
  }

  $self->{_Multiple}{$alias} = \%input;

  return;
}

# steal a page (well, actually code) from Class::Accessor for inputs
# which have multiple values
sub _mkMultipleAccessor {
    my($self, @fields) = @_;
    my $class = ref $self || $self;

    foreach my $field (@fields) {
	if ( $field eq 'DESTROY' ) {
	    require Carp;
	    Carp::carp('Having a data accessor named DESTROY  in '.
			"'$class' is unwise.");
	}

	my $accessor = sub {
	    my $self = shift;

	    return 1 == @_ ?
	      $self->getMultiple( $field, @_ ) :
		$self->setMultiple( $field, @_ );
	};

	my $alias = "_${field}_accessor";

	## no critic (ProhibitNoStrict)
	no strict 'refs';

	*{$class."\:\:$field"}  = $accessor
	  unless defined &{$class."\:\:$field"};

	*{$class."\:\:$alias"}  = $accessor
	  unless defined &{$class."\:\:$alias"};
    }

    return;
}

sub setMultiple
{
  my ( $self, $name, $value, $state ) = @_;

  croak( ref $self, "->setMultiple: wrong number of arguments\n" )
    unless @_ == 4;

  croak( ref $self, "->setMultiple: illegal value for $name: `$value'\n" )
    unless exists $self->{_Multiple}{$name}{$value};

  my $input = $self->{_Multiple}{$name}{$value};

  if ( defined $state && $state )
  {
    $input->value( $value );
  }
  else
 {
    $input->value( undef );
  }

  return;
}

sub getMultiple
{
  my ( $self, $name, $value ) = @_;

  confess( "Wrong number of arguments\n" )
    unless @_ == 3;

  croak( ref $self, "->getMultiple: illegal value for $name: `$value'\n" )
    unless exists $self->{_Multiple}{$name}{$value};

  my $input = $self->{_Multiple}{$name}{$value};

  return $input->value;
}

#---------------------------------------------------------------------------

sub possible_values
{
  my ( $self, $ifield ) = @_;

  defined $ifield or
    croak( ref $self, "->possible_values: missing field name\n" );

  # is this a multiple value beast?
  if ( exists  $self->{_Multiple}{$ifield} )
  {
    return keys %{$self->{_Multiple}{$ifield}}
  }
  elsif ( defined ( my $field = $self->field($ifield) ) )
  {
    return $self->{_ua}->current_form->find_input($field)->possible_values;
  }

  else
  {
    croak( ref $self, "->possible_values: unknown field: $ifield\n" );
  }
}

#---------------------------------------------------------------------------

sub dump
{
    my ( $self ) = @_;

    $self->{_ua}->current_form->dump;

    return;
}

sub form
{
    my ( $self ) = @_;
    return $self->{_ua}->current_form->form;
}

#---------------------------------------------------------------------------

sub save_as_defaults
{
  my $self = shift;

  # save current form field values.
  my @ivalues = map { [ $_ , $_->value ] } $self->{_ua}->current_form->inputs;
  $self->{_ivalues} = \@ivalues;

  return;
}

sub set_to_defaults
{
  my $self = shift;

  for my $field ( @{$self->{_ivalues}} )
  {
      my ( $obj, $value ) = @{$field};
      $obj->value($value)
	if defined $value;
  }

  return;
}

# alias old names for compatibility
*Astro::NED::Query::reset = *set_to_defaults;
*Astro::NED::Query::set_default = *save_as_defaults;


#---------------------------------------------------------------------------


sub query
{
  my $self = shift;

  # get class specific query presets
  $self->_query;

  my $ua = $self->{_ua};

  $ua->click;

  if ( $ua->res->is_error )
  {
    $ua->back;
    croak( ref($self), '->query: ', $ua->res->status_line );
  }

  my $content = $ua->content;
  $ua->back;

  return $self->_parse_query( $content );
}

sub _query
{
    my ( $self ) = @_;
    croak( $self, ': internal implementation error; _query undefined' );
}

sub _parse_query
{
    my ( $self ) = @_;
    croak( ref $self,
	   ': internal implementation error; _parse_query undefined' );
}

#---------------------------------------------------------------------------

sub timeout
{
    my ( $self, @args ) = @_;

    return $self->{_ua}->timeout( @args );
}

#---------------------------------------------------------------------------
1;
__END__