Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
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
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 install_web.pl Can't locate Net/OpenSSH.pm 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 install_web.pl line 5. BEGIN failed--compilation aborted at install_web.pl 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
No replies — Read more | Post response
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('http://facebook.com'); if ($mech->title eq 'Facebook - Log In or Sign Up') { $mech->submit_form( with_fields => { email => 'my@email.com', pass => 'my_password', } ); } sleep(1); $mech->get('https://www.facebook.com/PageName/events'); 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 +.org/?node_id=1095191 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 http://www.regular-expressions.info/refext.html
    (?<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/http.pm 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 => 'apisandbox.zuora.com' ); my $req = HTTP::Request->new(POST => 'https://apisandbox.zuora.com/app +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 => 'apisandbox.zuora.com' );

    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

Appending Text of One XML Node to that of the Other
4 direct replies — Read more / Contribute
by thomasd
on Feb 04, 2016 at 17:47

    I am having difficulties trying to figure out how to append the text from one Child Node to that of another before moving to the next parent.

    I have tried using a few different XML libraries and am currently testing XPath. That is before I decide to just write my own parser which I would rather not do right now.

    The following is a sample of the XML page

    <xdoc> <MsgSigs> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1</Description> <Key>ln1</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> </MsgSignals> </MsgSig> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1</Description> <Key>ln2</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> <Signal> <Description>0_SPN695 Eng. Override </Description> <Key>sig695</Key> <ValueType>1</ValueType> </Signal> </MsgSignals> </MsgSig> </xdoc>

    What I am trying to do is loop through the MsgSig nodes and take the key (eg, ln1, ln2) and append this key to the Description. Note: I am not wanting to go into the Signal Node (why I ruled out DOM). The result would look something like this

    <xdoc> <MsgSigs> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1 (ln1)</Description> <Key>ln1</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> </MsgSignals> </MsgSig> <MsgSig> <Description>TSC1 - Torque/Speed Cntrl 1 (ln2)</Description> <Key>ln2</Key> <XtdFrame>True</XtdFrame> <NetworkKey>net0</NetworkKey> <MsgSignals> <Signal> <Description>0_SPN695 Eng. Override </Description> <Key>sig695</Key> <ValueType>1</ValueType> </Signal> </MsgSignals> </MsgSig> </xdoc>

    As I mentioned I am currently using XPath and as a test have made it to here and here is where I sit.

    #!/usr/bin/perl -w use XML::XPath; use Data::Dumper; $file = "test.xml"; $xp = XML::XPath->new(filename => $file); @nodes = $xp->findnodes("/xdoc/MsgSigs/MsgSig"); foreach (@nodes) { $key = $_->findvalue('Key'); $descr = $_->findvalue('Description'); $text = $descr . "(" . $key . ")"; # A setValue would be awesome right about now or an # appendtext $_-> print $_->findvalue('Description'), "\n"; } #print out to xml file

    Any help would be very much appreciated.

    D. Thomas

Invalid value for shared scalar
3 direct replies — Read more / Contribute
by SwaJime
on Feb 03, 2016 at 14:31

    Hello again :-)

    Hopefully this is a simple problem ... I'd like some help getting this second method to work.

    I am working with a class that contains the following method:

    # Adds fields to a shared object sub set { my ($self, $tag, $value) = @_; lock($self); $self->{$tag} = shared_clone($value); }

    I'm trying to add a second method similar to the first:

    # Adds sub fields to a shared object sub set_alwd_info { my ($self, $tag, $value) = @_; lock($self); 43: $self->{ALWD_INFO}{$tag} = shared_clone($value); }

    But I'm getting this error when I try to run it:

    Invalid value for shared scalar at ./thread line 32.

    Full sample code:

    #!/usr/bin/perl # package ALWD::Cows; use strict; use warnings; use threads; use threads::shared qw(share is_shared shared_clone); # Constructor sub new { my $class = shift; share(my %self); # $self{ALWD_INFO} = {}; # ... ... ... my $self = bless(\%self, $class); return $self; } # Adds fields to a shared object sub set { my ($self, $tag, $value) = @_; lock($self); $self->{$tag} = shared_clone($value); } # Adds sub fields to a shared object sub set_alwd_info { my ($self, $tag, $value) = @_; lock($self); $self->{ALWD_INFO}{$tag} = shared_clone($value); } package main; my $sample = ALWD::Cows->new(); $sample->set("Key1", "Value1"); $sample->set_alwd_info("Key2", "Value2");
New Meditations
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
    watson-wilson.ca

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 );

    Output:

    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_build.pl (brew control) script and the test.pl (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/brew_build.pl

    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/brew_build.pl --reload 1 --count 3

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

    perl build/brew_build.pl -d 1 -c -1

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

    perl build/brew_build.pl -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/brew_build.pl 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

    brew_build.pl

    #!/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/brewbuild.pl [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\\test.pl" : "perlbrew exec perl $cwd/build/test.pl 2>/dev/null"; my $debug_exec_cmd = $is_win ? "berrybrew exec perl $cwd\\build\\test.pl" : "perlbrew exec perl $cwd/build/test.pl"; 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(); }

    test.pl

    #!/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?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (3)
As of 2016-02-10 04:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

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





    Results (332 votes), past polls