Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
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
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

Emulating Python's unittests MagicMock
1 direct reply — Read more / Contribute
by stevieb
on Nov 29, 2015 at 11:18

    Update: Mock::Sub. I haven't documented well the difference between OO and imported functions, so see EXAMPLES for the caveat for now. /Update

    I've been writing a lot of unit tests in Python lately, and really took to liking the MagicMock module. This morning, I thought I'd take a crack to see if I could emulate much of its functionality, before I write a full-blown module for it. So far, it implements called(), call_count(), side_effect and return_value:

    The Module itself (./Test/MockSub.pm):

    package Test::MockSub; sub mock { my $self = bless {}, shift; my $sub = shift; %{ $self } = @_; if (defined $self->{return_value} && defined $self->{side_effect}) +{ die "use only one of return_value or side_effect"; } my $called; { no strict 'refs'; *$sub = sub { $self->{call_count} = ++$called; return $self->{return_value} if defined $self->{return_val +ue}; $self->{side_effect}->() if $self->{side_effect}; }; } return $self; } sub called { return shift->call_count ? 1 : 0; } sub call_count { return shift->{call_count}; } sub reset { my $self = shift; delete $self->{$_} for keys %{ $self }; } 1;

    The outer module I'm calling the inner module with mocked subs from (./MyPackage.pm):

    package MyPackage; use lib '.'; use One; sub test { my $obj = One->new; $obj->foo; } 1;

    The inner module I'm mocking (./One.pm):

    package One; sub new { return bless {}, shift; } sub foo { print "in One::foo\n"; } 1;

    ... and finally the script I'm testing it all from:

    use warnings; use strict; use feature 'say'; use lib '.'; use Test::MockSub; use MyPackage; {# called() && call_counnt() my $foo = Test::MockSub->mock('One::foo'); MyPackage::test; MyPackage::test; my $count = $foo->call_count; say "testing call_count(): $count"; my $called = $foo->called; say "testing called(): $called"; } {# return_value my $foo = Test::MockSub->mock('One::foo', return_value => 'True'); my $ret = MyPackage::test; say "testing return_value: $ret"; } {# side_effect my $cref = sub {die "thowing error";}; my $foo = Test::MockSub->mock('One::foo', side_effect => $cref); eval{MyPackage::test;}; print "testing side_effect: "; say $@ ? 'success' : 'failed'; } {# side_effect && return_value dies() my $foo; my $cref = sub {}; eval{ $foo = Test::MockSub->mock('One::foo', side_effect => $cref, r +eturn_value => 1);}; print "testing side_effect & return_value dies(): "; say $@ ? 'success' : 'failed'; } {# reset() my $foo = Test::MockSub->mock('One::foo', return_value => 1); my $ret1 = MyPackage::test; $foo->reset; my $ret2 = MyPackage::test; print "testing reset():"; say defined $ret1 && ! defined $ret2 ? 'success' : 'failed'; }

    There's Test::MockModule and Test::MockObject, but I like the built-in methods, and how I've done it allows for mocking functions, class methods and object methods all at the same time (at least I think).

    Thoughts, criticism and feedback welcome as always.

Restarting File::Find
1 direct reply — Read more / Contribute
by Preceptor
on Nov 24, 2015 at 06:44

    One of the problems I've had in the past, is a need to walk a filesystem and 'batch up' files. There's a variety of reasons why - things like archiving, virus scanning, etc. Now, you _could_ do it the heavyweight way - collect a full tree directory structure, batch up that way. This didn't suit my needs - I've a billion ish files to inspect, and they change rather frequently.

    So as a workaround - make use of File::Find and it's ability to prune

    #!/usr/bin/env perl use strict; use warnings; use File::Find; my $start_from = "/path/to/search/some_dir/beneath"; my $count = 10_000; #how many files to grab in this 'batch'; my @file_list; sub finder { if ( defined $start_from and not $found ) { #partial match, walk directory. if ( $start_from =~ m/\QFile::Find::name/ ) { $File::Find::prune = 0; if ( $File::Find::name =~ m/\Q$start_from/ ) { $found = 1; } } else { $File::Find::prune = 1; #don't traverse into this dir } } if ( @file_list > $limit ) { $found = 0; $File::Find::prune = 1; return; } return unless -f $File::Find::name; push ( @file_list, $File::Find::name ); #backtracks a bit to the start of the current directory $start_from = $File::Find::dir; } find ( \&finder, '/path/to/search' ); print "Next start point: $start_from\n";

    Note - as it stands, this has a limiting factor in that it'll misbehaving if the directory structure changes (e.g. $start_from no longer exists. The workaround is chopping path elements off the end until you get to a dir that _does_ exist.

    Probably something like:

    while ( not -d $start_from and $start_from =~ m,/, ) { $start_from =~ s,/[^/]+$,,; }

    (There's probably a better solution using File::Spec or similar)

Subimage replacement script
1 direct reply — Read more / Contribute
by ohcamacj
on Nov 16, 2015 at 00:37

    I have more respect for OCR software now.

    Recently, trying to practice memorizing simple visual substitution ciphers; wrote a subimage replacement script that as input, takes

    • a directory containing lotsa tiny images. In my particular case, 156 carefully cropped screenshots. Upper and lowercase letters (26 + 26), bold letters (26 + 26), and underlined letters (26 + 26). Some repetation, but mostly a lot of time in the gimp; and using screenshots of partially highlighted / partially inverse colors text to figure out where the character boundries were. And also, images representing the replacement characters. In my case, 26 images and 130 symlinks -- the replacements are not case, bold, or underlined sensitive.
    • a single screenshot of an xterm, containing text in a monospace font without antialiasing.
    and outputs
    • a slightly distorted (in my case, replacements are larger than the originals; 8x20 vs. 6x13) image of the original text, with the simple visual substitution cipher applied.

    My script, has a few features that aren't strictly necessary for plain OCR of monospaced text in a known font at a known initial starting offset.

    • Pixel stepping scan mode. Until the first 10 characters are found, it steps pixel by pixel through the image; and only after that; starts jumping in 6x13 blocks.
    • color insensitivity and preservation. On colored or inverse colored text, remaps the replacement character, to the original colors; on a character by character basis.
    • image stretching. Having the replacement images (8x20) being slightly larger than the originals (6x13) added a bit of complexity.
    • high memory consumption. Only color format used is 24-bit, even though only 1.6 bits per pixel, are actually used (3 colors).

    And, what gives me much more respect for OCR software now, than before I started; is that the initial pixel stepping scan mode; prior to finding the first ten characters; is very slow.

    This code probably won't be useful to anyone else, because

    • nobody else has patience to spend a few hours in the gimp cropping screenshots of individual letters.
    • anyone smarter than me; probably would have modified font rendering from the very bottom -- font files -- instead of the very top -- screenshots. And starting from the very bottom, lets you skip the OCR-ish step entirely.

    It's also, sorta unclear and hard to read, due to misleading comments, and overuse of the comment-blocks-for-version-control design antipattern. Anyway,

    See also, soylentnews journal post #1, soylentnews journal post #2

Mollie Payment without Business::MollieAPI
No replies — Read more | Post response
by Beatnik
on Nov 13, 2015 at 03:57
    So I was looking at adding credit card payments to some site I'm building. Mollie.com seems like a nice platform but after checking out Business::MollieAPI (albeit really quickly) I decided not to go there and use a straight approach. The code below can run as a CGI script (add some CGI.pm magic) and uses a test key to issue a token, simulate a payment and confirm the payment. It's relatively straightforward if you look at the API documentation they offer on-line. Step 1: send an amount and description to the API, together with a redirect URL (on success and failure) and receive a token to confirm payment. Step 2: Pay. The returned URL will load a payment page at Mollie.com and will redirect to your chosen page. Store the ID prior to paying since you will need it to confirm the payment. Step 3: Confirm the payment status.
    #!/usr/bin/perl use LWP::UserAgent; use HTTP::Request; use JSON::XS qw(decode_json encode_json); use Data::Dumper; use strict; my $key = "test_GETYOURTESTKEYONTHEWEBSITE"; sub confirm # Argument: Mollie Transaction { my $transaction = shift @_; # Mollie will generate unique transactio +n ID prior to payment my $req = HTTP::Request->new('GET'=>"https://api.mollie.nl/v1/paymen +ts/$transaction"); $req->header('Authorization', 'Bearer ' . $key); my $ua = LWP::UserAgent->new(); my $res = $ua->request($req); if ($res->is_success) { my $data = decode_json($res->decoded_content); return $data->{'status'}; # 'paid' for OK, 'cancelled' for cancell +ed. } else { die Dumper $res; # Something else is going on } } sub pay # Arguments: Amount & Description { my $amount = shift; my $description = shift; my $req = HTTP::Request->new('POST'=>'https://api.mollie.nl/v1/payme +nts'); $req->header('Authorization', 'Bearer ' . $key); $req->content_type('application/json'); my %payment = ("amount"=>$amount,"description"=>$description,"redire +ctUrl"=>"http://www.somesite.com/cgi-bin/somescript.cgi"); # Trigger +confirmation here my $json = encode_json(\%payment); $req->content(encode_json(\%payment)); my $ua = LWP::UserAgent->new(); my $res = $ua->request($req); if ($res->is_success) { my $data = decode_json($res->decoded_content); my $url = $data->{'links'}{'paymentUrl'}; # On-line payment proces +s my $paymentid = $data->{'id'}; return $paymentid, $url; } else { die Dumper $res; # Something else is going on } } my ($id, $url) = &pay(100,"Lego Star Wars"); # Load URL and pay the money! my ($status) = &confirm($id); # Unique and temporary ID for transactio +n if ($status eq "paid") { print "RRRAARRWHHGWWR"; } # Walking Carpet Joke else { print "These are not the droids you're looking for!"; }


    Greetz
    Beatnik
    ... I'm belgian but I don't play one on TV.

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 examining the Monastery: (6)
    As of 2016-07-29 00:34 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      What is your favorite alternate name for a (specific) keyboard key?


















      Results (259 votes). Check out past polls.