Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

walto:

That's nifty! I reviewed your code and have a few comments about improvements for you, in no particular order. Please note that I'm not razzing you, just offering some suggestions, I think it's a nice project all said. I'm simply offering suggestions to help you improve, as I've had people help me in a similar fashion.

  • You're using duplicate data structures in your code, causing possible maintenance problems in the future. The duplication is also distracting when you're reviewing the code.

    I suggest making your lookup tables global to your package so all your routines can refer to them. Then you can remove a lot of duplication. So rather than having:

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

    in each of your subs, just move it to the top of your module and then you don't have to create and initialize your hashes each time you call your subroutine.

  • I notice that you're using code like:
    if ( !$passed_params{type} ) { $passed_params{type} = 0; } elsif ( !$type{ $passed_params{type} } ) { $passed_params{type} = 0; } else { $passed_params{type} = $type{ $passed_params{type} }; }

    You can do it more idiomatically like this:

    $passed_params{type} = $type{ $passed_params{type} // 'all' }//0;

    So if $passed_params{type} is false, you'd default to using the 'all' type; and if $passed_params{type} isn't false, but isn't a member of %type, it would return the value for 'all'.

  • It seems to me that passed_params is unnecessarily long, causing you a few line wraps you don't really need, so I changed passed_params to args in my updated version below.
  • Since you're doing the same argument validation in multiple locations, it makes sense to move them into their own subs. I don't suggest it to shorten the code (since the idiomatic version is a single line and a subroutine is also a single line)--rather it's to reduce the 'mental overhead'. Rather than remembering the complete validation procedure (simple as it is in this case), you just call your validator. No need to update multiple locations in your program if you want to change your validator, no need to remember the details of validating a particular data item, just call your validator and move on. It simplifies the understanding and modification of your code.
  • Updating the passed_params values with the validators seems overly long to me, especially when you need to pass the values into other parts of the code. Instead, I changed things like:
    $passed_params{day} = _get_day($passed_params{day}); . . . func(..., $passed_params{day}, ...);

    into:

    my $day = _get_day($passed_params{day}); . . . func(..., $day, ...); </c>

    This way, you already know that $day is validated, and it reduces your code size making things easier to see (IMO, anyway).

Here's what your code looks like after i made changes based on these observations.

#!/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.06"; 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 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 http://meteoalarm.eu/t +erms.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' => 'today +', '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' => 'tod +ay'); 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

I made a few other changes, too, but didn't think to list them. With the changes mentioned, I was able to knock off over 100 lines of code and improve the readability. These aren't the only things I could comment on or improve, but I need to move on to other tasks today, so I'll leave it at that.

...roboticus

When your only tool is a hammer, all problems look like your thumb.


In reply to Re: Meteoalarm - Weather warnings by roboticus
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?
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others perusing the Monastery: (2)
    As of 2017-12-15 01:15 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      What programming language do you hate the most?




















      Results (415 votes). Check out past polls.

      Notices?