File Coverage

blib/lib/Geo/WeatherNOAA.pm

Criterion	Covered	Total	%
statement	232	282	82.2
branch	64	116	55.1
condition	25	57	43.8
subroutine	18	20	90.0
pod	7	13	53.8
total	346	488	70.9

# $Id: WeatherNOAA.pm,v 4.38 2006/12/10 21:58:11 msolomon Exp $


package Geo::WeatherNOAA;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use LWP::Simple;
use LWP::UserAgent;
use Tie::IxHash;
use Text::Wrap;

require Exporter;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
	make_noaa_table

	print_forecast
	print_current

	get_city_zone
	process_city_zone

	get_city_hourly
	process_city_hourly
);

$VERSION = do { my @r = (q$Revision: 4.38 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
# my $URL_BASE = 'http://iwin.nws.noaa.gov/iwin/';
my $URL_BASE = 'http://www.weather.gov/view/prodsByState.php?';
# state=ia&prodtype=zone

use vars '$proxy_from_env';
$proxy_from_env = 0;

# Preloaded methods go here.

sub print_forecast {
	my ($city, $state, $filename, $fileopt, $UA) = @_;
	my $in = get_city_zone($city,$state,$filename,$fileopt,$UA);

	my $out;

	$out = "Geo::WeatherNOAA.pm v.$Geo::WeatherNOAA::VERSION\n";

	my ($date,$warnings,$forecast) =
	   process_city_zone($city,$state,$filename,$fileopt);

	$out .= "As of $date:\n";
	foreach my $warning (@$warnings) {
		$out .= wrap('WARNING: ','    ',"$warning\n");
	}
	foreach my $key (keys %$forecast) {
        	$out .= wrap('','    ',"$key: $forecast->{$key}\n");
	}
	return $out
}


#########################################################################
#########################################################################
#
# Zone file processing
#
#########################################################################
#########################################################################
sub process_city_zone {
	my ($city, $state, $filename, $fileopt, $UA) = @_;
	my $in = get_city_zone($city,$state,$filename,$fileopt,$UA);

	# Return error if problem getting URL
	if ($in =~ /Error/) {
		my %error;
		my @null;
		$error{'Error'} = 'Error';
		$error{'Network Error'} = $in;
		return ('',\@null,\%error);
	}
	#print STDERR $in;exit;

	# Split coverage, date, and forecast
	#
	my ($coverage, $date, $forecast) = ($in =~ /(^.*?)\012	# Coverage
						    (\d.*?)\012	# Date
						    (.*)/sx);	# Entire Forecast

	# Format Coverage
	#
	$coverage =~ s/corrected//gi;		# Remove stat word
	$coverage =~ s/(\/|-|\.\.\.)/, /g;	# Turn weird punct to commas
	$coverage =~ s/,\s*$//;			# Remove last comma
	$coverage = ucfirst_words($coverage);	# Make caps correct

	# Format date (easy)
	#
	$date = format_date($date);

	# Vars for forecast
	#
	my %forecast;
	tie %forecast, "Tie::IxHash";
	my @warnings;

	# Iterate through forecast and assign warnings to list or pairs to hash
	#
	my $forecast_item;	# Used as place holder for line breaks of $value
	my $warnings_done = 0;	# Flag for warnings (Always at top of forcast)

	foreach my $line (split "\012",$forecast) {
		# Be-gone if we've got temp data (will include parse for that later)
		last if $line =~ /^\.

		my ($key,$value);
		($key,$value) = ($line =~ /(.*?)\.\.\.(.*)/);

		if (! $value) {
			# If there's no value, this must be either a warning or
			# a continutation of value-data
			$key = $line;
		}
		next if ($key =~ /EXTENDED/);


		$warnings_done = 1 if ( ($key) and ($value) );
		#print "WARN_DONE: $warnings_done\n";

		if ($warnings_done) {
			if ( ($key =~ s/^\.//) and ($value) and ($key) ) {
				# Add VALUE to KEY (new key)
				$key =~ s/^\.//;
				$key = ucfirst_words($key);
				$forecast_item = $key;
				$forecast{$forecast_item} .= $value;
			}
			elsif ( $forecast_item ) {
				# Add KEY (with data) to OLD KEY (FORECAST_ITEM)
				$forecast{$forecast_item} .= ' ' . $key;
				$forecast{$forecast_item} .= ', ' . $value if $value;
			}
			else {
				# print "LINE IGNORED\n";
			}
		}
		elsif (! $warnings_done ) {
			if ( (!$key) and ($value) ) {
					$value = ucfirst lc $value;
					push @warnings, $value;
			}
			elsif ( ($key) and (!$value) ) {
					$key = ucfirst lc $key;
					push @warnings, $key;
			}
		}
		else {
			# line ignored
		}
	}

	foreach my $key ( keys %forecast ) {
		$forecast{$key} =~ tr/\012//d;			# Remove newlines
		#$forecast{$key} = lc($forecast{$key});	# No all CAPS
		$forecast{$key} =~ s/\s+/ /g;			# Rid of multi-spaces
		$forecast{$key} = sent_caps($forecast{$key});	# Proper sentance caps
	}

	return ($date,\@warnings,\%forecast,$coverage);

} # process_city_zone()


sub get_city_zone {
	my ($city, $state, $filename, $fileopt, $UA) = @_;

	# my $URL = $URL_BASE . lc $state . '/zone.html';
	my $URL = $URL_BASE . 'state=' . lc($state) . '&prodtype=zone';


	# City and States must be capital
	#
	$state = uc($state);
	$city  = uc($city);

	# Declare some working vars
	#
	my ($rawData, $coverage);

	# Get data from filehandle object
	#
	$rawData = get_data($URL,$filename,$fileopt,$UA);

	# clean raw data to remove leading whitespace (I hope this works) 2006-12-10
	#$rawData =~ s#\n\s*\.#\n.#gm;

	#my $t1 = $rawData;
	#$rawData =~ s#\r\n#\n#sg;
	$rawData =~ s#\n\s+#\n#sg;

	$rawData =~ s#\$\$#ENDOFSECTION#sg;

	# print STDERR $rawData;
	foreach my $line ($rawData =~ /\n(\w\wZ.*?)\012/sg) {
		$line =~ s/\r//g;
		$line =~ s/\n//g;
		# print STDERR "HERE: " . $line . "\n";
		my $pattern = "$line\\n(.*?)\\n(?:ENDOFSECTION|NNN)";
		#print STDERR "PATTERN=" . $pattern . "<--\n";
		my $section = ($rawData =~ /$pattern/sg)[0];
		if ($section) {
			#print "\n\n$section\n";
			#print "   SIZE OF DATA: " . length($section) . "\n";
			# Iterate though section and get coverage
			my $coverage_ended = 0;
			foreach my $line (split /\012/, $section) {
				$line =~ tr/\015//d; # \r
				$coverage .= $line . "\n" if (! $coverage_ended);
				if ($line !~ /^\w/) {
					$coverage_ended = 1;
				}
			}
			return $section if ( ($coverage =~ /$city/i) && ($section =~ /\d{4}/));
		}
	}
	return "$city not found";

	# Return error if there's an error
	if ($rawData =~ /Error/) {
		return $rawData;
	}

	# Find our city's data from all raw data
	#
	#foreach my $section ($rawData =~ /\012${state}Z.*?	# StateZone
	foreach my $section ($rawData =~ /\013\w\wZ.*?	# StateZone
					  \012\013(.*?)		# Data sect
					  \012\013(?:\$\$|NNN)/xsg) {
		# print STDERR "\n\nSECTION:\n$section\n";
		# Iterate though section and get coverage
		my $coverage_ended = 0;
		foreach my $line (split /\012/, $section) {
			$line =~ tr/\015//d; # \r
			$coverage .= $line . "\n" if (! $coverage_ended);
			if ($line !~ /^\w/) {
				$coverage_ended = 1;
			}
		}
		return $section if ( ($coverage =~ /$city/i) && ($section =~ /\d{4}/));
	}
	return "$city not found";
}

##############################################################################
##############################################################################
##
## Html for Mark's Site
##
##############################################################################
##############################################################################

sub font {
	my $in = shift;
	my $size = shift || 2;
	my $font_face = $main::font_face || 'FACE="Helvetica, Lucida, Ariel"';
	return qq|$in|;
}

sub make_noaa_table {
	my ($city, $state, $filename, $fileopt, $UA, $max_items) = @_;

	$fileopt ||= 'get';
	$max_items && $max_items--;
	$max_items ||= 4;

	my $med_bg   = $main::med_bg || '#ddddff';
	my $light_bg = $main::light_bg || '#eeeeff';
	my $font_face = $main::font_face || 'FACE="Helvetica, Lucida, Ariel"';

	my $locfilename;
	$locfilename = $filename . "_hourly";
	my $current = process_city_hourly( $city,$state,$locfilename,$fileopt,$UA );

	$locfilename = $filename . "_zone";
	my ($date,$warnings,$forecast,$coverage) = process_city_zone( $city,$state,$locfilename,$fileopt,$UA);
	my $cols = (keys %$forecast);
	$cols = $max_items if $cols > $max_items;
	my $out;
	$out .= qq|\n|; \n"; \n"; \n|; \n|; \n|; \n|; \n"; \n"; \n" . $bottom . "\n"; \n|; \n|; \n|; \n|; \n|; \n"; 




292




1





 





 





 





 





3



 	$out .= qq|\n|; 




293




1





 





 





 





 





4



 	$out .= qq|\n|; 




294




1





 





 





 





 





3



 	$out .= font('Current') . "\n




295




1





 





 





 





 





4



 	$out .= qq||; 




296




1





 





 





 





 





3



 	$out .= font($current) . "\n




297




 





 





 





 





 





 



   




298




 





 





 





 





 





 



 	# Add one to make cols real width of table 




299




 





 





 





 





 





 



 	# 




300




1





 





 





 





 





4



 	$cols++; 




301




 





 





 





 





 





 



   




302




 





 





 





 





 





 



 	# Add warnings, if needed 




303




 





 





 





 





 





 



 	# 




304




1




  
 50
  




 





 





 





5



 	if (@$warnings) { 




305




0





 





 





 





 





0



 		$out .= qq|\n|; 




306




0





 





 





 





 





0



 		foreach my $warning (@$warnings) { 




307




0





 





 





 





 





0



 			$out .= qq|




308




0





 





 





 





 





0



 			$out .= qq|\t|; 




309




0





 





 





 





 





0



 			$out .= qq|\n|; 




310




0





 





 





 





 





0



 			$out .= qq|\t$warning\n




311




 





 





 





 





 





 



 		} 




312




 





 





 





 





 





 



 	} 




313




 





 





 





 





 





 



   




314




 





 





 





 





 





 



 	# Iterate over the first $max_items items in forecast 




315




 





 





 





 





 





 



 	# 




316




1





 





 





 





 





3



 	my $bottom; # add this after the iteration; 




317




1





 





 





 





 





3



 	$out    .= qq|




318




1





 





 





 





 





3



 	$bottom .= qq|




319




1





 





 





 





 





7



 	foreach my $key ( (keys %$forecast)[0..($cols - 1)] ) { 




320




 





 





 





 





 





 



 		#print STDERR "DEBUG: $key\n"; 




321




5





 





 





 





 





56



 		$out    .= "\t" . font($key) . "




322




5





 





 





 





 





18



 		$bottom .= "\t" . font($forecast->{$key}) . "




323




 





 





 





 





 





 



 	} 




324




1





 





 





 





 





10



 	$out .= "




325




 





 





 





 





 





 



 	 




326




 





 





 





 





 





 



 	# Add coverage area 




327




1





 





 





 





 





5



 	$out .= qq|




328




1





 





 





 





 





3



 	$out .= qq|	| . font('Area') . qq|




329




1





 





 





 





 





5



 	$out .= qq|	| . font($coverage,1) . qq|




330




1





 





 





 





 





4



 	$out .= qq|




331




 





 





 





 





 





 



   




332




 





 





 





 





 





 



 	# Add credits 




333




 





 





 





 





 





 



 	# 




334




1





 





 





 





 





6



 	my $wx_cred = 'NOAA forecast made ' . 




335




 





 





 





 





 





 



 	  "$date by " . 




336




 





 





 





 





 





 



 	  "" . 




337




 





 





 





 





 





 



 	  "Geo::WeatherNOAA V.$Geo::WeatherNOAA::VERSION"; 




338




1





 





 





 





 





3



 	$out .= qq|




339




1





 





 





 





 





5



 	$out .= qq|| . font($wx_cred) . "




340




1





 





 





 





 





15



 	$out .= qq|\n|;
	$out .= qq|\n|;
	$out .= qq|
	$out .= font('Current') . "\n
	$out .= qq|
	$out .= font($current) . "\n

	# Add one to make cols real width of table
	#
	$cols++;

	# Add warnings, if needed
	#
	if (@$warnings) {
		$out .= qq|\n|;
		foreach my $warning (@$warnings) {
			$out .= qq|
			$out .= qq|\t
			$out .= qq|\n|;
			$out .= qq|\t$warning\n
		}
	}

	# Iterate over the first $max_items items in forecast
	#
	my $bottom; # add this after the iteration;
	$out    .= qq|
	$bottom .= qq|
	foreach my $key ( (keys %$forecast)[0..($cols - 1)] ) {
		#print STDERR "DEBUG: $key\n";
		$out    .= "\t
		$bottom .= "\t
	}
	$out .= "

	# Add coverage area
	$out .= qq|
	$out .= qq|
	$out .= qq|
	$out .= qq|

	# Add credits
	#
	my $wx_cred = 'NOAA forecast made ' .
	  "$date by " .
	  "" .
	  "Geo::WeatherNOAA V.$Geo::WeatherNOAA::VERSION";
	$out .= qq|
	$out .= qq|
	$out .= qq|



}

##############################################################################
##############################################################################
##
## Misc funcs
##
##############################################################################
##############################################################################

sub get_url {
    my ($URL, $UA) = @_;

	$URL or die "No URL to get!";

    # Create the useragent and get the data
    #
    if (! $UA) {
		$UA = new LWP::UserAgent;
		if ( $ENV{'HTTP_PROXY'} or $ENV{'http_proxy'} ) {
        	$UA->env_proxy;
		}
    }
    $UA->agent("WeatherNOAA/$VERSION");

    # Create a request
    my $req = new HTTP::Request GET => $URL;
    my $res = $UA->request($req);
    if ($res->is_success) {
		return $res->content;
    }
    else {
		return;
    }
} # getURL()

sub get_data {
	my ($URL,$filename,$fileopt,$UA) = @_;

	$fileopt ||= 'get';

	my $data;	# Data

	if ( ($fileopt eq 'get') || ($fileopt eq 'save') ) {
		print STDERR "Retrieving $URL\n" if $main::opt_v;
		$data = get_url($URL,$UA) ||
			return "Error getting data from $URL";
		if ( $fileopt eq 'save' ) {
			print STDERR "Writing $URL to $filename\n" if $main::opt_v;
			open(OUT,">$filename") or die "Cannot create $filename";
			print OUT $data;
			close OUT;
			$fileopt = 'usefile';
		}
	}
	if ( $fileopt eq 'usefile' ) {
		print STDERR "Reading data from $filename\n" if $main::opt_v;
		open(FILE,$filename) or die "Cannot read $filename";
		while () { $data .= $_; }
	}
	return $data;
} # get_fh

sub format_date {
	my $in = shift;
	$in =~ s/^(\d+)(\d\d)\s(AM|PM)\s(\w+)\s(\w+)\s(\w+)\s0*(\d+)/$1:$2\L$3\E ($4) \u\L$5\E\E \u\L$6 $7,/;
	$in =~ tr/\015//d; # \r
	return $in;
}
sub sent_caps {
	my $in = shift;
	$in = ucfirst(lc($in));
	$in =~ s/(\.\W+)(\w)/$1\U$2/g;		# Proper sentance caps
	return $in;
}

sub ucfirst_words {
	my ($in) = @_;
	return join " ", map ucfirst(lc($_)),(split /\s+/, $in);
}

#########################################################################
#########################################################################
##
## Hourly city data
##
#########################################################################
#########################################################################

sub get_city_hourly {
	my ($city,$state,$filename,$fileopt,$UA) = @_;

	# City and state in all caps please
	#
	$city  = uc $city;
	$state = uc $state;

	# work var
	my ($fields,$line,$date,$time);

	# Get data
	#
	#my $URL = $URL_BASE . lc $state . '/hourly.html';
	my $URL = $URL_BASE . 'state=' . lc($state) . '&prodtype=hourly';
	#print STDERR "Getting data from $URL\n";
	my $data = get_data($URL,$filename,$fileopt,$UA);
	my $datalength = length($data);
	#print STDERR "Got data ($datalength)\n";

	# Return error if there's an error
	if ($data =~ /Error/) {
		my %retHash;
		$retHash{ERROR} = $data;
		return \%retHash;
	}

	$data =~ s/\015//g; # \r

	#print STDERR "LOOKING FOR: " . $city . "\n";

	# Get line for our city from Data
	#
	foreach (split /\012/, $data) {
		chomp;
		s/^\s*//;
		$date   = $_ if /^\s*(\d+)(\d\d)\s+(AM|PM)\s+(\w+)/;
		$time = "$1:$2 $3" if (($1) && ($2) && ($3));
		$fields = $_ if /^CITY/;
		$line   = $_ if /^$city\s/;

		#print STDERR "LINE: $line\n" if $line;

		# Newest data seems to be at the top of the file
		last if $line;
	}
	$date = format_date($date);

	# Set pack strings
	#
	my $fields_pack_str;
	my $values_pack_str;
	if ( ($fields =~ /TMP/) and ($fields =~ /\sDP\s/) ) {
		#print STDERR "NEW FORMAT!\n";
		$fields_pack_str =
        	'@0 A15 @15 A9 @25 A3 @29 A2 @33 A2 @36 A8 @47 A5 @54 A7';
		$values_pack_str =
			'@0 A15 @15 A8 @24 A4 @28 A4 @32 A3 @36 A8 @46 A7 @53 A8';
	}
	else {
		#print STDERR "OLD FORMAT!\n";
		$fields_pack_str =
        	'@0 A15 @15 A9 @24 A5 @29 A5 @35 A4 @39 A8 @47 A8 @55 A8';
		$values_pack_str =
			'@0 A15 @15 A9 @24 A5 @29 A5 @34 A4 @39 A8 @47 A8 @55 A8';
	}

	# unpack gives error of the string is smaller than the unpack string
	$line .= ' ' x (64 - length($line)) if length($line) < 64;

	return { } unless ( ($line) && ($fields) ); # Return ref to empty hash

	my @fields;
	push @fields, 'DATE', 'TIME', unpack $fields_pack_str, $fields if $fields;
        #'@0 A15 @15 A9 @24 A5 @29 A5 @35 A4 @39 A8 @47 A8 @55 A8', $fields if $fields;
	my @values;
	push @values, $date, $time, unpack $values_pack_str, $line;
	#print STDERR "$line\n";
		#'@0 A15 @15 A9 @24 A5 @29 A5 @34 A4 @39 A8 @47 A8 @55 A8', $line;



	return { } if $values[3] eq 'NOT AVBL'; # Return ref to empty hash

	my %retValue;
	foreach my $i (0..$#fields) {
		# Convert odd fieldnames to standard
		$fields[$i] = 'DEWPT' if $fields[$i] eq 'DP';
		$fields[$i] = 'TEMP' if $fields[$i] eq 'TMP';

		# Assign value
		$retValue{$fields[$i]} = $values[$i];
	}

	return \%retValue;

} # get_city_hourly()

sub print_current {
	my ($city,$state,$filename,$fileopt,$UA) = @_;
	my $in = process_city_hourly($city, $state, $filename, $fileopt,$UA);
	return wrap('','    ',$in)
}


sub process_city_hourly {
	my ($city,$state,$filename,$fileopt,$UA) = @_;
	my $in = get_city_hourly($city, $state, $filename, $fileopt,$UA);

	$state = uc($state);

	return $in->{ERROR} if $in->{ERROR};
	$in->{CITY} or return "No data available";
	$in->{CITY} = ucfirst_words($in->{CITY});

	my %sky = (
               'SUNNY'          => 'sunny skies',
               'MOSUNNY'        => 'mostly sunny skies',
               'PTSUNNY'        => 'partly sunny skies',
               'CLEAR'          => 'clear weather',
               'DRIZZLE'        => 'a drizzle',
               'CLOUDY'         => 'cloudy skies',
               'MOCLDY'         => 'mostly cloudy skies',
               'PTCLDY'         => 'partly cloudy skies',
               'LGT RAIN'       => 'light rain',
			   'FRZ DRZL'		=> 'freezing drizzle',
               'FLURRIES'       => 'flurries',
               'LGT SNOW'       => 'light snow',
               'SNOW'           => 'snow',
               'N/A'            => 'N/A',
               'NOT AVBL'       => '*not available*',
               'FAIR'           => 'fair weather');

	# Format the wind direction and speed
	#
	my %compass = qw/N north S south E east W west/;
	# my $direction = join '',map $compass{$_},split(/(\w)\d/g, $in->{WIND});
	my $direction;
	{
		$direction = $in->{WIND};
		$direction =~ s/(.*?)G.*/$1/; 	# Remove gusts
		$direction =~ s/\d//g;			# Remove digits
		if ( $direction ) {
			$direction = $compass{$direction};
		}
	}
	my ($speed) = ($in->{WIND} =~ /(\d+)/);
	my ($gusts) = ($in->{WIND} =~ /G(\d+)/);

	if ($in->{WIND} eq 'CALM') {
		$in->{WIND} = 'calm';
	}
	else {
		$in->{WIND} = "$direction at ${speed} mph";
		$in->{WIND} .= ", gusts up to ${gusts} mph" if $gusts;
	}

	# Format relative humidity and ibarometric pressure
	#
	my $rh_pres;
    	if ($in->{RH}) {
        	$rh_pres = " The relative humidity was $in->{RH}\%";
    	}
	if ($in->{PRES}) {
          my %rise_fall = qw/R rising S steady F falling/;
          # my $direction = join '',map $rise_fall{$_},split(/\d(\w)/g, $in->{PRES});
          my $direction;
		  {
		  	$direction = $in->{PRES};
			$direction = ( $direction =~ /.*(\w)$/ )[0];
			if ( $direction ) {
				$direction = $rise_fall{$direction};
			}
		  }
          $in->{PRES} =~ tr/RSF//d;
          if ($rh_pres) {
                $rh_pres .= ", and b";
          }
          else {
                $rh_pres .= " B";
          }
          $rh_pres .= "arometric pressure was $direction from $in->{PRES} in";
    	}
    	$rh_pres .= '.' if $rh_pres;

	# Format output sentence
	#
	my $out;
	$out  = "At $in->{TIME}, $in->{CITY}, $state conditions were ";
	$out .= $sky{$in->{'SKY/WX'}} . " ";
	$out .= "at $in->{TEMP}°F, wind was $in->{WIND}. $rh_pres\n";
	return $out;

} # process_city_hourly()

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__