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 );
   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 $DEBUG = 0;
  14
  15 @EXPORT_OK = qw( get_censustract get_district );
  16
  17 =head1 NAME
  18
  19 FS::Misc::Geo - routines to fetch geographic information
  20
  21 =head1 FUNCTIONS
  22
  23 =over 4
  24
  25 =item get_censustract LOCATION YEAR
  26
  27 Given a location hash (see L<FS::location_Mixin>) and a census map year,
  28 returns a census tract code (consisting of state, county, and tract
  29 codes) or an error message.
  30
  31 =cut
  32
  33 sub get_censustract {
  34   my $location = shift;
  35   my $year  = shift;
  36
  37   warn Dumper($location, $year) if $DEBUG;
  38
  39   my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
  40
  41   my $return = {};
  42   my $error = '';
  43
  44   my $ua = new LWP::UserAgent;
  45   my $res = $ua->request( GET( $url ) );
  46
  47   warn $res->as_string
  48     if $DEBUG > 1;
  49
  50   unless ($res->code  eq '200') {
  51
  52     $error = $res->message;
  53
  54   } else {
  55
  56     my $content = $res->content;
  57     my $p = new HTML::TokeParser \$content;
  58     my $viewstate;
  59     my $eventvalidation;
  60     while (my $token = $p->get_tag('input') ) {
  61       if ($token->[1]->{name} eq '__VIEWSTATE') {
  62         $viewstate = $token->[1]->{value};
  63       }
  64       if ($token->[1]->{name} eq '__EVENTVALIDATION') {
  65         $eventvalidation = $token->[1]->{value};
  66       }
  67       last if $viewstate && $eventvalidation;
  68     }
  69
  70     unless ($viewstate && $eventvalidation ) {
  71
  72       $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
  73
  74     } else {
  75
  76       my($zip5, $zip4) = split('-',$location->{zip});
  77
  78       $year ||= '2011'; #2012 per http://transition.fcc.gov/form477/techfaqs.html soon/now?
  79       my @ffiec_args = (
  80         __VIEWSTATE => $viewstate,
  81         __EVENTVALIDATION => $eventvalidation,
  82         ddlbYear    => $year,
  83         txtAddress  => $location->{address1},
  84         txtCity     => $location->{city},
  85         ddlbState   => $location->{state},
  86         txtZipCode  => $zip5,
  87         btnSearch   => 'Search',
  88       );
  89       warn join("\n", @ffiec_args )
  90         if $DEBUG;
  91
  92       push @{ $ua->requests_redirectable }, 'POST';
  93       $res = $ua->request( POST( $url, \@ffiec_args ) );
  94       warn $res->as_string
  95         if $DEBUG > 1;
  96
  97       unless ($res->code  eq '200') {
  98
  99         $error = $res->message;
 100
 101       } else {
 102
 103         my @id = qw( MSACode StateCode CountyCode TractCode );
 104         $content = $res->content;
 105         warn $res->content if $DEBUG > 1;
 106         $p = new HTML::TokeParser \$content;
 107         my $prefix = 'UcGeoResult11_lb';
 108         my $compare =
 109           sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
 110
 111         while (my $token = $p->get_tag('span') ) {
 112           next unless ( $token->[1]->{id} && &$compare( $token->[1]->{id} ) );
 113           $token->[1]->{id} =~ /^$prefix(\w+)$/;
 114           $return->{lc($1)} = $p->get_trimmed_text("/span");
 115         }
 116
 117         unless ( $return->{tractcode} ) {
 118           warn "$error: $content ". Dumper($return) if $DEBUG;
 119           $error = "No census tract found";
 120         }
 121         $return->{tractcode} .= ' '
 122           unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
 123
 124       } #unless ($res->code  eq '200')
 125
 126     } #unless ($viewstate)
 127
 128   } #unless ($res->code  eq '200')
 129
 130   return "FFIEC Geocoding error: $error" if $error;
 131
 132   $return->{'statecode'} .  $return->{'countycode'} .  $return->{'tractcode'};
 133 }
 134
 135 sub get_district_methods {
 136   ''         => '',
 137   'wa_sales' => 'Washington sales tax',
 138 };
 139
 140 =item get_district LOCATION METHOD
 141
 142 For the location hash in LOCATION, using lookup method METHOD, fetch
 143 tax district information.  Currently the only available method is
 144 'wa_sales' (the Washington Department of Revenue sales tax lookup).
 145
 146 Returns a hash reference containing the following fields:
 147
 148 - district
 149 - tax (percentage)
 150 - taxname
 151 - exempt_amount (currently zero)
 152 - city, county, state, country (from
 153
 154 The intent is that you can assign this to an L<FS::cust_main_county>
 155 object and insert it if there's not yet a tax rate defined for that
 156 district.
 157
 158 get_district will die on error.
 159
 160 =over 4
 161
 162 =cut
 163
 164 sub get_district {
 165   no strict 'refs';
 166   my $location = shift;
 167   my $method = shift or return '';
 168   warn Dumper($location, $method) if $DEBUG;
 169   &$method($location);
 170 }
 171
 172 sub wa_sales {
 173   my $location = shift;
 174   my $error = '';
 175   return '' if $location->{state} ne 'WA';
 176
 177   my $return = { %$location };
 178   $return->{'exempt_amount'} = 0.00;
 179
 180   my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
 181   my $ua = new LWP::UserAgent;
 182
 183   my $delim = '<|>'; # yes, <|>
 184   my $year  = (localtime)[5] + 1900;
 185   my $month = (localtime)[4] + 1;
 186   my @zip = split('-', $location->{zip});
 187
 188   my @args = (
 189     'TaxType=S',  #sales; 'P' = property
 190     'Src=0',      #does something complicated
 191     'TAXABLE=',
 192     'Addr='.uri_escape($location->{address1}),
 193     'City='.uri_escape($location->{city}),
 194     'Zip='.$zip[0],
 195     'Zip1='.($zip[1] || ''), #optional
 196     'Year='.$year,
 197     'SYear='.$year,
 198     'Month='.$month,
 199     'EMon='.$month,
 200   );
 201
 202   my $query_string = join($delim, @args );
 203   $url .= "?$query_string";
 204   warn "\nrequest:  $url\n\n" if $DEBUG;
 205
 206   my $res = $ua->request( GET( "$url?$query_string" ) );
 207
 208   warn $res->as_string
 209   if $DEBUG > 1;
 210
 211   if ($res->code ne '200') {
 212     $error = $res->message;
 213   }
 214
 215   my $content = $res->content;
 216   my $p = new HTML::TokeParser \$content;
 217   my $js = '';
 218   while ( my $t = $p->get_tag('script') ) {
 219     my $u = $p->get_token; #either enclosed text or the </script> tag
 220     if ( $u->[0] eq 'T' and $u->[1] =~ /tblSales/ ) {
 221       $js = $u->[1];
 222       last;
 223     }
 224   }
 225   if ( $js ) { #found it
 226     # strip down to the quoted string, which contains escaped single quotes.
 227     $js =~ s/.*\('tblSales'\);c.innerHTML='//s;
 228     $js =~ s/(?<!\\)'.*//s; # (?<!\\) means "not preceded by a backslash"
 229     warn "\n\n  innerHTML:\n$js\n\n" if $DEBUG > 2;
 230
 231     $p = new HTML::TokeParser \$js;
 232     TD: while ( my $td = $p->get_tag('td') ) {
 233       while ( my $u = $p->get_token ) {
 234         next TD if $u->[0] eq 'E' and $u->[1] eq 'td';
 235         next if $u->[0] ne 'T'; # skip non-text
 236         my $text = $u->[1];
 237
 238         if ( lc($text) eq 'location code' ) {
 239           $p->get_tag('td'); # skip to the next column
 240           undef $u;
 241           $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
 242           $return->{'district'} = $u->[1];
 243         }
 244         elsif ( lc($text) eq 'total tax rate' ) {
 245           $p->get_tag('td');
 246           undef $u;
 247           $u = $p->get_token until $u->[0] eq 'T';
 248           $return->{'tax'} = $u->[1];
 249         }
 250       } # get_token
 251     } # TD
 252
 253     # just to make sure
 254     if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
 255       $return->{'tax'} *= 100; #percentage
 256       warn Dumper($return) if $DEBUG;
 257       return $return;
 258     }
 259     else {
 260       $error = 'district code/tax rate not found';
 261     }
 262   }
 263   else {
 264     $error = "failed to parse document";
 265   }
 266
 267   die "WA tax district lookup error: $error";
 268 }
 269
 270 =back
 271
 272 =cut
 273
 274
 275 1;