Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask

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.

Checking if your CPAN distributions need to bump their prereq versions
2 direct replies — Read more / Contribute
by stevieb
on Jun 26, 2017 at 13:52

    I've made two 'updates' to this post, but I'm going to let it fly for a bit, then I'm going to come back and edit in my updates into the post itself...

    Update: In v0.02, we now skip over prereqs where the version is listed as 0 (zero). This signifies that any version of a prereq is acceptable. To disable this and display all prereqs even if the version is zero, use the ignore_any => 0 parameter. /update

    Update2: I've updated the distribution (v0.05) to install a binary, checkdep, so that you don't have to write your own to use the library:

    Usage: checkdep PAUSEID [options] -a|--all Work on all dependencies, not just the author's -m|--module String; Work only on a specific distribution. (eg: Moc +k::Sub) -z|--zero Include dependencies listed with a version of zero -h|--help Display this help screen


    I've got quite a few CPAN distributions that require one another, and it's gotten to the point that it's very easy to forget to bump prereq versions before uploading a new release to the CPAN.

    As a stopgap, I wrote Module::CheckDep::Version (may not be indexed yet). What this module does is using MetaCPAN::Client, fetches all distributions by author, pulls out all prerequisite distributions and the version of it that your distribution has listed, checks if there's a newer version of it, and lists out the ones that need a bump in the prereq's version.

    The most basic of runs takes a single parameter, a PAUSE ID (CPAN username), and lists the discrepancies of prereq version mismatches for that author's own prereq distributions *only*. Here's an example of that:

    use warnings; use strict; use Module::CheckDep::Version qw(check_deps); check_deps('STEVEB');

    Here's the full output of that function call:

    Using the all => 1 param, we'll check against *all* prereqs, the author's own ones and those of any other author. If it's listed as a dependency, we'll check it:

    check_deps('STEVEB', all => 1);

    Example (snipped) output:

    Devel-Examine-Subs: Test::Trap: 0.00 -> v0.3.2 ExtUtils::MakeMaker: 0.00 -> 7.30 Carp: 0.00 -> 1.38 Data::Dumper: 0.00 -> 2.161 PPI: 0.00 -> 1.236 Mock::Sub: 1.06 -> 1.07 Data::Compare: 0.00 -> 1.25 Geo-Compass-Variation: ExtUtils::MakeMaker: 0.00 -> 7.30 RPi-LCD: ExtUtils::MakeMaker: 6.72 -> 7.30

    You can look up only a single distribution instead of listing all of them (this works with all => 1 as well):

    check_deps('STEVEB', module => 'RPi::WiringPi');


    Pi-WiringPi: RPi::I2C: 2.3602 -> 2.3603 RPi::LCD: 2.3601 -> 2.3603

    You can request the data back (a hashref of hashrefs) instead of displaying it to STDOUT:

    my $data = check_deps('STEVEB', return => 1);

    ...and finally, you can send in a code reference to handle the data within the module instead of getting it returned or printed. This sub can do anything you want it to. You get passed a single parameter, a hashref of hashrefs, same as with the return functionality:

    check_deps('STEVEB', handler => \&my_handler); sub my_handler { my $data = shift; for my $dist (keys %$data){ for my $dep (keys %{ $data->{$dist} }){ my $dep_ver = $data->{$dist}{$dep}{dep_ver}; my $cur_ver = $data->{$dist}{$dep}{cur_ver}; print "$dist has dep $dep with listed ver $dep_ver " . "and updated ver $cur_ver\n"; } } }

    Sample output:

    App-RPi-EnvUI has dep Async::Event::Interval with listed ver 0.00 and +updated ver 0.03 Devel-Trace-Subs has dep Devel::Examine::Subs with listed ver 1.61 and + updated ver 1.69 Devel-Trace-Subs has dep Mock::Sub with listed ver 1.01 and updated ve +r 1.07 RPi-WiringPi has dep RPi::LCD with listed ver 2.3601 and updated ver 2 +.3603 RPi-WiringPi has dep RPi::I2C with listed ver 2.3602 and updated ver 2 +.3603

    I was going to hook this into an automation script using other tools I have written, but I just don't have the time. Just knowing what needs to be updated is fine for me for now.

    Next version will have the ability to optionally skip prereqs that the author has set to 0 (ie. any version is acceptable).

    As always, have fun!

Yet another example to get URLs in parallel
2 direct replies — Read more / Contribute
by karlgoethebier
on Jun 17, 2017 at 11:36

    The role


    Please note that this version contains some annoying errors mistakes. Use 1.17 instead. See the explanations from marioroy below in this thread.

    package MyRole; # $Id:,v 1.12 2017/06/17 14:00:17 karl Exp karl $ use Role::Tiny; use threads; use MCE::Loop; use MCE::Shared; use MCE::Mutex; use WWW::Curl::Easy; use Config::Tiny; my $cfg = Config::Tiny->read(q(MyRole.cfg)); MCE::Loop::init { max_workers => $cfg->{params}->{workers}, chunk_size => 1, interval => $cfg->{params}->{interval}, }; my $fetch = sub { my $curl = WWW::Curl::Easy->new; my ( $header, $body ); $curl->setopt( CURLOPT_URL, shift ); $curl->setopt( CURLOPT_WRITEHEADER, \$header ); $curl->setopt( CURLOPT_WRITEDATA, \$body ); $curl->setopt( CURLOPT_FOLLOWLOCATION, $cfg->{params}->{followloca +tion} ); $curl->setopt( CURLOPT_TIMEOUT, $cfg->{params}->{timeout} ) +; $curl->perform; { header => $header, body => $body, info => $curl->getinfo(CURLINFO_HTTP_CODE), error => $curl->errbuf, }; }; sub uagent { my $urls = $_[1]; my $shared = MCE::Shared->hash; my $mutex = MCE::Mutex->new; mce_loop { MCE->yield; $mutex->enter( $shared->set( $_ => $fetch->($_) ) ); } $urls; my $iter = $shared->iterator(); my $result; while ( my ( $url, $data ) = $iter->() ) { $result->{$url} = $data; } $result; } 1; __END__
    package MyRole; # $Id:,v 1.17 2017/06/18 08:45:19 karl Exp karl $ use Role::Tiny; use threads; use MCE::Loop; use MCE::Shared; use WWW::Curl::Easy; use Config::Tiny; my $cfg = Config::Tiny->read(q(MyRole.cfg)); MCE::Loop::init { max_workers => $cfg->{params}->{workers}, chunk_size => 1, interval => $cfg->{params}->{interval}, }; my $fetch = sub { my $curl = WWW::Curl::Easy->new; my ( $header, $body ); $curl->setopt( CURLOPT_URL, shift ); $curl->setopt( CURLOPT_WRITEHEADER, \$header ); $curl->setopt( CURLOPT_WRITEDATA, \$body ); $curl->setopt( CURLOPT_FOLLOWLOCATION, $cfg->{params}->{followloca +tion} ); $curl->setopt( CURLOPT_TIMEOUT, $cfg->{params}->{timeout} ) +; $curl->perform; { header => $header, body => $body, info => $curl->getinfo(CURLINFO_HTTP_CODE), error => $curl->errbuf, }; }; sub uagent { my $urls = $_[1]; my $shared = MCE::Shared->hash; mce_loop { MCE->yield; $shared->set( $_ => $fetch->($_) ); } $urls; $shared->export; } 1; __END__

    The config file

    # $Id: MyRole.cfg,v 1.4 2017/06/17 13:48:19 karl Exp karl $ [params] timeout=10 followlocation=1 interval=0.005 workers=auto

    The class

    # $Id:,v 1.5 2017/06/16 15:35:32 karl Exp karl $ package MyClass; use Class::Tiny; use Role::Tiny::With; with qw(MyRole); 1; __END__

    The app

    #!/usr/bin/env perl # $Id:,v 1.14 2017/06/17 14:43:57 karl Exp karl $ use strict; use warnings; use MyClass; use Data::Dump; use HTML::Strip::Whitespace qw(html_strip_whitespace); use feature qw(say); my @urls = grep { $_ ne "" } <DATA>; chomp @urls; my $object = MyClass->new; my $result = $object->uagent( \@urls ); # dd $result; while ( my ( $url, $data ) = each %$result ) { say qq($url); say $data->{header}; # my $html; # html_strip_whitespace( # 'source' => \$data->{body}, # 'out' => \$html # ); # say $html; } __DATA__

    Update: Fixed mistakes. Thank you marioroy.

    Update2: Deleted unused module.

    Best regards, Karl

    «The Crux of the Biscuit is the Apostrophe»

    Furthermore I consider that Donald Trump must be impeached as soon as possible

Tk - Discipulus 15 puzzle
4 direct replies — Read more / Contribute
by Discipulus
on Jun 13, 2017 at 03:00



    perl [ --verbose --nocolor --charsize n --positions n n ..]


                       print to the screen the appearence of the board
                       and the solvability/difficulty of the game based
                       on the calculated and shown parity of permutations
                      high contrast colors instead of default ones
                      default colors are imperial red and gold
         -c|charsize  number
                      the size used for numbers on tiles
         -tiles|positions  sequence of numbers from 1 to 16
                      providing a correct sequence of numbers from 1 (the tile with
                      the 1 on it) to 16 (the empty tile) you can force the game
                      to show a particular initial disposition
                      This is unavailable while --extreme is used
                      instead of numbers, perl statements are shown
                      the victory condition is shown briefly then the board is
                      shuffled: good luck monks


    This classic puzzle game is dedicated to my 15th anniversary of presence at the perlmonks community.

    If run without arguments nor switches it displays a shuffled board with, in the above part, a description of the diffuculty and solvability of the current game.

    Not every disposition can lead to a victorious game: this is due to permutations parity. Games with odd permutations are impossible.

    You can shuffle the board using CTRL-S sequence.

    To play just click on the tile you want to move.

    Winners are rewarded with a surprise.

    Have fun!


    See about 15 puzzle at OEIS


    Info in italian

    Reference and support site for this program, if needed,


    Discipulus as found at


    PS some typo fixed: thanks to hexcoder


    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.
Digitally Adjustable Multi-Stage Op-Amp Gain Calculator - It's the Simple Things in Perl you Appreciate
No replies — Read more | Post response
by perldigious
on Jun 12, 2017 at 11:10

    This isn't a complicated, glamorous, or earth-shattering bit of Perl code. Quite the opposite really, it's an overly simple problem to solve for Perl, but that's sort of the point. It's more or less an example of one of the little things I'm apt to use Perl for everyday. I had a relatively simple Electrical Engineering problem I had to solve that became tedious to resolve anytime I'd fiddle with my exact component choices. This is the type of thing I used to do with Mathcad when I actually had a license for the full version, but usually a combination of Perl and Excel can make up 90% or more of the same functionality with a bit of clever manipulation.

    use utf8; use 5.022; use strict; use warnings; my $excitation_voltage = 5; # excitation voltage for load cel +l (volts) my $load_cell_sensitivity = 0.015; # adjusted (down via rheosat) loa +d cell full scale sensitivity (volts/volt) my $pot_taps1 = 128; # number of tap settings allowed +by diff amp gain pots my $pot_taps2 = 128; # number of tap settings allowed +by non-inverting amp gain pot my $desired_max_output = 4.8; # maximum final output voltage de +sired at full scale (volts), usually a limitation of the selected op +amp or for ADC input headroom my $allowed_output_deviation = 0.01; # how much deviation from $desire +d_max_output due to the limited number of pot settings is acceptable +(e.g. 0.01 would be 1%) my $printf_format = "%8s%15s%12s%15s%15s%14s"; printf "\n$printf_format\n$printf_format\n\n", "Diff Amp", "Non-Inv Am +p", "Diff Amp", "Non-Inv Amp", "Total", "Max Output", "Pot Set", "Pot + Set", "Gain", "Gain", "Gain", "Voltage"; my $possible = 0; foreach my $gain1 (map { ($pot_taps1-$_)/$_ } (1..$pot_taps1/2)) # + for diff amp, only half of pot taps usable since gains less than 1 a +re not allowed { foreach my $gain2 (map { ($pot_taps2-$_)/$_+1 } (1..$pot_taps2)) # + for non-inverting amp { if ( abs($desired_max_output-$gain1*$gain2*$excitation_voltage +*$load_cell_sensitivity)/$desired_max_output <= $allowed_output_devia +tion ) { printf "$printf_format\n", sprintf("%.0f", $pot_taps1/($ga +in1+1)), sprintf("%.0f", $pot_taps2/$gai +n2), sprintf("%.3f", $gain1), sprintf("%.3f", $gain2), sprintf("%.3f", $gain1*$gain2), sprintf("%.6f", $excitation_vol +tage*$load_cell_sensitivity*$gain1*$gain2); $possible = 1; } } } say "\nNo combination of potentiometer settings meets your criteria.\n +Try allowing for more \$allowed_output_deviation\nand/or adjusting yo +ur \$desired_max_output." if (!$possible);

    Plus, doing these sorts of things in Perl keeps my coding ability from going completely stagnant during long dry spells of an actual Perl project of any complexity. :-)

    Just another Perl hooker - Yep, I've definitely seen more than my share of d*cks in the world, that's for sure.
Manifest - A tool for matching EMC Symmetrix/VMAX Volumes to WWNs
1 direct reply — Read more / Contribute
by bpoag
on Jun 07, 2017 at 16:49
    Still living in the 90's? Do you treat modern storage technologies like deduplication and compression with Amish-like suspicion, bitterness and disdain? Then EMC's VMAX AF line is the choice for you--For the rest of us here in the present, we have to find ways of keeping this thing propped up on life support. One of the more irritating aspects of EMC's VMAX line is the fact that, amazingly there is no single CLI command to display a simple table relating volume names to WWNs. Rather than wait for EMC to provide this functionality (or, preferably, sunset the VMAX line alltogether) I've written a simple wrapper in Perl that provides this functionality.
    #!/usr/bin/perl ## ## Volume label to WWN/NAA manifest generator for VMAX arrays written +060717:1523 by Bowie J. Poag ## $DEBUG=1; $SID=$ARGV[0]; if ($SID eq "") { print "Manifest: No array specified. Exiting..\n\n"; } @dump=`symdev -sid $SID list -identifier device_name`; foreach $item (@dump) { chomp($item); $item=~s/\s+/ /g; @temp=split(" ",$item); $symDev=$temp[0]; $canonicalName=$temp[2]; if ($canonicalName=~/ACLX/) ## Special exception for gatekeeper LUN +s.. { $canonicalName=$temp[3]; } if (length($symDev)==5 && $symDev=~/[0-9a-fA-F]/ && $canonicalName +ne "") { $deviceHash{$symDev}{canonicalName}=$canonicalName; } } @dump=`symdev -sid $SID list -wwn`; foreach $item (@dump) { chomp($item); $item=~s/\s+/ /g; @temp=split(" ",$item); $symDev=$temp[0]; $WWN=$temp[4]; if (length($symDev)==5 && $symDev=~/[0-9a-fA-F]/ && length($WWN) > + 10) { $deviceHash{$symDev}{WWN}=$WWN; $suffix=substr $WWN,length($WWN)-4,4; $deviceHash{$symDev}{suffix}=$suffix; } } foreach $x (sort keys %deviceHash) { print "SID: [$SID] SymDev: [$x] Full WWN: [$deviceHash{$x}{WWN}] WW +N/NAA Suffix: [$deviceHash{$x}{suffix}] Name: [$deviceHash{$x}{canoni +calName}]\n"; }
calculate magnetic declination
1 direct reply — Read more / Contribute
by no_slogan
on Jun 01, 2017 at 20:53
    Inspired by a recent thread, calculate the magnetic declination (angle between true north and magnetic north) for a given longitude/latitude. If someone wants to put this on CPAN, be my guest, but then you're on the hook to update it to use the WMM2020 model when it's released in late 2019.
    # Magnetic declination calculation based on WMM2015 earth magnetism mo +del. # See use strict; use warnings; $, = " "; $\ = "\n"; print magnetic_declination(240, -80, 100e3, 2017.5); # WMM sample data print magnetic_declination(-122-4/60, 37+23/60, 32, 2017); # Mountain +View # magnetic_declination($lon, $lat, $hgt, $yr) # $lon: degrees longitude (east is positive) # $lat: degrees latitude (north is positive) # $hgt: elevation from sea level in meters, default=0 # $yr: year, default=2015 # Returns magnetic declination for the given location in degrees. # In array context, also returns magnetic inclination (dip).
GPS tracking with Perl
1 direct reply — Read more / Contribute
by stevieb
on May 16, 2017 at 20:56

    I finally got my little GPS unit for my Raspberry Pi, which cost me $50 CDN. It connects via the Rx and Tx pins of the serial interface. My new GPSD::Parse module (may not have indexed yet) is not Pi specific though. Any serial connected GPS device will work (even USB ones).

    There aren't any non-core modules in use so it's exceptionally lightweight. The only requirement is to have gpsd daemon installed and running. I run it like this: sudo gpsd /dev/ttyS0 -n -F /var/log/gpsd.sock at startup.

    Note that there is a much more extensive distribution Net::GPSD3 that does the same sort of thing, but I had a nightmare trying to install it with a whole long chain of dependencies, and it was a little confusing to use. I wrote this one for simplicity. All tests effectively skip until the next version, when I re-implement a test regime that uses a data file as the input instead of a network socket, which most may not have running. I also have immediate plans for new features, but I just wanted to get it up after 100% test coverage (locally) and 100% POD coverage so that I can see what it looks like on the CPAN.

    I've put together a tiny demo of some basic output below, but the information that can be extracted is quite extensive. The documentation explains all of the various attributes and how to get at them. It even shows how to extract the entire raw JSON data returned from the device, or that raw data after it's been converted into a Perl data structure.

    Tiny example. Of course in the real world, you'd put something like this in a loop, polling every second or whatever. Note that I've obfuscated the coordinates a tiny bit, but they are accurate right to my front door, literally:

    use warnings; use strict; use GPSD::Parse; my $gps = GPSD::Parse->new; $gps->poll; print "poll time: " . $gps->time . "\nlattitude: " . $gps->tpv('lat') . "\nlongitude: " . $gps->tpv('lon') . "\ndirection: " . $gps->tpv('track') . "\naltitude: " . $gps->tpv('alt') . "\n";

    I've also got this working in C on my Arduino Trinket Pro, which I'm going to use to make a hiking GPS so I can track my movements in the field.

    Here's the output. The altitude defaults to metres.

    poll time: 2017-05-17T00:48:16.000Z lattitude: 51.00000000 longitude: -114.000000000 direction: 324.87 altitude: 1084.9

    Here's a list of items you can fetch in regards to the TPV (Time Position Velocity):

    time => '2017-05-16T22:29:29.000Z' # date/time in UTC lon => '-114.000000000' # longitude lat => '51.000000' # latitude alt => '1084.9' # altitude (metres) climb => '0' # rate of ascent/decent (metres/sec) speed => '0' # rate of movement (metres/sec) track => '279.85' # heading (degrees from true north) device => '/dev/ttyS0' # GPS serial interface mode => 3 # NMEA mode epx => '3.636' # longitude error estimate (metres) epy => '4.676' # latitude error estimate (metres) epc => '8.16' # ascent/decent error estimate (meters) ept => '0.005' # timestamp error (sec) epv => '4.082' # altitude error estimate (meters) eps => '9.35' # speed error estimate (metres/sec) class => 'TPV' # data type (fixed as TPV) tag => 'ZDA' # identifier

    ...and information you can gather about the satellites you can see (using the satellites() method). Currently, after having the unit on for about 24 hours, I'm 'using' nine in total to pinpoint me:

    PRN => 16 # PRN ID of the satellite # 1-63 are GNSS satellites # 64-96 are GLONASS satellites # 100-164 are SBAS satellites ss => 20 # signal strength (dB) az => 161 # azimuth (degrees from true north) used => 1 # currently being used in calculations el => 88 # elevation in degrees
fun with induce
1 direct reply — Read more / Contribute
by daxim
on May 10, 2017 at 02:34
    use Kavorka qw(fun); use Scalar::Induce qw(induce void); fun repeat($val!, $times!) { induce { $_-- ? $val : void undef $_ } $times; } repeat('foo', 5); # ('foo', 'foo', 'foo', 'foo', 'foo') repeat({bar => 42}, 3); # 0 HASH(0x138be78) # bar => 42 # 1 HASH(0x138be78) # -> REUSED_ADDRESS # 2 HASH(0x138be78) # -> REUSED_ADDRESS fun range(:$from = 1, :$to!, :$step = 1) { induce { my $curr = $_; undef $_ if ($_ += $step) > $to; return $curr; } $from; } range(step => 1.1, from => 4, to => 17); # (4, 5.1, 6.2, 7.3, 8.4, 9.5, 10.6, 11.7, 12.8, 13.9, 15, 16.1) range(to => 7); # (1, 2, 3, 4, 5, 6, 7) fun partition($n!, @l!) { induce { my @part = splice @$_, 0, $n; undef $_ unless @$_; return \@part; } \@l } partition(3, qw(Aragorn Boromir Frodo Gandalf Gimli Legolas Merry Pipp +in Sam)); # ( # ['Aragorn', 'Boromir', 'Frodo'], # ['Gandalf', 'Gimli', 'Legolas'], # ['Merry', 'Pippin', 'Sam'] # ) fun factor($n!) { induce { for my $i (2..$_/2) { unless ($_ % $i) { $_ /= $i; return $i; } } my $curr = $_; undef $_; return $curr; } $n } factor(138600); # (2, 2, 2, 3, 3, 5, 7, 11)
Entity Tree for 2D isometric games
2 direct replies — Read more / Contribute
by holyghost
on May 09, 2017 at 02:42
    Hello, I've made a z-order speedy Game Entity Tree for use in 2D isometric view games. The thing is you can use an adapter on the tree and use references to alleviate the algorithm. You make lists of entities which get drawn when descending in the balanced tree, a key value is the depth of e.g. the house entities on a background. If you want a more OOP tree, you can use leaf and node tags, consed to data and check these before returning data from e.g. a leaf.
    ### Copyright (C) The Holy Ghost 2017 ###This program is released under the GPL 3.0 and artistic license 2.0 +. use EntityTreeAdapter; package EntityTree; sub new { my ($class) = @_; my $self = { %nodes => {}, @data = (), @_ }; bless ($self, $class); } sub adapter { my ($class) = @_; return EntityTreeAdapter($self); } sub insert { my ($self, $key, $d) = shift; foreach my $k (keys $self->{nodes}) { if ($k == $key) { push ($self->{data}, $d); return $self->{data}; } if ($k > $key and $k < $key) { $self->nodes = {}; $self->{nodes}{$key} .= EntityTree->new->(data + => $d, nodes => $self->collect_nodes($self->nodes)); return $self->{data}; } else { @keys = keys $self->nodes; while (@keys) { $self->insert(pop(@keys), $d); } } } } ### Normally there are only 2 keys per node sub collect_nodes { my ($self, $collection) = shift; my @keys = keys $collection; my @values = values $collection; foreach my $k (@keys) { $collection .= ($k => pop(@values)); } return $collection; } ### depth-frist search sub search { my ($self, $key) = shift; for my $k (keys $self->{nodes}) { if ($self->{nodes}{$k} == $key) { return push ($self->{nodes}{$k}->search($key), + $self->{nodes}{$key}); } else { return $self->{nodes}{$k}->search($key); } } return (); } 1;
    ### Copyright (C) The Holy Ghost 2017 ###This program is released under the GPL 3.0 and artistic license 2.0 +. package EntityTreeAdapter; sub new { my ($class) = @_; my $self = { $tree = shift, @_ }; bless ($self, $class); } sub insert { return $self->{tree}->insert($key, $d); } sub search { return $self->{tree}->search($key); } 1;
solve cubic equations
4 direct replies — Read more / Contribute
by no_slogan
on May 03, 2017 at 01:51
    Everybody knows the quadratic formula, which lets you solve this equation: a x2 + b x + c = 0. Turns out it's not hard to solve when there's also an x3 term. There are either one or three solutions. This algorithm makes me happy.
    use constant pi => 3.141592653589793; sub cubic { # solve a cubic equation in the form # x^3 + a x^2 + b x + c = 0 my ($a, $b, $c) = @_; my $q = $a*$a/9 - $b/3; my $r = ($a*$a/27 - $b/6)*$a + $c/2; my $s = $a / -3; my $d = $r*$r - $q*$q*$q; if ($d > 0) { my $t = (sqrt($d) + abs($r)) ** (1/3); my $u = ($t + $q / $t); return $r > 0 ? $s - $u : $s + $u; } else { my $t = atan2(sqrt(-$d), $r) / 3; my $u = 2 * sqrt($q); # $d <= 0 implies $q >= 0 return ( $s - $u * cos($t), $s - $u * cos($t + 2/3*pi), $s - $u * cos($t - 2/3*pi), ); } }
Prima + MCE::Hobo demonstration
4 direct replies — Read more / Contribute
by marioroy
on Apr 29, 2017 at 03:03

    Respected Monks,

    Starting with MCE 1.828 and MCE::Shared 1.825, running MCE with Prima is possible. The following is based on the Tk + MCE::Hobo demonstration (2nd example in the post). I tested Prima + MCE on Linux using CentOS 7.x and Windows with Strawberry Perl 5.22.x.

    use strict; use warnings; use MCE::Hobo; use MCE::Shared; use Prima qw( Application Buttons Label ); my $que = MCE::Shared->queue(); my $msg = MCE::Shared->scalar("Start"); my $hobo = MCE::Hobo->create("bg_task"); my $wm = Prima::MainWindow->new( size => [ 250, 200 ], text => 'Hello world!', onDestroy => \&quit ); my $lbl1 = Prima::Label->create( owner => $wm, size => [ 220, 50 ], text => 'Prima + MCE Demo', alignment => ta::Center, valignment => ta::Middle, pack => {} ); my $btn1 = Prima::Button->new( owner => $wm, size => [ 120, 50 ], text => $msg->get, onClick => \&fun, pack => {} ); my $btn2 = Prima::Button->new( owner => $wm, size => [ 120, 50 ], text => 'Quit', onClick => sub { $::application->close }, pack => {} ); my $timer = Prima::Timer->create( timeout => 100, onTick => sub { my $new_text = $msg->get; if ($new_text ne $btn1->text) { $btn1->set( text => $msg->get ); } } ); $timer->start; run Prima; sub fun { $que->enqueue("some event"); return; } sub quit { $timer->stop; $hobo->exit->join; $::application->close; } sub bg_task { while ( my $event = $que->dequeue ) { $msg->set("Step One"); sleep 1; $msg->set("Step Two"); sleep 1; $msg->set("Step Three"); } }

    So that the quit function isn't called twice, I'm only calling $::application->close inside the Quit handler. That closes the window which then triggers the MainWindow's onDestroy handler.

    Regards, Mario

    Update: Updated the timer handler. Thanks zentara.

    Update: On the Mac, mouse clicks between windows is greatly improved by setting an option in XQuartz -> Preferences -> Windows -> Click-through Inactive Windows. When enabled, clicking on an inactive window will cause that mouse click to pass through to that window in addition to activating it.

    Update: To improve performance on the Mac, set XQuartz -> Preferences -> Output -> Colors to Thousands. Then relaunch XQuartz for the option to take effect. Prima for the most part runs very well. Thank you, Dmitry.

Parallel::ForkManager + MCE::Shared demonstration
1 direct reply — Read more / Contribute
by marioroy
on Apr 23, 2017 at 22:26

    Respected Monks,

    In preparation for the upcoming MCE 1.828 and MCE::Shared 1.825 releases, am testing various modules with MCE::Shared. One of which is Parallel::ForkManager.

    Discipulus introduced me to zentara recently. zentara am pleased to meet you. Discipulus, imho, folks may choose any parallel module of their liking. It doesn't need to be MCE and the reason for this thread. I like Parallel::ForkManager too.

    Some time back, zentara wrote a Parallel::ForkManager + IPC::Shareable demonstration. Fast forward 2.5 years and here's another way. MCE::Shared provides users of Parallel::ForkManager with threads-like sharing capabilities. Below is zentara's example updated with MCE::Shared bits.

    Not to worry, MCE::Shared performs reasonably well.

    #!/usr/bin/perl # Based on Parallel::ForkManager + IPC::Shareable by zentara. # Found here: use strict; use Parallel::ForkManager; use MCE::Mutex; use MCE::Shared; my $mutex = MCE::Mutex->new(); my $parent_share = tie my %final_parent_hash, 'MCE::Shared'; my $fork_manager = new Parallel::ForkManager(5); $fork_manager->set_waitpid_blocking_sleep(0); foreach my $child ( 1 .. 10 ) { my $pid = $fork_manager->start($child) and next; # Optional, to have the shared-manager assign a data channel. # Helpful when involving heavy IPC usage, not the case here. # Increase 20 to 2000 to see perf-increase from calling ->init. MCE::Shared->init(); for my $id ( 1 .. 20 ) { my $key = $child . '-' . $id; # $mutex->lock; # mutex not necessary when storing unique keys # $parent_share->set($key => qq{|Kid $child pushed $id}); # OO $final_parent_hash{$key} = qq{|Kid $child pushed $id}; # $mutex->unlock; } $fork_manager->finish($child); } print "Waiting for Children...\n"; $fork_manager->wait_all_children; foreach my $child ( 1 .. 10 ) { for my $id ( 1 .. 20 ) { my $key = $child . '-' . $id; if (! exists $final_parent_hash{$key} ) { print "Missing data for Kid $child , data $id\n"; } else { print "$key = $final_parent_hash{$key}\n"; } } }

    The following are recommended modules for MCE::Shared.

    ## MCE::Shared 1. Sereal::Decoder 3.015+ 2. Sereal::Encoder 3.015+ 3. Sereal (ok for completeness, but MCE::Shared doesn't load this) ## MCE::Shared applies to Condvar, Handle, and Queue 1. IO::FDPass 1.2+

    Q. Why is Sereal beneficial?

    A. The main reason is for extra performance. To ensure minimum memory consumption, there's no reason to load the Storable module if Sereal is available in Perl. This is handled transparently.

    Q. Why is IO::FDPass beneficial?

    A. Being able to construct a shared condvar, handle, or queue while the shared-manager is running greatly adds to the ease-of-use. These involve handles behind the scene. Basically, am able to send the relevant fd descriptors to the shared-manager. Without FDPass, one must be careful to construct Condvar, Handle, and Queue first before other shared objects and later starting the shared-manager manually. Note: MCE and MCE::Hobo starts the shared-manager if not already started.

    Q. What is MCE::Shared->init all about?

    A. For MCE, MCE::Hobo, and threads (via CLONE), MCE::Shared->init() is called automatically. It assigns the worker 1 of 12 data channels for use during IPC. Calling init is totally optional. If the worker is sending data one time, probably not necessary. On the other hand, if doing lots of IPC, then yes worth it.

    For further reading, see also this thread made by karlgoethebier or this reply regarding performance characteristics (TIE and Mutex or OO). Basically, performance is possible. And so is fun.

    Regards, Mario.

Generic De Bruijn Sequence
5 direct replies — Read more / Contribute
by QM
on Apr 19, 2017 at 12:38
    I needed to write a sequence for a test, where there are N elements, and all T-tuples of elements are used, in the shortest sequence. A search turned up De Bruijn sequences.

    The easy algorithm takes N elements and produces every N-tuple permutation. With a little tinkering, I have the B(N,T) version. Not fast, can't handle large sequences, and runs out of space quickly. But for small T, does what I need.

    It quickly became apparent that large T values would not be useful in my test, though N could be about 50.

    Here are some results:


    Here's the code.

    #!/usr/bin/env perl # # Generate a string with the longest non-repeating subsequences possib +le. # Include overlaps. # # Input N, size of the alphabet. # Input T, tuples (pairs, triples, quadruples, etc.) # # Start with all N-length permutations. # Create a graph of all pairs A(B...Y)Z, # such that every pair whose left member ends with B...Y, # the right member starts with B...Y (for some length n-1) # Find an Eulerian path through the permutations (visit every node onl +y once) # The sequence of starting node, plus each additional ending letter, # is the De Bruijn sequence for this alphabet. use strict; use warnings; my $n = (shift or 4); # N for alphabet size my $t = (shift or $n); # T for Tuples (pairs, triples, quadruples) my $n1 = $n - 1; my $t1 = $t - 1; my @alphabet = ('A'..'Z','0'..'9','a'..'z'); if (@alphabet < $n) { die "Alphabet is smaller than $n\n"; } # glob character of length 1 my $alphabet = '{' . join(',', @alphabet[0..$n1]) . '}'; # Generate all strings of length $t in the given alphabet my $glob_string = $alphabet x $t; my @nodes = glob("$glob_string"); # Generate the graph of all strings that overlap in t-1 characters. my %graph; for my $node1 (@nodes) { for my $node2 (@nodes) { next if $node1 eq $node2; # If they overlap, add node2 to the array for node1 if (substr($node1,1,$t1) eq substr($node2,0,$t1)) { push @{$graph{$node1}}, $node2; } } } # String starts with first node's full string. # Walk through the graph: # Delete the node behind # Add the last char of next node to string # Print result my $node1 = $nodes[0]; my $q = 0; # print "$q : $node1\n"; # debug my $string = $node1; while (scalar keys %graph > 1) { my $moved = 0; # "reverse" here somehow "does the right thing", and enables an # Eulerian circuit with no added logic. for my $node2 (reverse @{$graph{$node1}}) { if (exists($graph{$node2})) { $string .= substr($node2,$t1,1); # Add last char to string delete($graph{$node1}); $node1 = $node2; $moved = 1; # print ++$q, " : $node2\n"; # debug last; } } # Avoid endless loops on pathological cases unless ($moved) { warn "Didn't find next node ($node1)\n"; last; } } print "$string\n"; exit;

    I'm interested in tweaks to make it faster, smaller, better, etc. Or pointers to other solutions.

    Quantum Mechanics: The dreams stuff is made of

Perl 2FA Secret Store
No replies — Read more | Post response
by rdfield
on Apr 16, 2017 at 13:28
    Everywhere I looked there seemed to only be an "app" for storing 2FA "Google Authenticator" secrets, here is short script that stores an encrypted file with the entered password.

    #!/usr/bin/perl use strict; use warnings; use Authen::OATH; use Convert::Base32; use File::Slurp; use Data::Serializer; =pod perl password nickname [secret] prints out the current and next 6 digit "Google Authenticator" token the secret is from the first line of the .google_authenticator file (o +r the "Secret" from online 2FA codes) ./ mylocalpassword myremoteacct@server WRFPU2CIXFIGYYYC stores the secret (WRFPU2CIXFIGYYYC) with the nickname myremoteacct@se +rver ./ mylocalpassword myremoteacct@server prints 826651 377440 which is the current 6 digit code (826651) and the next one (377440), +just in case :-) Note: the save file (2fa.txt) is encrypted using your password A good tutorial for adding 2FA to your SSH connections: +actor-authentication-for-ssh-on-ubuntu-14-04 Adding 2FA to Perl scripts: parameters: password - the password for the save file, which contains the map betw +een nicknames and secrets nickname - if the third parameter, secret, is not supplied then this d +isplays the 6 digit code secret - if supplied, then this secret is stored in the save file (./2 +fa.txt) for nickname =cut my $passwd = shift @ARGV; my $nickname = shift @ARGV; my $secret_base32 = shift @ARGV; my $filename = "2fa.txt"; my $ser = Data::Serializer->new( serializer => 'Storable', digester => 'MD5', cipher => 'DES', secret => $passwd, compress => 1 ); my $data; if (-e $filename) { eval { $data = $ser->deserialize("" . read_file($filename))}; if ($@) { die "error reading $filename: $@\n"; } } if (defined($secret_base32)) { $data->{$nickname} = $secret_base32; # no check on format of $secret_base32, if you can't get that right + it ain't my problem open FA2, ">", $filename or die "Can't open $filename for writing $ +@\n"; print FA2 $ser->serialize($data); close FA2; die "$nickname saved\n"; } die "$nickname not found\n" unless defined($data->{$nickname}); $secret_base32 = $data->{$nickname}; my $correct_token = sprintf("%06s", Authen::OATH->new->totp( decode_base32( $secret_base32 ) ) ); # the current token $correct_token .= " " . sprintf("%06s", Authen::OATH->new->totp( decode_base32( $secret_base32), time() + 30 ) ); # the next token die "$correct_token\n";


Happy unbirthday redux! and other birthday stuff
1 direct reply — Read more / Contribute
by Lady_Aleena
on Apr 15, 2017 at 01:34

    Hello everyone! About five and a half years ago, I posted Happy unbirthday!. When I saw my fifteenth PerlMonks anniversary, I decided to write something new. However, I began to notice the new code I was writing had similar aspects to the old code I wrote for Unbirthdays, specifically the date verification subroutines I was was writing. So, I opened up Unbirthdays and took a second look. So here is the updated Unbirthdays and the new Birthday scripts.


    Date::Verify verifies in input and returns the appropriate value.

    • four_digit_year verifies the user input a four digit year. Usage: four_digit_year($year)
    • month_name verifies the mount input is correct (such as inputting 13 as a month or the too short Ju). It returns a fully spelled out month name. Usage: month_name($month)
    • month_number verifies the same as month_name, but it returns a month number instead. Usage: month_number($month)
    • day_number verifies the day is a number and that the day exists within the month of the year. It returns the day number. Usage: day_number($year, $month, $day)

    I am thinking on localizing this to the various countries available on Date::Calc.

    I have made several changes to unbirthdays.

    • First, I got rid of the Q&A. That became annoying to me while testing the changes I made to the script. To that end, I moved the input to the command line as @ARGV.
    • Second, the Q&A was written to recurse until the input was in the correct form, however, the script now dies if the input is not in the correct form.
    • Third, I fixed several things from the former unbirthdays thread.

    Usage is: name month day year. However, if help is used, a helpful message appears.

    I was writing when I realized I was writing similar code as was in This script will tell the user their tropical zodiace sign, their birth stone and flowers (flowers for the US and UK are listed), and birth day stone (based on day of the week the user was born).

    This is a silly little script, but it helped me fix the previous one.

    Usage is: name month day year. However, if help is used, a helpful message appears.

    In closing

    I know these scripts probably still need work. I just hope you find them fun, or at least interesting.

    No matter how hysterical I get, my problems are not time sensitive. So, relax, have a cookie, and a very nice day!
    Lady Aleena

Add your 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?

    What's my password?
    Create A New User
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (3)
    As of 2018-02-19 04:39 GMT
    Find Nodes?
      Voting Booth?
      When it is dark outside I am happiest to see ...

      Results (258 votes). Check out past polls.