File Coverage

blib/lib/Astro/NED/Response/Objects.pm

Criterion	Covered	Total	%
statement	70	85	82.3
branch	8	14	57.1
condition	8	12	66.6
subroutine	12	13	92.3
pod	5	5	100.0
total	103	129	79.8

# --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::Response::Objects;

use 5.006;
use strict;
use warnings;
use Carp;

our $VERSION = '0.30';

use Astro::NED::Response::Fields;
use Astro::NED::Response::Object;


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

sub new
{
  my $class = shift;
  $class = ref $class || $class;

  my $self = {
	      curr_object => -1,
	      objects => [],
	     };
  bless $self, $class;

  return $self;
}

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

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

    return @{$self->{objects}};
 }

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

    return scalar @{$self->{objects}};
}

sub addobject
{
  my ( $self, @objects )  = @_;

  croak( __PACKAGE__, '->addobject: object is not of type Astro::NED::Response::Object' )
    if grep { ! $_->isa( 'Astro::NED::Response::Object' ) } @objects;

  push @{$self->{objects}}, @objects;

  return $self->nobjects;
}


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


sub parseHTML
{
  require HTML::LinkExtor;
  require HTML::TableParser;

  my $self = shift;

  # don't do this, as we don't want to copy the passed data.
  # my $html = shift;

  # first get list of links
  my $p = HTML::LinkExtor->new;
  $p->parse( $_[0]);

  ## no critic (AccessOfPrivateData)
  # HTML::LinkExtor returns a list of arrayrefs, not objects.
  my @links = grep { /search_type=Obj_id/i } map { $_->[2] } $p->links ;
  ## use critic

  my @cols;
  my @colnames;

  # HTML::Parser does its own funky handling of exceptions, which causes
  # exceptions in handlers to be printed and then rethrown. work around
  # that by keeping track of our exceptions excplicily and by using
  # $p->eof;
  my $error;

  $p = HTML::TableParser->new(
     [{
       cols => qr/Object Type/,
       DecodeNBSP => 1,

       hdr => sub {

         my %used;
	 for my $colname ( @{$_[2]} )
	 {
	   ## no critic (AccessOfPrivateData)
	   # @Fields is a list of arrayrefs, not objects.
	   my @matches = Astro::NED::Response::Fields::match( $colname );
	   ## use critic

           # A table column can't match more than one field, unless
           # it's the Row No. column, which is in there twice.
	   if ( 1 == @matches )
	   {
               my $match = $matches[0];
               ## no critic (AccessOfPrivateData)
               my $name = $match->{name};
               ## use critic

               if ( exists $used{$name} && $name ne 'No' )
               {
                   $error =  "internal error; matched $match->{name} to more than one column in NED table: " .
                     "$used{$name}, $colname \n";
                   $p->eof;
               }

               $used{$name} = $colname;
               push @colnames, $name;
           }
           else
           {
               if ( 0 == @matches )
               {
                   $error = "internal error: could not recognize column '$colname' in NED table\n";
                   $p->eof;
               }
               else
               {
                   ## no critic (AccessOfPrivateData)
                   $error = "internal error: multiple matches for column '$colname' in NED table: " .
                                join (", ", map { $_->{name} } @matches ) . "\n";
                   $p->eof;
                   ## use critic
               }

	   }

	 }
       },

       row => sub {
	 my %data;
	 @data{@colnames} = map { $_ eq '' || $_ eq '...' ? undef : $_ } @{$_[2]};
	 $data{InfoLink} = shift @links;
	 $data{Name} =~ s/^[*]//;

         my $object = Astro::NED::Response::Object->new( \%data );

         eval {
             Astro::NED::Response::Fields::check( \%data );
         };

         if ( $@ )
         {
             $error = "error parsing NED output: $@" . "for object:\n" . $object->dumpstr("\t");
             $@ = '';
             $p->eof;
         }

	 push @{$self->{objects}}, $object;
       },

       Trim => 1,
      }]
  );

  eval { $p->parse( $_[0] ) };
  if ( $@ || $error )
  {
      $error .= $@;
      Carp::croak( __PACKAGE__, ': ', $error );
  }

  return;
}

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


1;
__END__