Geo/TAF/example/scgi_weather.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # fetch a metar, taf or short taf from http://weather.noaa.gov
   4 #
   5 # This is a module which shows me doing my own thing using the
   6 # normalised input. It does essentially the same job as
   7 # cgi_weather.pl, it's just a lot more complicated but returns
   8 # a much shorter string that is a bit more cryptic.
   9 #
  10 # It also is designed really to just get the forecast and
  11 # actual weather.
  12 #
  13 # This is designed to be used in a IFRAME and returns HTML.
  14 # It will only query the website once every 30 minutes, the rest
  15 # of the time it will cache the result in an 'easily guessable'
  16 # place in /tmp (consider that as a warning).
  17 #
  18 # Call it from a web page like this:-
  19 #
  20 # <iframe src="cgi-bin/fetch_weather.pl?icao=EGSH&metar=1"
  21 #  name="METAR for EGSH" frameborder="1" width="90%" height="50">
  22 # [Your user agent does not support frames or is currently configured
  23 #  not to display frames. However, you may visit
  24 #  <A href="cgi-bin/fetch_weather.pl?icao=EGSH&metar=1">METAR for EGSH</A>]
  25 # </iframe>
  26 #
  27 # You can set as many of these as you like:-
  28 #
  29 #    break=1   insert a "<br /><br />" between each result
  30 #    onediv=1  make a multiple one div (not one div per thing)
  31 #    raw=1     will display the raw weather string
  32 #    debug=1   will display the objects
  33 #    force=1   always fetch the data (don't use any cached stuff)
  34 #
  35 # $Id$
  36 #
  37 # Copyright (c) 2003 Dirk Koopman G1TLH
  38 #
  39 use strict;
  40
  41 package main;
  42
  43 use CGI;
  44 use Geo::TAF;
  45 use LWP::UserAgent;
  46
  47 my $q = new CGI;
  48 my $site_code = uc $q->param('icao');
  49 my @sort = qw(metar staf);
  50 my $debug = $q->param('debug');
  51 my $raw = $q->param('raw');
  52 my $force = $q->param('force');
  53 my $dobrk = "<br /><br />" if $q->param('break') && @sort > 1;
  54 my $onediv = $q->param('onediv') && @sort > 1;
  55
  56
  57 my %st = (
  58                   VV => 'vert. viz',
  59                   SKC => "no cloud",
  60                   CLR => "no cloud no sig wthr",
  61                   BKN => "5-7okt",
  62                   SCT => "3-4okt",
  63                   FEW => "0-2okt",
  64                   OVC => "8okt",
  65                   CAVOK => "CAVOK(no cloud >10Km viz no sig wthr)",
  66                   CB => 'CuNim',
  67           TCU => 'tower Cu',
  68                   NSC => 'no sig cloud',
  69                   BLU => '3okt 2500ft 8Km viz',
  70                   WHT => '3okt 1500ft 5Km viz',
  71                   GRN => '3okt 700ft 3700m viz',
  72                   YLO => '3okt 300ft 1600m viz',
  73                   AMB => '3okt 200ft 800m viz',
  74                   RED => '3okt <200ft <800m viz',
  75                   NIL => 'no weather',
  76                   '///' => 'some',
  77                  );
  78
  79 my %wt = (
  80                   '+' => 'heavy',
  81           '-' => 'light',
  82           'VC' => 'in the vicinity',
  83
  84                   MI => 'shallow',
  85                   PI => 'partial',
  86                   BC => 'patches of',
  87                   DR => 'low drifting',
  88                   BL => 'blowing',
  89                   SH => 'showers',
  90                   TS => 'thunderstorms containing',
  91                   FZ => 'freezing',
  92                   RE => 'recent',
  93
  94                   DZ => 'drizzle',
  95                   RA => 'rain',
  96                   SN => 'snow',
  97                   SG => 'snow grains',
  98                   IC => 'ice crystals',
  99                   PE => 'ice pellets',
 100                   GR => 'hail',
 101                   GS => 'small hail/snow pellets',
 102                   UP => 'unknown precip',
 103
 104                   BR => 'mist',
 105                   FG => 'fog',
 106                   FU => 'smoke',
 107                   VA => 'volcanic ash',
 108                   DU => 'dust',
 109                   SA => 'sand',
 110                   HZ => 'haze',
 111                   PY => 'spray',
 112
 113                   PO => 'dust/sand whirls',
 114                   SQ => 'squalls',
 115                   FC => 'tornado',
 116                   SS => 'sand storm',
 117                   DS => 'dust storm',
 118                   '+FC' => 'water spouts',
 119                   WS => 'wind shear',
 120                   'BKN' => 'broken',
 121
 122                   'NOSIG' => 'no significant weather',
 123
 124                  );
 125
 126 start();
 127
 128 error("No ICAO (valid) site code ($site_code) specified") unless $site_code && $site_code =~ /^[A-Z]{4}$/;
 129
 130 my $base = "/tmp";
 131 my ($sort, $fn, $started);
 132
 133 print "<div class=\"weather\">$site_code ";
 134
 135 while ($sort = shift @sort) {
 136         $fn = "$base/${sort}_$site_code";
 137
 138         if (!$force && -e $fn) {
 139                 my ($mt, $size) = (stat $fn)[9,7] ;
 140                 $mt ||= 0;
 141                 $size ||= 0;
 142                 if ($mt + 30*60 < time || $size == 0) {
 143                         my $s = fetch_icao($sort);
 144                         store($s);
 145                         print $s;
 146                 } else {
 147                         my $s = retrieve($fn);
 148                         print $s;
 149                 }
 150         } else {
 151                 my $s = fetch_icao($sort);
 152                 store($s);
 153                 print $s;
 154         }
 155
 156         if (@sort > 0) {
 157                 print $onediv ? ' ' : '</div>';
 158                 print $dobrk if $dobrk;
 159                 print '<div class="weather">' unless $onediv;
 160         }
 161 }
 162
 163 finish();
 164 exit(0);
 165
 166 sub retrieve
 167 {
 168         my $fn = shift;
 169         open IN, "$fn" or die "cannot open $fn $!\n";
 170         my $s = <IN>;
 171         close IN;
 172         return $s;
 173 }
 174
 175 sub fetch_thing
 176 {
 177         my $sort = shift;
 178
 179         my $ua = new LWP::UserAgent;
 180         my $req = new HTTP::Request GET =>
 181         "http://weather.noaa.gov/cgi-bin/mget$sort.pl?cccc=$site_code";
 182
 183         my $response = $ua->request($req);
 184
 185         my $metar;
 186         if (!$response->is_success) {
 187                 error("METAR Fetch $site_code Error", $response->error_as_HTML);
 188         } else {
 189
 190         my $data = $response->as_string;
 191         ($metar) = $data =~ /($site_code\s+\d+Z?[^<]*)/;       # find the METAR string
 192
 193         # Sanity check
 194         if (length $metar < 10) {
 195                         error("METAR ($metar) is too short");
 196         }
 197         }
 198         return $metar;
 199 }
 200
 201 sub fetch_icao
 202 {
 203         my $sort = shift;
 204         my $metar = fetch_thing($sort);
 205
 206         # pass the data to the METAR module.
 207         my $m = new Geo::TAF;
 208         if ($sort =~ /taf$/) {
 209                 $m->taf($metar);
 210         } else {
 211                 $m->metar($metar);
 212         }
 213
 214         my @in;
 215         my $s;
 216         $s .= join "<br />", $m->raw, "<br />" if $raw;
 217         $s .= join "<br />", $m->as_chunk_strings, "<br />" if $debug;
 218         foreach my $c ($m->chunks) {
 219                 my ($sub) = (ref $c) =~ /::([A-Z]+)$/;
 220                 no strict 'refs';
 221                 if ($sub eq 'HEAD') {
 222                         $sub = $sort =~ /taf$/ ? "taf$sub" : "metar$sub";
 223                 }
 224                 push @in, &$sub($c);
 225         }
 226         $s .= join ' ', @in;
 227         return $s;
 228 }
 229
 230 sub start
 231 {
 232         return if $started;
 233         print $q->header(-type=>'text/html', -expires=>'+60m');
 234     print $q->start_html(-title=>"Weather for $site_code", -style=>{'src'=>'/style.css'},);
 235         $started = 1;
 236 }
 237
 238 sub finish
 239 {
 240         print "</div>";
 241         print  $q->end_html, "\n";
 242 }
 243
 244 sub store
 245 {
 246         my $s = shift;
 247         open OUT, ">$fn" or die "cannot open $fn $!\n";
 248         print OUT $s;
 249         close OUT;
 250 }
 251
 252 sub error
 253 {
 254         my $err = shift;
 255         my $more = shift;
 256         print $q->h3($err);
 257         print $more if $more;
 258         print "</div>", $q->end_html;
 259         warn($err);
 260
 261     exit(0);
 262 }
 263
 264 sub tafHEAD
 265 {
 266         my @in = @{$_[0]};
 267         return "FORECAST Issued $in[3] on " . Geo::TAF::EN::day($in[2]);
 268 }
 269
 270 sub metarHEAD
 271 {
 272         my @in = @{$_[0]};
 273         return "CURRENT Issued $in[3] on " . Geo::TAF::EN::day($in[2]);
 274 }
 275
 276 sub VALID
 277 {
 278         my @in = @{$_[0]};
 279         return "Valid $in[1]-\>$in[2] on " . Geo::TAF::EN::day($in[0]);
 280 }
 281
 282 sub WIND
 283 {
 284         my @in = @{$_[0]};
 285         my $out = "Wind";
 286         $out .= $in[0] eq 'VRB' ? " variable" : " $in[0]";
 287     $out .= " varying $in[4]-\>$in[5]" if defined $in[4];
 288         $out .= ($in[0] eq 'VRB' ? '' : "deg") . " $in[1]";
 289         $out .= " gust $in[2]" if defined $in[2];
 290         $out .= $in[3];
 291         return $out;
 292 }
 293
 294 sub PRESS
 295 {
 296         my @in = @{$_[0]};
 297         return "QNH $in[0]";
 298 }
 299
 300 sub TEMP
 301 {
 302         my @in = @{$_[0]};
 303         my $out = "Temp $in[0]C";
 304         $out .= " Dewp $in[1]C" if defined $in[1];
 305
 306         return $out;
 307 }
 308
 309 sub CLOUD
 310 {
 311         my @in = @{$_[0]};
 312
 313         return $st{$in[0]} if @in == 1;
 314         return "Cloud $st{$in[0]} \@ $in[1]ft" if $in[0] eq 'VV';
 315         my $out = "Cloud $st{$in[0]} \@ $in[1]ft";
 316         $out .= " $st{$in[2]}" if defined $in[2];
 317         return $out;
 318 }
 319
 320 #sub WEATHER
 321 #{
 322 #       goto &Geo::TAF::EN::WEATHER::as_string;
 323 #}
 324
 325
 326 sub WEATHER
 327 {
 328         my @in = @{$_[0]};
 329         my @out;
 330
 331         my ($vic, $shower);
 332         my $one = $in[0];
 333
 334         while (@in) {
 335                 my $t = shift @in;
 336
 337                 if (!defined $t) {
 338                         next;
 339                 } elsif ($t eq 'VC') {
 340                         $vic++;
 341                         next;
 342                 } elsif ($t eq 'SH') {
 343                         $shower++;
 344                         next;
 345                 } elsif ($t eq '+' && $one eq 'FC') {
 346                         push @out, $wt{'+FC'};
 347                         shift;
 348                         next;
 349                 }
 350
 351                 push @out, $wt{$t};
 352
 353                 if (@out && $shower) {
 354                         $shower = 0;
 355                         push @out, $wt{'SH'};
 356                 }
 357         }
 358         push @out, $wt{'VC'} if $vic;
 359
 360         return join ' ', @out;
 361 }
 362
 363 sub RVR
 364 {
 365         my @in = @{$_[0]};
 366         my $out = "RVR R$in[0] $in[1]$in[3]";
 367         $out .= " vary $in[2]$in[3]" if defined $in[2];
 368         if (defined $in[4]) {
 369                 $out .= " decr" if $in[4] eq 'D';
 370                 $out .= " incr" if $in[4] eq 'U';
 371         }
 372         return $out;
 373 }
 374
 375 sub RWY
 376 {
 377         return "";
 378 }
 379
 380 sub PROB
 381 {
 382         my @in = @{$_[0]};
 383
 384         my $out = "Prob $in[0]%";
 385         $out .= " $in[1]-\>$in[2]" if defined $in[1];
 386         return $out;
 387 }
 388
 389 sub TEMPO
 390 {
 391         my @in = @{$_[0]};
 392         my $out = "Temporary";
 393         $out .= " $in[0]-\>$in[1]" if defined $in[0];
 394
 395         return $out;
 396 }
 397
 398 sub BECMG
 399 {
 400         my @in = @{$_[0]};
 401         my $out = "Becoming";
 402         $out .= " $in[0]-\>$in[1]" if defined $in[0];
 403
 404         return $out;
 405 }
 406
 407 sub VIZ
 408 {
 409     my @in = @{$_[0]};
 410
 411     return "Viz $in[0]$in[1]";
 412 }
 413
 414 sub FROM
 415 {
 416     my @in = @{$_[0]};
 417
 418     return "From $in[0]";
 419 }
 420
 421 sub TIL
 422 {
 423     my @in = @{$_[0]};
 424
 425     return "Until $in[0]";
 426 }
 427
 428 1;