src/Modules/Weather.pl

   1 #!/usr/bin/perl
   2
   3 package Weather;
   4
   5 # kevin lenzo (C) 1999 -- get the weather forcast NOAA.
   6 # feel free to use, copy, cut up, and modify, but if
   7 # you do something cool with it, let me know.
   8
   9 # 16-SEP-99 lenzo@cs.cmu.edu switched to LWP::UA and
  10 #           put in a timeout.
  11
  12 my $no_weather;
  13 my $cache_time = 60 * 40 ; # 40 minute cache time
  14 my $default = 'KAGC';
  15
  16 BEGIN {
  17     $no_weather = 0;
  18     eval "use LWP::UserAgent";
  19     $no_weather++ if ($@);
  20 }
  21
  22 sub Weather {
  23         my ($args) = @_;
  24         &::performStrictReply(&queryText($args, 'weather'));
  25         return;
  26 }
  27
  28 sub Metar {
  29         my ($args) = @_;
  30         &::performStrictReply(&queryText($args, 'metar'));
  31         return;
  32 }
  33
  34 sub queryText {
  35     my ($station) = shift;
  36     my ($wxmode) = shift;
  37     my $result;
  38
  39     $station = uc($station);
  40     $station =~ s/for //i;
  41
  42     if ($no_weather) {
  43         return 0;
  44     } else {
  45
  46         if (exists $cache{$station}) {
  47             my ($time, $response) = split $; , $cache{$station};
  48             if ((time() - $time) < $cache_time) {
  49                 return $response;
  50             }
  51         }
  52
  53         my $ua = new LWP::UserAgent;
  54         $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
  55
  56         $ua->timeout(10);
  57         my $request = new HTTP::Request('GET', "http://weather.noaa.gov/weather/current/$station.html");
  58         my $response = $ua->request($request);
  59
  60         if (!$response->is_success) {
  61             if ($response->code == 404) {
  62                 return "I can't find station code \"$station\""
  63                     . " (see http://www.nws.noaa.gov/oso/site.shtml"
  64                     . " or http://www.nws.noaa.gov/tg/siteloc.shtml"
  65                     . " for ICAO locations codes).";
  66             } else {
  67                 return 'Something failed in connecting to the NOAA web'
  68                     . " server. Try again later.";
  69             }
  70         }
  71
  72         $content = $response->content;
  73         $content =~ s|.*?<BODY[^>]*>||is;
  74         #$content =~ s|.*?current weather conditions.*?<BR>([^<]*?)\s*<.*?</TR>||is;
  75         $content =~ s|.*?current weather conditions[^<]*(<[^>]+>\s*)+||is;
  76         $content =~ s|([^<]*?)\s*<.*?</TR>||is;
  77         my $place = $1;
  78         chomp $place;
  79
  80         $content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
  81         my $id = $1;
  82         chomp $id;
  83
  84         $content =~ s|.*?conditions at.*?</TD>||is;
  85
  86         #$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s; # local time
  87         $content =~ s|.*?<BR>\s+([^<]+?)\s*</FORM>.*?</TR>||s; # UTC
  88         my $time = $1;
  89         $time =~ s/-//g;
  90         $time =~ s/\s+/ /g;
  91
  92         $content =~ s|\s(.*?)<TD COLSPAN=2>||s;
  93         my $features = $1;
  94
  95         while ($features =~ s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s) {
  96             my ($f,$v) = ($1, $2);
  97             chomp $f; chomp $v;
  98             $feat{$f} = $v;
  99         }
 100
 101         $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;  # max temp;
 102         $max_temp = $1;
 103         $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
 104         $min_temp = $1;
 105
 106         if ($time) {
 107             if ($wxmode eq 'metar' && defined($feat{'ob'})) {
 108                 return ('METAR ' . $place . ": " . $feat{'ob'});
 109             }
 110
 111             $result = "$place; $id; last updated: $time";
 112             foreach (sort keys %feat) {
 113                 next if $_ eq 'ob';
 114                 $result .= "; $_: $feat{$_}";
 115             }
 116             my $t = time();
 117             $cache{$station} = join $;, $t, $result;
 118         } else {
 119             $result = "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
 120         }
 121         return $result;
 122     }
 123 }
 124
 125 if (0) {
 126     if (-t STDIN) {
 127         my $result = Weather::NOAA::get($default);
 128         $result =~ s/; /\n/g;
 129         print "\n$result\n\n";
 130     }
 131 }
 132
 133 1;
 134
 135 __END__
 136
 137 =head1 NAME
 138
 139 NOAA.pl - Get the weather from a NOAA server
 140
 141 =head1 PREREQUISITES
 142
 143         LWP::UserAgent
 144
 145 =head1 PARAMETERS
 146
 147 weather
 148
 149 =head1 PUBLIC INTERFACE
 150
 151         weather [for] <station>
 152
 153 =head1 DESCRIPTION
 154
 155 Contacts C<weather.noaa.gov> and gets the weather report for a given
 156 station.
 157
 158 =head1 AUTHORS
 159
 160 Kevin Lenzo