sub myListBox{
my @choice1;
my $path;
my @listbox_items = @_;

my $mw = MainWindow->new;
$mw->protocol('WM_DELETE_WINDOW',sub{return;});
my $lsb = $mw -> Frame();
$mw->title("Select terms");
my $lb = $mw->Scrolled("Listbox", 
       -scrollbars => "osoe",
       -height => 200,
       -width => 400,
       -selectmode => "multiple",
       -exportselection =>1)->pack( );
       
       $lb->insert('end', @listbox_items);
       $lb->pack(-side => "left");
       $lb->Button(-text => "Exit",
             -command => sub{exit; })->pack(-side => "bottom",
                                     -fill => 'x');
       $mw->Button(-text=>"Select", 
             -command => sub {
            foreach ($lb->curselection()) {
                        push @choice1, $listbox_items[$_];
                        }
                     $mw->destroy()},
     )->pack(-side => "bottom",
            -fill => 'x');

                            
my $label = $mw->Label(-text=>"Enter Directory Path:")->pack( );      
+                      
my $entry = $mw->Entry()->pack( );
my $localpath = $entry->get();
MainLoop;

return @choice1,$localpath;
}

[download]

Situation:

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

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.
[download]

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

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:

Directly using smbclient with SMB version 2 works fine:

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
[download]

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!

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"
+]' });
[download]

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.

snippet from http://www.regular-expressions.info/refext.html
(?<x>abc){3} matches abcabcabc. The group x matches abc.

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, $/; }
[download]

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.
[download]

What am I missing here? (scratch head)?

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;
[download]

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.

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);
[download]

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'
);
[download]

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);
[download]

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"
[download]

Any suggestions appreciated!

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.

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");
[download]

This function also supports the common attributes for new:

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

or even with shortcuts and aliasses:

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

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;
[download]

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");
[download]

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)) {
      ...
[download]

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)) {
[download]

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)) {
[download]

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
[download]

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)) {
     ...
     }
[download]

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" }
[download]

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;
[download]

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;
[download]

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..... 
[download]

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 );
[download]

Output:

Composed
yes
[download]

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 );
[download]

For me, the output was surprising:

Role
yes
[download]

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 );
[download]

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 );
[download]

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,
[download]

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
[download]

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
[download]

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
[download]

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

perl build/brew_build.pl -v 5.20.1
[download]

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
[download]

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();
}
[download]

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";
}
[download]