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                   SCT => "5-7okt",
  62                   BKN => "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 _dayend
 265 {
 266         my $d = sprintf "%d", shift;
 267         if ($d =~ /1$/) {
 268                 return "${d}st";
 269         } elsif ($d =~ /2$/) {
 270                 return "${d}nd";
 271         } elsif ($d =~ /3$/) {
 272                 return "${d}rd";
 273         }
 274         return "${d}th";
 275 }
 276
 277 sub tafHEAD
 278 {
 279         my @in = @{$_[0]};
 280         return "FORECAST Issued $in[3] " . _dayend($in[2]);
 281 }
 282
 283 sub metarHEAD
 284 {
 285         my @in = @{$_[0]};
 286         return "CURRENT Issued $in[3] " . _dayend($in[2]);
 287 }
 288
 289 sub VALID
 290 {
 291         my @in = @{$_[0]};
 292         return "Valid $in[1]-\>$in[2] " . _dayend($in[0]);
 293 }
 294
 295 sub WIND
 296 {
 297         my @in = @{$_[0]};
 298         my $out = "Wind";
 299         $out .= $in[0] eq 'VRB' ? " variable" : " $in[0]";
 300     $out .= " varying $in[4]-\>$in[5]" if defined $in[4];
 301         $out .= ($in[0] eq 'VRB' ? '' : "deg") . " $in[1]";
 302         $out .= " gust $in[2]" if defined $in[2];
 303         $out .= $in[3];
 304         return $out;
 305 }
 306
 307 sub PRESS
 308 {
 309         my @in = @{$_[0]};
 310         return "QNH $in[0]";
 311 }
 312
 313 sub TEMP
 314 {
 315         my @in = @{$_[0]};
 316         my $out = "Temp $in[0]C";
 317         $out .= " Dewp $in[1]C" if defined $in[1];
 318
 319         return $out;
 320 }
 321
 322 sub CLOUD
 323 {
 324         my @in = @{$_[0]};
 325
 326         return $st{$in[0]} if @in == 1;
 327         return "Cloud $st{$in[0]} \@ $in[1]ft" if $in[0] eq 'VV';
 328         my $out = "Cloud $st{$in[0]} \@ $in[1]ft";
 329         $out .= " $st{$in[2]}" if defined $in[2];
 330         return $out;
 331 }
 332
 333 #sub WEATHER
 334 #{
 335 #       goto &Geo::TAF::EN::WEATHER::as_string;
 336 #}
 337
 338
 339 sub WEATHER
 340 {
 341         my @in = @{$_[0]};
 342         my @out;
 343
 344         my ($vic, $shower);
 345         my $one = $in[0];
 346
 347         while (@in) {
 348                 my $t = shift @in;
 349
 350                 if (!defined $t) {
 351                         next;
 352                 } elsif ($t eq 'VC') {
 353                         $vic++;
 354                         next;
 355                 } elsif ($t eq 'SH') {
 356                         $shower++;
 357                         next;
 358                 } elsif ($t eq '+' && $one eq 'FC') {
 359                         push @out, $wt{'+FC'};
 360                         shift;
 361                         next;
 362                 }
 363
 364                 push @out, $wt{$t};
 365
 366                 if (@out && $shower) {
 367                         $shower = 0;
 368                         push @out, $wt{'SH'};
 369                 }
 370         }
 371         push @out, $wt{'VC'} if $vic;
 372
 373         return join ' ', @out;
 374 }
 375
 376 sub RVR
 377 {
 378         my @in = @{$_[0]};
 379         my $out = "RVR R$in[0] $in[1]$in[3]";
 380         $out .= " vary $in[2]$in[3]" if defined $in[2];
 381         if (defined $in[4]) {
 382                 $out .= " decr" if $in[4] eq 'D';
 383                 $out .= " incr" if $in[4] eq 'U';
 384         }
 385         return $out;
 386 }
 387
 388 sub RWY
 389 {
 390         return "";
 391 }
 392
 393 sub PROB
 394 {
 395         my @in = @{$_[0]};
 396
 397         my $out = "Prob $in[0]%";
 398         $out .= " $in[1]-\>$in[2]" if defined $in[1];
 399         return $out;
 400 }
 401
 402 sub TEMPO
 403 {
 404         my @in = @{$_[0]};
 405         my $out = "Temporary";
 406         $out .= " $in[0]-\>$in[1]" if defined $in[0];
 407
 408         return $out;
 409 }
 410
 411 sub BECMG
 412 {
 413         my @in = @{$_[0]};
 414         my $out = "Becoming";
 415         $out .= " $in[0]-\>$in[1]" if defined $in[0];
 416
 417         return $out;
 418 }
 419
 420 sub VIZ
 421 {
 422     my @in = @{$_[0]};
 423
 424     return "Viz $in[0]$in[1]";
 425 }
 426
 427 sub FROM
 428 {
 429     my @in = @{$_[0]};
 430
 431     return "From $in[0]";
 432 }
 433
 434 sub TIL
 435 {
 436     my @in = @{$_[0]};
 437
 438     return "Until $in[0]";
 439 }
 440
 441 1;