From 8e428a945011eb17a3d9a96c957a37965d4e5ba5 Mon Sep 17 00:00:00 2001 From: minima Date: Thu, 2 Nov 2006 14:07:47 +0000 Subject: [PATCH] add back the contents of this directory --- Geo/TAF/example/cgi_weather.pl | 157 ++++++++++++ Geo/TAF/example/cmd_chunks.pl | 68 +++++ Geo/TAF/example/cmd_taf.pl | 79 ++++++ Geo/TAF/example/fetch_weather.pl | 101 ++++++++ Geo/TAF/example/scgi_weather.pl | 428 +++++++++++++++++++++++++++++++ Geo/TAF/t/1.t | 40 +++ 6 files changed, 873 insertions(+) create mode 100755 Geo/TAF/example/cgi_weather.pl create mode 100755 Geo/TAF/example/cmd_chunks.pl create mode 100755 Geo/TAF/example/cmd_taf.pl create mode 100755 Geo/TAF/example/fetch_weather.pl create mode 100755 Geo/TAF/example/scgi_weather.pl create mode 100644 Geo/TAF/t/1.t diff --git a/Geo/TAF/example/cgi_weather.pl b/Geo/TAF/example/cgi_weather.pl new file mode 100755 index 00000000..3091c535 --- /dev/null +++ b/Geo/TAF/example/cgi_weather.pl @@ -0,0 +1,157 @@ +#!/usr/bin/perl -w +# +# fetch a metar, taf or short taf from http://weather.noaa.gov +# +# This is designed to be used in a IFRAME and returns HTML. +# It will only query the website once every 30 minutes, the rest +# of the time it will cache the result in an 'easily guessable' +# place in /tmp (consider that as a warning). +# +# Call it from a web page like this:- +# +# +# +# You can set as many of these as you like:- +# metar=1 for a metar (default, if no options) +# staf=1 for a short form (usually more uptodate) TAF +# taf=1 for a full 18 hour TAF +# break=1 insert a "

" between each result +# +# $Id$ +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# +use strict; +use CGI; +use Geo::TAF; +use LWP::UserAgent; + +my $q = new CGI; +my $site_code = uc $q->param('icao'); +my @sort; +push @sort, 'taf' if $q->param('taf'); +push @sort, 'staf' if $q->param('staf'); +push @sort, 'metar' if $q->param('metar') || @sort == 0; +my $dobrk = $q->param('break'); + +error("No ICAO (valid) site code ($site_code) specified") unless $site_code && $site_code =~ /^[A-Z]{4}$/; + +my $base = "/tmp"; +my ($sort, $fn, $started); + +while ($sort = shift @sort) { + $fn = "$base/${sort}_$site_code"; + + my ($mt, $size) = (stat $fn)[9,7]; + $mt ||= 0; + $size ||= 0; + + my $brk = "

" unless @sort; + + if ($mt + 30*60 < time || $size == 0) { + fetch_icao($brk); + } else { + my $s = retrieve(); + send_metar($s, $brk); + } +} + +sub retrieve +{ + open IN, "$fn" or die "cannot open $fn $!\n"; + my $s = ; + close IN; + return $s; +} + +sub fetch_icao +{ + my $brk = shift || ""; + my $ua = new LWP::UserAgent; + + my $req = new HTTP::Request GET => + "http://weather.noaa.gov/cgi-bin/mget$sort.pl?cccc=$site_code"; + + my $response = $ua->request($req); + + if (!$response->is_success) { + error("METAR Fetch $site_code Error", $response->error_as_HTML); + } else { + + # Yep, get the data and find the METAR. + + my $m = new Geo::TAF; + my $data; + $data = $response->as_string; # grap response + $data =~ s/\n//go; # remove newlines + $data =~ m/($site_code\s\d+Z.*?)taf($metar); + } else { + $m->metar($metar); + } + my $s = $m->as_string; + send_metar($s, $brk); + store($s); + } +} + +finish(); + +sub start +{ + return if $started; + print $q->header(-type=>'text/html', -expires=>'+60m'); + print $q->start_html(-title=>"Weather for $site_code", -style=>{'src'=>'/style.css'},); + $started = 1; +} + +sub finish +{ + print $q->end_html; +} + +sub store +{ + my $s = shift; + open OUT, ">$fn" or die "cannot open $fn $!\n"; + print OUT $s; + close OUT; +} + +sub send_metar +{ + my $s = shift; + my $brk = shift || ""; + + start(); + print "
$s
$brk"; +} + +sub error +{ + my $err = shift; + my $more = shift; + print $q->header(-type=>'text/html', -expires=>'+60m'); + print $q->start_html($err); + print $q->h3($err); + print $more if $more; + print $q->end_html; + warn($err); + + exit(0); +} + diff --git a/Geo/TAF/example/cmd_chunks.pl b/Geo/TAF/example/cmd_chunks.pl new file mode 100755 index 00000000..642bf410 --- /dev/null +++ b/Geo/TAF/example/cmd_chunks.pl @@ -0,0 +1,68 @@ +#!/usr/bin/perl +# +# This example takes METARs and TAFs from the standard input, parses them +# and prints them out in a (sort of readable) normalised form +# +# Note that this is a state machine which can take any old rubbish and looks +# for a start of a forecast in the input. It then searches for a blank line +# before looking for the next. +# +# You can get METARs from ftp://weather.noaa.gov/data/observations/metar +# TAFs from ftp://weather.noaa.gov/data/forecasts/taf/ and +# from ftp://weather.noaa.gov/data/forecasts/shorttaf/ +# directories. This program will parse these files directly +# +# You will need to press twice to get any output if you are entering +# stuff manually. +# +# $Id$ +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# + +use strict; +use Geo::TAF; + +my $in; +my $t; + +while () { + chomp; + if (/^\s*$/) { + if ($in) { + $t = new Geo::TAF; + if ($in =~ /(?:METAR|TAF)/) { + $t->decode($in); + } elsif ($in =~ /[QA]\d\d\d\d/) { + $t->metar($in); + } else { + $t->taf($in); + } + print_taf($t); + undef $in; + undef $t ; + } + } else { + if ($in) { + $in .= $_; + } else { + next unless Geo::TAF::is_weather($_); + $in = $_; + } + } +} + +print_taf($t) if $t; + +sub print_taf +{ + my $t = shift; + + print $t->raw, "\n\n"; + + my $spc = ""; + foreach my $c ($t->chunks) { + print $c->as_chunk, "\n"; + } + print "\n\n"; +} diff --git a/Geo/TAF/example/cmd_taf.pl b/Geo/TAF/example/cmd_taf.pl new file mode 100755 index 00000000..523bbc50 --- /dev/null +++ b/Geo/TAF/example/cmd_taf.pl @@ -0,0 +1,79 @@ +#!/usr/bin/perl +# +# This example takes METARs and TAFs from the standard input and +# prints them out in a readable form, in something approaching English +# +# Note that this is a state machine which can take any old rubbish and looks +# for a start of a forecast in the input. It then searches for a blank line +# before looking for the next. +# +# You can METARs from ftp://weather.noaa.gov/data/observations/metar/ and +# TAFs from ftp://weather.noaa.gov/data/forecasts/taf/ and +# from ftp://weather.noaa.gov/data/forecasts/shorttaf/ +# directories. This program will parse these files directly +# +# You will need to press twice to get any output if you are entering +# stuff manually. +# +# $Id$ +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# + +use strict; +use Geo::TAF; + +my $in; +my $t; + +while () { + chomp; + if (/^\s*$/) { + if ($in) { + $t = new Geo::TAF; + if ($in =~ /(?:METAR|TAF)/) { + $t->decode($in); + } elsif ($in =~ /[QA]\d\d\d\d/) { + $t->metar($in); + } else { + $t->taf($in); + } + print_taf($t); + undef $in; + undef $t ; + } + } else { + if ($in) { + $in .= $_; + } else { + next unless Geo::TAF::is_weather($_); + $in = $_; + } + } +} + +print_taf($t) if $t; + +sub print_taf +{ + my $t = shift; + + print $t->raw, "\n\n"; + + my $spc = ""; + foreach my $c ($t->chunks) { +# print "\n", $c->as_chunk, " "; + if ((ref $c) =~ /::(?:PROB|TEMPO|BECMG|FROM)$/) { + print "\n\t"; + $spc = ''; + } + print $spc, $c->as_string; + if ((ref $c) =~ /::(?:VALID)$/) { + print "\n\t"; + $spc = ''; + } else { + $spc = ' '; + } + } + print "\n\n"; +} diff --git a/Geo/TAF/example/fetch_weather.pl b/Geo/TAF/example/fetch_weather.pl new file mode 100755 index 00000000..8d01a225 --- /dev/null +++ b/Geo/TAF/example/fetch_weather.pl @@ -0,0 +1,101 @@ +#!/usr/bin/perl -w + +# $Id$ + +# this has been taken from Geo::METAR and modified +# +# Brief Description +# ================= +# +# fetch_temp.pl is a program that demonstrates how to get the current +# temperature from a nearby (or not) airport using Geo::METAR and the +# LWP modules. +# +# Given an airport site code on the command line, fetch_temp.pl +# fetches the current temperature and displays it on the +# command-line. For fun, here are some example airports: +# +# LA : KLAX +# Dallas : KDFW +# Detroit: KDTW +# Chicago: KMDW +# +# and of course: EGSH (Norwich) +# +# + +# Get the site code. +my ($debug, $raw); +my @sort; +while ($ARGV[0] =~ /^-/ && @ARGV > 1) { + my @f = split //, shift @ARGV; + shift @f; + foreach $f (@f) { + push @sort, 'taf' if $f eq 't' && ! grep $_ eq 'taf', @sort; + push @sort, 'staf' if $f eq 's' && ! grep $_ eq 'staf', @sort; + push @sort, 'metar' if $f eq 'm' && ! grep $_ eq 'metar', @sort; + $debug++ if $f eq 'x'; + $raw++ if $f eq 'r'; + } +} +push @sort, 'metar' unless @sort; + +my $site_code = uc shift @ARGV; + +die "Usage: $0 [-mts] \n" unless $site_code; + +# Get the modules we need. + +use Geo::TAF; +use LWP::UserAgent; +use strict; + +my $sort; + +foreach $sort (@sort) { + + my $ua = new LWP::UserAgent; + + my $req = new HTTP::Request GET => + "http://weather.noaa.gov/cgi-bin/mget$sort.pl?cccc=$site_code"; + + my $response = $ua->request($req); + + if ($response->is_success) { + + # Yep, get the data and find the METAR. + + my $m = new Geo::TAF; + my $data; + $data = $response->as_string; # grap response + $data =~ s/\n//go; # remove newlines + $data =~ m/($site_code\s\d+Z.*?)taf($metar); + } else { + $m->metar($metar); + } + print $m->raw, "\n" if $raw; + print join "\n", $m->as_chunk_strings, "\n" if $debug; + print $m->as_string, "\n"; + + } else { + + print $response->as_string, "\n"; + + } + print "\n"; +} + +exit 0; + + diff --git a/Geo/TAF/example/scgi_weather.pl b/Geo/TAF/example/scgi_weather.pl new file mode 100755 index 00000000..f15f07bd --- /dev/null +++ b/Geo/TAF/example/scgi_weather.pl @@ -0,0 +1,428 @@ +#!/usr/bin/perl -w +# +# fetch a metar, taf or short taf from http://weather.noaa.gov +# +# This is a module which shows me doing my own thing using the +# normalised input. It does essentially the same job as +# cgi_weather.pl, it's just a lot more complicated but returns +# a much shorter string that is a bit more cryptic. +# +# It also is designed really to just get the forecast and +# actual weather. +# +# This is designed to be used in a IFRAME and returns HTML. +# It will only query the website once every 30 minutes, the rest +# of the time it will cache the result in an 'easily guessable' +# place in /tmp (consider that as a warning). +# +# Call it from a web page like this:- +# +# +# +# You can set as many of these as you like:- +# +# break=1 insert a "

" between each result +# onediv=1 make a multiple one div (not one div per thing) +# raw=1 will display the raw weather string +# debug=1 will display the objects +# force=1 always fetch the data (don't use any cached stuff) +# +# $Id$ +# +# Copyright (c) 2003 Dirk Koopman G1TLH +# +use strict; + +package main; + +use CGI; +use Geo::TAF; +use LWP::UserAgent; + +my $q = new CGI; +my $site_code = uc $q->param('icao'); +my @sort = qw(metar staf); +my $debug = $q->param('debug'); +my $raw = $q->param('raw'); +my $force = $q->param('force'); +my $dobrk = "

" if $q->param('break') && @sort > 1; +my $onediv = $q->param('onediv') && @sort > 1; + + +my %st = ( + VV => 'vert. viz', + SKC => "no cloud", + CLR => "no cloud no sig wthr", + BKN => "5-7okt", + SCT => "3-4okt", + FEW => "0-2okt", + OVC => "8okt", + CAVOK => "CAVOK(no cloud >10Km viz no sig wthr)", + CB => 'CuNim', + TCU => 'tower Cu', + NSC => 'no sig cloud', + BLU => '3okt 2500ft 8Km viz', + WHT => '3okt 1500ft 5Km viz', + GRN => '3okt 700ft 3700m viz', + YLO => '3okt 300ft 1600m viz', + AMB => '3okt 200ft 800m viz', + RED => '3okt <200ft <800m viz', + NIL => 'no weather', + '///' => 'some', + ); + +my %wt = ( + '+' => 'heavy', + '-' => 'light', + 'VC' => 'in the vicinity', + + MI => 'shallow', + PI => 'partial', + BC => 'patches of', + DR => 'low drifting', + BL => 'blowing', + SH => 'showers', + TS => 'thunderstorms containing', + FZ => 'freezing', + RE => 'recent', + + DZ => 'drizzle', + RA => 'rain', + SN => 'snow', + SG => 'snow grains', + IC => 'ice crystals', + PE => 'ice pellets', + GR => 'hail', + GS => 'small hail/snow pellets', + UP => 'unknown precip', + + BR => 'mist', + FG => 'fog', + FU => 'smoke', + VA => 'volcanic ash', + DU => 'dust', + SA => 'sand', + HZ => 'haze', + PY => 'spray', + + PO => 'dust/sand whirls', + SQ => 'squalls', + FC => 'tornado', + SS => 'sand storm', + DS => 'dust storm', + '+FC' => 'water spouts', + WS => 'wind shear', + 'BKN' => 'broken', + + 'NOSIG' => 'no significant weather', + + ); + +start(); + +error("No ICAO (valid) site code ($site_code) specified") unless $site_code && $site_code =~ /^[A-Z]{4}$/; + +my $base = "/tmp"; +my ($sort, $fn, $started); + +print "
$site_code "; + +while ($sort = shift @sort) { + $fn = "$base/${sort}_$site_code"; + + if (!$force && -e $fn) { + my ($mt, $size) = (stat $fn)[9,7] ; + $mt ||= 0; + $size ||= 0; + if ($mt + 30*60 < time || $size == 0) { + my $s = fetch_icao($sort); + store($s); + print $s; + } else { + my $s = retrieve($fn); + print $s; + } + } else { + my $s = fetch_icao($sort); + store($s); + print $s; + } + + if (@sort > 0) { + print $onediv ? ' ' : '
'; + print $dobrk if $dobrk; + print '
' unless $onediv; + } +} + +finish(); +exit(0); + +sub retrieve +{ + my $fn = shift; + open IN, "$fn" or die "cannot open $fn $!\n"; + my $s = ; + close IN; + return $s; +} + +sub fetch_thing +{ + my $sort = shift; + + my $ua = new LWP::UserAgent; + my $req = new HTTP::Request GET => + "http://weather.noaa.gov/cgi-bin/mget$sort.pl?cccc=$site_code"; + + my $response = $ua->request($req); + + my $metar; + if (!$response->is_success) { + error("METAR Fetch $site_code Error", $response->error_as_HTML); + } else { + + my $data = $response->as_string; + ($metar) = $data =~ /($site_code\s+\d+Z?[^<]*)/; # find the METAR string + + # Sanity check + if (length $metar < 10) { + error("METAR ($metar) is too short"); + } + } + return $metar; +} + +sub fetch_icao +{ + my $sort = shift; + my $metar = fetch_thing($sort); + + # pass the data to the METAR module. + my $m = new Geo::TAF; + if ($sort =~ /taf$/) { + $m->taf($metar); + } else { + $m->metar($metar); + } + + my @in; + my $s; + $s .= join "
", $m->raw, "
" if $raw; + $s .= join "
", $m->as_chunk_strings, "
" if $debug; + foreach my $c ($m->chunks) { + my ($sub) = (ref $c) =~ /::([A-Z]+)$/; + no strict 'refs'; + if ($sub eq 'HEAD') { + $sub = $sort =~ /taf$/ ? "taf$sub" : "metar$sub"; + } + push @in, &$sub($c); + } + $s .= join ' ', @in; + return $s; +} + +sub start +{ + return if $started; + print $q->header(-type=>'text/html', -expires=>'+60m'); + print $q->start_html(-title=>"Weather for $site_code", -style=>{'src'=>'/style.css'},); + $started = 1; +} + +sub finish +{ + print "
"; + print $q->end_html, "\n"; +} + +sub store +{ + my $s = shift; + open OUT, ">$fn" or die "cannot open $fn $!\n"; + print OUT $s; + close OUT; +} + +sub error +{ + my $err = shift; + my $more = shift; + print $q->h3($err); + print $more if $more; + print "", $q->end_html; + warn($err); + + exit(0); +} + +sub tafHEAD +{ + my @in = @{$_[0]}; + return "FORECAST Issued $in[3] on " . Geo::TAF::EN::day($in[2]); +} + +sub metarHEAD +{ + my @in = @{$_[0]}; + return "CURRENT Issued $in[3] on " . Geo::TAF::EN::day($in[2]); +} + +sub VALID +{ + my @in = @{$_[0]}; + return "Valid $in[1]-\>$in[2] on " . Geo::TAF::EN::day($in[0]); +} + +sub WIND +{ + my @in = @{$_[0]}; + my $out = "Wind"; + $out .= $in[0] eq 'VRB' ? " variable" : " $in[0]"; + $out .= " varying $in[4]-\>$in[5]" if defined $in[4]; + $out .= ($in[0] eq 'VRB' ? '' : "deg") . " $in[1]"; + $out .= " gust $in[2]" if defined $in[2]; + $out .= $in[3]; + return $out; +} + +sub PRESS +{ + my @in = @{$_[0]}; + return "QNH $in[0]"; +} + +sub TEMP +{ + my @in = @{$_[0]}; + my $out = "Temp $in[0]C"; + $out .= " Dewp $in[1]C" if defined $in[1]; + + return $out; +} + +sub CLOUD +{ + my @in = @{$_[0]}; + + return $st{$in[0]} if @in == 1; + return "Cloud $st{$in[0]} \@ $in[1]ft" if $in[0] eq 'VV'; + my $out = "Cloud $st{$in[0]} \@ $in[1]ft"; + $out .= " $st{$in[2]}" if defined $in[2]; + return $out; +} + +#sub WEATHER +#{ +# goto &Geo::TAF::EN::WEATHER::as_string; +#} + + +sub WEATHER +{ + my @in = @{$_[0]}; + my @out; + + my ($vic, $shower); + my $one = $in[0]; + + while (@in) { + my $t = shift @in; + + if (!defined $t) { + next; + } elsif ($t eq 'VC') { + $vic++; + next; + } elsif ($t eq 'SH') { + $shower++; + next; + } elsif ($t eq '+' && $one eq 'FC') { + push @out, $wt{'+FC'}; + shift; + next; + } + + push @out, $wt{$t}; + + if (@out && $shower) { + $shower = 0; + push @out, $wt{'SH'}; + } + } + push @out, $wt{'VC'} if $vic; + + return join ' ', @out; +} + +sub RVR +{ + my @in = @{$_[0]}; + my $out = "RVR R$in[0] $in[1]$in[3]"; + $out .= " vary $in[2]$in[3]" if defined $in[2]; + if (defined $in[4]) { + $out .= " decr" if $in[4] eq 'D'; + $out .= " incr" if $in[4] eq 'U'; + } + return $out; +} + +sub RWY +{ + return ""; +} + +sub PROB +{ + my @in = @{$_[0]}; + + my $out = "Prob $in[0]%"; + $out .= " $in[1]-\>$in[2]" if defined $in[1]; + return $out; +} + +sub TEMPO +{ + my @in = @{$_[0]}; + my $out = "Temporary"; + $out .= " $in[0]-\>$in[1]" if defined $in[0]; + + return $out; +} + +sub BECMG +{ + my @in = @{$_[0]}; + my $out = "Becoming"; + $out .= " $in[0]-\>$in[1]" if defined $in[0]; + + return $out; +} + +sub VIZ +{ + my @in = @{$_[0]}; + + return "Viz $in[0]$in[1]"; +} + +sub FROM +{ + my @in = @{$_[0]}; + + return "From $in[0]"; +} + +sub TIL +{ + my @in = @{$_[0]}; + + return "Until $in[0]"; +} + +1; diff --git a/Geo/TAF/t/1.t b/Geo/TAF/t/1.t new file mode 100644 index 00000000..c54f63d5 --- /dev/null +++ b/Geo/TAF/t/1.t @@ -0,0 +1,40 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl 1.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use Test; +BEGIN { plan tests => 16 }; + +use Geo::TAF; +ok(1); # If we made it this far, we're ok. + + +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. + + +my $m; + +ok ($m = new Geo::TAF); +ok (! $m->metar("EGSH 311420Z 29010KT 1600 SHSN SCT004 BKN006 01/M02 Q1021")); +ok (length $m->as_string > 30); +ok ($m->icao eq 'EGSH'); +ok ($m->day == 31); +ok ($m->pressure == 1021); +ok ($m->temp == 1); +ok ($m->dewpoint == -2); +ok ($m->wind_dir == 290); +ok ($m->wind_speed == 10); +ok ($m->viz_dist == 1600); +ok ($m = new Geo::TAF); +ok (! $m->taf("EGSH 311205Z 311322 04010KT 9999 SCT020 + TEMPO 1319 3000 SHSN BKN008 PROB30 + TEMPO 1318 0700 +SHSN VV/// + BECMG 1619 22005KT")); +ok ($m->chunks); +ok ($m->as_chunk_string); -- 2.43.0