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 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;