File Coverage

blib/lib/Ham/Reference/Solar.pm

Criterion	Covered	Total	%
statement	9	80	11.2
branch	0	20	0.0
condition	0	23	0.0
subroutine	3	16	18.7
pod	7	7	100.0
total	19	146	13.0

package Ham::Reference::Solar;

# --------------------------------------------------------------------------
# Ham::Reference::Solar - A scraper to return solar data useful for
# Amateur Radio applications.
#
# Copyright (c) 2008-2010 Brad McConahay N8QQ.
# Cincinnat, Ohio USA
#
# This module is free software; you can redistribute it and/or
# modify it under the terms of the Artistic License 2.0. For
# details, see the full text of the license in the file LICENSE.
#
# This program is distributed in the hope that it will be
# useful, but it is provided "as is" and without any express
# or implied warranties. For details, see the full text of
# the license in the file LICENSE.
# --------------------------------------------------------------------------

use strict;
use warnings;
require LWP::UserAgent;
use vars qw($VERSION);

our $VERSION = '0.03';

my $solar_url = 'http://www.wm7d.net/hamradio/solar';
my $site_name = 'wm7d.net';
my $default_timeout = 10;

my $items =
{
	'sfi'             => 'SFI: \s*(.*?)\s*',
	'a-index'         => 'A-index: \s*(.*?)\s*',
	'a-index-text'    => -1, # calculated field
	'k-index'         => 'K-Index: \s*(.*?)\s*',
	'k-index-text'    => -1, # calculated field
	'forecast'        => 'Forecast for the next 24 hours:\s*(.*?)\s*',
	'summary'         => 'Summary for the past 24 hours:\s*(.*?)\s*',
	'sunspots'        => 'Current Sunspot Count:\s*(.*?)\s*',
	'image'           => -1, # calculated field
	'image_thumbnail' => '(http://umbra.nascom.nasa.gov.*?\.gif)',
	'time'            => 'Report last updated:\s*(.*?)\s*'
};

sub new
{
	my $class = shift;
	my %args = @_;
	my $self = {};
	$self->{timeout} = $args{timeout} || $default_timeout;
    bless $self, $class;
	_solar_init($self);
	return $self;
}

sub get
{
	my $self = shift;
	my $item = shift;
	$self->{$item};
}

sub set
{
	my $self = shift;
	my $item = shift;
	my $value = shift;
	# $self->{$item} = _remove_markup($value);
	$self->{$item} = $value;
}

sub get_hashref
{
	my $self = shift;
	my $items = $self->all_item_names;
	my $hash = {};
	foreach (sort @$items) { $hash->{$_} = $self->{$_} }
	return $hash;
}

sub all_item_names
{
	my $self = shift;
	my @item_names;
	foreach (sort(keys %$items)) { push @item_names, $_ }
	return \@item_names;
}

sub is_error { my $self = shift; $self->{error_message} }
sub error_message { my $self = shift; $self->{error_message} }

# -----------------------
#	PRIVATE
# -----------------------

sub _solar_init
{
	my $self = shift;
	my $content = $self->_get_content($solar_url) || return 0;
	chomp $content;
	$content =~ tr/\r\n//;
	foreach my $item (keys %$items)
	{
		next if $item eq "-1"; # don't parse calculated fields
		if ($content =~ s#$items->{$item}##i)
		{
			$self->set($item,$1)
		}
	}
	_calc_fields($self);
	if (!$self->{sfi})
	{
		$self->{is_error} = 1;
		$self->{error_message} = "Data Parsing error - Format at $site_name may have changed";
		return 0;
	}
}

sub _calc_fields
{
	my $self = shift;
	$self->{'a-index-text'} = _get_a_text($self->{'a-index'});
	$self->{'k-index-text'} = _get_k_text($self->{'k-index'});
	$self->{'image'} = $self->{'image_thumbnail'};
	$self->{'image'} =~ s/_thumbnail//;
}

sub _get_content
{
	my $self = shift;
	my $url = shift;
	my $ua = LWP::UserAgent->new( timeout=>$self->{timeout} );
	$ua->agent("Ham/Reference/Solar.pm $VERSION");
	my $request = HTTP::Request->new('GET', $url);
	my $response = $ua->request($request);
	if (!$response->is_success)
	{
		$self->{is_error} = 1;
		$self->{error_message} = "Error at $site_name - ".HTTP::Status::status_message($response->code);
		return 0;
	}
	return $response->content;
}

#sub _items
#{
#	my $self = shift;
#	my @item_names;
#	my $items = $self->all_item_names;
#	foreach (sort @$items) { push @item_names, $_ if $self->{$_} }
#	return \@item_names;
#}

sub _remove_markup
{
	my $text = shift;
	$text =~ s/<.*?>//g;
	return $text;
}

sub _get_a_text
{
	my $num = shift;
	return 'quiet' if $num >= 0 and $num <= 7;
	return 'unsettled' if $num >= 8 and $num <= 15;
	return 'active' if $num >= 16 and $num <= 29;
	return 'minor storm' if $num >= 30 and $num <= 49;
	return 'major storm' if $num >= 50 and $num <= 99;
	return 'severe storm' if $num >= 100 and $num <= 400;
}

sub _get_k_text
{
	my $num = shift;
	my @text = (
		'inactive',
		'very quiet',
		'quiet',
		'unsettled',
		'active',
		'minor storm',
		'major storm',
		'severe storm',
		'very severe storm',
		'extremely severe storm',
	);
	return $text[$num];
}

1;
__END__