Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Re^2: Meteoalarm - Weather warnings

by walto (Pilgrim)
on Sep 24, 2017 at 06:42 UTC ( [id://1199977]=note: print w/replies, xml ) Need Help??


in reply to Re: Meteoalarm - Weather warnings
in thread Meteoalarm - Weather warnings

Thanks roboticus for your detailed comment.

The code you provided is a good example of good (or best) coding practice. Your code is shorter and better readable than mine.
When I rewrote the original code had had only in mind to fix it and make it working with the new website. I did not give a thought to making the module any better. Shorter and more readable code is surely preferable.

You are right with you comment about future changings (in regions, countries and possibly also the website).
I fixed a bug in evaluating weather events (that also existed in the first post of this thread): 
#!/usr/bin/perl
#
#
package Meteoalarm;
use strict;
use warnings;
use Carp;
use LWP;
use HTML::Entities;
use HTML::TreeBuilder;
use utf8;
binmode STDOUT, ":encoding(UTF-8)";

our $VERSION = "0.07";

my %countries = (
    'AT' => { code=>10,  name=>'AT-Austria', },
    'BA' => { code=>10,  name=>'BA_Bosnia-Herzegovina', },
    'BE' => { code=>801, name=>'BE-Belgium', },
    'BG' => { code=>28,  name=>'BG-Bulgaria', },
    'CH' => { code=>319, name=>'CH-Switzerland', },
    'CY' => { code=>1,   name=>'CY-Cyprus', },
    'CZ' => { code=>14,  name=>'CZ-Czechia', },
    'DE' => { code=>808, name=>'DE-Germany', },
    'DK' => { code=>8,   name=>'DK-Denmark', },
    'EE' => { code=>805, name=>'EE-Estonia', },
    'ES' => { code=>831, name=>'ES-Spain', },
    'FI' => { code=>813, name=>'FI-Finland', },
    'FR' => { code=>94,  name=>'FR-France', },
    'GR' => { code=>16,  name=>'GR-Greece', },
    'HR' => { code=>806, name=>'HR-Croatia', },
    'HU' => { code=>7,   name=>'HU-Hungary', },
    'IE' => { code=>804, name=>'IE-Ireland', },
    'IL' => { code=>803, name=>'IL-Israel', },
    'IS' => { code=>11,  name=>'IS-Iceland', },
    'IT' => { code=>20,  name=>'IT-Italy', },
    'LT' => { code=>801, name=>'LT-Lithuania', },
    'LU' => { code=>2,   name=>'LU-Luxemburg', },
    'LV' => { code=>804, name=>'LV-Latvia', },
    'MD' => { code=>37,  name=>'MD-Moldova', },
    'ME' => { code=>3,   name=>'ME-Montenegro', },
    'MK' => { code=>6,   name=>'MK-Former Yugoslav Republic of Macedon
+ia', },
    'MT' => { code=>1,   name=>'MT-Malta', },
    'NL' => { code=>807, name=>'NL-Netherlands', },
    'NO' => { code=>814, name=>'NO-Norway', },
    'PL' => { code=>802, name=>'PL-Poland', },
    'PT' => { code=>26,  name=>'PT-Portugal', },
    'RO' => { code=>42,  name=>'RO-Romania', },
    'RS' => { code=>11,  name=>'RS-Serbia', },
    'SE' => { code=>813, name=>'SE-Sweden', },
    'SI' => { code=>801, name=>'SI-Slovenia', },
    'SK' => { code=>16,  name=>'SK-Slovakia', },
    'UK' => { code=>16,  name=>'UK-United-Kingdom' },
);

my %day = (
    'today' => 0,
    'tomorrow' => 1
);

my %type = (
    'all'                      => 0,
    'wind'                     => 1,
    'snow'                     => 2,
    'ice'                      => 2,
    'snow/ice'                 => 2,
    'thunderstorm'             => 3,
    'fog'                      => 4,
    'extreme high temperature' => 5,
    'extreme low temperature'  => 6,
    'coastal event'            => 7,
    'forestfire'               => 8,
    'avalanches'               => 9,
    'rain'                     => 10,
    'unnamed'                  => 11,
    'flood'                    => 12,
    'rainflood'                => 13
);

my %weather_to_text = (    # lower case for consistency
    1  => 'wind',
    2  => 'snow/ice',
    3  => 'thunderstorm',
    4  => 'fog',
    5  => 'extreme high temperature',
    6  => 'extreme low temperature',
    7  => 'coastal event',
    8  => 'forestfire',
    9  => 'avalanches',
    10 => 'rain',
    11 => 'unnamed',
    12 => 'flood',
    13 => 'rainflood'
);

my $url_base = "http://meteoalarm.eu/en_UK";

sub new {
    my $class = shift;
    my $self  = {};
    my %args  = @_;
    $self->{'user_agent'} = _make_user_agent( $args{'user_agent'} );
    bless( $self, $class );
    return $self;
}

sub countries {
    my $self = shift;
    my %args = @_;

    my $type = _get_type($args{type});
    my $day = _get_day($args{day});

    my $url = _make_country_url( $day, $type );
    my $content = $self->_fetch_content( $url );
    return _parse_country_warnings($content);
}

sub regions {
    my $self = shift;
    my %args = @_;

    croak "Invalid country_code: $args{country_code}"
      unless $args{country_code};

    my $day = _get_day($args{day});
    my $type = _get_type($args{type});
    my $country_name = _get_country_name($args{country_code});

    my $url = _make_country_url($day, $type, $country_name);

    my $content = $self->_fetch_content( $url );
    return _parse_region_warnings($content);
}

sub details {
    my $self = shift;
    my %args = @_;

    my ( $region, $code ) =
      $args{region_code} =~ /^([ABCDEFGHILMNPRSU][A-Z])(\d\d\d)/;
    $code =~ s /^0//;
    croak "Invalid region_code: $args{region_code}"
      unless ( exists $countries{$region}
        and ( $code <= $countries{$region}{code} ) );

    my $country_name = _get_country_name($region);
    my $type = _get_type($args{type});
    my $day = _get_day($args{day});

    my $url = _make_country_url($day, $type, $country_name);
    my $content = $self->_fetch_content( $url );
    return _parse_details($content);
}

sub codes {
    my $self = shift;
    my @codes;
    my @countries_short;

    if (@_) {
        @countries_short = @_;
    }
    else {
        @countries_short = _get_all_short_country_codes();
    }

    foreach my $country_short (@countries_short) {
        my $url = _make_country_url(0, 0, _get_country_name($country_s
+hort));
        my $content = $self->_fetch_content( $url );
        push @codes, _parse_codes($content);
    }
    return @codes;
}

sub _make_country_url {
    my ( $day, $type, $country_name ) = @_;

    $country_name //= 'EU-Europe';

    return "$url_base/$day/$type/$country_name.html";
}

sub _fetch_content {
    my ( $self, $url ) = @_;
    my $ua = LWP::UserAgent->new;
    $ua->agent($self->{user_agent});
    my $res = $ua->request( HTTP::Request->new( GET => $url ) );

    croak " Can't fetch http://meteoalarm.eu: $res->status_line \n"
      unless ( $res->is_success );

    return $res->decoded_content;
}

sub _parse_country_warnings {
    my $content = shift;
    my $p       = HTML::TreeBuilder->new_from_content($content);
    my (%data);

    my @cells = $p->look_down( _tag => q{td}, class => qr/^col[12]$/ )
+;
    for my $cell (@cells) {
        my @src;
        my $div = $cell->look_down( _tag => q{div} );
        my $id  = $div->id;
        my $alt = $div->attr(q{alt});

        $data{$id}{fullname} = $alt;

        my @weather_events =
          $div->look_down( _tag => 'span', class => qr{warn awt} );
        $data{$id}{warnings} =
          _parse_weather_events( \@weather_events );

        #
        # get tendency
        #
        my $tendency = $div->look_down(
            _tag  => 'div',
            class => qr{tendenz awt nt l\d}
        );
        if ( $tendency->{class} ) {
            $tendency->{class} =~ /tendenz awt nt l(\d)/;
            $data{$id}{tendency} = $1;
        }
    }
    return \%data;
}

sub _parse_region_warnings {
    my $content = shift;
    my $p       = HTML::TreeBuilder->new_from_content($content);

    my (%data);

    my @cells = $p->look_down(_tag=>qr{div}, id=>qr{area});
    for my $cell (@cells) {
        $cell->id =~ /area_([A-Z][A-Z]\d+)/;
    my $id = $1;
    my $fullname = $cell->look_down(_tag=>'span',id=>'cname')->as_text
+;
        my $div = $cell->look_down( _tag => q{div} );
        $data{$id}{fullname} = $fullname;

        my @weather_events =
          $div->look_down(_tag=> 'span', class=>qr{warnflag warn2});
        $data{$id}{warnings} =
          _parse_weather_events( \@weather_events );

        #
        # get tendency
        #
        my $tendency = $div->look_down(
            _tag  => 'span',
            class => qr{tendenz awt\d l\d}
        );
        if ( $tendency->{class} ) {
            $tendency->{class} =~ /tendenz awt\d l(\d)/;
            $data{$id}{tendency} = $1;
        }
    }
    return \%data;
}

sub _parse_weather_events {
    my $events = shift;

    my %literal_warnings;
    for my $event (@$events) {
        #print $event->{class}, "\n";
        $event->{class} =~ /warn\d* awt\d l(\d+) t(\d+)/;
        my $warn_level = $1;
        my $weather    = $2;
        $literal_warnings{ $weather_to_text{$weather} } = $warn_level;
    }
    return \%literal_warnings;
}

sub _parse_details {
    my $content = shift;
    my (%data);
    my $p = HTML::TreeBuilder->new_from_content( decode_entities $cont
+ent);
    $data{fullname} = $p->look_down( _tag => q{h1} )->as_text;

    if (
        $p->look_down(
            _tag  => q{div},
            class => q{warnbox awt nt l l1}
        )
      )
    {
        $data{warnings} = 'no warnings';
    }
    else {

        my @warnboxes = $p->look_down(
            _tag  => q{div},
            class => qr/warnbox awt/
        );

        for my $warnbox (@warnboxes) {

            my ($as_txt);

            my @info_divs = $warnbox->look_down(
                _tag  => q{div},
                class => q{info}
            );

            $as_txt = $info_divs[0]->as_text;

            my ( $from, $until ) = $as_txt =~ /valid from (.*) Until (
+.*)$/;

            $as_txt = $info_divs[1]->as_text;
            my ( $warning, $level ) =
              $as_txt =~ /(.+?)\s+Awareness Level:\s+(.*)/;
            $warning =~ s/s$//;

            my $text = $warnbox->look_down(
                _tag  => q{div},
                class => q{text}
            )->as_text;

            $data{warnings}{ lc $warning } =
              {    #lower case for constistency
                level => $level,
                from  => $from,
                until => $until,
                text  => $text,
              };
        }
    }
    return \%data;
}

sub _parse_codes {
    my $content = shift;
    my $p       = HTML::TreeBuilder->new_from_content($content);
    my (%data);

    #my @cells = $p->look_down( _tag => 'div', class => 'flags' );
    my @cells = $p->look_down( _tag => qr{a} );
    for my $cell (@cells) {
        if ( $cell->attr('xlink:href') ) {
            if ( $cell->attr('xlink:href') =~ /\/([A-Z][A-Z]\d+)-(.+?)
+.html/ ) {
                my $code     = $1;
                my $fullname = $2;
                $data{$fullname} = $code;
            }
        }

    }
    return \%data;
}

sub _make_user_agent {
    my $ua = shift;
    $ua =
'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:55.0) Gecko/20100101 Fire
+fox/55.0'
      unless ($ua);
    return $ua;
}

sub _extract_details_fullname {
    my $content = shift;
    my $region;
    if ( $content =~ /<h1>Weather warnings: (.+?)<\/h1>/ ) {
        $region = $1;
        decode_entities($region);
        if ( $region =~ /.??<.*<\/a>/ ) {
            $region =~ s/.??<.*<\/a>//;
        }
    }
    else {
        carp "Can't get region name\n";
    }
    return $region;
}

sub _get_day {
    my $day = shift;
    return $day{ $day // 'today' } // 0;
}

sub _get_type {
    my $type = shift;
    return $type{ $type // 'all' } // 0;
}

sub _get_all_short_country_codes {
    return sort keys %countries;
}

sub _get_country_code {
    my $region = shift;
    croak "Invalid region $region" unless exists $countries{$region};
    # $region === $countries{$region}{code} with the current data ... 
+but who knows about future updates?
    return $countries{$region}{code};
}

sub _get_country_name {
    my $code = shift;
    croak "Invalid country_code: $code" unless $code and exists $count
+ries{$code};
    return $countries{$code}{name};
}

1;

__END__

=head1 NAME
B<Meteoalarm> - OO Interface for meteoalarm.eu

=head1 SYNOPSIS
 
This Module gets weather warnings from meteoalarm.eu.
For further reading of terms and conditions see L<meteoalarm.eu|http:/
+/meteoalarm.eu/terms.php?lang=en_UK/>

 use Meteoalarm; 
my $meteo = Meteoalarm->new( 'user_agent' => 'Meteobot 0.001' );
my $countries = $meteo -> countries ('type' => 'all', 'day' => 'today'
+);
foreach my $country_code (sort keys %{$countries}){
    print "Country: $countries->{$country_code}->{'fullname'}\n";
    print "Tendency = $countries->{$country_code}->{tendency}\n" if ( 
+$countries->{$country_code}->{'tendency'});
    if (keys %{$countries->{$country_code}->{'warnings'}}){
    foreach my $warning (keys %{$countries->{$country_code}->{'warning
+s'}}){
            print "Event: $warning, severity: $countries->{$country_co
+de}->{'warnings'}->{$warning}\n";
    }
}
    else {print "No Warnings\n";}
}

 my $regions = $meteo->regions( 'country_code' => 'PT', 'day' => 'toda
+y', 'type' => 'all' );
foreach my $code ( sort keys %{$regions} ) {
    print "Region : $regions->{$code}->{'fullname'}: region_code = $co
+de\n" if ( keys %{ $regions->{$code}->{'warnings'} } );
    print "Tendency = $regions->{$code}->{tendency}\n" if ( $regions->
+{$code}->{'tendency'});
    foreach my $type ( keys %{ $regions->{$code}->{'warnings'} } ) {
        print
"$type Severity: $regions->{$code}->{'warnings'}->{$type}\n";
    }
}

 my $details = $meteo->details( 'region_code' => 'UK010', 'day' => 'to
+day');
my $name = $details->{'fullname'};
print "$name\n";

if ( $details->{warnings} eq 'no warnings' ) {
    print $details->{warnings}, "\n";
}
else {
    foreach my $warning ( keys %{ $details->{'warnings'} } ) {
        print "$warning\n";
        foreach my $detail ( keys %{ $details->{'warnings'}->{$warning
+} } ) {
            print "$detail: $details->{'warnings'}->{$warning}->{$deta
+il}\n";
        }
    }
}

 my $codes = $meteo->codes('FR');
my @codes = $meteo->codes();
foreach my $code (@codes) {
    foreach my $region ( sort keys %{$code} ) {
        print "Region name: $region, region code: $code->{$region}\n";
    }
}

=head1 DESCRIPTION

$meteo -> countries returns hashref of warnings for all countries.

$meteo -> regions returns hashref of warnings for all regions in a spe
+cified country

$meteo -> details returns hashref of detailled warnings for a specifie
+d region

$meteo -> codes returns arrayref of hash of name and region code of a 
+country

=head1 METHODS

=head1
    new( )

    creates a new meteoalarm object

=head2 Optional Arguments:
        new( 'user_agent' => 'Meteobot 0.001');

        changes the user agent string

=head1
    my $country = $meteo -> countries ();

=head2 Optional Arguments:

        'day' => 'today' || 'tomorrow'
        if day is not defined, default value is today

        'type' => 'all' || 'wind' || 'snow' || 'ice' || 'snow/ice' || 
+'snow' || 'ice' ||
                'thunderstorm' || 'fog' || 'extreme high temperature' 
+||
                'extreme low temperature' || 'coastal event' || 'fores
+tfire' ||
                'avalanches' || 'rain'

        if type is not defined, default type is all

=head1
    $regions = $meteo -> regions ('country_code' => 'DE');

    country_code is a 2 letter abbreviation

=head2 Optional arguments:

    day=> 'today' || 'tomorrow'
    if day is not defined, default value is today

=head1 $details = $meteo->details ('region_code' => 'ES005');

region_code consits of 2 letters for the country and 3 digits

=head2 Optional arguments:

    day=> 'today' || 'tomorrow'
    if day is not defined, default value is today

=head1
$code = $meteo -> codes ();

Returns arrayref of hash for region names and codes for all countries

=head2 Optional Arguments

    $code = $meteo -> codes ('PL');
    Countrycode for a specific country

=cut

[download]

In Section Cool Uses for Perl

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: note [id://1199977]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others exploiting the Monastery: (4)
As of 2024-04-25 23:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found