File Coverage

blib/lib/Geo/Coder/Geocoder/US.pm

Criterion	Covered	Total	%
statement	50	91	54.9
branch	5	26	19.2
condition	0	3	0.0
subroutine	12	17	70.5
pod	5	5	100.0
total	72	142	50.7

package Geo::Coder::Geocoder::US;

use 5.006002;

use strict;
use warnings;

use Carp;
use LWP::UserAgent;
use Text::CSV;
use URI;
# use URI::Escape qw{ uri_escape };

our $VERSION = '0.009';

use constant RETRACTION_MESSAGE =>
	'Geo::Coder::Geocoder::US is being retracted, because the underlying web site no longer exists';

Carp::cluck( RETRACTION_MESSAGE );
{

##  my %valid_arg = map { $_ => 1 } qw{ debug interface ua };
    my %valid_arg = map { $_ => 1 } qw{ debug ua };

    sub new {
	my ( $class, %args ) = @_;
	carp( RETRACTION_MESSAGE );

	ref $class
	    and $class = ref $class;

##	exists $args{interface}
##	    or $args{interface} = 'namedcsv';

	exists $args{ua}
	    or $args{ua} = LWP::UserAgent->new();

	my $self = \%args;
	bless $self, $class;

	foreach my $key ( sort keys %args ) {
	    exists $valid_arg{$key}
		or croak "Argument $key is invalid";
	    $self->$key( $args{$key} );
	}

	# Fake up the interface attribute, which I would like to keep
	# internally for a bit, but am not sure I want to expose.

	$args{interface} = 'namedcsv';
	$args{_interface} = \&_geocode_namedcsv;

	return $self;
    }

}

sub debug {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $val = $self->{debug} = shift @args;
	my $ua = $self->ua();
	my ( $method, @args ) = $val ?
	    ( add_handler => \&_dump ) :
	    ( 'remove_handler' );
	$ua->$method( request_send => @args );
	$ua->$method( response_done => @args );
	return $self;
    } else {
	return $self->{debug};
    }
}

{

    use constant BASE_URL => 'http://geocoder.us/';
    use constant DELAY => 15;

    my $wait_for = time - DELAY;
##  my %valid_arg = map { $_ => 1 } qw{ location };

    sub geocode {
	my ( $self, @args ) = @_;
	my %parm = @args % 2 ? ( location => @args ) : @args;
	defined $parm{location}
	    or croak "You must provide a location to geocode";

	my $uri = URI->new( BASE_URL );
	$uri->path_segments( service => $self->{interface} );
	$uri->query_form( address => $parm{location} );

#	$parm{location} = uri_escape( $parm{location} );

	my $now = time;
	while ( $wait_for > $now ) {
	    sleep $wait_for - $now;
	    $now = time;
	}
	$wait_for = $now + DELAY;

#	my $rslt = $self->{response} = $self->{ua}->get(
#	    BASE_URL. 'service/' . $self->{interface} .
#	    '?address=' .
#	    $parm{location}
#	);
	my $rslt = $self->{response} = $self->{ua}->get( $uri );
	$rslt->is_success()
	    or return;

	return $self->{_interface}->( $self, $rslt->content() );
    }

}

=begin comment

sub _geocode_csv {
    my ( $self, $content ) = @_;
    my $csv = $self->{_CSV} ||= Text::CSV->new( { binary => 1 } );
    my @rtn;
    foreach ( split qr{ \r \n? | \n }smx, $content ) {
	$csv->parse( $_ )
	    or croak $csv->error_diag();
	my %data;
	# TODO field names consistent with Geo::Coder::Many.
	@data{ qw< lat long address city state zip > } =
	    $csv->fields();
	defined $data{long}
	    or %data = ( error => $data{lat} );
	push @rtn, \%data;
    }
    return wantarray ? @rtn : $rtn[0];
}

=end comment

=cut

sub _geocode_namedcsv {
    my ( $self, $content ) = @_;
    my $csv = $self->{_CSV} ||= Text::CSV->new( { binary => 1 } );
    my @rtn;
    foreach ( split qr{ \r \n? | \n }smx, $content ) {
	$csv->parse( $_ )
	    or croak $csv->error_diag();
	my %data;
	foreach ( $csv->fields() ) {
	    s/ \A ( \w+ ) = //smx
		or next;
	    $data{$1} = $_;
	}
	push @rtn, \%data;
    }
    return wantarray ? @rtn : $rtn[0];
}

=begin comment

sub _geocode_rest {
    my ( $self, $content ) = @_;
    my $rslt;
    eval {
	$rslt = $self->_get_xml_parser->parse( $content );
	1;
    } or return [ { error => $content } ];
    _mung_tree( $rslt );
    my @rtn = _extract_point( $rslt );
    return wantarray ? @rtn : $rtn[0];
}

sub _extract_point {
    my ( $list ) = @_;
    my @pts;
    foreach my $tag ( @{ $list } ) {
	'ARRAY' eq ref $tag
	    or next;
	if ( $tag->[0] =~ m/ \b Point \z /smx ) {
	    my %pt;
	    foreach my $datum ( @{ $tag }[ 2 .. $#$tag ] ) {
		my $name = $datum->[0];
		$name =~ s/ [^:]* : //smx;
		$pt{$name} = $datum->[2];
	    }
	    push @pts, \%pt;
	} else {
	    push @pts, _extract_point( $tag );
	}
    }
    return @pts;
}

sub _mung_tree {
    my ( $list ) = @_;
    my @xfrm;
    my $inx = 0;
    while ( $inx <= $#$list ) {
	my $tag = $list->[$inx++];
	my $val = $list->[$inx++];
	if ( 'ARRAY' eq ref $val ) {
	    my @info = @{ $val };
	    my $attr = shift @info;
	    _mung_tree( \@info );
	    splice @info, 0, 0, $tag, $attr;
	    push @xfrm, \@info;
	} elsif ( ! ref $val && $val =~ m/ \S /smx ) {
	    $val =~ s/ \s+ / /smx;
	    $val =~ s/ \A \s+ //smx;
	    $val =~ s/ \s+ \z //smx;
	    if ( @xfrm && ! ref $xfrm[-1] ) {
		$xfrm[-1] .= ' ' . $val;
	    } else {
		push @xfrm, $val;
	    }
	}
    }
    @{ $list } = @xfrm;
    return $list;
}

# $ curl 'http://geocoder.us/service/rest?address=1600+Pennsylvania+Ave,+Washington+DC'
#
#
# xmlns:dc="http://purl.org/dc/elements/1.1/"
# xmlns:geo="http://www.w3.org/2003/01/geo/wgs84_pos#"
# xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
# >
#
# 1600 Pennsylvania Ave NW, Washington DC 20502
# -77.037684
# 38.898748
#
#

{

    my $xml_parser_loaded;
    sub _get_xml_parser {
	my ( $self ) = @_;
	return ( $self->{_XML_PARSER} ||= do {
		defined $xml_parser_loaded
		    or eval {
		    require XML::Parser;
		    $xml_parser_loaded = 0;
		    1;
		}
		    or $xml_parser_loaded = $@;
		$xml_parser_loaded
		    and croak 'Unable to load XML::Parser';

		XML::Parser->new( Style	=> 'Tree' );
	    } );
    }

}

sub interface {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $interface = shift @args;
	my $code = $self->can( "_geocode_$interface" )
	    or croak "'interface' style '$interface' is not supported";
	$self->{interface} = $interface;
	$self->{_interface} = $code;
	return $self;
    } else {
	return $self->{interface};
    }
}

=end comment

=cut

sub response {
    my ( $self ) = @_;
    return $self->{response};
}

sub ua {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $ua = shift @args;
	local $@ = undef;
	eval { $ua->isa( 'LWP::UserAgent' ); 1 }
	    or croak "'ua' must be an LWP::UserAgent object";
	$self->{ua} = $ua;
	return $self;
    } else {
	return $self->{ua};
    }
}

sub _dump {
    my ( $msg ) = @_;
    print STDERR "\n", ref $msg, "\n";
    print STDERR $msg->dump();
    return;
}


1;

__END__