File Coverage

blib/lib/Net/Plazes/Base.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

#########
# Author:        rmp
# Maintainer:    $Author: rmp $
# Created:       2008-08-13
# Last Modified: $Date$
# Id:            $Id$
# $HeadURL$
#
package Net::Plazes::Base;
use strict;
use warnings;
use base qw(Class::Accessor);
use Carp;
use English qw(-no_match_vars);
use HTTP::Request;
use LWP::UserAgent;
use XML::LibXML;
use Lingua::EN::Inflect qw(PL);

our $VERSION = '0.03';

__PACKAGE__->mk_accessors(fields());

sub new {
  my ($class, $ref) = @_;
  $ref ||= {};
  bless $ref, $class;
  return $ref;
}

sub service {
  return q[];
}

sub doc_element {
  my $self  = shift;
  my ($ref) = (ref $self || $self) =~ /([^:]+)$/mx;
  my $el    = lc $ref;

  return $el;
}

sub fields {
  return ();
}

sub useragent {
  my $self = shift;

  if(!$self->{useragent}) {
    $self->{useragent} = LWP::UserAgent->new();
    $self->{useragent}->env_proxy();
    $self->{useragent}->agent(qq[Net::Plazes v$VERSION]);
  }

  return $self->{useragent};
}

sub parser {
  my $self = shift;

  if(!$self->{parser}) {
    $self->{parser} = XML::LibXML->new();
  }

  return $self->{parser};
}

sub process_dom {
  my ($self, $obj, $dom) = @_;

  for my $field ($self->fields()) {
    my $els = [$dom->getElementsByTagName($field)];
    if($els->[0]) {
      my $fc = $els->[0]->getFirstChild();
      if($fc) {
	$obj->{$field} = $fc->getData();
      } else {
	$obj->{$field} = q[];
      }
    }
  }

  return $obj;
}

sub has_many {
  my $class  = shift;
  my $plural = PL($class->doc_element());
  my $ns     = "${class}::$plural";

  no strict 'refs'; ## no critic

  *{$ns} = sub {
    my $self = shift;

    if(!$self->{$plural}) {
      $self->list();
    }

    return $self->{$plural};
  };

  use strict;
  return 1;
}

sub get {
  my ($self, $field) = @_;
  if(defined $self->{$field}) {
    return $self->{$field};
  }

  if($self->{id}) {
    $self->read();

  } else {
    $self->list();
  }

  return $self->{$field};
}

sub read { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
  my $self     = shift;
  my $obj_uri  = sprintf q[%s/%s], $self->service(), $self->id();
  if($obj_uri !~ /\.xml$/mx) {
    $obj_uri .= q[.xml];
  }
  my $req      = HTTP::Request->new('GET', $obj_uri, ['Accept' => 'text/xml']);
  my $response = $self->useragent->request($req);

  if(!$response->is_success()) {
    croak $response->status_line() . " fetching $obj_uri";
  }

  my $dom;
  eval {
    $dom = $self->parser->parse_string($response->content());

  } or do {
    croak q[Error parsing response] . $response->content(). qq[\nRequest was: $obj_uri];
  };

  $self->process_dom($self, $dom);

  return $dom;
}

sub list {
  my ($self, $obj_uri) = @_;
  $obj_uri   ||= $self->service();

  if($obj_uri !~ /\.xml$/mx) {
    $obj_uri .= q[.xml];
  }

  my $req      = HTTP::Request->new('GET', $obj_uri, ['Accept' => 'text/xml']);
  my $response = $self->useragent->request($req);

  my $dom;
  eval {
    $dom = $self->parser->parse_string($response->content());
    1;
  } or do {
    croak q[Error parsing response: ] . $response->content(). qq[\nRequest was: $obj_uri];
  };

  my $objs = [];
  my $els  = [$dom->getElementsByTagName($self->doc_element())];

  for my $el (@{$els||[]}) {
    my $pkg = ref $self;
    push @{$objs}, $self->process_dom($pkg->new(), $el);
  }

  $self->{PL($self->doc_element())} = $objs;
  return $dom;
}

1;
__END__