Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

The Monastery Gates

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

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
Inappropriate I/O control operation
4 direct replies — Read more / Contribute
by cormanaz
on Sep 26, 2017 at 11:22
    Good day Bros. I am getting Inappropriate I/O control operation when trying to open some text files. I have been coding Perl for a long time and this has never happened to me, so I'm a little flummoxed. I originally tried to do the open with the typeglob IN which I have always used before. I researched it a little and found some suggestions that this can cause the error and it was better practice to use a lexical filehandle, so I did so:
    #!/usr/bin/perl -w use strict; $| = 1; my @coders = qw(kristin madison scott sean steve zeb); my @files = qw( 17524106 18033790 19683851 27033992 3987896 4058888 4139141 4454294 5303897 5380762 ); foreach my $f (@files) { foreach my $c (@coders) { my $fn = "round1/$c/$f\.txt"; open(my $in, $fn); print "$f\t$c\t$!\n"; close $in; } }
    Every open returns an output like 17524106    kristin    Inappropriate I/O control operation Another strange thing is that the above is a pared-down version of a script that actually processes the data in the files. When I ran that, it read and processed the files for some of the @coders (I/O error notwithstanding) but not the others.

    Not sure what I'm doing wrong or how to fix it. Suggestions?

Set condition only if array becomes empty
2 direct replies — Read more / Contribute
by Anonymous Monk
on Sep 26, 2017 at 08:50

    I need to execute "else" condition only if , foreach checks all the values of the array and array has become empty. I am using the following code (some commands are internal to the organization, but you can infer)

    $rh->cmd('show pim join summary | except "^Instan +ce|^Route"'); my $output = $rh->get_response; my @outputlist = split /\s+/, $output; foreach $output (@outputlist) { if ($output eq "3000") { put_log("All PIM groups are learned in + Master"); } else { put_log ("fail"); } }

    output of the above command "show pim join summary | except "^Instance|^Route" is below

    regress@sherlock# run show pim join summary | except "^Instance|^Route +" (s,g) 3000 200

    In the above code, foreach gets each member of the array and it finds 3000 in the middle and it passes, but i want the else condition to be executed only once , not for each array element comparison. More precisely, else should be excuted only after the array is empty and 3000 is not found. Is there a way to do it

using "require" problem
4 direct replies — Read more / Contribute
by gauss76
on Sep 26, 2017 at 03:51

    Hi All

    I have the following problem and don't know how to resolve it.

    Basically, I have a perl .pl file (main.pl) that requires another .pl file (routines.pl) in order to work correctly (everything running on a Linux machine). The files are both in the same folder and I currently use the following syntax in the file main.pl

    require "./routines.pl";

    This works fine if I run main.pl from the folder that contians the two files. However if I run the program from a different folder with, say, the command

    perl /home/user/code/main.pl

    Then I get an error saying "can't locate ./routines.pl.

    I know that I can change the "require" statement to:

    require "/home/user/code/routines.pl"

    However, for me, this is not an option as I need to copy the code to another Linux system where the containing folder will be different (the two files will still be in the same folder)

    So, my question: Is there any way to use the same "require" statement so that I can run my program from any folder with the command

    perl /home/user/code/main.pl

    where the folder for the code (/home/user/code/main.pl) can change?

    Please let me know if anything is not clear.

    Many thanks for any help on this

    gauss76

CPAN Catch-22
1 direct reply — Read more / Contribute
by snax
on Sep 25, 2017 at 16:37

    So I've managed to shoot myself in the foot. Earlier today I did an update of my CPAN module, via a perl -MCPAN -e shell session. This was kind of a reflex because I hadn't used CPAN for a while. That turned out OK (upgraded to v2.14 of CPAN), but ever since, any time I use perl -MCPAN -e shell and try to install or update anything, I get an annoying error:

    Will not use CPAN::Meta::Requirements, need version 2.120920

    Naturally that requirement is a literal specification in the v2.14 CPAN.pm module code. It's not "need >=". I have v2.125 of CPAN::Meta::Requirements.

    Any clues on how best to sort this out? I grabbed source for CPAN v 2.16 but building that shows I need to upgrade other things, and I want to be able to rely on the CPAN module for managing packages. It's great when it works right :)

Run multiple alert monitoring perl scripts on several Linux machines hosting multiple oracle DB
4 direct replies — Read more / Contribute
by aravind.kalla
on Sep 25, 2017 at 16:06

    Hi Monks,

    I am looking for Perl solutions where I need to read JSON configuration file containing linux server details and connected oracle DB information,
    read this and run several Alert scripts on these DB's...say 100 Linux servers each hosting 4 oracle DB...The process is currently working in a serial manner.

    i.e. reads the json file for {1st Linux server->1st DB-> Run Alert scripts.}
    1st Linux server->2nd DB-> Run Alert scripts.
    ...3rd DB
    ...4th DB

    Then reads the json file for {2nd Linux server ->1st DB-> Run Alert scripts}
    2nd Linux server->2nd DB-> Run Alert scripts.
    ...3rd DB
    ...4th DB

    and so on for next 100 (linux servers) * 4 (DBS) = 400 (hosts to monitor.)

    This is again connected to a scheduling tool crontab for every 60 mins... but since its running serially for all 100 servers its taking nearly 90 mins ....and hence the second run overlapping the first run. Looking for robust parallel solutions!!!!

When modules install in perl5
6 direct replies — Read more / Contribute
by cristofayre
on Sep 25, 2017 at 08:00

    My shared server has the usual "!#/usr/bin/perl" for use by everyone, but personal installations appear to go into "perl/usr/lib/perl5" folder.

    So if my scripts access the former, all is well. But to access the latter ...??? Have I got to change all my scripts to the new path of "!# perl/usr/lib/perl5" or is there a way to 'force' the new path into @inc. How would you do it if some "use xxx" are in /usr/bin/perl, and some in the second folder?

    Did my last host use a "symlink" for this, and if so, where did he put it.

    Finally, if the "use" entry could not be found, would this generate a "suexec violation" error? A script using "File::Find::Rule", permission 755 designed to update all the file permissions came back with the above for a 500 error. I asked host, and their response: "Please set all your perl files to 755" (In otherwords, they had no idea!)

    This is the script:

    #!/usr/bin/perl print "content-type: text/html\n\n"; # use CGI::Carp qw( fatalsToBrowser ); use File::Find::Rule; my @files = File::Find::Rule->file()->name('*.pl')->in('/home/cristofa +/public_html'); # set ->in('.') to start from current directory for ($x=0; $x<@files; $x++){ chmod (0755, $files[$x]); print "$files[$x]&lt;br&gt;"; } print "All done";

    # CARP is commented out because - whilst CGI is installed - it doesn't specifically list CGI::CARP. I installed the latter ... which comes back to the initial "perl5" path query! Script works on my Windows / Strawberry perl version.

    And yes, I know you CAN use a foreach / while loop ... but I still find that a bit 'symbolic' and prefer to 'see' what's happening each loop.

Looping trough Array Key/Value Pairs
6 direct replies — Read more / Contribute
by maikelnight
on Sep 25, 2017 at 06:45

    Dear Monks, i am new to perl...I have an array which Dumps to this:

    $VAR1 = { '_shards' => { 'skipped' => 0, 'successful' => 5, 'total' => 5, 'failed' => 0 }, 'hits' => { 'hits' => [ { '_id' => 'AV6SrwuTv7sBjjRqMiW1', '_source' => { 'request' => '/inde +x.php', 'clientip' => '192. +168.1.1' }, '_type' => 'nginx', '_index' => 'nginx-2017.09.18', '_score' => '4.238926' }, { '_id' => 'AV6UL-DOv7sBjjRqMidb', '_source' => { 'clientip' => '192. +168.1.1', 'request' => '/' }, '_score' => '4.189655', '_type' => 'nginx', '_index' => 'nginx-2017.09.18' } ], 'total' => 2, 'max_score' => '4.238926' }, 'took' => 0, 'timed_out' => undef };

    I try to get the key/values from '_source' but i dont know how. I can dump for example with: "print Dumper $_->{'hits'}{'hits'}->[0]->{'_source'};" and foreach, and get the pair from [0] and i can alter [0] to 1 and get the other pair.

    foreach $_(@testarray) { print Dumper $_->{'hits'}{'hits'}->[0]->{'_source'}; }

    But how can i loop through to get all the values? I tried to loop with foreach and a counter but it didnt work, it always gives [0] (indeed i might make a mistake). May i ask one to get me some help how to? Thanks a lot.

PPI replacing/updating a stub
3 direct replies — Read more / Contribute
by clueless newbie
on Sep 24, 2017 at 11:41

    How to replace a (sub's) stub using PPI?

    I'm playing with PPI and the problem of fleshing out a stub has me baffled. The following snippet illustrates my problem.

    #!/usr/bin/env perl use if (-d 'C:/Users/clueless_newbie'),lib=>'C:/Users/clueless_newbie/ +GOOGLE~1/code/lib'; use if (-d 'C:/Users/clueless_newbie'),lib=>'C:/Users/clueless_newbie/ +code/Perl-5/devlib'; # $ENV{DBG} -> compile time; $ENV{DEBUG} -> run time. use if ($ENV{DBG} || $ENV{DEBUG}),"Devel::UnComment","#[=]#","Keep"; use Data::Dumper; use PPI; use PPI::Dumper; use strict; use warnings; use 5.10.0; { # INTERNALS }; # INTERNALS my $raw=<<'__RAW__'; package FeeFi; sub Fee { print "Fee\n"; } sub Fi { print "Fi\n"; } -1; __RAW__ my %sub_h; { # Save the subs; replacing them with placeholders # Create the PPI document my $document=PPI::Document->new(\$raw) or die "oops!"; $document->save('before'); for my $sub (@{$document->find('PPI::Statement::Sub') || []}) { unless ($sub->forward) { #say $sub->name; # save the sub and its content $sub_h{$sub->name}{content}=$sub->content; # Replace the sub's block as a stub by removing its childr +en my @elements=$sub->block->children; for (my $i=0; $i < @elements; $i++) { $elements[$i]->remove; }; }; }; # Save the stubbed out "main/package" under the key ''; $sub_h{''}{content}=$document->content; }; #=# DEBUG [ sub_h=>\%sub_h ]; # Completing the round trip { # Create the stubbed out main my $document=PPI::Document->new(\$sub_h{''}{content}) or die "oops creating ''!"; #=# DEBUG '',PPI::Dumper->new($document,whitespace=>0)->string; # Find and flesh out the stubs for my $stub (@{$document->find('PPI::Statement::Sub') || []}) { unless ($stub->forward) { my $name=$stub->name; #=# TRACE $name; # Flesh out this stub my $sub=PPI::Document->new(\$sub_h{$name}{content})->find_ +first('PPI::Statement::Sub'); #=# TRACE '',PPI::Dumper->new($sub,whitespace=>0)->string; # So ow do I flesh out the stub from $sub???? $stub->insert_after($sub) # <=== Doesn't do it! or warn "Can't insert_after!"; #=# DEBUG '',PPI::Dumper->new($document,whitespace=>0)->st +ring; }; }; #=# DEBUG '',PPI::Dumper->new($document,whitespace=>0)->string; $document->save('after'); # <=== "after" should be prog +rammatically equal to "before" }; exit;
How to do popcount (aka Hamming weight) in Perl
6 direct replies — Read more / Contribute
by eyepopslikeamosquito
on Sep 24, 2017 at 06:23

    In More Betterer Game of Life, I needed a popcount (aka Hamming weight) function to sum the one bits in a 64-bit value.

    I started with the basic popcount1 below, scraped with little thought from the Hamming_weight wikipedia page.

    I'd like to improve that, hence this node.

    use strict; use warnings; use Benchmark qw(timethese); sub popcount1 { my $x = shift; my $count; for ($count = 0; $x; ++$count) { $x &= $x - 1 } return $count; } sub popcount2 { return sprintf('%b', shift) =~ tr/1//; } # Update: unpack('%b*', pack('J', shift)) is better (see Rosetta ref. +below) sub popcount3 { return unpack('%32b*', pack('Q', shift)); } my $start = 2**32 - 42; my $end = $start + 1000000; print "sanity test for correctness\n"; for my $i (0 .. 256, $start .. $end) { my $one = popcount1($i); my $two = popcount2($i); my $three = popcount3($i); # print "$i: $one $two $three\n"; $one == $two or die; $one == $three or die; } timethese 50, { One => sub { popcount1($_) for $start .. $end }, Two => sub { popcount2($_) for $start .. $end }, Three => sub { popcount3($_) for $start .. $end }, };

    Running the above program on my machine produced:

    sanity test for correctness Benchmark: timing 50 iterations of One, Three, Two... One: 29 wallclock secs (28.41 usr + 0.00 sys = 28.41 CPU) @ 1.76/ +s (n=50) Three: 10 wallclock secs (10.00 usr + 0.00 sys = 10.00 CPU) @ 5.00/ +s (n=50) Two: 10 wallclock secs (10.03 usr + 0.00 sys = 10.03 CPU) @ 4.98/ +s (n=50)

    Improvements welcome.

    References

Win32 Network Adapter module naming
3 direct replies — Read more / Contribute
by VinsWorldcom
on Sep 22, 2017 at 09:25

    A while back I needed a Win32 module for getting network interface / adapter information much like IO::Interface or Net::Interface or Net::Libdnet .. but for Windows (obviously). Also, I know of Win32::IPConfig and Win32::IPConfig::Adapter which use the registry, but don't have all the functionality I needed. Finding nothing that suited at the time, I started to write one myself using XS and hitting the GetAdaptersAddresses() API and parsing the IP_ADAPTER_ADDRESSES structure, but alas my XS skills suck and I ended up writing a Perl interface around some 'wmic', 'netsh' and other Windows command line calls. Hey, it worked.

    I thought about CPAN upload for a long while (years) and now I probably should, but what to name it? Originally, 'Win32::GetAdapterAddresses' would have been a good name, but I don't do the XS API integration so didn't want to misrepresent the functionality. It's currently called 'Win32::Interface' - which made sense since at the time, IO::Interface was mainly the functionality I was trying to duplicate. But now not so sure. How about ...

    • Win32::Interface - descriptive (for me), but thinking of others, I'm now not so sure. Also, I see Win32::API::Interface which is totally unrelated and I could cause confusion.
    • Win32::Adapter - maybe?
    • Win32::Network::Adapter - getting un-useful-ly long just to be overly descriptive
    • Win32::Network::Interface - same as above
    • IO::Interface::Win32 - I'm not actually sub-classing IO::Interface, so probably not a good idea
    • Net::Interface::Win32 - same as above
    • Win32::IO::Interface - just iterating names now ...
    • Win32::IO::Adapter - and again ...
    • Win32::Net::Interface - again ...
    • Win32::Net::Adapter - ...

    Mainly, should it live under IO::, Net:: or Win32::, and then what name under the top level namespace? Suggestions? Maybe a Perlmonks Poll?!?

perlcall for dummies
2 direct replies — Read more / Contribute
by frazap
on Sep 22, 2017 at 03:10
    I have the following files for a embryonic keyboard hook on windows

    lib/Kbh.pm

    package Kbh; our $VERSION = '0.01'; require XSLoader; XSLoader::load('Kbh', $VERSION); sub process_key { print "process_key in perl\n"; } 1;
    Makefile.pl
    use ExtUtils::MakeMaker; WriteMakefile ( NAME => 'Kbh', VERSION => '0.01', OBJECT => 'hook.o Kbh.o', );
    hook.h
    LRESULT CALLBACK HookCallback(int nCode, WPARAM wParam, LPARAM lParam) +; void processKey(); void register_hook(); void unregister_hook(); void MsgLoop();
    hook.c
    #include <windows.h> #include <WinAble.h> #include "stdio.h" #include "hook.h" HHOOK hook; LRESULT CALLBACK HookCallback( int nCode, WPARAM wParam, LPARAM lParam + ) { processKey(); return CallNextHookEx( hook, nCode, wParam, lParam ); } void processKey() { printf("processKey in C\n"); } void MsgLoop() { MSG message; while ( GetMessage( &message, NULL, 0, 0 ) ) { TranslateMessage(&message); DispatchMessage(&message); } } void register_hook() { HMODULE hMod = (HMODULE) GetModuleHandle(NULL); hook = SetWindowsHookEx( WH_KEYBOARD_LL, HookCallback, hMod, 0 ); } void unregister_hook() { UnhookWindowsHookEx(hook); }
    and Kbh.xs
    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "hook.h" MODULE = Kbh PACKAGE = Kbh PROTOTYPES: DISABLE void MsgLoop() void register_hook() void unregister_hook() void processKey() INIT: int count; PPCODE: dSP; PUSHMARK(SP); count= call_pv("Kbh::process_key", G_DISCARD|G_NOARGS); if (count != 0) croak("Big trouble\n");
    When I run
    Perl Makefile.pl dmake

    the things compile.

    When I run runit.pl from the main directory(use ctrl+c to quit)

    runit.pl
    use lib qw(./lib ./blib/arch/auto/Kbh); use Kbh; Kbh::register_hook(); Kbh::MsgLoop; Kbh::unregister_hook();
    I see that the hook is installed, I get two messages from processKey when I hit a key, but I don't have msg "process_key from perl"

    What am I missing ?

    Thanks

    François
replace all numerics to words in a txt file
3 direct replies — Read more / Contribute
by imhacked
on Sep 22, 2017 at 02:22

    Hi, I am trying to replace all numerics to words in a very large txt file. Example as follows Sentence : I am going to 44 avenue. Result : I am going to forty four avenue. I have written as follows :

    use Lingua::EN::Numbers qw(num2en num2en_ordinal); if(isdigit (\w) s/(\w)/num2en(\w)/g;

    But I get following error :

    Unquoted string "w" may clash with future reserved word at tocorpus.pl + line 21. syntax error at tocorpus.pl line 22, near ") s/(\w)/num2en(\w)/g" Execution of tocorpus.pl aborted due to compilation errors
New Meditations
[RFC] File::Replace
2 direct replies — Read more / Contribute
by haukex
on Sep 20, 2017 at 05:50

    Many of you are probably aware of the pattern of opening a temporary file, reading from the original file and writing the modified contents to the temporary file, and then renameing the temporary file over the original file, which is often an atomic operation (depending on OS & FS). I recently wrote a module to encapsulate this behavior, and here is one of three interfaces that are available in File::Replace. There are several options to configure the behavior, including the ability to specify PerlIO layers, what happens if the file doesn't exist yet, etc.

    use File::Replace 'replace2'; my ($infh,$outfh) = replace2($filename); while (<$infh>) { # write whatever you like to $outfh here print $outfh "X: $_"; } close $infh; # closing both handles will close $outfh; # trigger the replace

    Since I hope this is something that you might find useful, I would be happy about any feedback you might have!

    To give a practical example, here is an update of my code from this node. As you can see I was able to get rid of eight lines of fairly complicated code, while keeping the main loop entirely unchanged. The module also adds some more robustness, as it incorporates a few more checks on whether operations were successful or not.

New Cool Uses for Perl
Meteoalarm - Weather warnings
1 direct reply — Read more / Contribute
by walto
on Sep 23, 2017 at 00:50
    Meteoalarm.eu (http://meteoalarm.eu) is the official website from European national weather services that gives out warnings in extreme weather situations. It has been a while ago that i wrote a perl module for processing this information. (Weather warnings from www.meteoalarm.eu). The website is still on but has changed since. That made some changes necessary. I wrote the module only for informational purposes and it is not meant to use it for anything critical. Here is the code:
    #!/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"; sub new { my $class = shift; my $self = {}; my %passed_params = @_; $self->{'user_agent'} = _make_user_agent( $passed_params{'user_agent'} ); bless( $self, $class ); return $self; } sub countries { my $self = shift; my %passed_params = @_; 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 ); 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} }; } my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } my $url = _make_country_url( $passed_params{day}, $passed_params{type} ); my $content = _fetch_content( $url, $self->{'user_agent'} ); my $country_warnings = _parse_country_warnings($content); return $country_warnings; } sub regions { my ($self) = shift; my %passed_params = @_; my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } 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 %country_codes = ( 'AT' => 'AT-Austria', 'BA' => 'BA_Bosnia-Herzegovina', 'BE' => 'BE-Belgium', 'BG' => 'BG-Bulgaria', 'CH' => 'CH-Switzerland', 'CY' => 'CY-Cyprus', 'CZ' => 'CZ-Czechia', 'DE' => 'DE-Germany', 'DK' => 'DK-Denmark', 'EE' => 'EE-Estonia', 'ES' => 'ES-Spain', 'FI' => 'FI-Finland', 'FR' => 'FR-France', 'GR' => 'GR-Greece', 'HR' => 'HR-Croatia', 'HU' => 'HU-Hungary', 'IE' => 'IE-Ireland', 'IL' => 'IL-Israel', 'IS' => 'IS-Iceland', 'IT' => 'IT-Italy', 'LT' => 'LT-Lithuania', 'LU' => 'LU-Luxemburg', 'LV' => 'LV-Latvia', 'MD' => 'MD-Moldova', 'ME' => 'ME-Montenegro', 'MK' => 'MK-Former Yugoslav Republic of Macedonia', 'MT' => 'MT-Malta', 'NL' => 'NL-Netherlands', 'NO' => 'NO-Norway', 'PL' => 'PL-Poland', 'PT' => 'PT-Portugal', 'RO' => 'RO-Romania', 'RS' => 'RS-Serbia', 'SE' => 'SE-Sweden', 'SI' => 'SI-Slovenia', 'SK' => 'SK-Slovakia', 'UK' => 'UK-United-Kingdom' ); 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} }; } croak "Invalid country_code: $passed_params{country_code}" unless $passed_params{country_code}; my $url = 'http://meteoalarm.eu/en_UK/' . $passed_params{day} . '/' . $passed_params{type} . '/' . $country_codes{ $passed_params{country_code} } . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); my $region_warnings = _parse_region_warnings($content); return $region_warnings; } sub details { my $self = shift; my %passed_params = @_; my %country_codes = ( 'AT' => 10, 'BA' => 10, 'BE' => 801, 'BG' => 28, 'CH' => 319, 'CY' => 1, 'CZ' => 14, 'DE' => 808, 'DK' => 8, 'EE' => 805, 'ES' => 831, 'FI' => 813, 'FR' => 94, 'GR' => 16, 'HR' => 806, 'HU' => 7, 'IE' => 804, 'IL' => 803, 'IS' => 11, 'IT' => 20, 'LT' => 801, 'LU' => 2, 'LV' => 804, 'MD' => 37, 'ME' => 3, 'MK' => 6, 'MT' => 1, 'NL' => 807, 'NO' => 814, 'PL' => 802, 'PT' => 26, 'RO' => 42, 'RS' => 11, 'SE' => 813, 'SI' => 801, 'SK' => 16, 'UK' => 16 ); my ( $region, $code ) = $passed_params{region_code} =~ /^([ABCDEFGHILMNPRSU][A-Z])(\d\d\ +d)/; $code =~ s /^0//; croak "Invalid region_code: $passed_params{region_code}" unless ( $country_codes{$region} and ( $code <= $country_codes{$region} ) ); my $details; 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 ); 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} }; } my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } my $url = 'http://meteoalarm.eu/en_UK/' . $passed_params{day} . '/' . $passed_params{type} . '/' . $passed_params{region_code} . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); $details = _parse_details($content); return $details; } sub codes { my $self = shift; my @codes; my @countries_short; if (@_) { @countries_short = @_; } else { @countries_short = qw(AT BA BE BG CH CY CZ DE DK EE ES FI FR GR HR HU IE IL IS +IT LT LU LV MD ME MK MT NL NO PL PT RO RS SE SI SK UK); } my %country_codes = ( 'AT' => 'AT-Austria', 'BA' => 'BA_Bosnia-Herzegovina', 'BE' => 'BE-Belgium', 'BG' => 'BG-Bulgaria', 'CH' => 'CH-Switzerland', 'CY' => 'CY-Cyprus', 'CZ' => 'CZ-Czechia', 'DE' => 'DE-Germany', 'DK' => 'DK-Denmark', 'EE' => 'EE-Estonia', 'ES' => 'ES-Spain', 'FI' => 'FI-Finland', 'FR' => 'FR-France', 'GR' => 'GR-Greece', 'HR' => 'HR-Croatia', 'HU' => 'HU-Hungary', 'IE' => 'IE-Ireland', 'IL' => 'IL-Israel', 'IS' => 'IS-Iceland', 'IT' => 'IT-Italy', 'LT' => 'LT-Lithuania', 'LU' => 'LU-Luxemburg', 'LV' => 'LV-Latvia', 'MD' => 'MD-Moldova', 'ME' => 'ME-Montenegro', 'MK' => 'MK-Former Yugoslav Republic of Macedonia', 'MT' => 'MT-Malta', 'NL' => 'NL-Netherlands', 'NO' => 'NO-Norway', 'PL' => 'PL-Poland', 'PT' => 'PT-Portugal', 'RO' => 'RO-Romania', 'RS' => 'RS-Serbia', 'SE' => 'SE-Sweden', 'SI' => 'SI-Slovenia', 'SK' => 'SK-Slovakia', 'UK' => 'UK-United-Kingdom' ); foreach my $country_short (@countries_short) { my $url = 'http://meteoalarm.eu/en_UK/' . '0' . '/' . '0' . '/' . $country_codes{$country_short} . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); push @codes, _parse_codes($content); } return @codes; } sub _make_country_url { my ( $day, $type ) = @_; my $url = 'http://meteoalarm.eu/en_UK/' . $day . '/' . $type . '/EU-Europe +.html'; return $url; } sub _fetch_content { my ( $url, $user_agent ) = @_; my $ua = LWP::UserAgent->new; $ua->agent($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 %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 %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; } 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
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
[holli]: i am designing an interface. check this out, can you tell immediatly tell me what the code does?
[holli]: scratch one "tell". you decide which ;)
[danaj]: :) Thanks, I should visit more often.

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (9)
As of 2017-09-26 21:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    During the recent solar eclipse, I:









    Results (297 votes). Check out past polls.

    Notices?