4 use base qw( Exporter );
5 use vars qw( $DEBUG @EXPORT_OK );
8 use HTTP::Request::Common qw( GET POST );
15 @EXPORT_OK = qw( get_censustract get_district );
19 FS::Misc::Geo - routines to fetch geographic information
25 =item get_censustract LOCATION YEAR
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.
37 warn Dumper($location, $year) if $DEBUG;
39 my $url = 'http://www.ffiec.gov/Geocode/default.aspx';
44 my $ua = new LWP::UserAgent;
45 my $res = $ua->request( GET( $url ) );
50 unless ($res->code eq '200') {
52 $error = $res->message;
56 my $content = $res->content;
57 my $p = new HTML::TokeParser \$content;
60 while (my $token = $p->get_tag('input') ) {
61 if ($token->[1]->{name} eq '__VIEWSTATE') {
62 $viewstate = $token->[1]->{value};
64 if ($token->[1]->{name} eq '__EVENTVALIDATION') {
65 $eventvalidation = $token->[1]->{value};
67 last if $viewstate && $eventvalidation;
70 unless ($viewstate && $eventvalidation ) {
72 $error = "either no __VIEWSTATE or __EVENTVALIDATION found";
76 my($zip5, $zip4) = split('-',$location->{zip});
78 $year ||= '2011'; #2012 per http://transition.fcc.gov/form477/techfaqs.html soon/now?
80 __VIEWSTATE => $viewstate,
81 __EVENTVALIDATION => $eventvalidation,
83 txtAddress => $location->{address1},
84 txtCity => $location->{city},
85 ddlbState => $location->{state},
87 btnSearch => 'Search',
89 warn join("\n", @ffiec_args )
92 push @{ $ua->requests_redirectable }, 'POST';
93 $res = $ua->request( POST( $url, \@ffiec_args ) );
97 unless ($res->code eq '200') {
99 $error = $res->message;
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';
109 sub { my $t=shift; scalar( grep { lc($t) eq lc("$prefix$_")} @id ) };
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");
117 unless ( $return->{tractcode} ) {
118 warn "$error: $content ". Dumper($return) if $DEBUG;
119 $error = "No census tract found";
121 $return->{tractcode} .= ' '
122 unless $error || $JSON::VERSION >= 2; #broken JSON 1 workaround
124 } #unless ($res->code eq '200')
126 } #unless ($viewstate)
128 } #unless ($res->code eq '200')
130 return "FFIEC Geocoding error: $error" if $error;
132 $return->{'statecode'} . $return->{'countycode'} . $return->{'tractcode'};
135 sub get_district_methods {
137 'wa_sales' => 'Washington sales tax',
140 =item get_district LOCATION METHOD
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).
146 Returns a hash reference containing the following fields:
151 - exempt_amount (currently zero)
152 - city, county, state, country (from
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
158 get_district will die on error.
166 my $location = shift;
167 my $method = shift or return '';
168 warn Dumper($location, $method) if $DEBUG;
173 my $location = shift;
175 return '' if $location->{state} ne 'WA';
177 my $return = { %$location };
178 $return->{'exempt_amount'} = 0.00;
180 my $url = 'http://webgis2.dor.wa.gov/TaxRateLookup_AGS/TaxReport.aspx';
181 my $ua = new LWP::UserAgent;
183 my $delim = '<|>'; # yes, <|>
184 my $year = (localtime)[5] + 1900;
185 my $month = (localtime)[4] + 1;
186 my @zip = split('-', $location->{zip});
189 'TaxType=S', #sales; 'P' = property
190 'Src=0', #does something complicated
192 'Addr='.uri_escape($location->{address1}),
193 'City='.uri_escape($location->{city}),
195 'Zip1='.($zip[1] || ''), #optional
202 my $query_string = join($delim, @args );
203 $url .= "?$query_string";
204 warn "\nrequest: $url\n\n" if $DEBUG;
206 my $res = $ua->request( GET( "$url?$query_string" ) );
211 if ($res->code ne '200') {
212 $error = $res->message;
215 my $content = $res->content;
216 my $p = new HTML::TokeParser \$content;
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/ ) {
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;
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
238 if ( lc($text) eq 'location code' ) {
239 $p->get_tag('td'); # skip to the next column
241 $u = $p->get_token until $u->[0] eq 'T'; # and then skip non-text
242 $return->{'district'} = $u->[1];
244 elsif ( lc($text) eq 'total tax rate' ) {
247 $u = $p->get_token until $u->[0] eq 'T';
248 $return->{'tax'} = $u->[1];
254 if ( $return->{'district'} =~ /^\d+$/ and $return->{'tax'} =~ /^.\d+$/ ) {
255 $return->{'tax'} *= 100; #percentage
256 warn Dumper($return) if $DEBUG;
260 $error = 'district code/tax rate not found';
264 $error = "failed to parse document";
267 die "WA tax district lookup error: $error";