Geocoding.pm

   1 package Geo::USCensus::Geocoding;
   2
   3 use strict;
   4 use warnings;
   5
   6 use LWP::UserAgent;
   7 use JSON;
   8 use URI;
   9 use Geo::USCensus::Geocoding::Match;
  10
  11 =head1 NAME
  12
  13 Geo::USCensus::Geocoding - The U.S. Census Bureau geocoding service
  14
  15 =head1 VERSION
  16
  17 Version 0.01
  18
  19 =cut
  20
  21 our $VERSION = '0.01';
  22 our $DEBUG = 1;
  23
  24 =head1 SYNOPSIS
  25
  26     use Geo::USCensus::Geocoding;
  27
  28     my $request = {
  29       # required fields
  30       street  => '123 Main Street',
  31       city    => 'San Francisco',   # city
  32       state   => 'CA',              # state/province
  33       zip     => '93102',           # zip/postal code
  34       # optional fields
  35       benchmark => 'Public_AR_ACS2013', # default is "Public_AR_Current"
  36       vintage   => 'Census2010_ACS2013', # default is "Current_Current"
  37     };
  38     my $result = Geo::USCensus::Geocoding->query($request);
  39
  40     if ($result->matches) {
  41       my $match = $result->match(0);
  42       print $match->matchedAddress,"\n",
  43             $match->coordinates->{x},',',$match->coordinates->{y},"\n",
  44             $match->censustract,"\n";
  45     }
  46
  47 =head1 CLASS METHODS
  48
  49 =head2 query HASHREF
  50
  51 Send a request to the web service.  See
  52 L<http://geocoding.geo.census.gov/geocoder> for API documentation. This
  53 package will always use the JSON data format and the Geographies return type.
  54
  55 Returns an object of class Geo::USCensus::Geocoding.
  56
  57 =cut
  58
  59 my $ua = LWP::UserAgent->new;
  60 my $api_uri = 'http://geocoding.geo.census.gov/geocoder/geographies/address';
  61
  62 sub query {
  63   my $class = shift;
  64   my %opt = (
  65     benchmark => 'Public_AR_Current',
  66     vintage   => 'Current_Current',
  67   );
  68   if (ref $_[0] eq 'HASH') {
  69     %opt = (%opt, %{ $_[0] });
  70   } else {
  71     %opt = (%opt, @_);
  72   }
  73
  74   $opt{format} = 'json';
  75
  76   foreach (qw(street city state zip)) {
  77     die "$_ required\n" unless length($opt{$_});
  78   }
  79
  80   my $uri = URI->new($api_uri);
  81   $uri->query_form(\%opt);
  82   warn "$class->query\n$uri\n\n" if $DEBUG;
  83   my $http_req = HTTP::Request->new(GET => $uri->as_string);
  84   my $resp = $ua->request($http_req);
  85   my $self = { addr_response => $resp };
  86   bless $self, $class;
  87   if ( $resp->is_success ) {
  88     local $@;
  89     my $tree = eval { from_json($resp->content) };
  90     if ($@) {
  91       $self->message("Unable to parse response:\n$@");
  92       return $self;
  93     }
  94     if (!exists $tree->{result}) {
  95       $self->message("Response does not contain geocoding results.");
  96       warn $self->message. "\n".$resp->content."\n\n";
  97       return $self;
  98     }
  99     $tree = $tree->{result};
 100
 101     my @matches;
 102     if (exists( $tree->{addressMatches} )) {
 103       foreach my $am (@{ $tree->{addressMatches} }) {
 104         push @matches, Geo::USCensus::Geocoding::Match->new($am);
 105       }
 106     } # else what? does this happen if there's no match? a proper REST
 107       # interface should throw a 404
 108     $self->{matches} = \@matches;
 109   } else {
 110     $self->message( $resp->status_line );
 111   }
 112   $self;
 113 }
 114
 115 =head1 METHODS
 116
 117 =head2 message
 118
 119 Sets/gets an explicit error status.
 120
 121 =cut
 122
 123 sub message {
 124   my $self = shift;
 125   if (@_) {
 126     $self->{_message} = shift;
 127   }
 128   $self->{_message} || '';
 129 }
 130
 131 =head2 matches
 132
 133 Returns the number of matches found.
 134
 135 =cut
 136
 137 sub matches {
 138   my $self = shift;
 139   $self->{matches} ? scalar @{ $self->{matches} } : 0;
 140 }
 141
 142 =head2 match NUMBER
 143
 144 Returns a specific match (starting from zero). Matches are returned
 145 as L<Geo::USCensus::Geocoding::Match> objects, in the order they were
 146 returned by the service.
 147
 148 =cut
 149
 150 sub match {
 151   my $self = shift;
 152   my $i = shift;
 153   $self->{matches}->[$i];
 154 }
 155
 156 =head1 AUTHOR
 157
 158 Mark Wells, C<< <mark at freeside.biz> >>
 159
 160 =head1 SUPPORT
 161
 162 Commercial support for this module is available from Freeside Internet
 163 Services:
 164
 165     L<http://www.freeside.biz/>
 166
 167 =back
 168
 169
 170 =head1 LICENSE AND COPYRIGHT
 171
 172 Copyright (C) 2014 Mark Wells.
 173
 174 This program is free software; you can redistribute it and/or modify it
 175 under the terms of either: the GNU General Public License as published
 176 by the Free Software Foundation; or the Artistic License.
 177
 178 See http://dev.perl.org/licenses/ for more information.
 179
 180 =cut
 181
 182 1;