Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical
 
PerlMonks  

Cool Uses for Perl

( #1044=superdoc: print w/ replies, xml ) Need Help??

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

CUFP's
Automate and dispatch unit test runs across perl/berrybrew on remote Windows and Unix systems
No replies — Read more | Post response
by stevieb
on Apr 27, 2016 at 13:17

    My Test::BrewBuild test deployment system is now reasonably stable, and has the ability to dispatch test runs to remote test servers. This means with a single command, you can run your unit tests across any number of perl instances on any Operating Systems automatically, and get the results delivered back to you.

    To do this, we use the bbdispatch to send brewbuild commands to previously configured remote testers. To start a bbtester, log on to the system and run bbtester start. That'll start the tester and put it in the background.

    Now's probably a good time to state that Git is required to be installed on all systems used for network testing, and one should peruse the basic system setup doc.

    In these examples, I have three testers set up. tester1 is the DNS name of a Ubuntu Linux system running perlbrew, tester2 is a Windows 2008 Server running berrybrew, and the localhost is a FreeBSD server, again running perlbrew.

    There are three flags for bbdispatch:

    • -c: A quoted string containing the brewbuild commands to run. Eg: "brewbuild -i 5.20.3 -R". If omitted, we will default to simply "brewbuild"
    • -r: A string containing a repository you want to test. Eg: https://github.com/stevieb9/mock-sub. If you are currently in a repository directory, we'll automatically fetch and use it and you can omit this flag
    • -t: These are your testers. This flag can be specified multiple times.

    Note that you can alternatively use a config file to store the dispatcher information.

    Here's the most basic example. We're already in a repository working directory so we can omit -r, we're only working on a tester on localhost, and we'll just use the default brewbuild test run:

    # start a tester on the localhost me@host:~/repos/mock-sub$ bbtester start Started the Test::BrewBuild test server at PID 20584 on IP address 0.0 +.0.0 and TCP port 7800... # dispatch a test run of my [metamod://Mock::Sub] # module (from within the repo dir) me@host:~/repos/mock-sub$ bbdispatch -t localhost localhost - x86_64-linux 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS

    Things get more useful when you have multiple testers across multiple different Operating Systems.

    This example does a basic run using the same repo as above, but this time I'm explicitly setting it. I'm also dispatching to three tester systems:

    $ bbdispatch -t localhost -t tester1 -t tester2 -r https://github.com/ +stevieb9/mock-sub tester1 - MSWin32-x64-multi-thread 5.22.1_64 :: PASS 5.10.1_32 :: PASS 5.20.3_32 :: PASS tester2 - x86_64-linux 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS localhost - amd64-freebsd 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: PASS

    Below, we use the -c flag to tell brewbuild that we want to perform test on the current module (I'm back in the repo dir again so I omit -r), and then have brewbuild run unit tests of all the module's reverse dependencies (-R) to ensure our proposed updated module doesn't break down-river (ie. modules that require/use your module) modules.

    $ bbdispatch -t localhost -t tester1 -t tester2 -c "brewbuild -R" tester1 - MSWin32-x64-multi-thread reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.10.1_32 :: PASS 5.20.3_32 :: PASS 5.22.1_64 :: PASS Devel::Examine::Subs 5.20.3_32 :: PASS 5.22.1_64 :: PASS 5.10.1_32 :: FAIL Devel::Trace::Subs 5.20.3_32 :: PASS 5.22.1_64 :: PASS 5.10.1_32 :: FAIL localhost - amd64-freebsd reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.10.1 :: PASS 5.22.1 :: PASS 5.14.4 :: FAIL Devel::Examine::Subs 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: PASS Devel::Trace::Subs 5.10.1 :: PASS 5.14.4 :: PASS 5.22.1 :: FAIL tester2 - x86_64-linux reverse dependencies: File::Edit::Portable, Devel::Examine::Subs, Deve +l::Trace::Subs File::Edit::Portable 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS Devel::Examine::Subs 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: PASS Devel::Trace::Subs 5.18.4 :: PASS 5.20.3 :: PASS 5.22.1 :: FAIL

    Notice that some results are FAIL. In this case, we create a bblog directory in the directory you're working in, and generate log files for each individual fail. This allows you to see what broke and where, without having to go to each individual system. You can then update/fix code, then run another dispatch. Here's an example of the files that were generated by the above run:

    $ ls bblog tester1_Devel-Examine-Subs-5.10.1_32-FAIL.bblog tester1_Devel-Trace-Subs-5.10.1_32-FAIL.bblog tester2_Devel-Trace-Subs-5.22.1-FAIL.bblog localhost_Devel-Trace-Subs-5.22.1-FAIL.bblog localhost_File-Edit-Portable-5.14.4-FAIL.bblog

    The log files contain all errors that the tester would have produced to STDOUT and STDERR, with the cpanm build logs appended.

    On a normal dispatch run (without running revdep), the log file would have appeared as tester1_5.10.1_32-FAIL.bblog. Running brewbuild in standalone mode (no dispatching): 5.10.1_32-FAIL.bblog. You can optionally save even the PASS logs if you choose by using the -S, --save flag to brewbuild.

    FURTHER READING:

    Notes:

    • we don't actually shell out and run the brewbuild commands directly with system() or backticks or the like. We dissect the command string, turn the arguments into their respective parameters, and use the API to do the actual testing
Saving some seconds.
No replies — Read more | Post response
by BrowserUk
on Apr 26, 2016 at 15:14

    After posting my solution to 1161491 I had some 'free time' so I was playing.

    My REPL which (can) time chunks of code for me automatically, produced some depressing numbers:

    C:\test>p1 [0]{0} Perl> use Algorithm::Combinatorics qw[ permutations ];; [0]{0.00943684577941895} Perl> $iter = permutations( [ reverse 1 .. 9 +] );; [0]{0.000318050384521484} Perl> printf "\r%s\t", join '', @$_ while de +fined( $_ = $iter->next );; 123456789 [0]{22.5874218940735} Perl>

    22.5 seconds to generate 9! = 362880 permutations seemed longer than I would have expected; so then I wondered how much of that was down to the generation and how much the formatting and printing:

    [0]{0} Perl>@d = permutations( [ reverse 1 .. 9 ] );; [0]{2.31235218048096} Perl> [0]{0} Perl> printf "\r%s\t", join '', @$_ for @d;; 123456789 [0]{18.9919490814209} Perl>

    So less than 2.5 seconds for the generation and almost 19 for the formatting and printing. (Leaving 1 second 'lost in the mix'.)

    Of course, that one line for printing is doing rather a lot. Unpacking the contents of the anon arrays to a list; joining the list of digits into a string; and then interpolating that into another string before writing it out. So then I wondered about the cost of each of those elements of the task.

    Looking at the code I saw that I could avoid 300,000 calls to each of join and printf by interpolating the lists from the array references directly into a string; provided I set $" appropriately:

    [0]{0} Perl> $"=''; $_ = "@$_" for @d;; [0]{1.93835282325745} Perl>

    That was a nice saving, so then I thought about writing the output. Rather than use a loop: print for @d; which means calling print 300,000 times -- with all the calls into the kernel that involves -- why not join those 300,000 strings into a single string (one call to join) and the output it with a single call to print:

    [0]{} Perl> $d = join "\r", @d;; [0]{0.0442740917205811} Perl> print $d;; 123456789 [0]{4.72821307182312} Perl>

    Summing the individual parts came out to ~10 seconds rather than the original 22.5. So let's put it all together and verify it:

    [0]{0} Perl> $"=''; @d = permutations( [ reverse 1 .. 9 ] ); $_ = "@$_ +" for @d; $d = join "\r", @d; print $d;; 123456789 [0]{9.26112604141235} Perl>

    Sure enough. Under 10 seconds; over 50% saved. Nice.

    Can we go further?:

    [0]{0} Perl> $"=''; print join "\r", map "@$_", permutations( [ revers +e 1 .. 9 ] );; 123456789 [0]{10.0599029064178} Perl> [0]{0} Perl> $"=''; print join "\r", map "@$_", permutations( [ revers +e 1 .. 9 ] );; 123456789 [0]{10.086268901825} Perl>

    And the answer is no. Sometimes the elimination of intermediate variables -- especially intermediate arrays when the alternative is several long lists -- backfires.

    Still. Another 5 minutes of 'idle time' waiting for another long simulation run occupied with an fun exercise, the lessons of which just might stay in my consciousness long enough to become influencial in the code I write in future.

    A few otherwise idle minutes spent now, saving a few seconds on something that doesn't really benefit from that saving; that just might save me hours or days if the lessons happen to be applicable to my next project; or the one after that.

    (If only I could apply those same level of savings to the simulation software I using -- open source, but I cannot compile it locally -- as perhaps then I would be lookng at a 20 hour wait for its completion rather than the 40+ I have in prospect :().


    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority". I knew I was on the right track :)
    In the absence of evidence, opinion is indistinguishable from prejudice.
Script to copy files from directory 'a' to 'b' by newest time no more than 'max' files in dest
No replies — Read more | Post response
by symgryph
on Apr 25, 2016 at 19:39

    This is my rather convoluted way of ensuring that the following is true: 1. No more than x number of files in my 'to' directory 2. Newest files will be given the highest precedence in the move 3. Zero length files will be killed 4. Only move .log files via glob. If anyone wants to use or improve, feel free, since I think a hash would have been a lot less complex than an array with a sort and regex substring match....ick.

    #!/usr/bin/perl -w #This file sees how many files are currently in a target directory use File::Copy; chdir "/tmp/to/"; @filesto = glob("*.log"); $numFiles = scalar @filesto; #maxfiles needs to be 1 larger than your maximum value due to perl usi +ng a 0 based index for arrays. $maxfiles = 5 - $numFiles; if ($maxfiles <=0) { exit; } chdir "/tmp/from"; @filesfrom = glob("*.log"); $counter=0; foreach (@filesfrom) { ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($filesfrom[$counter]); #Unlink files that are zero bytes prior to copy. if ($size eq 0) { unlink $filesfrom[$counter]; $counter--; next; } $filestoCreated[$counter] = $ctime . " " .$filesfrom[$counter]; $counter++; } #@sortedlist = reverse sort @filestoCreated; #This is a particularly nasty sort which essentially uses a regex as s +ubstring match to only sort the numeric part of my hacked up array. E +nsures that we get #a numeric sort only. @sortedlist = sort { ($b =~ /(^\d+)/)[0] <=> ($a =~ /(^\d+)/)[0] || uc($a) cmp uc($b) } @filestoCreated; #This section ensures that the system will never copy more than the ma +x number of files defined in maxfiles. $loopcounter=scalar (@sortedlist); if ($loopcounter > $maxfiles) { $loopcounter = $maxfiles-1; print "Loopcounter is greater than than maxfiles: $maxfiles Loopc +ounter: $loopcounter\n"; } $countfinals=0; while ($countfinals<$loopcounter) { my @execute= split / /, $sortedlist[$countfinals]; system "/bin/mv /tmp/from/$execute[1] /tmp/to/$execute[1]"; $countfinals++; }
    "Two Wheels good, Four wheels bad."
[perl6] Open "regex.ext" file with corresponding program and ask for deletion
No replies — Read more | Post response
by mimosinnet
on Apr 25, 2016 at 05:28

    I have been happily playing with perl6. This code opens with the corresponding program and asks for deletion of files with a defined pattern and extension. For example:

    $ Files perl pdf

    Open the pdf files that have 'perl' in the name and asks for deletion. Available in github

    #!/usr/bin/env perl6 # Reads files in the form of pattern.extension and asks for deletion # Modules {{{ use v6; use IO::Glob; # }}} # Variables {{{ # Program associated to extension my %exe = 'pdf' => 'mupdf', 'PDF' => 'mupdf', 'txt' => 'less', 'odt' => 'lowriter', 'doc' => 'antiword', # Exolore using docx2txt 'docx' => 'lowriter', # Explore using feh and delete with ctrl-del 'JPG' => 'xv', 'jpg' => 'xv', 'png' => 'xv', 'flv' => 'mpv', 'vimbackup' => 'gvim' ; # extensions my @extensions = %exe.keys; # }}} # sub main {{{ sub MAIN($pattern is rw, $ext) { die "The extension '$ext' has not been defined" unless $ext ~~ @ex +tensions.any; # variables {{{ $pattern = "*" if $pattern eq "all"; my $program = %exe{$ext}; my @files = glob("*$pattern*.$ext"); # }}} # Read and Delete Files {{{ for @files -> $file { my @args = $program, $file; my $command = run @args; $command.exitcode == 0 or die "system @args failed: $!"; my $delete = prompt("\n \n Delete file $file (s/n) "); last if $delete eq ""; next if $delete ne "s"; say "mv $file /tmp/$file"; my $io = IO::Path.new($file); $io.rename("/tmp/$file"); prompt("\n Press 'return' to continue "); } # }}} # Exit and list files {{{ @files = glob("*.$ext"); say "-" x 60; for @files -> $file {say "$file ";} say "-" x 60; # }}} } # }}} # sub usage {{{ sub USAGE () { say "USAGE:\n Files regex/all [ @extensions ]"; } # }}}
Perlocracy
No replies — Read more | Post response
by QuillMeantTen
on Apr 10, 2016 at 14:04

    As older and wiser monks mill around the courtyard, no one wonders about the lack of news from young Quill. Last time he was seen he got a well deserved beating for tempting those who lack in wisdom with tools beyond their understanding that could easily be made to wreck havoc on their home networks.

    So, even if his arrival is of no surprise, his cries of
    I REKT IT!
    prove challenging to ignore and disturb many an elder from their own medidations.

    Fast enough, one of those whose deep thoughts got interrupted ask him:
    "you rekt what?"
    "Exactly, EUREKA, that's it!" answers the feverish apprentice.

    As more monks come to the courtyard he begins to expose his latest idea...


    After spending long hours reflecting on the foolishness of my misdeeds and how providing script kiddies with weapons is the most desecrating act one could perpetrate inside those holy walls, I found something even more subversive and potentially destructive.

    Some of you, if interested in voting methods might have heard about condorcet methods. I for one think that those are way better than the currently used one. And I have my favorite. Mam or Maximize Affirmed Majorities, aka MTM (minimize thwarted minorities) can be considered a variant of the Tideman method. Once I started reading about it I wanted to use it and tell others about it.

    As many of you know by now when I get my eyes and mind on an algorithm I can not rest until I have implemented it myself to try and understand it as completely as possible.


    Today I give you a small script that implements the MAM voting procedure, you can use it to simulate elections with as many ballots as you want or to run it on ballots you may have collected, just put votes in text files with a .bt extension.


    Say you have 6 candidates, a possible ballot could be:

    1 3 2,4
    Meaning, you wish one to win, if not one then three, if three does not win you dont care whether 2 or 4 win. Any candidates left out of a ballot are considered equally ranked at the bottom. Hence this ballot is equivalent to:
    1 3 2,4 5,6


    Update:Patched the code for eventualities that did not happen during testing:
    1. no one ranks two candidates strictly, then complete the tiebreak from a randomly generated strict ballot
    2. Make tiebreaking rules conform so if the two majorities concern the same winner then the loser will be compared using the tiebreak
    3. Make majorities calculation output two different majorities in case of 1 vs 2 has same votes as 2 vs 1 and let the tiebreak mechanism do its work
    4. patch bug in majorities calculation where < and = would be treated the same way
    5. Now allows for any number of candidate (regex \d limited it to 9)
    6. To allow result comparison I added the schulze voting method, now accessible with the -s option
    7. Fixed a typo causing a miscalculation when in shulze mode
    So here is the code, I hope you'll have as much fun using it as I had writing it! Cheers :-)

Etags for Emacs and Moose
No replies — Read more | Post response
by choroba
on Apr 05, 2016 at 18:17
    When working on a larger project (50k+ lines), I usually can't remember the structure of the packages and I need some kind of a tool to help me. The simplest but still quite a powerful solution is etags (yes, I use Emacs). It generates a TAGS file that Emacs can use to show where a given subroutine is declared, etc. (Similar tool exists for vim, but I'm not familiar with the output format enough to make my script support both the editors.)

    The problem is that the default setting for Perl reports not only all the subroutine declarations, but also declarations of lexical variables (my). I don't need to know where a lexical variable was declared: normally, it's in the same block where the cursor is, maybe one level higher. What I'd like to have, though, are the attributes' accesors that Moo(se) provides; they're declared with has which etags can't handle.

    I haven't found a way how to persuade etags to handle multiline declarations, neither have I found any other solution. So, I created a simple script that creates the TAGS file that's more useful for me than the default. It still doesn't handle all the possibilities (different names for setters/getters, builders, delegation, etc.) - you can check the END section for all the constructs it can parse.

    The current version of the code is here, but you can find it at GitHub where it might change as I (or you!) add new features.

    ($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,
Decode contact list from Nokia phone.
No replies — Read more | Post response
by ambrus
on Apr 05, 2016 at 17:03

    The Nokia 6303c mobile phone can save a backup of the contact list (i.e. phone book) to the SD card. This node tells how to extract the list of contacts from such a backup to a human-readable file.

    This description comes with no warranty. If you lose your contacts, you are on your own.

    Note that the following procedure only saves the contacts from the phone memory. If you have contacts in the SIM card, you may have to copy those to the phone memory first.

    I know of no procedure to restore a contact list to the phone. As far as I've tried, the phone can't even load the backups it wrote itself.

GqrxRawAudioPlot(wxPerl, GD, UDP client, UDP server, & memory file)
No replies — Read more | Post response
by jmlynesjr
on Apr 03, 2016 at 21:19

    GqrxRawAudioPlot(wxPerl, GD, UDP client, UDP server, & memory file)

    AKA - Another wxPerl example.

    Back in June I was looking into the purchase of Digilent's Analog Discovery USB O-scope(still looking). I was considering wrapping the SDK shared library until kovacslattila pointed out that a Linux version of the Waveforms software was under development(now available). The result was that I dropped my plan to wrap the SDK shared library. What I had put together at that point was a simulated O-scope display based on wxPerl and GD. Reference: Digilent Inc. Analog Discovery

    Fast forward to October... I had been playing with the Gqrx Software Defined Radio package and had developed a wxPerl script that used Telnet and threads to implement a scanner function on top of Gqrx. Reference: SDR Scanner(aka Threaded wxPerl Example)

    Last month, a user on the Gqrx google group asked if there was a way to display the raw audio produced by Gqrx. As it turns out, one channel of the demodulated audio is output to a UDP port. It sounded like a fun challenge and a reason to dig out the simulated O-scope code. Listed below is the GqrxRawAudioPlot.pl script and the udpserver.pl script(provides test UDP packets so that the plot code can be run without having to have SDR hardware and Gqrx installed). If you don't want to run these scripts, you can see a screen snapshot at jmlynesjr.

    If nothing else, it's another wxPerl example along with GD graphics, memory file usage, a UDP client and a UDP server.

    GqrxRawAudioPlot.pl

    udpserver.pl

    James

    There's never enough time to do it right, but always enough time to do it over...

Activate your perl programs by touch with Touchable.pm!
2 direct replies — Read more / Contribute
by Discipulus
on Apr 01, 2016 at 03:09
    Touchable.pm is not yet published, but perlmonks deserves a preview
    Just by including this incredibly simple module
    you can prevent unwanted access to
    your perl programs and
    protect your compiled application from
    unintended double clicks. Here the code and example usage
    #!/usr/bin/perl use strict; use warnings; package Touchable; exit 0 unless (stat ($0))[9] && (($^T - (stat ($0))[9] ) < 3);

    Example of usage:
    # consuming script: yourprogram.pl use strict; use warnings; use Touchable; print "here $0\n"; # usage example perl yourprogram.pl # works only if touch activated.. touch yourprogram.pl & perl yourprogram.pl here yourprogram.pl

    Have a nice 1st of April!

    Have fun!

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Automate Perl/BerryBrew unit testing on Unix/Windows (Take 2)
No replies — Read more | Post response
by stevieb
on Mar 18, 2016 at 21:46

    Disclaimer: this isn't just a cool use for/of Perl, it's a request to get some testers of an extremely easy to use app so I can hopefully get feedback.

    NOTE: The current version this doc is based on is v0.05. I only uploaded it to CPAN a while ago, so it may not be indexed yet. Previous versions won't act according to this doc. You can either wait for it to be indexed, or fetch the zip/tarball file and install manually.

    When I say easy to use, I mean it. If you have PerlBrew or BerryBrew installed and a module you've developed that's structured in a sane way:

    cpan Test::BrewBuild cd /path/to/MyModule brewbuild

    Output:

    perl-5.8.9 :: PASS perl-5.10.1 :: PASS perl-5.22.1 :: PASS perl-5.23.8 :: PASS

    ...yep, that's it. It'll run all of your unit tests across all of your currently installed *brew instances. We can get much deeper, however, I'll start with some explanations. I'm looking for feedback, so if you aren't interested in forking and submitting a PR or opening a bug report and it errors/warns on you, all you have to do is set a debug level and either post the output here, or email me at my CPAN email address.

    brewbuild --debug 7 # or brewbuild -d 7

    This app/module works across both *nix and Windows, recognizes both ExtUtils::MakeMaker and Module::Build installers, and can be configured *very* easily with custom build plugins if neither of these work for you. I'll show the default plugin, then I'll provide an example of how to include your own.

    Default bundled plugin:

    package Test::BrewBuild::Plugin::DefaultExec; sub brewbuild_exec { return <DATA>; } 1; __DATA__ if ($^O eq 'MSWin32'){ my $make = -e 'Makefile.PL' ? 'dmake' : 'Build'; system "cpanm --installdeps . && $make && $make test"; } else { my $make = -e 'Makefile.PL' ? 'make' : './Build'; system "cpanm --installdeps . && $make && $make test"; }

    That's it. Unfortunately at this time, it's not possible via CLI args to include a non-installed plugin, so unless you want to write one to put on the CPAN, you just need to copy a CustomPlugin.pm file into ~/perl5/perlbrew/perls/*PERLVER*/lib/site_perl/*PERLVER*/Test/BrewBuild/Plugin directory. Then:

    brewbuild --plugin 'Test::BrewBuild::Plugin::CustomPlugin' # or just set the TBB_PLUGIN environment variable to make it persisten +t

    Using local plugins is imminent, just not there yet.

    Now, here are some use cases. Note that all command line arguments have a single letter (ie. -d for --debug) shortforms:

    Remove all existing *brew perl instances (less the one you may be using), install two new random versions, and test against all instances including the pristine ones:

    brewbuild --remove --count 2

    Run against all currently installed instances, and install one random new one and test against it too:

    brewbuild --count 1

    Install a few specific versions (use just the number portion from *brew available) and test against all installed:

    brewbuild --version 5.20.3 -v 5.22.1 -v 5.8.9

    The current documentation describes more situations, and you can read the docs for all installed pieces of the module here.

    Note that ironically, I wrote this project to perform unit testing as I'm a huge stickler (I often have 100 times the number of lines of test code than I do code), but in this case, it has happened backwards. Don't worry, tests are coming fast and furious.

    I wrote this module because Travis-CI doesn't perform tests on Windows. This module allows me to run my tests against all perl versions on both nix and Windows prior to putting it into the CPAN Testers wheelhouse.

    Thanks for reading, and if you get a chance to test it out, I'd greatly appreciate any and all feedback.

    Cheers,

    -stevieb

Getting numeric month for comparisons
4 direct replies — Read more / Contribute
by Lady_Aleena
on Mar 05, 2016 at 07:47

    I wrote this little script to get numeric months for comparisons. The input can be in initial uppercase, all uppercase, and all lowercase. I added a few other languages for fun.

    #!/usr/bin/perl use strict; use warnings; my @month_numbers = (1..12); my %month_names = ( 'English' => [qw(January February March April May June July Aug +ust Spetember October November December)], 'English abbr' => [qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Now De +c)], 'Dutch' => [qw(januari februari maart april mei juni juli aug +ustus september oktober november december)], 'French' => [qw(janvier février mars avril mai juin juillet ao +űt septembre octobre novembre décembre)], 'German' => [qw(Januar Februar März April Mai Juni Juli August + September Oktober November Dezember)], 'Greek' => [qw(Ianuários Fevruários Mártios Aprílios Máios Iú +nios Iúlios Avghustos Septémvrios Októvrios Noémvrios Thekémvrios)], 'Italian' => [qw(gennaio febbraio marzo aprile maggio giugno lu +glio agosto settembre ottobre novembre dicembre)], 'Spanish' => [qw(enero febrero marzo abril mayo junio julio ago +sto septiembre octubre noviembre diciembre)], ); my %months; for my $language (keys %month_names) { @months{@{$month_names{$language}}} = @month_numbers; @months{map(uc $_, @{$month_names{$language}})} = @month_numbers; @months{map(lc $_, @{$month_names{$language}})} = @month_numbers; } sub get_month_number { my $month = shift; return $months{$month}; }

    So, if you want the month number for July, you use it like the following.

    print get_month_number('July');

    The above will return 7.

    Now you can put dates in the right order. I'll be modularizing this shortly. 8)

    Updates

    Code simplified from morgon's (no @month_numbers array) and poj's (case insensitive input) suggestions.

    my %months; for my $language (keys %month_names) { my $number = 0; $months{lc $_} = ++$number for @{$month_names{$language}}; } sub get_month_number { my $month = lc shift; return $months{$month}; }

    Added aprile to Italian list of months from AnomalousMonk.

    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena
Coverage History
2 direct replies — Read more / Contribute
by choroba
on Feb 17, 2016 at 10:07
    You probably know how to use Devel::Cover, or even Coveralls as part of your Travis CI. I wanted to see how the coverage of my tests changes in time for each coverage type: that's something you can't get from the mentioned module and services easily. CPANCover shows it for released versions, but I wanted a more granular report.

    I've written a program that does it. At the end, it creates a PNG graph that shows how each coverage type changed with each commit. It also modifies the HTML pages generated by cover so you can navigate between commits by clicking on the arrows.

    If you use git as your version control system, your distribution stores code in the lib/ directory, and tests are located in `t/`, you can try the following code without modification (tested on Linux only). It checks for its dependencies, but if you want to be prepared, here's the list:

    Comments welcome. If you want to modify the code to handle SVN or CVS, use other tools to create the graph or track changes in different directories, we should probably start a GitHub project.

    If you have lots of commits, the first run can take some time. The next run will only process the commits that haven't been processed, yet, if you don't delete the created directories.

    Update: Added CPANCover.

    ($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,
A Thanks sample POP3 Autoresponder
1 direct reply — Read more / Contribute
by Anonymous Monk
on Feb 12, 2016 at 09:41
    Thanks for your help. I run this out of the crontab.
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"; }
raffle_tickets_generator
4 direct replies — Read more / Contribute
by QuillMeantTen
on Dec 03, 2015 at 04:20

    Greetings fellow monks,

    Yesterday my lady asked me if I could do her a favor, gallant fool that I am I answered at once

    "Of course, my paramour, it would be my honor to take on any quest, to slay any foe metaphorical or otherwise for your honor". For my defense the day before I forgot to make her lasagnas as promised and she was quite disappointed with my chicken and mushroom pie so that's why I did not ask what the task would be before accepting.

    A strange activity was asked of me : writing raffle tickets with nice images in such a way that they could be easily printed and then cut out as individual tickets.
    As more than 3 hundreds of them were required by 6 pm the same day (someone had dumped the task on her without warning) she told me that using Excel was a solution but as it was computer related she hoped I knew some wizardry to accomplish the task in mere moments.

    So I grabbed my spear, shield, poleaxe, steed and my trusted GCC (gnu compiler cat, an universal syntax checker that will sit on my lap while I code and try to rip my throat if I move and sometimes when I make syntax mistakes)

    I soon came up with this idea : Write it using latex, break the latex doc in discrete parts and then use a perl script to rearrange them as needed

    Here is the resulting script : you give it a path to the image you want, the number of tickets you want and the scale for the image and you should (hopefully) get some kind of result.
    Also you will need pdflatex.
    As usual, I'm looking for ways to get better so constructive criticism is welcome.

    Update: added autodie, thanks athanasius
    use constant, rewrite the first loop, thanks anonymous monk, I'm going to read on the use of the DATA section


Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • 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 musing on the Monastery: (5)
    As of 2016-04-30 08:15 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      :nehw tseb si esrever ni gnitirW







      Results (441 votes). Check out past polls.