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
  13 FS::UID->install_callback( sub {
  14   $conf = new FS::Conf;
  15 } );
  16
  17 $DEBUG = 0;
  18
  19 @EXPORT_OK = qw( get_district );
  20
  21 =head1 NAME
  22
  23 FS::Misc::Geo - routines to fetch geographic information
  24
  25 =head1 CLASS METHODS
  26
  27 =over 4
  28
  29 =item get_censustract LOCATION YEAR
  30
  31 Given a location hash (see L<FS::location_Mixin>) and a census map year,
  32 returns a census tract code (consisting of state, county, and tract
  33 codes) or an error message.
  34
  35 =cut
  36
  37 sub get_censustract_ffiec {
  38   my $class = shift;
  39   my $location = shift;
  40   my $year  = shift;
  41
  42   warn Dumper($location, $year) if $DEBUG;
  43
  44   my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
  45
  46   my $return = {};
  47   my $error = '';
  48
  49   my $ua = new LWP::UserAgent;
  50   my $res = $ua->request( GET( $url ) );
  51
  52   warn $res->as_string
  53     if $DEBUG > 2;
  54
  55   unless ($res->code  eq '200') {
  56
  57     $error = $res->message;
  58
  59   } else {
  60
  61     my $content = $res->content;
  62     my $p = new HTML::TokeParser \$content;
  63     my $viewstate;
  64     my $eventvalidation;
  65     while (my $token = $p->get_tag('input') ) {
  66       if ($token->[1]->{name} eq '__VIEWSTATE') {
  67         $viewstate = $token->[1]->{value};
  68       }
  69       if ($token->[1]->{name} eq '__EVENTVALIDATION') {
  70         $eventvalidation = $token->[1]->{value};
  71       }
  72       last if $viewstate && $eventvalidation;
  73     }
  74
  75     unless ($viewstate && $eventvalidation ) {
  76
  77       $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
  78
  79     } else {
  80
  81       my($zip5, $zip4) = split('-',$location->{zip});
  82
  83       $year ||= '2011'; #2012 per http://transition.fcc.gov/form477/techfaqs.html soon/now?
  84       my @ffiec_args = (
  85         __VIEWSTATE => $viewstate,
  86         __EVENTVALIDATION => $eventvalidation,
  87         ddlbYear    => $year,
  88         txtAddress  => $location->{address1},
  89         txtCity     => $location->{city},
  90         ddlbState   => $location->{state},
  91         txtZipCode  => $zip5,
  92         btnSearch   => 'Search',
  93       );
  94       warn join("\n", @ffiec_args )
  95         if $DEBUG > 1;
  96
  97       push @{ $ua->requests_redirectable }, 'POST';
  98       $res = $ua->request( POST( $url, \@ffiec_args ) );
  99       warn $res->as_string
 100         if $DEBUG > 2;
 101
 102       unless ($res->code  eq '200') {
 103
 104         $error = $res->message;
 105
 106       } else {
 107
 108         my @id = qw( MSACode StateCode CountyCode TractCode );
 109         $content = $res->content;
 110         warn $res->content if $DEBUG > 2;
 111         $p = new HTML::TokeParser \$content;
 112         my $prefix = 'UcGeoResult11_lb';
 113         my $compare =
 114           sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
 115
 116         while (my $token = $p->get_tag('span') ) {
 117           next unless ( $token->[1]->{id} && &$compare( $token->[1]->{id} ) );
 118           $token->[1]->{id} =~ /^$prefix(\w+)$/;
 119           $return->{lc($1)} = $p->get_trimmed_text("/span");
 120         }
 121
 122         unless ( $return->{tractcode} ) {
 123           warn "$error: $content ". Dumper($return) if $DEBUG;
 124           $error = "No census tract found";
 125         }
 126         $return->{tractcode} .= ' '
 127           unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
 128
 129       } #unless ($res->code  eq '200')
 130
 131     } #unless ($viewstate)
 132
 133   } #unless ($res->code  eq '200')
 134
 135   die "FFIEC Geocoding error: $error\n" if $error;
 136
 137   $return->{'statecode'} .  $return->{'countycode'} .  $return->{'tractcode'};
 138 }
 139
 140 sub get_district_methods {
 141   ''         => '',
 142   'wa_sales' => 'Washington sales tax',
 143 };
 144
 145 =item get_district LOCATION METHOD
 146
 147 For the location hash in LOCATION, using lookup method METHOD, fetch
 148 tax district information.  Currently the only available method is
 149 'wa_sales' (the Washington Department of Revenue sales tax lookup).
 150
 151 Returns a hash reference containing the following fields:
 152
 153 - district
 154 - tax (percentage)
 155 - taxname
 156 - exempt_amount (currently zero)
 157 - city, county, state, country (from
 158
 159 The intent is that you can assign this to an L<FS::cust_main_county>
 160 object and insert it if there's not yet a tax rate defined for that
 161 district.
 162
 163 get_district will die on error.
 164
 165 =over 4
 166
 167 =cut
 168
 169 sub get_district {
 170   no strict 'refs';
 171   my $location = shift;
 172   my $method = shift or return '';
 173   warn Dumper($location, $method) if $DEBUG;
 174   &$method($location);
 175 }
 176
 177 sub wa_sales {
 178   my $location = shift;
 179   my $error = '';
 180   return '' if $location->{state} ne 'WA';
 181
 182   my $return = { %$location };
 183   $return->{'exempt_amount'} = 0.00;
 184
 185   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 186   my $ua = new LWP::UserAgent;
 187
 188   my $delim = '<|>'; # yes, <|>
 189   my $year  = (localtime)[5] + 1900;
 190   my $month = (localtime)[4] + 1;
 191   my @zip = split('-', $location->{zip});
 192
 193   my @args = (
 194     'TaxType=S',  #sales; 'P' = property
 195     'Src=0',      #does something complicated
 196     'TAXABLE=',
 197     'Addr='.uri_escape($location->{address1}),
 198     'City='.uri_escape($location->{city}),
 199     'Zip='.$zip[0],
 200     'Zip1='.($zip[1] || ''), #optional
 201     'Year='.$year,
 202     'SYear='.$year,
 203     'Month='.$month,
 204     'EMon='.$month,
 205   );
 206
 207   my $query_string = join($delim, @args );
 208   $url .= "?$query_string";
 209   warn "\nrequest:  $url\n\n" if $DEBUG > 1;
 210
 211   my $res = $ua->request( GET( "$url?$query_string" ) );
 212
 213   warn $res->as_string
 214   if $DEBUG > 2;
 215
 216   if ($res->code ne '200') {
 217     $error = $res->message;
 218   }
 219
 220   my $content = $res->content;
 221   my $p = new HTML::TokeParser \$content;
 222   my $js = '';
 223   while ( my $t = $p->get_tag('script') ) {
 224     my $u = $p->get_token; #either enclosed text or the </script> tag
 225     if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
 226       $js = $u->[1];
 227       last;
 228     }
 229   }
 230   if ( $js ) { #found it
 231     # strip down to the quoted string, which contains escaped single quotes.
 232     $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
 233     $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
 234     warn "\n\n  innerHTML:\n$js\n\n" if $DEBUG > 2;
 235
 236     $p = new HTML::TokeParser \$js;
 237     TD: while ( my $td = $p->get_tag('td') ) {
 238       while ( my $u = $p->get_token ) {
 239         next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
 240         next if $u->[0] ne 'T'; # skip non-text
 241         my $text = $u->[1];
 242
 243         if ( lc($text) eq 'location code' ) {
 244           $p->get_tag('td'); # skip to the next column
 245           undef $u;
 246           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 247           $return->{'district'} = $u->[1];
 248         }
 249         elsif ( lc($text) eq 'total tax rate' ) {
 250           $p->get_tag('td');
 251           undef $u;
 252           $u = $p->get_token until $u->[0] eq 'T';
 253           $return->{'tax'} = $u->[1];
 254         }
 255       } # get_token
 256     } # TD
 257
 258     # just to make sure
 259     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 260       $return->{'tax'} *= 100; #percentage
 261       warn Dumper($return) if $DEBUG > 1;
 262       return $return;
 263     }
 264     else {
 265       $error = 'district code/tax rate not found';
 266     }
 267   }
 268   else {
 269     $error = "failed to parse document";
 270   }
 271
 272   die "WA tax district lookup error: $error";
 273 }
 274
 275 sub standardize_usps {
 276   my $class = shift;
 277
 278   eval "use Business::US::USPS::WebTools::AddressStandardization";
 279   die $@ if $@;
 280
 281   my $location = shift;
 282   if ( $location->{country} ne 'US' ) {
 283     # soft failure
 284     warn "standardize_usps not for use in country ".$location->{country}."\n";
 285     $location->{addr_clean} = '';
 286     return $location;
 287   }
 288   my $userid   = $conf->config('usps_webtools-userid');
 289   my $password = $conf->config('usps_webtools-password');
 290   my $verifier = Business::US::USPS::WebTools::AddressStandardization->new( {
 291       UserID => $userid,
 292       Password => $password,
 293       Testing => 0,
 294   } ) or die "error starting USPS WebTools\n";
 295
 296   my($zip5, $zip4) = split('-',$location->{'zip'});
 297
 298   my %usps_args = (
 299     FirmName => $location->{company},
 300     Address2 => $location->{address1},
 301     Address1 => $location->{address2},
 302     City     => $location->{city},
 303     State    => $location->{state},
 304     Zip5     => $zip5,
 305     Zip4     => $zip4,
 306   );
 307   warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
 308     if $DEBUG > 1;
 309
 310   my $hash = $verifier->verify_address( %usps_args );
 311
 312   warn $verifier->response
 313     if $DEBUG > 1;
 314
 315   die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
 316     if $verifier->is_error;
 317
 318   my $zip = $hash->{Zip5};
 319   $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
 320
 321   { company   => $hash->{FirmName},
 322     address1  => $hash->{Address2},
 323     address2  => $hash->{Address1},
 324     city      => $hash->{City},
 325     state     => $hash->{State},
 326     zip       => $zip,
 327     country   => 'US',
 328     addr_clean=> 'Y' }
 329 }
 330
 331 my %ezlocate_error = ( # USA_Geo_002 documentation
 332   10  => 'State not found',
 333   11  => 'City not found',
 334   12  => 'Invalid street address',
 335   14  => 'Street name not found',
 336   15  => 'Address range does not exist',
 337   16  => 'Ambiguous address',
 338   17  => 'Intersection not found', #unused?
 339 );
 340
 341 sub standardize_ezlocate {
 342   my $self = shift;
 343   my $location = shift;
 344   my $class;
 345   #if ( $location->{country} eq 'US' ) {
 346   #  $class = 'USA_Geo_004Tool';
 347   #}
 348   #elsif ( $location->{country} eq 'CA' ) {
 349   #  $class = 'CAN_Geo_001Tool';
 350   #}
 351   #else { # shouldn't be a fatal error, just pass through unverified address
 352   #  warn "standardize_teleatlas: address lookup in '".$location->{country}.
 353   #       "' not available\n";
 354   #  return $location;
 355   #}
 356   #my $path = $conf->config('teleatlas-path') || '';
 357   #local @INC = (@INC, $path);
 358   #eval "use $class;";
 359   #if ( $@ ) {
 360   #  die "Loading $class failed:\n$@".
 361   #      "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
 362   #}
 363
 364   $class = 'Geo::EZLocate'; # use our own library
 365   eval "use $class";
 366   die $@ if $@;
 367
 368   my $userid = $conf->config('ezlocate-userid')
 369     or die "no ezlocate-userid configured\n";
 370   my $password = $conf->config('ezlocate-password')
 371     or die "no ezlocate-password configured\n";
 372
 373   my $tool = $class->new($userid, $password);
 374   my $match = $tool->findAddress(
 375     $location->{address1},
 376     $location->{city},
 377     $location->{state},
 378     $location->{zip}, #12345-6789 format is allowed
 379   );
 380   warn "ezlocate returned match:\n".Dumper($match) if $DEBUG > 1;
 381   # error handling - B codes indicate success
 382   die $ezlocate_error{$match->{MAT_STAT}}."\n"
 383     unless $match->{MAT_STAT} =~ /^B\d$/;
 384
 385   {
 386     address1    => $match->{STD_ADDR},
 387     address2    => $location->{address2},
 388     city        => $match->{STD_CITY},
 389     state       => $match->{STD_ST},
 390     country     => $location->{country},
 391     zip         => $match->{STD_ZIP}.'-'.$match->{STD_P4},
 392     latitude    => $match->{MAT_LAT},
 393     longitude   => $match->{MAT_LON},
 394     censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}.
 395                    sprintf('%04.2f',$match->{CEN_TRCT}),
 396     addr_clean  => 'Y',
 397   };
 398 }
 399
 400 =back
 401
 402 =cut
 403
 404
 405 1;