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