Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
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

In reply to Re^2: Meteoalarm - Weather warnings by walto
in thread Meteoalarm - Weather warnings by walto

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    [Corion]: Hurr - as I'm running some not-so-static websites nowadays, maybe I really should implement a link checker that crawls these sites and checks that all internal links work ...
    [Corion]: (in the sense of not returning 404 errors)
    [1nickt]: Corion Surely you have one or more lying around?

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (12)
    As of 2017-10-18 11:19 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      My fridge is mostly full of:

















      Results (244 votes). Check out past polls.

      Notices?