source: trunk/npemap.org.uk/cgi/geocoder.fcgi @ 404

#!/usr/bin/perl
# Looks up a location for a given postcode, returning the closest we have,
#  and an idea of how accurate a match we found.
# Looks up the nearest postcode for a given location, optionally returning
#  the several nearest (rather than just the nearest)
# Looks up the nearest postcode area for a given location, optionally
#  returning the several nearest (rather than just the nearest)
#
# Can return plain text, JS, JS callback, or XML
#
# TODO: Make me more generic, so I can work on the portal site
#
# Copyright (c) 2006 Dominic Hargreaves, Nick Burch and David Sheldon
# See accompanying file "LICENCE" for licence details

use strict;
use warnings;

use CGI::Fast qw/:standard -debug/;

# Find our private perl libraries
use FindBin;
use lib "$FindBin::Bin/../perllib";
use NPEMap;

sub print_err;

# Set up database handler to try and make sure it's ready for the first
# request
# No point in handling errors here since they'll get handled by the request
# handler
my $dbh = setup_dbh();

# Build our prepared statements:
#   Postcode to location matchers
my ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher) =
        &build_ptl_matchers($dbh);
#   Location to postcode matcher
my $postcode_matcher = &build_ltp_matcher($dbh);
#   Location to area code matchers
my $pc_area_matcher = &build_lta_matcher($dbh);


my @outputs = qw(text xml js);

my $cgi;
# Process incoming requests
REQUEST: while ($cgi = new CGI::Fast) {

    # In case the database went away, make sure we have a connection
    unless ($dbh = setup_dbh()) {
        print_internal_err('Error setting up database connection');
        next REQUEST;
    }
        # Ensure we still have prepared statements
        unless($full_matcher) {
                ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher) =
                        &build_ptl_matchers($dbh);
        }
        unless($postcode_matcher) {
                $postcode_matcher = &build_ltp_matcher($dbh);
        }
        unless($pc_area_matcher) {
                $pc_area_matcher = &build_lta_matcher($dbh);
        }


        # What output format do they want?
        my $output = $outputs[0];
        if(defined $cgi->param("format")) {
                foreach my $possoutput (@outputs) {
                        if($possoutput eq $cgi->param("format")) {
                                $output = $possoutput;
                        }
                }
        }

        # How many results did they want?
        # (Not all searches support more than one result)
        my $limit_results = 1;
        if(defined $cgi->param("results")) {
                $limit_results = $cgi->param("results");
                unless($limit_results =~ /^\d+$/) {
                        print_err ("Invalid maximum number of results '$limit_results' supplied");
                        next REQUEST;
                }
        }


        # Did they want to do postcode -> location, or location -> postcode?
        my %request;
        my @results;

        # What postcode were they asking about?
        if(defined $cgi->param("postcode") && $cgi->param("postcode")) {
                $limit_results = 1;
                $request{type} = "location";

                $request{postcode} = uc($cgi->param("postcode"));
                ($request{outward},$request{inward}) = 
                                ($request{postcode} =~ /^([A-Z]+\d+[A-Z]?)\s*(\d[A-Z][A-Z])?$/);

                unless($request{outward}) {
                        print_err ("Invalid postcode '".$request{postcode}."' supplied");
                        next REQUEST;
                }
        } elsif(defined $cgi->param("easting") && $cgi->param("easting") && 
                defined $cgi->param("northing") && $cgi->param("northing")) {
                $request{type} = "postcode";
                $request{easting} = $cgi->param("easting");
                $request{northing} = $cgi->param("northing");

                if( (defined $cgi->param("area") && $cgi->param("area")) ||
                    (defined $cgi->param("areas") && $cgi->param("areas")) ) {
                        $request{type} = "area";
                }

                unless($request{easting} =~ /^\d+$/) {
                        print_err ("Invalid easting '".$request{easting}."' supplied");
                        next REQUEST;
                }
                unless($request{northing} =~ /^\d+$/) {
                        print_err ("Invalid northing '".$request{northing}."' supplied");
                        next REQUEST;
                }
        } else {
                print_err ("You must either supply the parameter 'postcode', or the two parameters 'easting' and 'northing'");
                next REQUEST;
        }


        # Find what the user was after
        if($request{type} eq "area") {
                @results = execute_lt($pc_area_matcher, $request{easting}, $request{northing}, $limit_results);
        }
        elsif($request{type} eq "postcode") {
                @results = execute_lt($postcode_matcher, $request{easting}, $request{northing}, $limit_results);
        }
        else {
                my ($easting,$northing,$matched,$pc);
                my ($outward,$inward) = ($request{outward},$request{inward});

                # Work out until we find a match
                ($easting,$northing,$matched,$pc) = execute_ptl($full_matcher,$outward,$inward);
                unless($matched) {
                        ($easting,$northing,$matched,$pc) = 
                                        execute_ptl($outer1_matcher,$outward,substr($inward,0,1));
                }
                unless($matched) {
                        ($easting,$northing,$matched,$pc) = 
                                        execute_ptl($outer_matcher,$outward);
                }
                unless($matched) {
                        my ($mpart) = ($outward =~ /^([A-Z]+)\d/);
                        my $mlen = length($mpart);

                        ($easting,$northing,$matched,$pc) = 
                                        execute_ptl($area_matcher,$mpart,$mlen,$mpart,$mlen);

                        unless($matched) {
                                print_err "Postcode area '$mpart' not found, postcode probably invalid";
                                next REQUEST;
                        }
                }

                # Save the results
                my %res;
                $res{easting} = $easting;
                $res{northing} = $northing;
                $res{matched} = $matched;
                $res{postcode} = $pc;
                push @results, \%res;
        }


        # Format the easting and northing, if we have them
        foreach my $res (@results) {
                if($res->{easting}) {
                        $res->{ieasting} = int($res->{easting});
                }
                if($res->{northing}) {
                        $res->{inorthing} = int($res->{northing});
                }
        }


        # Render
        if($output eq "xml") {
                print header("text/xml");
                print "<?xml version='1.0'?>\n";
                print "<geocoder>\n";
                print "  <request>\n";
                if($request{postcode}) {
                        print "     <postcode>$request{postcode}</postcode>\n";
                        print "     <outward>$request{outward}</outward>\n";
                        print "     <inward>$request{inward}</inward>\n";
                } else {
                        print "     <easting>$request{easting}</easting>\n";
                        print "     <northing>$request{northing}</northing>\n";
                }
                print "  </request>\n\n";

                foreach my $res (@results) {
                        if(scalar @results > 1) {
                                print "  <result>\n";
                        }
                        print "    <easting>".$res->{ieasting}."</easting>\n";
                        print "    <northing>".$res->{inorthing}."</northing>\n";
                        print "    <postcode>$res->{postcode}</postcode>\n";
                        if(scalar @results > 1) {
                                print "  </result>\n";
                        }
                }

                print "</geocoder>\n";
        } elsif ($output eq "js") {
                print header("text/javascript");

                if(defined $cgi->param("callback")) {
                        print $cgi->param("callback") . "(";
                }
                # TODO:
                #  make me play nicely if there are several results
                #  (need to do some array magic probably)
                foreach my $res (@results) {
                        print "{ pc: \"$res->{postcode}\", e: $res->{ieasting}, n: $res->{inorthing} }";
                }
                if(defined $cgi->param("callback")) {
                        print ");";
                }
                print "\n";
    } else {
                print header("text/plain");
                print "# Easting,Northing,Matched Postcode\n";

                foreach my $res (@results) {
                        print $res->{ieasting}.",".$res->{inorthing}.",'".$res->{postcode}."'\n";
                }
        }
}

# No more requests to serve, so tidy up
$dbh->disconnect;

# Run a postcode to location matcher
sub execute_ptl {
        my $matcher = shift;
        my @args = @_;

        my ($easting,$northing,$matched,$pc);

        $matcher->execute(@args);
        while( my @row = $matcher->fetchrow_array ) {
                ($easting,$northing,$matched,$pc) = @row;
        }

        return ($easting,$northing,$matched,$pc);
}

# Run a location to postcode/area matcher
sub execute_lt {
        my $matcher = shift;
        my @args = @_;

        my @results;

        $matcher->execute(@args);
        while( my @row = $matcher->fetchrow_array ) {
                my %res = (
                        outward  => $row[0],
                        inward   => $row[1],
                        easting  => $row[2],
                        northing => $row[3]
                );

                if($res{inward}) {
                        $res{postcode} = $res{outward}." ".$res{inward};
                } else {
                        $res{postcode} = $res{outward};
                }

                push @results, \%res;
        }

        return @results;
}


# Build our various matcher prepared statements

# Postcode to Location matchers
sub build_ptl_matchers {
        my $dbh = shift;

        my $base_sql_a = "SELECT AVG(easting) AS easting, ".
                         "AVG(northing) AS northing, COUNT(id) AS matched, ";
        my $base_sql_b = " AS postcode ".
                         "FROM postcodes ".
                         "WHERE NOT deleted ";

        my $full_sql = $base_sql_a . " outward || ' ' || inward " . $base_sql_b . 
                   "AND outward = ? AND inward = ? ".
                       "GROUP BY outward, inward";
        my $outer1_sql = $base_sql_a . " outward || ' ' || substr(inward,1,1) || '##'".
                       $base_sql_b . "AND outward = ? AND substr(inward,1,1) = ?".
                       "GROUP BY outward, substr(inward,1,1)";
        my $outer_sql = $base_sql_a . " outward || ' ###'". $base_sql_b . 
                   "AND outward = ? GROUP BY outward";
        my $area_sql = $base_sql_a . " ? || '' " . $base_sql_b . 
                       "AND substr(outward,1,?) = ? ".
                       "GROUP BY substr(outward,1,?)";

        my $full_matcher = $dbh->prepare($full_sql);
        my $outer1_matcher = $dbh->prepare($outer1_sql);
        my $outer_matcher = $dbh->prepare($outer_sql);
        my $area_matcher = $dbh->prepare($area_sql);

        return ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher);
}

# Location to Postcode matcher
sub build_ltp_matcher {
        my $dbh = shift;

        my $sql = "SELECT outward, inward, easting, northing ".
                  "FROM postcodes ".
                  "WHERE inward IS NOT NULL AND inward <> '' ".
                  "ORDER BY ( ".
                  "   POW(easting - ?, 2) + POW(northing - ?, 2) ".
                  ") LIMIT ? ";

        my $matcher = $dbh->prepare($sql);
        return $matcher;
}

# Location to nearby postcode areas matcher
sub build_lta_matcher {
        my $dbh = shift;

        my $sql = "SELECT outward, '' AS inward, avg_e AS easting, avg_n AS northing ".
                  "FROM ( ".
                  "   SELECT outward, ".
                  "          AVG(easting) AS avg_e, ".
                  "          AVG(northing) AS avg_n ".
                  "   FROM postcodes ".
                  "   GROUP BY outward ".
                  ") AS areas ".
                  "ORDER BY ( ".
                  "   POW(avg_e - ?, 2) + POW(avg_n - ?, 2) ".
                  ") LIMIT ? ";

        my $matcher = $dbh->prepare($sql);
        return $matcher;
}


# Helper routines
sub print_err {
    my $err = shift;
    print header("text/plain", "400 $err");
    print "Error: $err\n";
}

sub print_internal_err {
    my $err = shift;
    print header("text/plain", "500 $err");
    print "Error: $err\n";
}