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
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
5 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//; } 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
Keeping relationally child objects alive with Moo
3 direct replies — Read more / Contribute
by SimonClinch
on Sep 21, 2017 at 06:24
    Hi Monks, The concept of inheritance carries with it a concept of parent and child, but what if I want a relational parent/child model?

    So using Moo, I tried this:

    package Myproject::Model; use Moo; has table => (is => 'rw'); sub newtable { my ($self, $table) = @_; my $tob = Myproject::Model::Table->new( # also uses Moo and define +s these ro attributes:- name => $table, model => $self, ); $self->table or $self->table({}); my $tables = $self->table; $tables -> {$table} = $tob; } 1;
    Problem is that sometimes a $tob gets destroyed in spite of being nested in a living model object.

    But rather than hack my way around what I did, I am wondering if I am missing a tried and tested way of storing relationally child objects in their relationally parent object (including if necessary upgrading from Moo to Moose). Many thanks in advance for suggestions (I am looking for architectural insight/tips rather than merely fixing the code I already have).

    One world, one people

Problem upgrading XML::Fast from 0.11 to 0.17
3 direct replies — Read more / Contribute
by mje
on Sep 21, 2017 at 05:33

    I've been using XML::Fast to process XML files for some time and successfully. However, the code was moved to a newer machine and has stopped working in some circumstances. A difference between the machines is XML::Fast version, 0.11 on original machine (working) and 0.17 on new machine (not working). When no other changes are made but to upgrade to 0.17 on the old machine it also stops working.

    The error I'm getting is:

    Failed to encode 2017-9-21T08-49-17.XML to JSON for indexing - malform +ed or illegal unicode character in string [&#65533;ndby IF], cannot c +onvert to JSON at xx.pm line 1827.

    The XML file comes from a 3rd party and is ISO-8859-1 encoded. The bit it is complaining about is <Value>Br<F8>ndby IF</Value>. A cut down version of the XML which fails is:

    <?xml version="1.0" encoding="ISO-8859-1"?> <xx feedtype="delta"><Timestamp CreatedTime="2017-09-21T06:49:17" Time +Zone="GMT"/><Value>Br°ndby IF</Value></xx>

    The code which is now failing is:

    use Cpanel::JSON::XS; use XML::Fast; sub esIndexFile2 { my ($self, $file) = @_; my $xml = do { local $/ = undef; open (my $fh, "<:encoding(ISO-8859-1)", $file) or die "Failed +to open $file - $!"; <$fh>; }; $xml =~ s/^(?:.*\n)//; # remove first line - the encoding lin +e my $hash; eval { $hash = xml2hash $xml; }; if (my $ev = $@) { warn("Failed to parse file $file for indexing - $@ - SKIPPING" +); return; } my $json = eval { encode_json($hash); # <------------ fails here }; if (my $ev = $@) { $self->logwarn("Failed to encode $file to JSON for indexing - +$@ - SKIPPING"); return; } return 1; }

    The changes file for XML::Fast is not too helpful. I have discovered adding utf8decode => 1 to the xml2hash makes it work now but I don't really understand why. I am doing anything wrong here? What might have changed in XML::Fast to cause this to happen?

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?
and all is quiet...

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









    Results (294 votes). Check out past polls.

    Notices?