diff options
Diffstat (limited to 'TIGERweb.pm')
| -rw-r--r-- | TIGERweb.pm | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/TIGERweb.pm b/TIGERweb.pm new file mode 100644 index 0000000..553e3ed --- /dev/null +++ b/TIGERweb.pm @@ -0,0 +1,174 @@ +package Geo::USCensus::TIGERweb; + +use strict; +use warnings; + +use LWP::UserAgent; +use HTTP::Request::Common; +use JSON::MaybeXS; +use IO::Socket::SSL; +use List::Util qw(first); + +use Geo::USCensus::TIGERweb::Service; + +=head1 NAME + +Geo::USCensus::TIGERweb - The U.S. Census Bureau TIGER data services + +=cut + +our $VERSION = '0.01'; +our $DEBUG = 0; + +=head1 SYNOPSIS + + use Geo::USCensus::TIGERweb; + + print Dumper(Geo::USCensus::TIGERweb->info); # enumerates services + my $service = Geo::USCensus::TIGERweb->service('Tracts_Blocks'); + print Dumper($service->info); + my $layer = $service->layer('Census Blocks'); # id or name + print Dumper($layer->info); + my $result = $layer->query( + # required fields + geometry => { x => -121.48778, y => 38.578793 }, # see below + fields => [ 'OID', 'GEOID', 'STATE', 'COUNTY' ], + # optional + # spatialRel => 'esriSpatialRelIntersects', # see below + # inSR => 4326, # the default, GPS coords + # outSR => 4326, + ); + + # convenience method: given a longitude and latitude, return + # the census block containing that point, or dies on error + my $blocknum = Geo::USCensus::TIGERweb->census_block_at_point( + lat => 38.578793, + lon => -121.48778 + ); + +=head1 CLASS METHODS + +=over 4 + +=item info + +Returns a description of the available services. + +=item service NAME + +Constructor; returns a L<Geo::USCensus::TIGERweb::Service> handle to the +named service. + +=cut + +my $ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE }); +my $url = 'https://tigerweb.geo.census.gov/arcgis/rest/services'; + +our $GLOBAL = bless { debug => 0, info => undef, path => 'TIGERweb' }; + +# in principle this could be turned into a general ArcGIS client + +sub request { + my ($self, $path, $params) = @_; + $self = $GLOBAL if !ref($self); + my $full_path = join('/', $url, $self->{path}); + $full_path .= "/$path" if $path; + $params = [ %$params ] if ref($params) eq 'HASH'; + push @$params, ( f => 'pjson' ); # always use this + warn "POST $full_path\n" if $self->{debug}; + warn encode_json($params)."\n" if $self->{debug} > 1; + my $response = $ua->request( + POST $full_path, Content => $params + ); + if ( !$response->is_success ) { + $self->{error} = $response->status_line; + return; + } + my $data = decode_json($response->decoded_content); + if ( $data->{error} ) { + $self->{error} = $data->{error}{message}; + return; + } + return $data; +} + +sub info { + my $self = shift; + $self = $GLOBAL if !ref($self); + return $self->{info} ||= $self->request(''); +} + +sub create { + # internal constructor + my $self = shift; + my $subclass = shift; + my $subpath = shift; + $self = $GLOBAL if !ref($self); + my $class = "Geo::USCensus::TIGERweb::$subclass"; + my $new = { debug => $self->{debug}, + info => undef, + path => $self->{path} . '/' . $subpath, + }; + bless $new, $class; + return $new; +} + +sub service { + my $class = shift; + my $service_name = shift; + my $def = first { $_->{name} eq "TIGERweb/$service_name" } + @{ $GLOBAL->info->{services} }; + die "TIGERweb service name '$service_name' not found" if !$def; + my $type = $def->{type}; + return $GLOBAL->create('Service', "$service_name/$type"); +} + +=item census_block_at_point PARAMS + +Takes numeric values for "lat" and "lon" and returns the census block number +at that location. This is actually the reason for this entire library. + +=cut + +sub census_block_at_point { + my ($class, %opt) = @_; + die "latitude and longitude required\n" + unless defined($opt{lat}) and defined($opt{lon}); + $GLOBAL->{debug} = $opt{debug} if $opt{debug}; + my $layer = $class->service('Tracts_Blocks')->layer('Census Blocks'); + my $result = $layer->query( + geometry => { x => $opt{lon}, y => $opt{lat} }, + fields => [ 'GEOID' ], + ); + if ($layer->{error}) { + warn $layer->{error}."\n"; + } + if (my $f = $result->{features}) { + if (scalar(@$f) == 0) { + warn "no census block found\n"; + return; + } else { + return $f->[0]->{attributes}{GEOID}; + } + } else { + warn "no features in query result\n"; + return; + } +} + +=back + +=head1 LICENSE AND COPYRIGHT + +Copyright (C) 2016 Mark Wells. +Copyright (C) 2016 Freeside Internet Services, Inc. + +This program is free software; you can redistribute it and/or modify it +under the terms of either: the GNU General Public License as published +by the Free Software Foundation; or the Artistic License. + +See http://dev.perl.org/licenses/ for more information. + +=cut + +1; |