1 | #!/usr/bin/perl |
---|
2 | # Looks up a location for a given postcode, returning the closest we have, |
---|
3 | # and an idea of how accurate a match we found. |
---|
4 | # Looks up the nearest postcode for a given location, optionally returning |
---|
5 | # the several nearest (rather than just the nearest) |
---|
6 | # Looks up the nearest postcode area for a given location, optionally |
---|
7 | # returning the several nearest (rather than just the nearest) |
---|
8 | # |
---|
9 | # Can return plain text, JS, JS callback, or XML |
---|
10 | # |
---|
11 | # TODO: Make me more generic, so I can work on the portal site |
---|
12 | # |
---|
13 | # Copyright (c) 2006 Dominic Hargreaves, Nick Burch and David Sheldon |
---|
14 | # See accompanying file "LICENCE" for licence details |
---|
15 | |
---|
16 | use strict; |
---|
17 | use warnings; |
---|
18 | |
---|
19 | use CGI::Fast qw/:standard -debug/; |
---|
20 | |
---|
21 | # Find our private perl libraries |
---|
22 | use FindBin; |
---|
23 | use lib "$FindBin::Bin/../perllib"; |
---|
24 | use NPEMap; |
---|
25 | |
---|
26 | sub print_err; |
---|
27 | |
---|
28 | # Set up database handler to try and make sure it's ready for the first |
---|
29 | # request |
---|
30 | # No point in handling errors here since they'll get handled by the request |
---|
31 | # handler |
---|
32 | my $dbh = setup_dbh(); |
---|
33 | |
---|
34 | # Build our prepared statements: |
---|
35 | # Postcode to location matchers |
---|
36 | my ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher) = |
---|
37 | &build_ptl_matchers($dbh); |
---|
38 | # Location to postcode matcher |
---|
39 | my $postcode_matcher = &build_ltp_matcher($dbh); |
---|
40 | # Location to area code matchers |
---|
41 | my $pc_area_matcher = &build_lta_matcher($dbh); |
---|
42 | |
---|
43 | |
---|
44 | my @outputs = qw(text xml js); |
---|
45 | |
---|
46 | my $cgi; |
---|
47 | # Process incoming requests |
---|
48 | REQUEST: while ($cgi = new CGI::Fast) { |
---|
49 | |
---|
50 | # In case the database went away, make sure we have a connection |
---|
51 | unless ($dbh = setup_dbh()) { |
---|
52 | print_internal_err('Error setting up database connection'); |
---|
53 | next REQUEST; |
---|
54 | } |
---|
55 | # Ensure we still have prepared statements |
---|
56 | unless($full_matcher) { |
---|
57 | ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher) = |
---|
58 | &build_ptl_matchers($dbh); |
---|
59 | } |
---|
60 | unless($postcode_matcher) { |
---|
61 | $postcode_matcher = &build_ltp_matcher($dbh); |
---|
62 | } |
---|
63 | unless($pc_area_matcher) { |
---|
64 | $pc_area_matcher = &build_lta_matcher($dbh); |
---|
65 | } |
---|
66 | |
---|
67 | |
---|
68 | # What output format do they want? |
---|
69 | my $output = $outputs[0]; |
---|
70 | if(defined $cgi->param("format")) { |
---|
71 | foreach my $possoutput (@outputs) { |
---|
72 | if($possoutput eq $cgi->param("format")) { |
---|
73 | $output = $possoutput; |
---|
74 | } |
---|
75 | } |
---|
76 | } |
---|
77 | |
---|
78 | # How many results did they want? |
---|
79 | # (Not all searches support more than one result) |
---|
80 | my $limit_results = 1; |
---|
81 | if(defined $cgi->param("results")) { |
---|
82 | $limit_results = $cgi->param("results"); |
---|
83 | unless($limit_results =~ /^\d+$/) { |
---|
84 | print_err ("Invalid maximum number of results '$limit_results' supplied"); |
---|
85 | next REQUEST; |
---|
86 | } |
---|
87 | } |
---|
88 | |
---|
89 | |
---|
90 | # Did they want to do postcode -> location, or location -> postcode? |
---|
91 | my %request; |
---|
92 | my @results; |
---|
93 | |
---|
94 | # What postcode were they asking about? |
---|
95 | if(defined $cgi->param("postcode") && $cgi->param("postcode")) { |
---|
96 | $limit_results = 1; |
---|
97 | $request{type} = "location"; |
---|
98 | |
---|
99 | $request{postcode} = uc($cgi->param("postcode")); |
---|
100 | ($request{outward},$request{inward}) = |
---|
101 | ($request{postcode} =~ /^([A-Z]+\d+[A-Z]?)\s*(\d[A-Z][A-Z])?$/); |
---|
102 | |
---|
103 | unless($request{outward}) { |
---|
104 | print_err ("Invalid postcode '".$request{postcode}."' supplied"); |
---|
105 | next REQUEST; |
---|
106 | } |
---|
107 | } elsif(defined $cgi->param("easting") && $cgi->param("easting") && |
---|
108 | defined $cgi->param("northing") && $cgi->param("northing")) { |
---|
109 | $request{type} = "postcode"; |
---|
110 | $request{easting} = $cgi->param("easting"); |
---|
111 | $request{northing} = $cgi->param("northing"); |
---|
112 | |
---|
113 | if( (defined $cgi->param("area") && $cgi->param("area")) || |
---|
114 | (defined $cgi->param("areas") && $cgi->param("areas")) ) { |
---|
115 | $request{type} = "area"; |
---|
116 | } |
---|
117 | |
---|
118 | unless($request{easting} =~ /^\d+$/) { |
---|
119 | print_err ("Invalid easting '".$request{easting}."' supplied"); |
---|
120 | next REQUEST; |
---|
121 | } |
---|
122 | unless($request{northing} =~ /^\d+$/) { |
---|
123 | print_err ("Invalid northing '".$request{northing}."' supplied"); |
---|
124 | next REQUEST; |
---|
125 | } |
---|
126 | } else { |
---|
127 | print_err ("You must either supply the parameter 'postcode', or the two parameters 'easting' and 'northing'"); |
---|
128 | next REQUEST; |
---|
129 | } |
---|
130 | |
---|
131 | |
---|
132 | # Find what the user was after |
---|
133 | if($request{type} eq "area") { |
---|
134 | @results = execute_lt($pc_area_matcher, $request{easting}, $request{northing}, $limit_results); |
---|
135 | } |
---|
136 | elsif($request{type} eq "postcode") { |
---|
137 | @results = execute_lt($postcode_matcher, $request{easting}, $request{northing}, $limit_results); |
---|
138 | } |
---|
139 | else { |
---|
140 | my ($easting,$northing,$matched,$pc); |
---|
141 | my ($outward,$inward) = ($request{outward},$request{inward}); |
---|
142 | |
---|
143 | # Work out until we find a match |
---|
144 | ($easting,$northing,$matched,$pc) = execute_ptl($full_matcher,$outward,$inward); |
---|
145 | unless($matched) { |
---|
146 | ($easting,$northing,$matched,$pc) = |
---|
147 | execute_ptl($outer1_matcher,$outward,substr($inward,0,1)); |
---|
148 | } |
---|
149 | unless($matched) { |
---|
150 | ($easting,$northing,$matched,$pc) = |
---|
151 | execute_ptl($outer_matcher,$outward); |
---|
152 | } |
---|
153 | unless($matched) { |
---|
154 | my ($mpart) = ($outward =~ /^([A-Z]+)\d/); |
---|
155 | my $mlen = length($mpart); |
---|
156 | |
---|
157 | ($easting,$northing,$matched,$pc) = |
---|
158 | execute_ptl($area_matcher,$mpart,$mlen,$mpart,$mlen); |
---|
159 | |
---|
160 | unless($matched) { |
---|
161 | print_err "Postcode area '$mpart' not found, postcode probably invalid"; |
---|
162 | next REQUEST; |
---|
163 | } |
---|
164 | } |
---|
165 | |
---|
166 | # Save the results |
---|
167 | my %res; |
---|
168 | $res{easting} = $easting; |
---|
169 | $res{northing} = $northing; |
---|
170 | $res{matched} = $matched; |
---|
171 | $res{postcode} = $pc; |
---|
172 | push @results, \%res; |
---|
173 | } |
---|
174 | |
---|
175 | |
---|
176 | # Format the easting and northing, if we have them |
---|
177 | foreach my $res (@results) { |
---|
178 | if($res->{easting}) { |
---|
179 | $res->{ieasting} = int($res->{easting}); |
---|
180 | } |
---|
181 | if($res->{northing}) { |
---|
182 | $res->{inorthing} = int($res->{northing}); |
---|
183 | } |
---|
184 | } |
---|
185 | |
---|
186 | |
---|
187 | # Render |
---|
188 | if($output eq "xml") { |
---|
189 | print header("text/xml"); |
---|
190 | print "<?xml version='1.0'?>\n"; |
---|
191 | print "<geocoder>\n"; |
---|
192 | print " <request>\n"; |
---|
193 | if($request{postcode}) { |
---|
194 | print " <postcode>$request{postcode}</postcode>\n"; |
---|
195 | print " <outward>$request{outward}</outward>\n"; |
---|
196 | print " <inward>$request{inward}</inward>\n"; |
---|
197 | } else { |
---|
198 | print " <easting>$request{easting}</easting>\n"; |
---|
199 | print " <northing>$request{northing}</northing>\n"; |
---|
200 | } |
---|
201 | print " </request>\n\n"; |
---|
202 | |
---|
203 | foreach my $res (@results) { |
---|
204 | if(scalar @results > 1) { |
---|
205 | print " <result>\n"; |
---|
206 | } |
---|
207 | print " <easting>".$res->{ieasting}."</easting>\n"; |
---|
208 | print " <northing>".$res->{inorthing}."</northing>\n"; |
---|
209 | print " <postcode>$res->{postcode}</postcode>\n"; |
---|
210 | if(scalar @results > 1) { |
---|
211 | print " </result>\n"; |
---|
212 | } |
---|
213 | } |
---|
214 | |
---|
215 | print "</geocoder>\n"; |
---|
216 | } elsif ($output eq "js") { |
---|
217 | print header("text/javascript"); |
---|
218 | |
---|
219 | if(defined $cgi->param("callback")) { |
---|
220 | print $cgi->param("callback") . "("; |
---|
221 | } |
---|
222 | # TODO: |
---|
223 | # make me play nicely if there are several results |
---|
224 | # (need to do some array magic probably) |
---|
225 | foreach my $res (@results) { |
---|
226 | print "{ pc: \"$res->{postcode}\", e: $res->{ieasting}, n: $res->{inorthing} }"; |
---|
227 | } |
---|
228 | if(defined $cgi->param("callback")) { |
---|
229 | print ");"; |
---|
230 | } |
---|
231 | print "\n"; |
---|
232 | } else { |
---|
233 | print header("text/plain"); |
---|
234 | print "# Easting,Northing,Matched Postcode\n"; |
---|
235 | |
---|
236 | foreach my $res (@results) { |
---|
237 | print $res->{ieasting}.",".$res->{inorthing}.",'".$res->{postcode}."'\n"; |
---|
238 | } |
---|
239 | } |
---|
240 | } |
---|
241 | |
---|
242 | # No more requests to serve, so tidy up |
---|
243 | $dbh->disconnect; |
---|
244 | |
---|
245 | # Run a postcode to location matcher |
---|
246 | sub execute_ptl { |
---|
247 | my $matcher = shift; |
---|
248 | my @args = @_; |
---|
249 | |
---|
250 | my ($easting,$northing,$matched,$pc); |
---|
251 | |
---|
252 | $matcher->execute(@args); |
---|
253 | while( my @row = $matcher->fetchrow_array ) { |
---|
254 | ($easting,$northing,$matched,$pc) = @row; |
---|
255 | } |
---|
256 | |
---|
257 | return ($easting,$northing,$matched,$pc); |
---|
258 | } |
---|
259 | |
---|
260 | # Run a location to postcode/area matcher |
---|
261 | sub execute_lt { |
---|
262 | my $matcher = shift; |
---|
263 | my @args = @_; |
---|
264 | |
---|
265 | my @results; |
---|
266 | |
---|
267 | $matcher->execute(@args); |
---|
268 | while( my @row = $matcher->fetchrow_array ) { |
---|
269 | my %res = ( |
---|
270 | outward => $row[0], |
---|
271 | inward => $row[1], |
---|
272 | easting => $row[2], |
---|
273 | northing => $row[3] |
---|
274 | ); |
---|
275 | |
---|
276 | if($res{inward}) { |
---|
277 | $res{postcode} = $res{outward}." ".$res{inward}; |
---|
278 | } else { |
---|
279 | $res{postcode} = $res{outward}; |
---|
280 | } |
---|
281 | |
---|
282 | push @results, \%res; |
---|
283 | } |
---|
284 | |
---|
285 | return @results; |
---|
286 | } |
---|
287 | |
---|
288 | |
---|
289 | # Build our various matcher prepared statements |
---|
290 | |
---|
291 | # Postcode to Location matchers |
---|
292 | sub build_ptl_matchers { |
---|
293 | my $dbh = shift; |
---|
294 | |
---|
295 | my $base_sql_a = "SELECT AVG(easting) AS easting, ". |
---|
296 | "AVG(northing) AS northing, COUNT(id) AS matched, "; |
---|
297 | my $base_sql_b = " AS postcode ". |
---|
298 | "FROM postcodes ". |
---|
299 | "WHERE NOT deleted "; |
---|
300 | |
---|
301 | my $full_sql = $base_sql_a . " outward || ' ' || inward " . $base_sql_b . |
---|
302 | "AND outward = ? AND inward = ? ". |
---|
303 | "GROUP BY outward, inward"; |
---|
304 | my $outer1_sql = $base_sql_a . " outward || ' ' || substr(inward,1,1) || '##'". |
---|
305 | $base_sql_b . "AND outward = ? AND substr(inward,1,1) = ?". |
---|
306 | "GROUP BY outward, substr(inward,1,1)"; |
---|
307 | my $outer_sql = $base_sql_a . " outward || ' ###'". $base_sql_b . |
---|
308 | "AND outward = ? GROUP BY outward"; |
---|
309 | my $area_sql = $base_sql_a . " ? || '' " . $base_sql_b . |
---|
310 | "AND substr(outward,1,?) = ? ". |
---|
311 | "GROUP BY substr(outward,1,?)"; |
---|
312 | |
---|
313 | my $full_matcher = $dbh->prepare($full_sql); |
---|
314 | my $outer1_matcher = $dbh->prepare($outer1_sql); |
---|
315 | my $outer_matcher = $dbh->prepare($outer_sql); |
---|
316 | my $area_matcher = $dbh->prepare($area_sql); |
---|
317 | |
---|
318 | return ($full_matcher,$outer1_matcher,$outer_matcher,$area_matcher); |
---|
319 | } |
---|
320 | |
---|
321 | # Location to Postcode matcher |
---|
322 | sub build_ltp_matcher { |
---|
323 | my $dbh = shift; |
---|
324 | |
---|
325 | my $sql = "SELECT outward, inward, easting, northing ". |
---|
326 | "FROM postcodes ". |
---|
327 | "WHERE inward IS NOT NULL AND inward <> '' ". |
---|
328 | "ORDER BY ( ". |
---|
329 | " POW(easting - ?, 2) + POW(northing - ?, 2) ". |
---|
330 | ") LIMIT ? "; |
---|
331 | |
---|
332 | my $matcher = $dbh->prepare($sql); |
---|
333 | return $matcher; |
---|
334 | } |
---|
335 | |
---|
336 | # Location to nearby postcode areas matcher |
---|
337 | sub build_lta_matcher { |
---|
338 | my $dbh = shift; |
---|
339 | |
---|
340 | my $sql = "SELECT outward, '' AS inward, avg_e AS easting, avg_n AS northing ". |
---|
341 | "FROM ( ". |
---|
342 | " SELECT outward, ". |
---|
343 | " AVG(easting) AS avg_e, ". |
---|
344 | " AVG(northing) AS avg_n ". |
---|
345 | " FROM postcodes ". |
---|
346 | " GROUP BY outward ". |
---|
347 | ") AS areas ". |
---|
348 | "ORDER BY ( ". |
---|
349 | " POW(avg_e - ?, 2) + POW(avg_n - ?, 2) ". |
---|
350 | ") LIMIT ? "; |
---|
351 | |
---|
352 | my $matcher = $dbh->prepare($sql); |
---|
353 | return $matcher; |
---|
354 | } |
---|
355 | |
---|
356 | |
---|
357 | # Helper routines |
---|
358 | sub print_err { |
---|
359 | my $err = shift; |
---|
360 | print header("text/plain", "400 $err"); |
---|
361 | print "Error: $err\n"; |
---|
362 | } |
---|
363 | |
---|
364 | sub print_internal_err { |
---|
365 | my $err = shift; |
---|
366 | print header("text/plain", "500 $err"); |
---|
367 | print "Error: $err\n"; |
---|
368 | } |
---|