FS/FS/Misc/Geo.pm

   1 package FS::Misc::Geo;
   2
   3 use strict;
   4 use base qw( Exporter );
   5 use vars qw( $DEBUG @EXPORT_OK $conf );
   6 use LWP::UserAgent;
   7 use HTTP::Request;
   8 use HTTP::Request::Common qw( GET POST );
   9 use HTML::TokeParser;
  10 use URI::Escape 3.31;
  11 use Data::Dumper;
  12 use FS::Conf;
  13 use Locale::Country;
  14
  15 FS::UID->install_callback( sub {
  16   $conf = new FS::Conf;
  17 } );
  18
  19 $DEBUG = 0;
  20
  21 @EXPORT_OK = qw( get_district );
  22
  23 =head1 NAME
  24
  25 FS::Misc::Geo - routines to fetch geographic information
  26
  27 =head1 CLASS METHODS
  28
  29 =over 4
  30
  31 =item get_censustract LOCATION YEAR
  32
  33 Given a location hash (see L<FS::location_Mixin>) and a census map year,
  34 returns a census tract code (consisting of state, county, and tract
  35 codes) or an error message.
  36
  37 =cut
  38
  39 sub get_censustract_ffiec {
  40   my $class = shift;
  41   my $location = shift;
  42   my $year  = shift;
  43
  44   warn Dumper($location, $year) if $DEBUG;
  45
  46   my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
  47
  48   my $return = {};
  49   my $error = '';
  50
  51   my $ua = new LWP::UserAgent;
  52   my $res = $ua->request( GET( $url ) );
  53
  54   warn $res->as_string
  55     if $DEBUG > 2;
  56
  57   unless ($res->code  eq '200') {
  58
  59     $error = $res->message;
  60
  61   } else {
  62
  63     my $content = $res->content;
  64     my $p = new HTML::TokeParser \$content;
  65     my $viewstate;
  66     my $eventvalidation;
  67     while (my $token = $p->get_tag('input') ) {
  68       if ($token->[1]->{name} eq '__VIEWSTATE') {
  69         $viewstate = $token->[1]->{value};
  70       }
  71       if ($token->[1]->{name} eq '__EVENTVALIDATION') {
  72         $eventvalidation = $token->[1]->{value};
  73       }
  74       last if $viewstate && $eventvalidation;
  75     }
  76
  77     unless ($viewstate && $eventvalidation ) {
  78
  79       $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
  80
  81     } else {
  82
  83       my($zip5, $zip4) = split('-',$location->{zip});
  84
  85       $year ||= '2012';
  86       my @ffiec_args = (
  87         __VIEWSTATE => $viewstate,
  88         __EVENTVALIDATION => $eventvalidation,
  89         ddlbYear    => $year,
  90         txtAddress  => $location->{address1},
  91         txtCity     => $location->{city},
  92         ddlbState   => $location->{state},
  93         txtZipCode  => $zip5,
  94         btnSearch   => 'Search',
  95       );
  96       warn join("\n", @ffiec_args )
  97         if $DEBUG > 1;
  98
  99       push @{ $ua->requests_redirectable }, 'POST';
 100       $res = $ua->request( POST( $url, \@ffiec_args ) );
 101       warn $res->as_string
 102         if $DEBUG > 2;
 103
 104       unless ($res->code  eq '200') {
 105
 106         $error = $res->message;
 107
 108       } else {
 109
 110         my @id = qw( MSACode StateCode CountyCode TractCode );
 111         $content = $res->content;
 112         warn $res->content if $DEBUG > 2;
 113         $p = new HTML::TokeParser \$content;
 114         my $prefix = 'UcGeoResult11_lb';
 115         my $compare =
 116           sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
 117
 118         while (my $token = $p->get_tag('span') ) {
 119           next unless ( $token->[1]->{id} && &$compare( $token->[1]->{id} ) );
 120           $token->[1]->{id} =~ /^$prefix(\w+)$/;
 121           $return->{lc($1)} = $p->get_trimmed_text("/span");
 122         }
 123
 124         unless ( $return->{tractcode} ) {
 125           warn "$error: $content ". Dumper($return) if $DEBUG;
 126           $error = "No census tract found";
 127         }
 128         $return->{tractcode} .= ' '
 129           unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
 130
 131       } #unless ($res->code  eq '200')
 132
 133     } #unless ($viewstate)
 134
 135   } #unless ($res->code  eq '200')
 136
 137   die "FFIEC Geocoding error: $error\n" if $error;
 138
 139   $return->{'statecode'} .  $return->{'countycode'} .  $return->{'tractcode'};
 140 }
 141
 142 #sub get_district_methods {
 143 #  ''         => '',
 144 #  'wa_sales' => 'Washington sales tax',
 145 #};
 146
 147 =item get_district LOCATION METHOD
 148
 149 For the location hash in LOCATION, using lookup method METHOD, fetch
 150 tax district information.  Currently the only available method is
 151 'wa_sales' (the Washington Department of Revenue sales tax lookup).
 152
 153 Returns a hash reference containing the following fields:
 154
 155 - district
 156 - tax (percentage)
 157 - taxname
 158 - exempt_amount (currently zero)
 159 - city, county, state, country (from
 160
 161 The intent is that you can assign this to an L<FS::cust_main_county>
 162 object and insert it if there's not yet a tax rate defined for that
 163 district.
 164
 165 get_district will die on error.
 166
 167 =over 4
 168
 169 =cut
 170
 171 sub get_district {
 172   no strict 'refs';
 173   my $location = shift;
 174   my $method = shift or return '';
 175   warn Dumper($location, $method) if $DEBUG;
 176   &$method($location);
 177 }
 178
 179 sub wa_sales {
 180   my $location = shift;
 181   my $error = '';
 182   return '' if $location->{state} ne 'WA';
 183
 184   my $return = { %$location };
 185   $return->{'exempt_amount'} = 0.00;
 186
 187   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 188   my $ua = new LWP::UserAgent;
 189
 190   my $delim = '<|>'; # yes, <|>
 191   my $year  = (localtime)[5] + 1900;
 192   my $month = (localtime)[4] + 1;
 193   my @zip = split('-', $location->{zip});
 194
 195   my @args = (
 196     'TaxType=S',  #sales; 'P' = property
 197     'Src=0',      #does something complicated
 198     'TAXABLE=',
 199     'Addr='.uri_escape($location->{address1}),
 200     'City='.uri_escape($location->{city}),
 201     'Zip='.$zip[0],
 202     'Zip1='.($zip[1] || ''), #optional
 203     'Year='.$year,
 204     'SYear='.$year,
 205     'Month='.$month,
 206     'EMon='.$month,
 207   );
 208
 209   my $query_string = join($delim, @args );
 210   $url .= "?$query_string";
 211   warn "\nrequest:  $url\n\n" if $DEBUG > 1;
 212
 213   my $res = $ua->request( GET( "$url?$query_string" ) );
 214
 215   warn $res->as_string
 216   if $DEBUG > 2;
 217
 218   if ($res->code ne '200') {
 219     $error = $res->message;
 220   }
 221
 222   my $content = $res->content;
 223   my $p = new HTML::TokeParser \$content;
 224   my $js = '';
 225   while ( my $t = $p->get_tag('script') ) {
 226     my $u = $p->get_token; #either enclosed text or the </script> tag
 227     if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
 228       $js = $u->[1];
 229       last;
 230     }
 231   }
 232   if ( $js ) { #found it
 233     # strip down to the quoted string, which contains escaped single quotes.
 234     $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
 235     $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
 236     warn "\n\n  innerHTML:\n$js\n\n" if $DEBUG > 2;
 237
 238     $p = new HTML::TokeParser \$js;
 239     TD: while ( my $td = $p->get_tag('td') ) {
 240       while ( my $u = $p->get_token ) {
 241         next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
 242         next if $u->[0] ne 'T'; # skip non-text
 243         my $text = $u->[1];
 244
 245         if ( lc($text) eq 'location code' ) {
 246           $p->get_tag('td'); # skip to the next column
 247           undef $u;
 248           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 249           $return->{'district'} = $u->[1];
 250         }
 251         elsif ( lc($text) eq 'total tax rate' ) {
 252           $p->get_tag('td');
 253           undef $u;
 254           $u = $p->get_token until $u->[0] eq 'T';
 255           $return->{'tax'} = $u->[1];
 256         }
 257       } # get_token
 258     } # TD
 259
 260     # just to make sure
 261     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 262       $return->{'tax'} *= 100; #percentage
 263       warn Dumper($return) if $DEBUG > 1;
 264       return $return;
 265     }
 266     else {
 267       $error = 'district code/tax rate not found';
 268     }
 269   }
 270   else {
 271     $error = "failed to parse document";
 272   }
 273
 274   die "WA tax district lookup error: $error";
 275 }
 276
 277 sub standardize_usps {
 278   my $class = shift;
 279
 280   eval "use Business::US::USPS::WebTools::AddressStandardization";
 281   die $@ if $@;
 282
 283   my $location = shift;
 284   if ( $location->{country} ne 'US' ) {
 285     # soft failure
 286     warn "standardize_usps not for use in country ".$location->{country}."\n";
 287     $location->{addr_clean} = '';
 288     return $location;
 289   }
 290   my $userid   = $conf->config('usps_webtools-userid');
 291   my $password = $conf->config('usps_webtools-password');
 292   my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
 293       UserID => $userid,
 294       Password => $password,
 295       Testing => 0,
 296   } ) or die "error starting USPS WebTools\n";
 297
 298   my($zip5, $zip4) = split('-',$location->{'zip'});
 299
 300   my %usps_args = (
 301     FirmName => $location->{company},
 302     Address2 => $location->{address1},
 303     Address1 => $location->{address2},
 304     City     => $location->{city},
 305     State    => $location->{state},
 306     Zip5     => $zip5,
 307     Zip4     => $zip4,
 308   );
 309   warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
 310     if $DEBUG > 1;
 311
 312   my $hash = $verifier->verify_address( %usps_args );
 313
 314   warn $verifier->response
 315     if $DEBUG > 1;
 316
 317   die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
 318     if $verifier->is_error;
 319
 320   my $zip = $hash->{Zip5};
 321   $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
 322
 323   { company   => $hash->{FirmName},
 324     address1  => $hash->{Address2},
 325     address2  => $hash->{Address1},
 326     city      => $hash->{City},
 327     state     => $hash->{State},
 328     zip       => $zip,
 329     country   => 'US',
 330     addr_clean=> 'Y' }
 331 }
 332
 333 my %ezlocate_error = ( # USA_Geo_002 documentation
 334   10  => 'State not found',
 335   11  => 'City not found',
 336   12  => 'Invalid street address',
 337   14  => 'Street name not found',
 338   15  => 'Address range does not exist',
 339   16  => 'Ambiguous address',
 340   17  => 'Intersection not found', #unused?
 341 );
 342
 343 sub standardize_ezlocate {
 344   my $self = shift;
 345   my $location = shift;
 346   my $class;
 347   #if ( $location->{country} eq 'US' ) {
 348   #  $class = 'USA_Geo_004Tool';
 349   #}
 350   #elsif ( $location->{country} eq 'CA' ) {
 351   #  $class = 'CAN_Geo_001Tool';
 352   #}
 353   #else { # shouldn't be a fatal error, just pass through unverified address
 354   #  warn "standardize_teleatlas: address lookup in '".$location->{country}.
 355   #       "' not available\n";
 356   #  return $location;
 357   #}
 358   #my $path = $conf->config('teleatlas-path') || '';
 359   #local @INC = (@INC, $path);
 360   #eval "use $class;";
 361   #if ( $@ ) {
 362   #  die "Loading $class failed:\n$@".
 363   #      "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
 364   #}
 365
 366   $class = 'Geo::EZLocate'; # use our own library
 367   eval "use $class 0.02"; #Geo::EZLocate 0.02 for error handling
 368   die $@ if $@;
 369
 370   my $userid = $conf->config('ezlocate-userid')
 371     or die "no ezlocate-userid configured\n";
 372   my $password = $conf->config('ezlocate-password')
 373     or die "no ezlocate-password configured\n";
 374
 375   my $tool = $class->new($userid, $password);
 376   my $match = $tool->findAddress(
 377     $location->{address1},
 378     $location->{city},
 379     $location->{state},
 380     $location->{zip}, #12345-6789 format is allowed
 381   );
 382   warn "ezlocate returned match:\n".Dumper($match) if $DEBUG > 1;
 383   # error handling - B codes indicate success
 384   die $ezlocate_error{$match->{MAT_STAT}}."\n"
 385     unless $match->{MAT_STAT} =~ /^B\d$/;
 386
 387   my %result = (
 388     address1    => $match->{MAT_ADDR},
 389     address2    => $location->{address2},
 390     city        => $match->{MAT_CITY},
 391     state       => $match->{MAT_ST},
 392     country     => $location->{country},
 393     zip         => $match->{MAT_ZIP},
 394     latitude    => $match->{MAT_LAT},
 395     longitude   => $match->{MAT_LON},
 396     censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}.
 397                    sprintf('%07.2f',$match->{CEN_TRCT}),
 398     addr_clean  => 'Y',
 399   );
 400   if ( $match->{STD_ADDR} ) {
 401     # then they have a postal standardized address for us
 402     %result = ( %result,
 403       address1    => $match->{STD_ADDR},
 404       address2    => $location->{address2},
 405       city        => $match->{STD_CITY},
 406       state       => $match->{STD_ST},
 407       zip         => $match->{STD_ZIP}.'-'.$match->{STD_P4},
 408     );
 409   }
 410
 411   \%result;
 412 }
 413
 414 sub standardize_tomtom {
 415   # post-2013 TomTom API
 416   # much better, but incompatible with ezlocate
 417   my $self = shift;
 418   my $location = shift;
 419   my $class = 'Geo::TomTom::Geocoding';
 420   eval "use $class";
 421   die $@ if $@;
 422
 423   my $key = $conf->config('tomtom-userid')
 424     or die "no tomtom-userid configured\n";
 425
 426   my $country = code2country($location->{country});
 427   my ($address1, $address2) = ($location->{address1}, $location->{address2});
 428   # try to fix some cases of the address fields being switched
 429   if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) {
 430     $address2 = $address1;
 431     $address1 = $location->{address2};
 432   }
 433   my $result = $class->query(
 434     key => $key,
 435     T   => $address1,
 436     L   => $location->{city},
 437     AA  => $location->{state},
 438     PC  => $location->{zip},
 439     CC  => country2code($country, LOCALE_CODE_ALPHA_3),
 440   );
 441   unless ( $result->is_success ) {
 442     die "TomTom geocoding error: ".$result->message."\n";
 443   }
 444   my ($match) = $result->locations;
 445   if (!$match) {
 446     die "Location not found.\n";
 447   }
 448   my $type = $match->{type};
 449   warn "tomtom returned $type match\n" if $DEBUG;
 450   warn Dumper($match) if $DEBUG > 1;
 451   my $tract = '';
 452   if ( defined $match->{censusTract} ) {
 453     $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}.
 454              join('.', $match->{censusTract} =~ /(....)(..)/);
 455   }
 456   # match levels below "intersection" should not be considered clean
 457   my $clean = ($type eq 'addresspoint'  ||
 458                $type eq 'poi'           ||
 459                $type eq 'house'         ||
 460                $type eq 'intersection'
 461               ) ? 'Y' : '';
 462
 463   $address2 = normalize_address2($address2, $location->{country});
 464
 465   $address1 = '';
 466   $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber});
 467   $address1 .= $match->{street} if $match->{street};
 468
 469   return +{
 470     address1    => $address1,
 471     address2    => $address2,
 472     city        => $match->{city},
 473     state       => $location->{state},    # this will never change
 474     country     => $location->{country},  # ditto
 475     zip         => ($match->{standardPostalCode} || $match->{postcode}),
 476     latitude    => $match->{latitude},
 477     longitude   => $match->{longitude},
 478     censustract => $tract,
 479     addr_clean  => $clean,
 480   };
 481 }
 482
 483 =iten normalize_address2 STRING, COUNTRY
 484
 485 Given an 'address2' STRING, normalize it for COUNTRY postal standards.
 486 Currently only works for US and CA.
 487
 488 =cut
 489
 490 # XXX really ought to be a separate module
 491 my %address2_forms = (
 492   # Postal Addressing Standards, Appendix C
 493   # (plus correction of "hanger" to "hangar")
 494   US => {qw(
 495     APARTMENT     APT
 496     BASEMENT      BSMT
 497     BUILDING      BLDG
 498     DEPARTMENT    DEPT
 499     FLOOR         FL
 500     FRONT         FRNT
 501     HANGAR        HNGR
 502     HANGER        HNGR
 503     KEY           KEY
 504     LOBBY         LBBY
 505     LOT           LOT
 506     LOWER         LOWR
 507     OFFICE        OFC
 508     PENTHOUSE     PH
 509     PIER          PIER
 510     REAR          REAR
 511     ROOM          RM
 512     SIDE          SIDE
 513     SLIP          SLIP
 514     SPACE         SPC
 515     STOP          STOP
 516     SUITE         STE
 517     TRAILER       TRLR
 518     UNIT          UNIT
 519     UPPER         UPPR
 520   )},
 521   # Canada Post Addressing Guidelines 4.3
 522   CA => {qw(
 523     APARTMENT     APT
 524     APPARTEMENT   APP
 525     BUREAU        BUREAU
 526     SUITE         SUITE
 527     UNIT          UNIT
 528     UNITÉ         UNITÉ
 529   )},
 530 );
 531
 532 sub normalize_address2 {
 533   # Some things seen in the address2 field:
 534   # Whitespace
 535   # The complete address (with address1 containing part of the company name,
 536   # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite
 537   # number, etc.)
 538   my ($addr2, $country) = @_;
 539   $addr2 = uc($addr2);
 540   if ( exists($address2_forms{$country}) ) {
 541     my $dict = $address2_forms{$country};
 542     # protect this
 543     $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g?
 544     my @words;
 545     # remove all punctuation and spaces
 546     foreach my $w (split(/\W+/, $addr2)) {
 547       if ( exists($dict->{$w}) ) {
 548         push @words, $dict->{$w};
 549       } else {
 550         push @words, $w;
 551       }
 552     }
 553     my $result = join(' ', @words);
 554     # correct spacing of pound sign + number
 555     $result =~ s/NUMBER(\d)/# $1/;
 556     warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1;
 557     $addr2 = $result;
 558   }
 559   $addr2;
 560 }
 561
 562
 563 =back
 564
 565 =cut
 566
 567
 568 1;