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

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
Problem reading Excel File
2 direct replies — Read more / Contribute
by gunther_maier
on Feb 10, 2016 at 05:44
    Dear Monks,
    I would appreciate help with the following problem:


    I download some data via a weblink, which in my web browser I can either save as XLSX-file or open in Excel. In the latter case, the file opens in protected view and I need to click the button "Enable Editing".

    What I want to do:

    I want to download this file and extract some information from it all in a Perl script. I have mastered downloading with the help of LWP::Simple, but cannot find a way to read the information from the Excel file without manually opening it, clicking "Enable Editing" and saving it again. Once this is done, I can read the content without problems with Spreadsheet::XLSX.

    Many thanks
    Gunther Maier

Regex: Asterisk with NO preceding token
1 direct reply — Read more / Contribute
by pedrete
on Feb 10, 2016 at 03:09
    Hi Monks...!!

    i have "silly"? question for you, please....

    in Perl regex... what is the behaviour of an asterisk with no preceding token????

    an example of my doubt:

    .* matches  
    ok so far...



    *  also matches!!!!!!!!!

Cant find modules after upgrade
3 direct replies — Read more / Contribute
by cbtshare
on Feb 09, 2016 at 11:16

    I recently installed installed perl (v5.23.3) , now my old scripts wont work because it complains about modules, but those modules were installed and if I try reinstalling it says

    cpan -i Net::OpenSSH CPAN: Storable loaded ok (v2.51) Reading '/root/.cpan/Metadata' Database was generated on Tue, 09 Feb 2016 14:53:50 GMT CPAN: Module::CoreList loaded ok (v5.20160120) Net::OpenSSH is up to date (0.70). #>perl Can't locate Net/ in @INC (you may need to install the Net:: +OpenSSH module) (@INC contains: /usr/local/perl-5.23.3/lib/site_perl/ +5.23.3/x86_64-linux /usr/local/perl-5.23.3/lib/site_perl/5.23.3 /usr/ +local/perl-5.23.3/lib/5.23.3/x86_64-linux /usr/local/perl-5.23.3/lib/ +5.23.3 .) at line 5. BEGIN failed--compilation aborted at line 5.

    How do I install the modules in the new location or have the metadata read in the new location? thank you

Unable to establish SMB2 connection using Filesys::SmbClient
2 direct replies — Read more / Contribute
by Netras
on Feb 09, 2016 at 08:05

    Hello Perl Monks,

    I need to access a SMB host which requires SMB version 2. Filesys::SmbClient (3.2) has served me well working with SMB1 but does not successfully create a SMB2 connection. This is the error I get:

    samba_tevent: EPOLL_CTL_DEL EBADF for fde[0x27c9930] mpx_fde[(nil)] fd[8] - disabling

    Directly using smbclient with SMB version 2 works fine:

    smbclient -U domain\\user //HOSTNAME/ShareName -c "dir" -m SMB2

    But when omitting the max-protocol tag (-m) while using smbclient, a very similar error appears:

    smbclient -U domain\\user //HOSTNAME/ShareName -c "dir" samba_tevent: EPOLL_CTL_DEL EBADF for fde[0x7f454d1eff50] mpx_fde[(nil +)] fd[7] - disabling

    I assume that Filesys::SmbClient is trying to use SMB version 1 to connect to the target host and I have no idea how I can change this behaviour. I have checked the official module documentation with no success and tried forcing the client protocol version in /etc/samba/smb.conf but this has no effect on Filesys::SmbClient as well.

    Is there someone that has had this issue or has any ideas? I would appreciate any feedback and/or help in the matter.

    Thank you!

How to input text into Facebook's event form with WWW::Mechanize::Firefox?
1 direct reply — Read more / Contribute
by nysus
on Feb 09, 2016 at 01:23

    Facebook has no API for submitting an event to a Facebook page. So I'm attempting to use WWW::Mechanize::Firefox with this script:

    my $mech = WWW::Mechanize::Firefox->new(activate => 1); $mech->autoclose_tab(0); $mech->get(''); if ($mech->title eq 'Facebook - Log In or Sign Up') { $mech->submit_form( with_fields => { email => '', pass => 'my_password', } ); } sleep(1); $mech->get(''); my $page_id = 777777777777777; $mech->click({ synchronize => 0, xpath => '//a[text() = "Create Event" +]' }, 10, 10); sleep(3); # selects all input fields and sets value to 'hello world' # even though values are set, the fields remain blank despite trying t +o simulate some js events # per suggestion from Corion, the man himself, at http://www.perlmonks my @selectors = $mech->selector('input'); foreach my $selector (@selectors) { $selector->__event('focus'); $selector->{value} = 'hello world'; $selector->__event('change'); $selector->__event('blur'); } # attempts to publish event, results in form errors because fields are + blank $mech->click({ synchronize => 0, xpath => '//button[text() = "Publish" +]' });

    I have verified that the input fields are getting values set by printing the values out. I'm sure there's got to be a way to do this but I can't figure it out.

    $PM = "Perl Monk's";
    $MCF = "Most Clueless Friar Abbot Bishop Pontiff Deacon";
    $nysus = $PM . $MCF;
    Click here if you love Perl Monks

Do a named regex group in 5.8?
3 direct replies — Read more / Contribute
by crusty_collins
on Feb 08, 2016 at 15:57
    I was wondering if I can do a named group regex with some kind of trickery like is available in 5.10?
    any ideas?

    snippet from
    (?<x>abc){3} matches abcabcabc. The group x matches abc.

    "We can't all be happy, we can't all be rich, we can't all be lucky and it would be so much less fun if we were. There must be the dark background to show up the bright colours." Jean Rhys (1890-1979)
Tk::LabEntry - how to reach the configuration of label via callback?
2 direct replies — Read more / Contribute
by vagabonding electron
on Feb 07, 2016 at 08:28
    Hi All,

    I try to validate the content of entry in Tk::LabEntry widget. I would like to change the configuration of the label part if the content is not a number (simply to color it red). I can do this with the background of the entry (code below), however an attempt to reach the option -labelBackground produces an error message "unknown option".

    I know that Tk::LabEntry is a Mega-Widget. I cannot find a way to reach its configuration (that is, the label part) via callback. It would work if I call the widget by name (that is,  $le->configure(-labelBackground => 'red'); would do the job in the code below). I would like to stick with callback however since I have several such widgets in the real application.

    Please give me an advice. Thank you!

    #!/perl use strict; use warnings FATAL => qw(all); use Tk; use Tk::LabEntry; use List::Util qw(first); use Scalar::Util qw(looks_like_number); my $mw = MainWindow->new(); $mw->title("Test"); my $test = 8; my $width = 250; my $length = 125; $mw->minsize($width, $length); my $FONT = $mw->fontCreate(-family => 'verdana', -size => 14, -weight => 'normal'); my $le = $mw->LabEntry(-label => 'Value', -labelPack => [qw/-side left -anchor w/], -labelFont => '9x15bold', -font => $FONT, -relief => 'ridge', -textvariable => \$test, -width => 2, )->pack(); $le->bind('<Key>' => sub { labelCheck($_[0]);}); MainLoop; sub labelCheck { my $x = $_[0]->get(); if ( !(looks_like_number($x)) or ($x < 0) ) { $_[0]->delete(0, 'end'); $_[0]->configure( -background => 'red'); # $_[0]->configure( -labelBackground => 'red'); } else { $_[0]->configure( -background => '#f0f0f0',); # $_[0]->configure( -labelBackground => '#f0f0f0'); do_something(); } return 1; } sub do_something { print $test, $/; }
Getting stranger values in subtraction
7 direct replies — Read more / Contribute
by Anonymous Monk
on Feb 06, 2016 at 02:50

    Dear Monks,

    I am at my wits' end over the values "-3.5527136788005e-015" and "-1.4210854715202e-014" when 0 is expected in each case. I'm on Windows Perl 5.14.

    Essentially, what I am doing is to subtract a total amount (a session value) from each item's amount. Sometimes I get the expected 0 but sometimes I get strange values even though last amount to be subtracted from the total amount is equal to that total amount:

    foreach my $key (sort keys %$cart_info) { my $qty = $cart_info->{$key}->{qty}; my $amount = $cart_info->{$key}->{amount}; $session->param('CART')->{total_amount} -= $amount; $session->param('CART')->{total_qty} -= $qty;; } # First sample Before: session_total_amt: 585.86 After: key: 116, amount: 112.09, session_total_amt: 473.77 Before: session_total_amt: 473.77 After: key: 117, amount: 69.75, session_total_amt: 404.02 Before: session_total_amt: 404.02 After: key: 118, amount: 113.57, session_total_amt: 290.45 Before: session_total_amt: 290.45 After: key: 123, amount: 113.57, session_total_amt: 176.88 Before: session_total_amt: 176.88 After: key: 124, amount: 69.75, session_total_amt: 107.13 Before: session_total_amt: 107.13 After: key: 125, amount: 80.89, session_total_amt: 26.24 Before: session_total_amt: 26.24 After: key: 50, amount: 26.24, session_total_amt: -3.5527136788005e-01 +5 # Notice that both the session_total_amt and the amount to be subtract +ed are 26.24. How did I end up with -3.5527136788005e-015? # Second sample Before: session_total_amt: 319.02 After: key: 116, amount: 112.09, session_total_amt: 206.93 Before: session_total_amt: 206.93 After: key: 117, amount: 69.75, session_total_amt: 137.18 Before: session_total_amt: 137.18 After: key: 118, amount: 113.57, session_total_amt: 23.61 Before: session_total_amt: 23.61 After: key: 56, amount: 23.61, session_total_amt: -1.4210854715202e-01 +4 # Same thing here. The session_total_amt and the amount to be subtract +ed are both 23.61.

    What am I missing here? (scratch head)?

OpenSSL and Crypt::CBC don't give the same ciphertext
3 direct replies — Read more / Contribute
by LonelyPilgrim
on Feb 05, 2016 at 18:36

    Greetings, Wise Monks. I am a wayfarer returned from many travels.

    I'm taking a Network Security course and am pretty much a novice when it comes to encryption. My assignment asks me to encrypt and decrypt a 1024-byte plaintext (which happens to be a transcript from the opening of Zork) by calling the OpenSSL binary -- but that's kind of slow, I suspect owing in part to the latency of launching new processes and file I/O, so I had (what I thought to be) the bright idea of doing the decryption separately in Perl (using Crypt::CBC) and timing the difference.

    That's all well and good; doing it the Perl way appears to be considerably faster; but here's my problem: I can't get OpenSSL and Crypt::CBC to give me the same ciphertext. Can anybody help me figure out what I am doing wrong?

    My code:

    #!/usr/bin/env perl use strict; use warnings 'all'; my $test_in = 'test.txt'; my $test_out = 'test.bin'; my $cipher = 'des-cbc'; my $iv = '0123456789ABCDEF'; my $fixed_key = '0123456789ABCDEF'; open (my $infile, '<', $test_in) or die "Couldn't open $test_in for input: $!"; undef $/; my $plaintext = <$infile>; close ($infile); # OpenSSL my $enc = "openssl enc -$cipher -iv $iv -nosalt -out $test_out -K $fix +ed_key"; print "$enc\n"; open (my $pipe, "|-", $enc); print $pipe $plaintext; close $pipe; # Crypt::CBC require Crypt::CBC; require Crypt::Cipher::DES; $iv = pack("h*", $iv); $fixed_key = pack("h*", $fixed_key); my $crypt = Crypt::CBC->new( -cipher => 'Cipher::DES', -iv => $iv, -key => $fixed_key, -literal_key => 1, -header => 'none', ); my $ciphertext = $crypt->encrypt($plaintext); open (my $cipherout, '>', 'cryptx.bin') or die "Couldn't open cryptx.bin for output: $!"; binmode($cipherout); print $cipherout $ciphertext; close $cipherout;

    Comparing test.bin (the output from OpenSSL) and cryptx.bin (the output from Perl) shows that the two are completely different from the first byte. The files are the same length (1032 bytes) and do not change with each run.

    UPDATE: I fixed it. Oh, I'm an idiot. Endianness: so simple and yet so important. It should have been H* instead of h* in my pack statements. Fix that, and it gives the right result.

How to not send TLS 1.0 on https soap call
1 direct reply — Read more / Contribute
by davew
on Feb 05, 2016 at 13:29

    I had a perl app to query some data via SOAP, and it was working up until yesterday. Now I just get the error:

    LWP::Protocol::https::Socket: SSL connect attempt failed at /usr/lib/perl5/site_perl/5.8.8/LWP/Protocol/ line 47.

    Someone from the server team told me they just upgraded to no longer support TLS 1.0. I've tried a few things (including upgrading my openssl library from 0.9.8 to 1.0.1), and still can't get it working.

    Here is the snippet of what was working before:

    #!/usr/bin/perl use strict; use LWP::UserAgent; use HTTP::Request; use HTTP::Response; my $ua = LWP::UserAgent->new(); $ua->ssl_opts( SSL_ca_file => '/var/www/cgi-bin/sz/api/apisb-fullrootchain.crt', SSL_verifycn_scheme => 'http', SSL_verifycn_name => '' ); my $req = HTTP::Request->new(POST => ' +s/services/a/68.0'); $req->header( 'Content-Type' => 'text/xml; charset=utf-8', 'SOAPAction' => 'login' ); $req->content($xml_content); my $resp = $ua->request($req);

    In addition to upgrading openssl library, I also tried adding the SSL_version param to ssl_opts call (trying all kinds of permutations of the version string such as tlsv1_1, tlsv11, etc).

    $ua->ssl_opts( SSL_version => '!TLSv1', SSL_ca_file => '/var/www/cgi-bin/sz/api/apisb-fullrootchain.crt', SSL_verifycn_scheme => 'http', SSL_verifycn_name => '' );

    Also, I tried this with similar permutations:

    my $context = new IO::Socket::SSL::SSL_Context( SSL_version => '!tlsv1', ); IO::Socket::SSL::set_default_context($context);

    Here are my specifics:

    [root@one-commerce-vm.cs.qai install]# perl -MIO::Socket::SSL -e 'prin +t "$IO::Socket::SSL::VERSION\n"' 2.023 [root@one-commerce-vm.cs.qai install]# perl -MNet::SSLeay -e 'print "$ +Net::SSLeay::VERSION\n"' 1.72 [root@one-commerce-vm.cs.qai install]# perl -MNet::HTTP -e 'print "$Ne +t::HTTP::VERSION\n"' 6.09 [root@one-commerce-vm.cs.qai install]# perl -MLWP::UserAgent -e 'print + "$LWP::UserAgent::VERSION\n"' 6.15 [root@one-commerce-vm.cs.qai install]# openssl version -a OpenSSL 1.0.1g 7 Apr 2014 built on: Fri Feb 5 09:19:23 PST 2016 platform: linux-x86_64 options: bn(64,64) rc4(16x,int) des(idx,cisc,16,int) idea(int) blowfi +sh(idx) compiler: gcc -DOPENSSL_THREADS -D_REENTRANT -DDSO_DLFCN -DHAVE_DLFCN_ +H -Wa,--noexecstack -m64 -DL_ENDIAN -DTERMIO -O3 -Wall -DOPENSSL_IA32 +_SSE2 -DOPENSSL_BN_ASM_MONT -DOPENSSL_BN_ASM_MONT5 -DOPENSSL_BN_ASM_G +F2m -DSHA1_ASM -DSHA256_ASM -DSHA512_ASM -DMD5_ASM -DAES_ASM -DVPAES_ +ASM -DBSAES_ASM -DWHIRLPOOL_ASM -DGHASH_ASM OPENSSLDIR: "/usr/local/ssl"

    Any suggestions appreciated!

Need help to remove AutoLoader in Tx::Text::SuperText
2 direct replies — Read more / Contribute
by capfan
on Feb 05, 2016 at 13:06

    Hi all!

    I just got co-maint on Tk::Text::SuperText. I wanted to make it look better, like having a lib folder and tests.

    There is also some issues in this module and I would like to investigate. However, the module does use AutoLoader, which makes it harder for me to understand the module.

    So I tried to remove AutoLoader. Simply remove the use AutoLoader statement, remove the __END__ block and move all method inside the module.

    But then it happens: suddently, stuff that worked before does not work anymore. To be precise: With the current state of the module (v0.9.5), typing a < works fine. With the new state, with the adjustments as described above, it crashes immediately.

    How can this be? Any ideas welcome.

File::Find traversing a link into a mounted flash drive
1 direct reply — Read more / Contribute
by swampyankee
on Feb 05, 2016 at 12:40

    I did a quick search, but didn't quite find anything that was sufficiently close to be an answer

    I'm trying to use File::Find to find image files, so I can randomly change my wallpaper. I know; it's a silly task ⌣. My problem is that I have a bunch of image files on a flash drive, and File::Find won't follow a symbolic link to the contents of the flash drive. I suspect it's because File::Find, even when $File::Find::follow is set won't recurse into a different file system.

    I'm using Fedora 21, Perl v5.18.4, File::Find version 1.23.

    sub image_search { my $name = $File::Find::name; my $dir = $File::Find::dir; my @globbed; my @temp; my $images = '(png$)|(jpg$)|(gif$)|(jpeg$)'; if (-l $name) { print "processing link named $name\n"; @globbed = glob("$name/*"); } else { print "processing directory named $dir\n"; @globbed = glob("$dir/*"); } if (@globbed) { @globbed = grep {m/$images/i} @globbed; $image_list{$dir} = [@globbed]; } } ## end sub image_search
    Sorry for the a) less-than-optimal code design and b) absence of comments.

    Information about American English usage here and here. Floating point issues? Please read this before posting. — emc

New Meditations
CSV headers. Feedback wanted
No replies — Read more | Post response
by Tux
on Feb 10, 2016 at 08:18

    Given small CSV data files or big(ger) CSV data files with a filter so that all of the data fits into memory, the Text::CSV_XS' csv function will most likely accomodate the common usage:

    use Text::CSV_XS qw( csv ); my $aoa = csv (in => "file.csv");

    This function also supports the common attributes for new:

    my $aoa = csv (in => "file.csv", sep_char => ";");

    or even with shortcuts and aliasses:

    my $aoa = csv (in => "file.csv", sep => ";");

    If there is lots to process inside each row, not all rows would fit into memory, or the callback structure and options for csv will obscure the code, reverting to the low level interface is the only way to go:

    use autodie; use Text::CSV_XS; my $csv = Text::CSV_XS->new ( binary => 1, auto_diag => 1, sep_char => ";", }); open my $fh, "<", "file.csv"; while (my $row = $csv->getline ($fh)) { # do something with the row } close $fh;

    Quite often a CSV data source has got one header line that holds the column names, which is easy to ask for in the csv funtion:

    # Default: return a list of lists (rows) my $aoa = csv (in => "file.csv"); # Using the header line: return a list of hashes (records) my $aoh = csv (in => "file.csv", headers => "auto");

    Or in low-level

    open my $fh, "<", "file.csv"; my @hdr = @{$csv->getline ($fh)}; $csv->column_names (@hdr); while (my $row = $csv->getline_hr ($fh)) { ...

    This week I was confronted with a set of CSV files where the separator character was changing based on the content of the file. Oh, the horror! If the CSV file was expected to contain amounts, the program that did the export chose to use a ; separator and in other cases it used the default ,. IMHO the person that decided to do this should be fired without even blinking the eye.

    This implied that on opening the CSV data stream, I - as a consumer - had to know in advance what this specific file would be like. Which made me come up with a new thought:

    "If a CSV stream is supposed to have a header line that definess the column names, it is (very) unlikely that the column names will contain unpleasant characters like embedded newlines, semi-colons, or comma's. Remember, these are column names, not data rows. Not that it is prohibited to have header fields that have comma's or other non-word characters, but let us assume that it is uncommon enough to warrant support for easy of use."

    So I wanted to convert this:

    open my $fh, "<", "file.csv"; my @hdr = @{$csv->getline ($fh)}; $csv->column_names (@hdr); while (my $row = $csv->getline_hr ($fh)) {

    where the $csv instance has to know what the separator is, to

    open my $fh, "<", "file.csv"; my @hdr = $csv->header ($fh); $csv->column_names (@hdr); while (my $row = $csv->getline_hr ($fh)) {

    which will do the same, but also detect and set the separator.

    where the new header method will read the first line of the already opened stream, detect the separator based on a default list of allowed separators, use the detected sparator to set sep_char for given $csv instance and use it to parse the line and return the result as a list.

    As this came to me as common practice, before you parse the rest of your CSV, I came up with a local method (not (yet) in Text::CSV_XS) that does this for me:

    sub Text::CSV_XS::header { my ($csv, $fh, $seps) = @_; my $hdr = lc <$fh> or return; foreach my $sep (@{$seps || [ ";", "," ]}) { index $hdr, $sep < 0 and next; $csv->sep_char ($sep); last; } open my $h, "<", \$hdr; my $row = $csv->getline ($h); close $h; @{$row // []}; } # Text::CSV_XS::header

    it even has some documentation :)

    =head2 $csv->header ($fh) Return the CSV header and set C<sep_char>. my @hdr = $csv->header ($fh); my @hdr = $csv->header ($fh, [ ";", ",", "|", "\t" ]); Assuming that the file opened for parsing has a header, and the header does not contain problematic characters like embedded newlines, read the first line from the open handle, auto-detect whether the header separates the column names with a character from the allowed separator list. That list defaults to C<[ ";", "," ]> and can be overruled with an optional second argument. If any of the allowed separators matches (checks are done in order), set C<sep_char> to that sequence for the current CSV_XS instance and use it to parse the first line and return it as an array where all fields are mapped to lower case: my $csv = Text::CSV_XS->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<:encoding(iso-8859-1)", "file.csv"; my @hdr = $csv->header ($fh) or die "file.csv has no header line\n"; # $csv now has the correct sep_char while (my $row = $csv->getline ($fh)) { ... }

    After two days of intensive use, I thought this might be useful to add to Text::CSV_XS so we all can profit, but I want to get it right from the start, so I ask for feedback (already got some from our local PM group)

    Let the bikeshedding commence ...

    • Is this functionality useful enough to add at all
    • is $csv->header a useful method name (remember we also have low level methods to deal with hashes, like $csv->column_names)
    • Is the proposed API sufficient
    • Do you see any shortcomings

    Things I envision in this function is to also auto-detect encoding when the line includes a BOM and set it to the stream using binmode or have some option to allow this new method to not only return the headers, but use them to set the column names:

    #--- my $data = "foo,bar\r\n1,baz\r\n"; open my $fh, "<", \$data; my @hdr = $csv->header ($fh); # ("foo", "bar") while (my $row = $csv->getline ($fh)) { # $row = [ "1", "baz" ] #--- my $data = "foo;bar\r\n1;baz\r\n"; open my $fh, "<", \$data; my @hdr = $csv->header ($fh); # ("foo", "bar") $csv->column_names (@hdr); while (my $row = $csv->getline_hr ($fh)) { # $row = { foo => "1", bar => "baz" } #--- my $data = "foo|bar\r\n1|baz\r\n"; open my $fh, "<", \$data; $csv->column_names ($csv->header ($fh, [ ";", ",", "|" ])); while (my $row = $csv->getline_hr ($fh)) { # $row = { foo => "1", bar => "baz" }

    Enjoy, Have FUN! H.Merijn
How to ask better questions using Test::More and sample data
1 direct reply — Read more / Contribute
by neilwatson
on Feb 08, 2016 at 15:24

    I encourage wisdom seekers to present sample data and use Test::More in the example code of their question. Let's look at some examples.

    How do I make the regex match?

    #!/usr/bin/perl use strict; use warnings; use Test::More; my $data = "Some string here"; my $regex = qr/ fancy regex here /mxis; like( $data, $regex, "Matching my regex" ); done_testing;

    Your code fails, but readers can read this code and run it and make changes that will make it pass.

    Why does my sub return an error?

    #!/usr/bin/perl use strict; use warnings; use Test::More; sub mysub { return; } ok( mysub(), "Should return true" ); done_testing;

    Presenting larger sample data as if you were reading a file line by line.

    Use __DATA__.

    #!/usr/bin/perl use strict; use warnings; use Test::More; my $wanted_matches = 2; my $actual_matches = 0; my $regex = qr/ fancy regex here /mxis; while ( my $line = <DATA> ) { chomp $line; if ( $line =~ $regex ){ $actual_matches++; } } ok( $wanted_matches == $actual_matches, "Correct number of matches" ); done_testing; __DATA__ line one..... line two..... .... line ten.....

    Neil Watson

Role Composition versus Inheritance
1 direct reply — Read more / Contribute
by choroba
on Feb 07, 2016 at 15:37
    I use Moo in my latest toy project. When experimenting with Moo::Role, I discovered the rules of interaction of role composition and inheritance are not specified in detail, and the current behaviour surprised me a bit.

    In the examples below, I'll use Role::Tiny, as that's what Moo::Role uses under the hood, and it also contains all the important documentation.

    The basic rule of role composition is the following:

    If a method is already defined on a class, that method will not be composed in from the role.

    Let's see an example:

    #! /usr/bin/perl use warnings; use strict; use feature qw{ say }; { package MyRole; use Role::Tiny; sub where { 'Role' } sub role { 'yes' } } { package MyClass; sub new { bless {}, shift } sub where { 'Class' } } { package MyComposed; use Role::Tiny::With; with 'MyRole'; sub new { bless {}, shift } sub where { 'Composed' } } my $c = 'MyComposed'->new; say $c->$_ for qw( where role );


    Composed yes

    The "yes" shows the role was composed into the class, but the "where" method still comes from the original class. So far, so good.

    What do you think should happen, if the class doesn't implement the method, but inherits it from a parent?

    { package MyHeir; use parent -norequire => 'MyClass'; use Role::Tiny::With; with 'MyRole'; } my $h = 'MyHeir'->new; say $h->$_ for qw( where role );

    For me, the output was surprising:

    Role yes

    The same happens when you apply the role to an instance of a class:

    my $o = 'MyClass'->new; 'Role::Tiny'->apply_roles_to_object($o, 'MyRole'); say $o->$_ for qw( where role );

    We started with an object of a class that implemented the where method, but the resulting object uses the role's method. Maybe because a new class is created for the object inheriting from the original one, and the role is then applied to it, as with MyHeir above?

    In fact, I needed that behaviour. As it's not documented explicitely, though, I decided to program defensively, require the where method, and use the around modifier for better readability and clearer specification of the intent:

    { package MyAround; use Role::Tiny; requires 'where'; around where => sub { 'Around' }; sub role { 'yes' } } my $o2 = 'MyClass'->new; 'Role::Tiny'->apply_roles_to_object($o2, 'MyAround'); say $o2->$_ for qw( where role );

    Even if the composition rules changed, my object would still get the where method from the role.

    ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
New Cool Uses for Perl
Automate multi-perl unit testing with Perlbrew/Berrybrew
1 direct reply — Read more / Contribute
by stevieb
on Feb 09, 2016 at 14:18

    Recently, in Re: Testing in Perl, I said I was working on a script that automates multiple test builds of a module against a number of Perlbrew instances. Below are the (brew control) script and the (test runner) script, and here's the git repo.

    This works on all platforms I've tested it on (FreeBSD, Linux and Windows). For *nix, you need to have Perlbrew installed. On Windows, Berrybrew is required. You'll also require cpanm from App::cpanminus.

    The reasoning behind this creation is due to the fact Travis CI only performs builds on Linux machines, and I wanted an easy way to perform release candidate builds on Windows as well in much the same manner.

    It was rather quickly slapped together, but it's simply a prototype. Now that I know it works pretty well, I'm going to turn it into a proper Test module.

    In your module, create a build directory in the root, and drop these two files into it. Here are some usage examples:

    Run unit tests on all currently installed perl versions:

    perl build/

    Remove all currently installed perl instances (except the one you're using), and install three new random versions, and run tests on those pristine instances (short forms for args (eg: -c for --count) are available:

    perl build/ --reload 1 --count 3

    Install all versions of perl available to Perlbrew, without removing existing instances, and enable verbose output:

    perl build/ -d 1 -c -1

    Install a specific version of perl, and run tests on all installed versions:

    perl build/ -v 5.20.1

    Example output (note that if one perlbrew instance fails tests, all processing stops (exit;) and the actual test output for the failed build is displayed along with the perl version so you can further investigate. Otherwise, on success:

    % perl build/ perl-5.23.7 perl-5.22.1 perl-5.20.3 perl-5.18.4 perl-5.14.4 perl-5.12.5 perl-5.12.5 :: PASS perl-5.14.4 :: PASS perl-5.18.4 :: PASS perl-5.20.3 :: PASS perl-5.22.1 :: PASS perl-5.23.7 :: PASS

    #!/usr/bin/perl use warnings; use strict; use Cwd; use Getopt::Long; my ($debug, $count, $reload, $version, $help); GetOptions( "debug=i" => \$debug, "count=i" => \$count, "reload=i" => \$reload, "version=s" => \$version, "help" => \$help, ); if ($help){ print <<EOF; Usage: perl build/ [options] Options: --debug | -d: Bool, enable verbosity --count | -c: Integer, how many random versions of perl to insta +ll. Send in -1 to install all available versions. --reload | -r: Bool, remove all installed perls (less the current + one) before installation of new ones --verion | -v: String, the number portion of an available perl ve +rsion according to "perlbrew available" Note that only o +ne is allowed at this time --help | -h: print this help message EOF exit; } my $cwd = getcwd(); my $is_win = 0; $is_win = 1 if $^O =~ /Win/; run($count); sub perls_available { my $brew_info = shift; my @perls_available = $is_win ? $brew_info =~ /(\d\.\d+\.\d+_\d+)/g : $brew_info =~ /(perl-\d\.\d+\.\d+)/g; if ($is_win){ for (@perls_available){ s/perl-//; } } return @perls_available; } sub perls_installed { my $brew_info = shift; return $is_win ? $brew_info =~ /(\d\.\d{2}\.\d(?:_\d{2}))(?!=_)\s+\[installed +\]/ig : $brew_info =~ /i.*?(perl-\d\.\d+\.\d+)/g; } sub instance_remove { my @perls_installed = @_; if ($debug) { print "$_\n" for @perls_installed; print "\nremoving previous installs...\n"; } my $remove_cmd = $is_win ? 'berrybrew remove' : 'perlbrew uninstall'; for (@perls_installed){ my $ver = $^V; $ver =~ s/v//; if ($_ =~ /$ver$/){ print "skipping version we're using, $_\n" if $debug; next; } `$remove_cmd $_`; } print "\nremoval of existing perl installs complete...\n" if $debu +g; } sub instance_install { my $count = shift; my @perls_available = @_; my $install_cmd = $is_win ? 'berrybrew install' : 'perlbrew install --notest -j 4'; my @new_installs; if ($version){ $version = $is_win ? $version : "perl-$version"; push @new_installs, $version; } else { if ($count) { while ($count > 0){ push @new_installs, $perls_available[rand @perls_avail +able]; $count--; } } } if (@new_installs){ for (@new_installs){ print "\ninstalling $_...\n"; `$install_cmd $_`; } } else { print "\nusing existing versions only\n" if $debug; } } sub results { my $exec_cmd = $is_win ? "berrybrew exec perl $cwd\\build\\" : "perlbrew exec perl $cwd/build/ 2>/dev/null"; my $debug_exec_cmd = $is_win ? "berrybrew exec perl $cwd\\build\\" : "perlbrew exec perl $cwd/build/"; my $result; print "\n...executing\n" if $debug; if ($is_win){ $result = `$exec_cmd`; } else { if ($debug){ $result = `$debug_exec_cmd`; } else { $result = `$exec_cmd`; } } my @ver_results = split /\n\n\n/, $result; print "\n\n"; for (@ver_results){ my $ver; if (/^([Pp]erl-\d\.\d+\.\d+)/){ $ver = $1; } my $res; if (/Result:\s+(PASS)/){ $res = $1; } else { print $_; exit; } print "$ver :: $res\n"; } } sub run { my $count = shift // 0; my $brew_info = $is_win ? `berrybrew available` : `perlbrew available`; my @perls_available = perls_available($brew_info); $count = scalar @perls_available if $count < 0; my @perls_installed = perls_installed($brew_info); print "$_\n" for @perls_installed; if ($debug){ print "$_ installed\n" for @perls_installed; print "\n"; } my %perl_vers; instance_remove(@perls_installed) if $reload; instance_install($count, @perls_available); results(); }

    #!/usr/bin/perl use warnings; use strict; use Cwd; my $cwd = getcwd(); if ($^O ne 'MSWin32'){ system "cpanm --installdeps . && make && make test"; } else { system "cpanm --installdeps . && dmake && dmake test"; }
Log In?

What's my password?
Create A New User
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (13)
As of 2016-02-10 13:23 GMT
Find Nodes?
    Voting Booth?

    How many photographs, souvenirs, artworks, trophies or other decorative objects are displayed in your home?

    Results (346 votes), past polls