X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FMisc%2FGeo.pm;h=6bd817cfccdef98ad2768ef5544b9ed167f57d20;hb=ecc15d03711690d2b2aeeda2bd8ff1119956c583;hp=71098ebb25793cb83652221ac68063308d8422df;hpb=5d3f0bee89466e382851b8d0f0c76de3f35bb6b6;p=freeside.git diff --git a/FS/FS/Misc/Geo.pm b/FS/FS/Misc/Geo.pm index 71098ebb2..6bd817cfc 100644 --- a/FS/FS/Misc/Geo.pm +++ b/FS/FS/Misc/Geo.pm @@ -6,10 +6,12 @@ use vars qw( $DEBUG @EXPORT_OK $conf ); use LWP::UserAgent; use HTTP::Request; use HTTP::Request::Common qw( GET POST ); +use HTTP::Cookies; use HTML::TokeParser; use URI::Escape 3.31; use Data::Dumper; use FS::Conf; +use Locale::Country; FS::UID->install_callback( sub { $conf = new FS::Conf; @@ -47,19 +49,20 @@ sub get_censustract_ffiec { my $return = {}; my $error = ''; - my $ua = new LWP::UserAgent; + my $ua = new LWP::UserAgent('cookie_jar' => HTTP::Cookies->new); my $res = $ua->request( GET( $url ) ); warn $res->as_string if $DEBUG > 2; - unless ($res->code eq '200') { + if (!$res->is_success) { $error = $res->message; } else { my $content = $res->content; + my $p = new HTML::TokeParser \$content; my $viewstate; my $eventvalidation; @@ -73,7 +76,7 @@ sub get_censustract_ffiec { last if $viewstate && $eventvalidation; } - unless ($viewstate && $eventvalidation ) { + if (!$viewstate or !$eventvalidation ) { $error = "either no __VIEWSTATE or __EVENTVALIDATION found"; @@ -81,10 +84,11 @@ sub get_censustract_ffiec { my($zip5, $zip4) = split('-',$location->{zip}); - $year ||= '2012'; + $year ||= '2013'; my @ffiec_args = ( __VIEWSTATE => $viewstate, __EVENTVALIDATION => $eventvalidation, + __VIEWSTATEENCRYPTED => '', ddlbYear => $year, txtAddress => $location->{address1}, txtCity => $location->{city}, @@ -383,21 +387,182 @@ sub standardize_ezlocate { die $ezlocate_error{$match->{MAT_STAT}}."\n" unless $match->{MAT_STAT} =~ /^B\d$/; - { - address1 => $match->{STD_ADDR}, + my %result = ( + address1 => $match->{MAT_ADDR}, address2 => $location->{address2}, - city => $match->{STD_CITY}, - state => $match->{STD_ST}, + city => $match->{MAT_CITY}, + state => $match->{MAT_ST}, country => $location->{country}, - zip => $match->{STD_ZIP}.'-'.$match->{STD_P4}, + zip => $match->{MAT_ZIP}, latitude => $match->{MAT_LAT}, longitude => $match->{MAT_LON}, censustract => $match->{FIPS_ST}.$match->{FIPS_CTY}. - sprintf('%04.2f',$match->{CEN_TRCT}), + sprintf('%07.2f',$match->{CEN_TRCT}), addr_clean => 'Y', + ); + if ( $match->{STD_ADDR} ) { + # then they have a postal standardized address for us + %result = ( %result, + address1 => $match->{STD_ADDR}, + address2 => $location->{address2}, + city => $match->{STD_CITY}, + state => $match->{STD_ST}, + zip => $match->{STD_ZIP}.'-'.$match->{STD_P4}, + ); + } + + \%result; +} + +sub standardize_tomtom { + # post-2013 TomTom API + # much better, but incompatible with ezlocate + my $self = shift; + my $location = shift; + my $class = 'Geo::TomTom::Geocoding'; + eval "use $class"; + die $@ if $@; + + my $key = $conf->config('tomtom-userid') + or die "no tomtom-userid configured\n"; + + my $country = code2country($location->{country}); + my ($address1, $address2) = ($location->{address1}, $location->{address2}); + # try to fix some cases of the address fields being switched + if ( $address2 =~ /^\d/ and $address1 !~ /^\d/ ) { + $address2 = $address1; + $address1 = $location->{address2}; + } + my $result = $class->query( + key => $key, + T => $address1, + L => $location->{city}, + AA => $location->{state}, + PC => $location->{zip}, + CC => country2code($country, LOCALE_CODE_ALPHA_3), + ); + unless ( $result->is_success ) { + die "TomTom geocoding error: ".$result->message."\n"; + } + my ($match) = $result->locations; + if (!$match) { + die "Location not found.\n"; + } + my $type = $match->{type}; + warn "tomtom returned $type match\n" if $DEBUG; + warn Dumper($match) if $DEBUG > 1; + my $tract = ''; + if ( defined $match->{censusTract} ) { + $tract = $match->{censusStateCode}. $match->{censusFipsCountyCode}. + join('.', $match->{censusTract} =~ /(....)(..)/); + } + # match levels below "intersection" should not be considered clean + my $clean = ($type eq 'addresspoint' || + $type eq 'poi' || + $type eq 'house' || + $type eq 'intersection' + ) ? 'Y' : ''; + + $address2 = normalize_address2($address2, $location->{country}); + + $address1 = ''; + $address1 = $match->{houseNumber} . ' ' if length($match->{houseNumber}); + $address1 .= $match->{street} if $match->{street}; + + return +{ + address1 => $address1, + address2 => $address2, + city => $match->{city}, + state => $location->{state}, # this will never change + country => $location->{country}, # ditto + zip => ($match->{standardPostalCode} || $match->{postcode}), + latitude => $match->{latitude}, + longitude => $match->{longitude}, + censustract => $tract, + addr_clean => $clean, }; } +=iten normalize_address2 STRING, COUNTRY + +Given an 'address2' STRING, normalize it for COUNTRY postal standards. +Currently only works for US and CA. + +=cut + +# XXX really ought to be a separate module +my %address2_forms = ( + # Postal Addressing Standards, Appendix C + # (plus correction of "hanger" to "hangar") + US => {qw( + APARTMENT APT + BASEMENT BSMT + BUILDING BLDG + DEPARTMENT DEPT + FLOOR FL + FRONT FRNT + HANGAR HNGR + HANGER HNGR + KEY KEY + LOBBY LBBY + LOT LOT + LOWER LOWR + OFFICE OFC + PENTHOUSE PH + PIER PIER + REAR REAR + ROOM RM + SIDE SIDE + SLIP SLIP + SPACE SPC + STOP STOP + SUITE STE + TRAILER TRLR + UNIT UNIT + UPPER UPPR + )}, + # Canada Post Addressing Guidelines 4.3 + CA => {qw( + APARTMENT APT + APPARTEMENT APP + BUREAU BUREAU + SUITE SUITE + UNIT UNIT + UNITÉ UNITÉ + )}, +); + +sub normalize_address2 { + # Some things seen in the address2 field: + # Whitespace + # The complete address (with address1 containing part of the company name, + # or an ATTN or DBA line, or P.O. Box, or department name, or building/suite + # number, etc.) + my ($addr2, $country) = @_; + $addr2 = uc($addr2); + if ( exists($address2_forms{$country}) ) { + my $dict = $address2_forms{$country}; + # protect this + $addr2 =~ s/#\s*(\d)/NUMBER$1/; # /g? + my @words; + # remove all punctuation and spaces + foreach my $w (split(/\W+/, $addr2)) { + if ( exists($dict->{$w}) ) { + push @words, $dict->{$w}; + } else { + push @words, $w; + } + } + my $result = join(' ', @words); + # correct spacing of pound sign + number + $result =~ s/NUMBER(\d)/# $1/; + warn "normalizing '$addr2' to '$result'\n" if $DEBUG > 1; + $addr2 = $result; + } + $addr2; +} + + =back =cut