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
Perl AWS Error
3 direct replies — Read more / Contribute
by cbtshare
on Feb 12, 2016 at 14:08

    Hey all, I am using the perl AWS api( https://metacpan.org/pod/VM::EC2) to make a script, the module is installed, but when I run a sample script, I am getting the error below.I search on google and cant seem to find anything wrong.Can anyone assist? Thank you

    Can't call method "architecture" on an undefined value at aws.pl line +18.
    #!/usr/local/perl-5.23.3/perl use strict; use warnings; use VM::EC2; my $ec2 = VM::EC2->new(-access_key => "5454fgfffh", -secret_key => "dscsdcsd", -endpoint => 'http://ec2.amazonaws.com ); #Get image my $image = $ec2->describe_images('ami-469e1d2a'); # get some information about the image my $architecture = $image->architecture; my $description = $image->description; my @devices = $image->blockDeviceMapping; for my $d (@devices) { print $d->deviceName,"\n"; print $d->snapshotId,"\n"; print $d->volumeSize,"\n"; }
Help me beat NodeJS
5 direct replies — Read more / Contribute
by rickyw59
on Feb 12, 2016 at 12:09

    Hello, I'm trying to write a script to go through hundreds of "log.gz" files, roughly 500,000 lines per file. Is there something limiting me? How can perl do a single file 3 times faster, but when I start forking perl's performance tanks? Below are the results of timing the parsing of a single file. When timing 70 files, nodejs takes 20 seconds and perl is at 60 seconds.

    zcat &> /dev/null 0.54s user 0.01s system 99% cpu 0.549 total node test.js 0.79s user 0.05s system 130% cpu 0.646 total perl test.pl 0.23s user 0.03s system 38% cpu 0.686 total

    I've tried forking for each file (limited to the number of cpus(24)). I've also tried dividing the logs by number of forks evenly, IE fork 24 times and each fork works n number of files, some how this was slightly slower. Both node and perl are spawning zcats and parsing line-by-line. I'm unable to use zlib, due to the files being zipped in-correctly by the device generating the logs.

    *Edit: the directory is an nfsv3 mounted SAN. For tests, I'm only reading, no printing so IO on the test server should not be an issue. Also both node and perl tests are being run in the same environment.

    #!/usr/local/bin/perl use strict; use warnings; use Parallel::ForkManager; my $pm = new Parallel::ForkManager(24); my $dir = '/data/logs/*.log.gz'; my @files = sort(glob "$dir"); for my $file(@files) { $pm->start and next; open(FH,"-|") || exec "/bin/zcat", $file; while(my $line = <FH>){ my @matches = $line =~ /".*?"|\S+/g; # print "$matches[0],$matches[1],$matches[3],$matche +s[4]; #matches[0] = date, matches[1] = time, matches[3] = source IP #matches[4] = dest IP, some other matches are used or may be used. #line is space seperated, but any field with a space is inside "", hen +ce regex instead of split. } $pm->finish; } $pm->wait_all_children;
How to wait for putty to finish before proceeding.
3 direct replies — Read more / Contribute
by SwaJime
on Feb 11, 2016 at 12:18

    Howdy again,

    More info: This is Windows 7 Enterprise running ActivePerl 5.16.3

    I've run into another problem.

    Whereas before switching to use pageant, this command does not return control to the calling script until the putty window is closed.

    putty -ssh -l $user $address -t -m $filename

    This command returns immediately and I have no way of knowing when the putty window is closed by the user.

    pageant @ppk_files -c putty -ssh -l $user $address -t -m $filename

    The reason this is a problem is because I'm trying to run two consecutive calls to putty. One to one server setting up data, the second to a second server to process that data, which is not ready until the user closes the first putty session.

    Here are sample files to illustrate: In Test1.pl, the second putty window is not opened until the first putty window is closed. This is the desired behavior. In Test2.pl, the second putty window is opened before the first window is closed. This is not good because the data has not been set up yet.

    Test1.pl:

    #!/usr/bin/perl # use strict; use warnings; system('putty -ssh -l root 192.168.100.2 -t -m C:\Users\JWSIMP~1\AppDa +ta\Local\Temp\BoKFVjf1B9'); system('putty -ssh -l operations 192.168.10.245 -t -m C:\Users\JWSIMP~ +1\AppData\Local\Temp\d60NPopq6A');

    Test2.pl:

    #!/usr/bin/perl # use strict; use warnings; system('pageant F:\.keys\acuroot_1_8_12_rsa.ppk F:\.keys\acuroot_1_8_1 +3_rsa.ppk -c putty -ssh -l root 192.168.100.2 -t -m C:\Users\JWSIMP~1 +\AppData\Local\Temp\BoKFVjf1B9'); system('pageant F:\.keys\operations_rsa.ppk -c putty -ssh -l operation +s 192.168.10.245 -t -m C:\Users\JWSIMP~1\AppData\Local\Temp\d60NPopq6 +A');

    So, long story short ... how can I get that functionality back? I don't want both sessions opening at the same time.

    Please forgive me if this is something that is already documented. I have been searching for an answer for quite some time now.

    Thanks,

    John

Multi level dependency structure
4 direct replies — Read more / Contribute
by MH1
on Feb 11, 2016 at 12:09

    Greetings monks, long time lurker, first post. Typically I can googlefoo my way around to find a solution but I'm not sure how to go about that for this problem. I have a flat file consisting of item and item dependencies. But I need to be able to track it back to find all the potential dependencies, basically following the rabbit down the hole.

    Plain Example: if item1 requires item2 and item3, and item3 requires item4 -> then item1 also requires item4.

    I'm working with around 120k rows so I know the relationships are going to be rather complex, however a task is a task.

    Relevant Code:

    #load hash after some parsing in a foreach loop push(@{$jobs{$JobName}{1}}, $blah); ... $level =1; $nextlevel = 2; while ($level <= 10) { foreach my $dep (keys %jobs) { foreach (@{$jobs{$dep}{$level}}) { print "$dep $level $_\n"; push( @{$jobs{$dep}{$nextlevel}},@{$jobs{$_}{$level}} ); next if ${$jobs{$_}{$level}}[0] eq "$dep"; last if ${$jobs{$_}{$level}}[0] eq ''; #this cancels the loop +if any of the dependencies don't have dependencies, which is a proble +m if there's additional } } $level++; $nextlevel++; }

    So one of the problems is the last statement is prematurely breaking the loop if X dep doesn't have a dep, but there's additional deps in the array. Without that terminate feature the script will run until the while loop has been fulfilled, I have no way of breaking out once I have tracked all the dependencies down. As for CPAN and modules, given my environment I'm very limited on what I can use.

    Example Data(first column is job, rest are dependencies):

    job1, job2,job1, job3,job2 job4,job2 job5,job2,job4 job6,jobz joba,job4,jobb jobz,jobbc,job2

    Any guidance will be greatly appreciated!

    I figured it out, made some loop structure changes, thanks VinsWorldcom for your replay

    while ($level <= 10) { foreach $dep (keys %jobs) { foreach (@{$jobs{$dep}{$level}}) { print "Key:$dep Value:$_ Lvl:$level Seen:$seen{$_}\n"; if ($seen{$_} eq '') { push( @{$jobs{$dep}{$nextlevel}},@{$job +s{$_}{$level}} ); } $seen{$_} = 1; next if ${$jobs{$_}{$level}}[0] eq "$dep"; last if $seen{$_} == 1; } } %seen = ''; @temparray = ''; $level++; $nextlevel++; }
trying to implement file tail with regular expression
1 direct reply — Read more / Contribute
by mkhayat
on Feb 11, 2016 at 06:06

    I build a script to read from diagnostic file and track a message. in case the message found a service in a server will restarted. I was successful in this however once the script reach end of the file it start again and this mean that it will keep restarting the service. I searched and found that there is library which called file::tail library which is made for this kind of issues unfortunately i was not able to modify my script in able to use this library. I am new in perl and I am trying to find my way into perl world. please help me :)

    use File::Tail; my $diagfile; my $Checkoutput; my $hostName1; my $hostName2; sub init { my ($dir) = @_; my $line; my $var; my $val; open (LREP2, "$dir/config/param.ini"); while ($line = <LREP2>) { chop $line; ($var,$val) = split(/=/, $line); if ($var eq "DIAGFILE") { $diagfile = $val; } if ($var eq "CHECKFILE") { $Checkoutput = $val; } if ($var eq "HOSTNAME1") { $hostName1 = $val; } if ($var eq "HOSTNAME2") { $hostName2 = $val; } } close LREP2; } #MAIN die "Usage: $0 <app_root_dir>" unless @ARGV == 1; my $app_root_dir = shift; &init($app_root_dir); my $line; open (DIAG, "$diagfile"); my $clock = 0; while (1) { open LOGFILE, ">>$app_root_dir/logs/detailedlog.log"; while ($line = <DIAG>) { if ($line =~ /is higher than 5 seconds/) { if ($clock == 0) { $clock = 60; my $commandStr2 = "sc \\\\$hostName1 stop AudioSrv >$a +pp_root_dir\\logs\\StopServiceOutput1.txt" ; print LOGFILE "about to execute=$commandStr2\n"; system($commandStr2); print LOGFILE "just executed=$commandStr2\n"; my $commandStr4 = "sc \\\\$hostName2 stop AudioSrv >$a +pp_root_dir\\logs\\StopServiceOutput2.txt" ; print LOGFILE "about to execute=$commandStr4\n"; system($commandStr4); print LOGFILE "just executed=$commandStr4\n"; sleep(5); my $commandStr3 = "sc \\\\$hostName1 start AudioSrv >$ +app_root_dir\\logs\\StartServiceOutput1.txt"; print LOGFILE "about to execute=$commandStr3\n"; system($commandStr3); print LOGFILE "just executed=$commandStr3\n"; my $commandStr5 = "sc \\\\$hostName2 start AudioSrv >$ +app_root_dir\\logs\\StartServiceOutput2.txt"; print LOGFILE "about to execute=$commandStr5\n"; system($commandStr5); print LOGFILE "just executed=$commandStr5\n"; } $clock --; sleep(1); } close LOGFILE; } sleep(65); }
Proper way to create packages and re-usable code?
7 direct replies — Read more / Contribute
by bt101
on Feb 10, 2016 at 22:25
    Hi I normally write one-file scripts. However I have written a rather extensive set of routines and I would like to re-use the code for several programs. I gather the way to do this is to split up the code and put it into packages. However my mind is boggling on how several things should work. One example is...let's say your original one-file program writes logs using log4perl. In that case you simply initialize the log and then call routines to write to that log from anywhere in your program. How does/should this work when you have split the code into packages? If you initialize log4perl in the main code, how to all of the package routines write to the log file? It is so simple with C where multiple files are just linked into one flat program. I'm fundamentally missing something.
Listbox, radio buttons and text box in sub function?
1 direct reply — Read more / Contribute
by Ppeoc
on Feb 10, 2016 at 08:26
    Hi Monks! I am trying to write a sub function that returns values to the main function using TK GUI. I got the listbox working but cant seem to get the text box to return values to the main function. Here is my code,
    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; }
    No value is returned for $localpath. The code runs fine for just the listbox. But when I start adding radio buttons and text boxes, the code gets messed up. My idea is to have a listbox in the left, radiobuttons on top right and text box on bottom right. Any help will be highly appreciated.
Problem reading Excel File
3 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:

    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

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:

    This:
    .*@abc.com matches monks@abc.com  
    ok so far...

    BUT...

    this:

    *@abc.com  also matches!!!!!!!!!
    WHY????

    Thanks!
    Pedrete.
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
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('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

New Meditations
Autoload versus auto-generating accessors
5 direct replies — Read more / Contribute
by goldenblue
on Feb 11, 2016 at 10:54

    after reading through PerlMonks Sections I decided this post should go here...

    I have been using Autoload extensively for my getters and setters, and refrained from "auto-writing" them, basically because I didn't like how it looked in the code.

    I also stumbled across some code that uses a baseclass with a makeattr-method it uses as "initializer", to write these accessors, which I also find pretty cool...

    Now I was wondering, which method do others prefer?

    So I would like to open a discussion:

      what are the advantages and drawbacks of each method, or do you see a third alternative? And which do you prefer?

    Maybe someone with a higher level would like to make this into a poll?


    --
CSV headers. Feedback wanted
2 direct replies — Read more / Contribute
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
    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 browsing the Monastery: (3)
As of 2016-02-13 04:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

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





    Results (418 votes), past polls