File Coverage

blib/lib/Acme/Test/Weather.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

=head1 NAME

Acme::Test::Weather - Test the weather conditions for a user.

=head1 SYNOPSIS

  use Test::Weather;
  plan tests => 2;

  # You may only install something
  # when it's nice outside.

  &isnt_snowing();
  &isnt_cloudy();

  # output:

  1..2
  ok 1 - it's partly cloudy in Montreal, Canada
  not ok 2 - it's partly cloudy in Montreal, Canada
  #     Failed test (./t/mtl.t at line 5)
  #                   'Partly Cloudy'
  #           matches '(?i-xsm:\bcloudy)'
  # Looks like you failed 1 tests of 2.

=head1 DESCRIPTION

Test the weather conditions for a user.

The package determines a user's location by looking up their hostname /
IP address using the I package.

Based on the data returned, weather conditions are polled using the
I package.

Because, you know, it may be important to your Perl module that it's
raining outside...

=cut

use strict;

package Acme::Test::Weather;
use base qw (Exporter);

$Acme::Test::Weather::VERSION = '0.2';

@Acme::Test::Weather::EXPORT = qw (plan

              is_sunny   isnt_sunny
              is_cloudy  isnt_cloudy
              is_snowing isnt_snowing
              is_raining isnt_raining

              eq_celsius    lt_celsius    gt_celsius
              eq_fahrenheit lt_fahrenheit gt_fahrenheit
              eq_humidity   lt_humidity   gt_humidity
              );

#

use Test::Builder;

use Sys::Hostname;
use Socket;

use CAIDA::NetGeoClient;
use Geography::Countries;
use Weather::Underground;

my $addr    = gethostbyname(hostname);
my $ip      = inet_ntoa($addr);

my $test    = Test::Builder->new();

my $geo     = CAIDA::NetGeoClient->new();
my $record  = $geo->getRecord($ip);

my $city    = ucfirst(lc($record->{CITY}));

# If city is in the States use the state as
# the region. Otherwise use Geography::Countries
# to munge the two letter code for the country
# into its actual name.

# Because things like 'Cambridge, US' cause
# wunderground.com to spazz out :-(

my $region  = ($record->{COUNTRY} eq "US") ?
  ucfirst(lc($record->{STATE})) : country($record->{COUNTRY});

my $place   = "$city, $region";

my $weather = Weather::Underground->new(place => $place);
my $data    = $weather->getweather()->[0];

#use Data::Denter;
#print Indent($data);

=head1 PACKAGE FUNCTIONS

=cut

=head2 &is_cloudy()

Make sure it is cloudy, but remember the silver lining.

=cut

sub is_cloudy {
  $test->like($data->{conditions},qr/\b(cloudy|overcast)/i,&_conditions());
};

=head2 &isnt_cloudy()

No clouds. Not even little fluffy ones.

=cut

sub isnt_cloudy {
  $test->unlike($data->{conditions},qr/\b(cloudy|overcast)/i,&_conditions());
};

=head2 &is_raining()

Make sure it is raining.

=cut

sub is_raining {
  $test->like($data->{conditions},qr/\brain/i,&_conditions());
};

=head2 &isnt_raining()

Make sure sure it is not raining.

=cut

sub isnt_raining {
  $test->unlike($data->{conditions},qr/\brain/i,&_conditions());
};

=head2 &is_snowing()

Make sure it is snowing.

=cut

sub is_snowing {
  $test->like($data->{conditions},qr/\bsnow/i,&_conditions());
};

=head2 &isnt_snowing()

Make sure it is not snowing.

=cut

sub isnt_snowing {
  $test->unlike($data->{conditions},qr/\bsnow/i,&_conditions());
};

=head2 &is_sunny()

Make sure it is sunny.

=cut

sub is_sunny {
  $test->like($data->{conditions},qr/\bsun/i,&_conditions());
};

=head2 &isnt_sunny()

Make sure it is not sunny. Why are you so angry?

=cut

sub isnt_sunny {
  $test->unlike($data->{conditions},qr/\bsun/i,&_conditions());
};

=head2 &eq_celsius($int)

Temperature in degrees Celsius.

=cut

sub eq_celsius {
  $test->cmp_ok($data->{celsius},"==",$_[0],&_temp("celsius"));
}

=head2 >_celsius($int)

Cooler than, in degrees Celcius.

=cut

sub gt_celsius {
  $test->cmp_ok($data->{celsius},">",$_[0],&_temp("celsius"));
}

=head2 <_celsius($int)

Warmer than, in degrees Celsius.

=cut

sub lt_celsius {
  $test->cmp_ok($data->{celsius},"<",$_[0],&_temp("celsius"));
}

=head2 &eq_fahrenheit($int)

Temperature, in degrees Fahrenheit.

=cut

sub eq_fahrenheit {
  $test->cmp_ok($data->{fahrenheit},"==",$_[0],&_temp("fahrenheit"));
}

=head2 >_fahrenheit($int)

Warmer than, in degrees Fahrenheit.

=cut

sub gt_fahrenheit {
  $test->cmp_ok($data->{fahrenheit},">",$_[0],&_temp("fahrenheit"));
}

=head2 <_fahrenheit($int)

Cooler than, in degrees Fahrenheit.

=cut

sub lt_fahrenheit {
  $test->cmp_ok($data->{fahrenheit},"<",$_[0],&_temp("fahrenheit"));
}

=head2 &eq_humidity($int)

Humidity.

=cut

sub eq_humidity {
  $test->cmp_ok($data->{humidity},"==",$_[0],&_humidity());
}

=head2 >_humidity($int)

Humidity is greater than.

=cut

sub gt_humidity {
  $test->cmp_ok($data->{humidity},">",$_[0],&_humidity());
}

=head2 <_humidity($int)

Humidity is less than.

=cut

sub lt_humidity {
  $test->cmp_ok($data->{humidity},"<",$_[0],&_humidity());
}

sub _conditions { return "it's ".lc($data->{conditions})." in $place"; }

sub _humidity { return "the humidity in $place is $data->{humidity}"; }

sub _temp { my $m = shift; return "it $data->{$m} degrees $m in $place"; }

# Stuff I, ahem, borrowed from Test::More

sub plan {
    my(@plan) = @_;

    my $caller = caller;

    $test->exported_to($caller);

    my @imports = ();
    foreach my $idx (0..$#plan) {
        if( $plan[$idx] eq 'import' ) {
            my($tag, $imports) = splice @plan, $idx, 2;
            @imports = @$imports;
            last;
        }
    }

    $test->plan(@plan);

    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}

sub _export_to_level
{
      my $pkg = shift;
      my $level = shift;
      (undef) = shift;                  # redundant arg
      my $callpkg = caller($level);
      $pkg->export($callpkg, @_);
}

=head1 VERSION

0.2

=head1 DATE

$Date: 2003/02/21 19:25:34 $

=head1 AUTHOR

Aaron Straup Cope

=head1 SEE ALSO

http://www.caida.org/tools/utilities/netgeo/NGAPI/index.xml

L

http://search.cpan.org/dist/Acme

=head1 SHOUT-OUTS

It's all Kellan's fault.

=head1 BUGS

Not hard to imagine.

Please report all bugs via http://rt.cpan.org

=head1 LICENSE

Copyright (c) 2003, Aaron Straup Cope. All Rights Reserved.

This is free software, you may use it and distribute it under the same terms as Perl itself

=cut

return 1;