source: trunk/npemap.org.uk/cgi/get-meta.fcgi @ 513

Last change on this file since 513 was 513, checked in by Nick Burch, 14 years ago

Support fetching metadata on ie tiles too, via the optional ie flag

  • Property svn:executable set to *
File size: 4.7 KB
Line 
1#!/usr/bin/perl
2# Looks up the meta information on a number of tiles (expressed as
3#  eastingxnorthing), including sheet number and publication year.
4#
5# Can return plain text, JS, JS callback, or XML
6#
7# Copyright (c) 2006 Dominic Hargreaves, Nick Burch and David Sheldon
8# See accompanying file "LICENCE" for licence details
9
10use strict;
11use warnings;
12
13use CGI::Fast qw/:standard -debug/;
14
15# Find our private perl libraries
16use FindBin;
17use lib "$FindBin::Bin/../perllib";
18use NPEMap::Config;
19use NPEMap;
20
21sub print_err;
22
23my @outputs = qw(text xml js);
24
25my $cgi;
26# Process incoming requests
27REQUEST: while ($cgi = new CGI::Fast) {
28        # What output format do they want?
29        my $output = $outputs[0];
30        if(defined $cgi->param("format")) {
31                foreach my $possoutput (@outputs) {
32                        if($possoutput eq $cgi->param("format")) {
33                                $output = $possoutput;
34                        }
35                }
36        }
37
38        # Did they request the irish grid?
39        my $ie = 0;
40        if(defined $cgi->param('ie')) {
41                $ie = 1;
42        }
43
44        # While tiles (well, easting and northing km values) do they want to
45        #  know about?
46        my @requests;
47        my %tiles;
48
49        # Tile easting and northings (km)
50        if(defined $cgi->param("tiles")) {
51                @requests = split(",", $cgi->param("tiles"));
52                foreach my $req (@requests) {
53                        my ($e,$n) = ($req =~ /^(\d+)x(\d+)$/);
54                        unless($e && $n) {
55                                print_err ("Invalid tile '$req' requested, must be of the form eastingxnorthing" );
56                                next REQUEST;
57                        }
58                        $tiles{$e}->{$n} = 1;
59                }
60        }
61        # Real easting and northings (m)
62        if(defined $cgi->param("locations")) {
63                @requests = split(",", $cgi->param("locations"));
64                foreach my $req (@requests) {
65                        my ($e,$n) = ($req =~ /^(\d+)x(\d+)$/);
66                        $e = int($e / 1000);
67                        $n = int($n / 1000);
68
69                        unless($e && $n) {
70                                print_err ("Invalid tile '$req' requested, must be of the form eastingxnorthing" );
71                                next REQUEST;
72                        }
73                        $tiles{$e}->{$n} = 1;
74                }
75        }
76        unless(keys %tiles) {
77                print_err ("No tiles requested. Supply a 'tiles' parameter, of the form eastingxnorthing,eastingxnorthing,....");
78                next REQUEST;
79        }
80
81        # Load the meta files (one per easting)
82        foreach my $easting (keys %tiles) {
83                my $meta_dir = "/meta1/";
84                if($ie) { $meta_dir = "/meta1i/"; } 
85
86                my $meta = $tiledir.$meta_dir.$easting.".txt";
87                if(-f $meta) {
88                        open(META, "<$meta");
89                        while(my $line = <META>) {
90                                if($line =~ /^\#/) { next; }
91
92                                chomp $line;
93                                my ($e,$n,$sheet,$year) = split(/,/, $line);
94
95                                # Do they want this one?
96                                if($tiles{$e}->{$n}) {
97                                        my %m;
98                                        $m{sheet} = $sheet;
99                                        $m{year} = $year;
100                                        $tiles{$e}->{$n} = \%m;
101                                }
102                        }
103                        close META;
104                }
105        }
106
107        # Make any we couldn't find have a blank hash
108        foreach my $easting (keys %tiles) {
109                foreach my $northing (sort keys %{$tiles{$easting}}) {
110                        unless(ref $tiles{$easting}->{$northing} eq "HASH") {
111                                my %m;
112                                $tiles{$easting}->{$northing} = \%m;
113                        }
114                }
115        }
116       
117
118        # Render
119        if($output eq "xml") {
120                print header("text/xml");
121                print "<?xml version='1.0'?>\n";
122                print "<metadata>\n";
123                foreach my $easting (sort keys %tiles) {
124                        foreach my $northing (sort keys %{$tiles{$easting}}) {
125                                print "  <result easting=\"$easting\" northing=\"$northing\"";
126                                if(keys %{$tiles{$easting}->{$northing}}) {
127                                        my %m = %{$tiles{$easting}->{$northing}};
128                                        print ">\n";
129                                        if($m{sheet}) {
130                                                print "    <sheet>$m{sheet}</sheet>\n";
131                                        }
132                                        if($m{year}) {
133                                                print "    <year>$m{year}</year>\n";
134                                        }
135                                        print "  </result>\n";
136                                } else {
137                                        print " />\n";
138                                }
139                        }
140                }
141                print "</metadata>\n";
142        } elsif ($output eq "js") {
143                print header("text/javascript");
144
145                if(defined $cgi->param("callback")) {
146                        print $cgi->param("callback") . "(";
147                }
148
149                print " { ";
150                my $count = 0;
151                foreach my $easting (sort keys %tiles) {
152                        foreach my $northing (sort keys %{$tiles{$easting}}) {
153                                if($count > 0) { print " , "; }
154
155                                my %m = %{$tiles{$easting}->{$northing}};
156                                print " \"${easting}x${northing}\":{ ";
157                                if(keys %m) {
158                                        print "easting:$easting, northing:$northing, sheet:\"$m{sheet}\", year:\"$m{year}\"";
159                                }
160                                $count++;
161                                print " } ";
162                        }
163                }
164                print " } ";
165
166                if(defined $cgi->param("callback")) {
167                        print ");";
168                }
169                print "\n";
170    } else {
171                print header("text/plain");
172                print "# Easting,Northing,Sheet,Year\n";
173
174                foreach my $easting (sort keys %tiles) {
175                        foreach my $northing (sort keys %{$tiles{$easting}}) {
176                                print "$easting,$northing,";
177                                if(keys %{$tiles{$easting}->{$northing}}) {
178                                        print $tiles{$easting}->{$northing}->{sheet}.",";
179                                        print $tiles{$easting}->{$northing}->{year}."\n";
180                                } else {
181                                        print ",\n";
182                                }
183                        }
184                }
185        }
186}
187
188# No more requests to serve, so tidy up
189
190
191# Helper routines
192sub print_err {
193    my $err = shift;
194    print header("text/plain", "400 $err");
195    print "Error: $err\n";
196}
197
198sub print_internal_err {
199    my $err = shift;
200    print header("text/plain", "500 $err");
201    print "Error: $err\n";
202}
Note: See TracBrowser for help on using the repository browser.