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
  14 FS::UID->install_callback( sub {
  15   $conf = new FS::Conf;
  16 } );
  17
  18 $DEBUG = 0;
  19
  20 @EXPORT_OK = qw( get_district );
  21
  22 =head1 NAME
  23
  24 FS::Misc::Geo - routines to fetch geographic information
  25
  26 =head1 CLASS METHODS
  27
  28 =over 4
  29
  30 =item get_censustract LOCATION YEAR
  31
  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.
  35
  36 =cut
  37
  38 sub get_censustract_ffiec {
  39   my $class = shift;
  40   my $location = shift;
  41   my $year  = shift;
  42
  43   warn Dumper($location, $year) if $DEBUG;
  44
  45   my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
  46
  47   my $return = {};
  48   my $error = '';
  49
  50   my $ua = new LWP::UserAgent;
  51   my $res = $ua->request( GET( $url ) );
  52
  53   warn $res->as_string
  54     if $DEBUG > 2;
  55
  56   unless ($res->code  eq '200') {
  57
  58     $error = $res->message;
  59
  60   } else {
  61
  62     my $content = $res->content;
  63     my $p = new HTML::TokeParser \$content;
  64     my $viewstate;
  65     my $eventvalidation;
  66     while (my $token = $p->get_tag('input') ) {
  67       if ($token->[1]->{name} eq '__VIEWSTATE') {
  68         $viewstate = $token->[1]->{value};
  69       }
  70       if ($token->[1]->{name} eq '__EVENTVALIDATION') {
  71         $eventvalidation = $token->[1]->{value};
  72       }
  73       last if $viewstate && $eventvalidation;
  74     }
  75
  76     unless ($viewstate && $eventvalidation ) {
  77
  78       $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
  79
  80     } else {
  81
  82       my($zip5, $zip4) = split('-',$location->{zip});
  83
  84       $year ||= '2011'; #2012 per http://transition.fcc.gov/form477/techfaqs.html soon/now?
  85       my @ffiec_args = (
  86         __VIEWSTATE => $viewstate,
  87         __EVENTVALIDATION => $eventvalidation,
  88         ddlbYear    => $year,
  89         txtAddress  => $location->{address1},
  90         txtCity     => $location->{city},
  91         ddlbState   => $location->{state},
  92         txtZipCode  => $zip5,
  93         btnSearch   => 'Search',
  94       );
  95       warn join("\n", @ffiec_args )
  96         if $DEBUG > 1;
  97
  98       push @{ $ua->requests_redirectable }, 'POST';
  99       $res = $ua->request( POST( $url, \@ffiec_args ) );
 100       warn $res->as_string
 101         if $DEBUG > 2;
 102
 103       unless ($res->code  eq '200') {
 104
 105         $error = $res->message;
 106
 107       } else {
 108
 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';
 114         my $compare =
 115           sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
 116
 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");
 121         }
 122
 123         unless ( $return->{tractcode} ) {
 124           warn "$error: $content ". Dumper($return) if $DEBUG;
 125           $error = "No census tract found";
 126         }
 127         $return->{tractcode} .= ' '
 128           unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
 129
 130       } #unless ($res->code  eq '200')
 131
 132     } #unless ($viewstate)
 133
 134   } #unless ($res->code  eq '200')
 135
 136   die "FFIEC Geocoding error: $error\n" if $error;
 137
 138   $return->{'statecode'} .  $return->{'countycode'} .  $return->{'tractcode'};
 139 }
 140
 141 #sub get_district_methods {
 142 #  ''         => '',
 143 #  'wa_sales' => 'Washington sales tax',
 144 #};
 145
 146 =item get_district LOCATION METHOD
 147
 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).
 151
 152 Returns a hash reference containing the following fields:
 153
 154 - district
 155 - tax (percentage)
 156 - taxname
 157 - exempt_amount (currently zero)
 158 - city, county, state, country (from
 159
 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
 162 district.
 163
 164 get_district will die on error.
 165
 166 =over 4
 167
 168 =cut
 169
 170 sub get_district {
 171   no strict 'refs';
 172   my $location = shift;
 173   my $method = shift or return '';
 174   warn Dumper($location, $method) if $DEBUG;
 175   &$method($location);
 176 }
 177
 178 sub wa_sales {
 179   my $location = shift;
 180   my $error = '';
 181   return '' if $location->{state} ne 'WA';
 182
 183   my $return = { %$location };
 184   $return->{'exempt_amount'} = 0.00;
 185
 186   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 187   my $ua = new LWP::UserAgent;
 188
 189   my $delim = '<|>'; # yes, <|>
 190   my $year  = (localtime)[5] + 1900;
 191   my $month = (localtime)[4] + 1;
 192   my @zip = split('-', $location->{zip});
 193
 194   my @args = (
 195     'TaxType=S',  #sales; 'P' = property
 196     'Src=0',      #does something complicated
 197     'TAXABLE=',
 198     'Addr='.uri_escape($location->{address1}),
 199     'City='.uri_escape($location->{city}),
 200     'Zip='.$zip[0],
 201     'Zip1='.($zip[1] || ''), #optional
 202     'Year='.$year,
 203     'SYear='.$year,
 204     'Month='.$month,
 205     'EMon='.$month,
 206   );
 207
 208   my $query_string = join($delim, @args );
 209   $url .= "?$query_string";
 210   warn "\nrequest:  $url\n\n" if $DEBUG > 1;
 211
 212   my $res = $ua->request( GET( "$url?$query_string" ) );
 213
 214   warn $res->as_string
 215   if $DEBUG > 2;
 216
 217   if ($res->code ne '200') {
 218     $error = $res->message;
 219   }
 220
 221   my $content = $res->content;
 222   my $p = new HTML::TokeParser \$content;
 223   my $js = '';
 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/ ) {
 227       $js = $u->[1];
 228       last;
 229     }
 230   }
 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;
 236
 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
 242         my $text = $u->[1];
 243
 244         if ( lc($text) eq 'location code' ) {
 245           $p->get_tag('td'); # skip to the next column
 246           undef $u;
 247           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 248           $return->{'district'} = $u->[1];
 249         }
 250         elsif ( lc($text) eq 'total tax rate' ) {
 251           $p->get_tag('td');
 252           undef $u;
 253           $u = $p->get_token until $u->[0] eq 'T';
 254           $return->{'tax'} = $u->[1];
 255         }
 256       } # get_token
 257     } # TD
 258
 259     # just to make sure
 260     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 261       $return->{'tax'} *= 100; #percentage
 262       warn Dumper($return) if $DEBUG > 1;
 263       return $return;
 264     }
 265     else {
 266       $error = 'district code/tax rate not found';
 267     }
 268   }
 269   else {
 270     $error = "failed to parse document";
 271   }
 272
 273   die "WA tax district lookup error: $error";
 274 }
 275
 276 sub standardize_usps {
 277   my $class = shift;
 278
 279   eval "use Business::US::USPS::WebTools::AddressStandardization";
 280   die $@ if $@;
 281
 282   my $location = shift;
 283   if ( $location->{country} ne 'US' ) {
 284     # soft failure
 285     warn "standardize_usps not for use in country ".$location->{country}."\n";
 286     $location->{addr_clean} = '';
 287     return $location;
 288   }
 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( {
 292       UserID => $userid,
 293       Password => $password,
 294       Testing => 0,
 295   } ) or die "error starting USPS WebTools\n";
 296
 297   my($zip5, $zip4) = split('-',$location->{'zip'});
 298
 299   my %usps_args = (
 300     FirmName => $location->{company},
 301     Address2 => $location->{address1},
 302     Address1 => $location->{address2},
 303     City     => $location->{city},
 304     State    => $location->{state},
 305     Zip5     => $zip5,
 306     Zip4     => $zip4,
 307   );
 308   warn join('', map "$_: $usps_args{$_}\n", keys %usps_args )
 309     if $DEBUG > 1;
 310
 311   my $hash = $verifier->verify_address( %usps_args );
 312
 313   warn $verifier->response
 314     if $DEBUG > 1;
 315
 316   die "USPS WebTools error: ".$verifier->{error}{description} ."\n"
 317     if $verifier->is_error;
 318
 319   my $zip = $hash->{Zip5};
 320   $zip .= '-' . $hash->{Zip4} if $hash->{Zip4} =~ /\d/;
 321
 322   { company   => $hash->{FirmName},
 323     address1  => $hash->{Address2},
 324     address2  => $hash->{Address1},
 325     city      => $hash->{City},
 326     state     => $hash->{State},
 327     zip       => $zip,
 328     country   => 'US',
 329     addr_clean=> 'Y' }
 330 }
 331
 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?
 340 );
 341
 342 sub standardize_ezlocate {
 343   my $self = shift;
 344   my $location = shift;
 345   my $class;
 346   #if ( $location->{country} eq 'US' ) {
 347   #  $class = 'USA_Geo_004Tool';
 348   #}
 349   #elsif ( $location->{country} eq 'CA' ) {
 350   #  $class = 'CAN_Geo_001Tool';
 351   #}
 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";
 355   #  return $location;
 356   #}
 357   #my $path = $conf->config('teleatlas-path') || '';
 358   #local @INC = (@INC, $path);
 359   #eval "use $class;";
 360   #if ( $@ ) {
 361   #  die "Loading $class failed:\n$@".
 362   #      "\nMake sure the TeleAtlas Perl SDK is installed correctly.\n";
 363   #}
 364
 365   $class = 'Geo::EZLocate'; # use our own library
 366   eval "use $class";
 367   die $@ if $@;
 368
 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";
 373
 374   my $tool = $class->new($userid, $password);
 375   my $match = $tool->findAddress(
 376     $location->{address1},
 377     $location->{city},
 378     $location->{state},
 379     $location->{zip}, #12345-6789 format is allowed
 380   );
 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$/;
 385
 386   {
 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}),
 397     addr_clean  => 'Y',
 398   };
 399 }
 400
 401 =back
 402
 403 =cut
 404
 405
 406 1;