4 use base qw( Exporter );
5 use vars qw( $DEBUG @EXPORT_OK $conf );
8 use HTTP::Request::Common qw( GET POST );
14 FS::UID->install_callback( sub {
20 @EXPORT_OK = qw( get_district );
24 FS::Misc::Geo - routines to fetch geographic information
30 =item get_censustract LOCATION YEAR
32 Given a location hash (see L<FS::location_Mixin>) and a census map year,
33 returns a census tract code (consisting of state, county, and tract
34 codes) or an error message.
38 sub get_censustract_ffiec {
43 warn Dumper($location, $year) if $DEBUG;
45 my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
50 my $ua = new LWP::UserAgent;
51 my $res = $ua->request( GET( $url ) );
56 unless ($res->code eq '200') {
58 $error = $res->message;
62 my $content = $res->content;
63 my $p = new HTML::TokeParser \$content;
66 while (my $token = $p->get_tag('input') ) {
67 if ($token->[1]->{name} eq '__VIEWSTATE') {
68 $viewstate = $token->[1]->{value};
70 if ($token->[1]->{name} eq '__EVENTVALIDATION') {
71 $eventvalidation = $token->[1]->{value};
73 last if $viewstate && $eventvalidation;
76 unless ($viewstate && $eventvalidation ) {
78 $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
82 my($zip5, $zip4) = split('-',$location->{zip});
86 __VIEWSTATE => $viewstate,
87 __EVENTVALIDATION => $eventvalidation,
89 txtAddress => $location->{address1},
90 txtCity => $location->{city},
91 ddlbState => $location->{state},
93 btnSearch => 'Search',
95 warn join("\n", @ffiec_args )
98 push @{ $ua->requests_redirectable }, 'POST';
99 $res = $ua->request( POST( $url, \@ffiec_args ) );
103 unless ($res->code eq '200') {
105 $error = $res->message;
109 my @id = qw( MSACode StateCode CountyCode TractCode );
110 $content = $res->content;
111 warn $res->content if $DEBUG > 2;
112 $p = new HTML::TokeParser \$content;
113 my $prefix = 'UcGeoResult11_lb';
115 sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
117 while (my $token = $p->get_tag('span') ) {
118 next unless ( $token->[1]->{id} && &$compare( $token->[1]->{id} ) );
119 $token->[1]->{id} =~ /^$prefix(\w+)$/;
120 $return->{lc($1)} = $p->get_trimmed_text("/span");
123 unless ( $return->{tractcode} ) {
124 warn "$error: $content ". Dumper($return) if $DEBUG;
125 $error = "No census tract found";
127 $return->{tractcode} .= ' '
128 unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
130 } #unless ($res->code eq '200')
132 } #unless ($viewstate)
134 } #unless ($res->code eq '200')
136 die "FFIEC Geocoding error: $error\n" if $error;
138 $return->{'statecode'} . $return->{'countycode'} . $return->{'tractcode'};
141 #sub get_district_methods {
143 # 'wa_sales' => 'Washington sales tax',
146 =item get_district LOCATION METHOD
148 For the location hash in LOCATION, using lookup method METHOD, fetch
149 tax district information. Currently the only available method is
150 'wa_sales' (the Washington Department of Revenue sales tax lookup).
152 Returns a hash reference containing the following fields:
157 - exempt_amount (currently zero)
158 - city, county, state, country (from
160 The intent is that you can assign this to an L<FS::cust_main_county>
161 object and insert it if there's not yet a tax rate defined for that
164 get_district will die on error.
172 my $location = shift;
173 my $method = shift or return '';
174 warn Dumper($location, $method) if $DEBUG;
179 my $location = shift;
181 return '' if $location->{state} ne 'WA';
183 my $return = { %$location };
184 $return->{'exempt_amount'} = 0.00;
186 my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
187 my $ua = new LWP::UserAgent;
189 my $delim = '<|>'; # yes, <|>
190 my $year = (localtime)[5] + 1900;
191 my $month = (localtime)[4] + 1;
192 my @zip = split('-', $location->{zip});
195 'TaxType=S', #sales; 'P' = property
196 'Src=0', #does something complicated
198 'Addr='.uri_escape($location->{address1}),
199 'City='.uri_escape($location->{city}),
201 'Zip1='.($zip[1] || ''), #optional
208 my $query_string = join($delim, @args );
209 $url .= "?$query_string";
210 warn "\nrequest: $url\n\n" if $DEBUG > 1;
212 my $res = $ua->request( GET( "$url?$query_string" ) );
217 if ($res->code ne '200') {
218 $error = $res->message;
221 my $content = $res->content;
222 my $p = new HTML::TokeParser \$content;
224 while ( my $t = $p->get_tag('script') ) {
225 my $u = $p->get_token; #either enclosed text or the </script> tag
226 if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
231 if ( $js ) { #found it
232 # strip down to the quoted string, which contains escaped single quotes.
233 $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
234 $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
235 warn "\n\n innerHTML:\n$js\n\n" if $DEBUG > 2;
237 $p = new HTML::TokeParser \$js;
238 TD: while ( my $td = $p->get_tag('td') ) {
239 while ( my $u = $p->get_token ) {
240 next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
241 next if $u->[0] ne 'T'; # skip non-text
244 if ( lc($text) eq 'location code' ) {
245 $p->get_tag('td'); # skip to the next column
247 $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
248 $return->{'district'} = $u->[1];
250 elsif ( lc($text) eq 'total tax rate' ) {
253 $u = $p->get_token until $u->[0] eq 'T';
254 $return->{'tax'} = $u->[1];
260 if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
261 $return->{'tax'} *= 100; #percentage
262 warn Dumper($return) if $DEBUG > 1;
266 $error = 'district code/tax rate not found';
270 $error = "failed to parse document";
273 die "WA tax district lookup error: $error";
276 sub standardize_usps {
279 eval "use Business::US::USPS::WebTools::AddressStandardization";
282 my $location = shift;
283 if ( $location->{country} ne 'US' ) {
285 warn "standardize_usps not for use in country ".$location->{country}."\n";
286 $location->{addr_clean} = '';
289 my $userid = $conf->config('usps_webtools-userid');
290 my $password = $conf->config('usps_webtools-password');
291 my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
293 Password => $password,
295 } ) or die "error starting USPS WebTools\n";
297 my($zip5, $zip4) = split('-',$location->{'zip'});
300 FirmName => $location->{company},
301 Address2 => $location->{address1},
302 Address1 => $location->{address2},
303 City => $location->{city},
304 State => $location->{state},
308 warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
311 my $hash = $verifier->verify_address( %usps_args );
313 warn $verifier->response
316 die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
317 if $verifier->is_error;
319 my $zip = $hash->{Zip5};
320 $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
322 { company => $hash->{FirmName},
323 address1 => $hash->{Address2},
324 address2 => $hash->{Address1},
325 city => $hash->{City},
326 state => $hash->{State},
332 my %ezlocate_error = ( # USA_Geo_002 documentation
333 10 => 'State not found',
334 11 => 'City not found',
335 12 => 'Invalid street address',
336 14 => 'Street name not found',
337 15 => 'Address range does not exist',
338 16 => 'Ambiguous address',
339 17 => 'Intersection not found', #unused?
342 sub standardize_ezlocate {
344 my $location = shift;
346 #if ( $location->{country} eq 'US' ) {
347 # $class = 'USA_Geo_004Tool';
349 #elsif ( $location->{country} eq 'CA' ) {
350 # $class = 'CAN_Geo_001Tool';
352 #else { # shouldn't be a fatal error, just pass through unverified address
353 # warn "standardize_teleatlas: address lookup in '".$location->{country}.
354 # "' not available\n";
357 #my $path = $conf->config('teleatlas-path') || '';
358 #local @INC = (@INC, $path);
361 # die "Loading $class failed:\n$@".
362 # "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
365 $class = 'Geo::EZLocate'; # use our own library
369 my $userid = $conf->config('ezlocate-userid')
370 or die "no ezlocate-userid configured\n";
371 my $password = $conf->config('ezlocate-password')
372 or die "no ezlocate-password configured\n";
374 my $tool = $class->new($userid, $password);
375 my $match = $tool->findAddress(
376 $location->{address1},
379 $location->{zip}, #12345-6789 format is allowed
381 warn "ezlocate returned match:\n".Dumper($match) if $DEBUG > 1;
382 # error handling - B codes indicate success
383 die $ezlocate_error{$match->{MAT_STAT}}."\n"
384 unless $match->{MAT_STAT} =~ /^B\d$/;
387 address1 => $match->{STD_ADDR},
388 address2 => $location->{address2},
389 city => $match->{STD_CITY},
390 state => $match->{STD_ST},
391 country => $location->{country},
392 zip => $match->{STD_ZIP}.'-'.$match->{STD_P4},
393 latitude => $match->{MAT_LAT},
394 longitude => $match->{MAT_LON},
395 censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}.
396 sprintf('%04.2f',$match->{CEN_TRCT}),