Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things

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.

Free Microsoft ebook downloader.
No replies — Read more | Post response
by marto
on Jul 21, 2017 at 11:35

    I was made aware that Microsoft giving away free ebooks. Excuse the clickbaity page title, I have nothing to do with it. While people have posted wget scripts to download them all, it doesn't rename them so you end up with some random file names. I threw the script below together really quickly, consider it a cheap hacky but functional (no errors here) script. For each 'Category' it creates a directory, and uses Mojolicious/Mojo::UserAgent to get the page, parse what we need from it, download each file to the it's associated category directory, with the actual ebook name.


    • Ensure you have an up to date Mojolicious installed (cpanm Mojolicious).
    • Copy the script below into it's own directory before running.
    • Not all ebooks are available in all formats. I just select the top one in the list. Most are PDF, some are ebup or .doc
    #!/usr/bin/perl use strict; use warnings; no warnings 'utf8'; use Mojo::UserAgent; my $ebookURL = ' +icrosoft-ebook-giveaway-im-giving-away-millions-of-free-microsoft-ebo +oks-again-including-windows-10-office-365-office-2016-power-bi-azure- +windows-8-1-office-2013-sharepo/'; my $ua = Mojo::UserAgent->new; print "Get page\n"; my $res = $ua->get( $ebookURL )->res; # css selector we want the first table witin the entry-content div, sk +ipping # the first row which is a header, but not a 'th' tag. my $selector = 'div.entry-content table:first-of-type tr:not(:first-of +-type)'; warn "Parse page\n"; $res->dom->find( $selector )->each( sub{ my $category = $_->children->[0]->all_text; my $title = $_->children->[1]->all_text; my $url = $_->children->[2]->at('a')->attr('href'); my $type = $_->children->[2]->at('a')->all_text; # download each file print "downloading: $title\n"; # create category directory unless it already exists mkdir $category unless( -d $category ); $ua->max_redirects(5) ->get( $url ) ->result->content->asset->move_to($category . '/' . $title . '.' + . $type); # play nice sleep(7); });
Using a controllerless servo on the Raspberry Pi with Perl
2 direct replies — Read more / Contribute
by stevieb
on Jul 08, 2017 at 17:03

    I've received quite a few pieces of great feedback from a variety of people since posting about writing my Perl/Raspberry Pi tutorial, and a lot of good has come from that feedback already.

    One person who pointed out one minor mistake of mine with follow up with some other questions, asked about how to run a servo without needing a controller board. I realized that I hadn't exposed a couple of functions in the core WiringPi::API distribution that allowed a user to configure the PWM frequency, which is required as the Pi default doesn't play nice with typical servos.

    The default PWM base frequency on a Pi is 19.2MHz, which is then divided by the clock signal (default: 32) and the PWM range (0-1023). So to get the default operating frequency:

    # base range clck operational freq 19.2e6 / 1024 / 32 == 586Hz

    To get this down to 50Hz required for a typical servo, I bumped up the range to 2000 (nice round number), and then just bounced around with the clock signal divider until I hit 50:

    19.2e6 / 2000 / 192 == 50Hz

    To be honest, I found the formula online, but then read through the datasheet for the Pi, and went on my way to not just copy and paste, but figure out exactly what frequency meant, what the divisors meant and then felt comfortable knowing exactly how PWM works ;)

    So, for full left, the servo requires a pulse of 50Hz for ~1ms (PWM 50), centre is ~1.5ms (PWM 150) and full right is ~2.5ms (PWM 250). My servo required me to tweak these numbers a tiny bit to get the full 180 degree motion.

    Anyway, to some code. I've commented the code as to what's happening and when, but an overall is that when started, the servo will go full-left, wait a sec, then swing from left-to-right, then back right-to-left until a SIGINT (CTRL-C) is caught, at which time, it puts the servo back to left position, then puts the pin back to INPUT mode so that if a different software is run after, the pin won't still be in PWM mode.

    Unfortunately, at this time, we still require sudo for PWM functionality. It's being looked at. It's the *only* thing left that requires root.

    use warnings; use strict; use RPi::WiringPi; use RPi::WiringPi::Constant qw(:all); die "need root!\n" if $> !=0; use constant { LEFT => 60, RIGHT => 255, CENTRE => 150, PIN => 18, DIVISOR => 192, RANGE => 2000, DELAY => 0.001, }; # set up a signal handler for CTRL-C my $run = 1; $SIG{INT} = sub { $run = 0; }; # create the Pi object my $pi = RPi::WiringPi->new; # create a signal pin, set mode to PWM output my $s = $pi->pin(PIN); $s->mode(PWM_OUT); # configure PWM to 50Hz for the servo $pi->pwm_mode(PWM_MODE_MS); $pi->pwm_clock(DIVISOR); $pi->pwm_range(RANGE); # set the servo to left max $s->pwm(LEFT); sleep 1; while ($run){ for (LEFT .. RIGHT){ # sweep all the way left to right $s->pwm($_); select(undef, undef, undef, DELAY); } sleep 1; for (reverse LEFT .. RIGHT){ # sweep all the way right to left $s->pwm($_); select(undef, undef, undef, DELAY); } sleep 1; } # set the pin back to INPUT $s->pwm(LEFT); $s->mode(INPUT);

    It won't be until later today after I get some extra tests written and update a couple of other items that are lingering, but it is available on Github for now.

    Note that the Pi may struggle to power the servo and it may cause a low-voltage situation, so it's best you power your 5v servo from an alternate source (I just happen to have a few powered-up Arduino's nearby all with 5v pins accessible). Also note that even though the +/- of the servo is 5v, you can safely connect the signal pin on it to the 3.3v GPIO on the Pi as on the servo, the pin is input only (ie. it doesn't feed back to the Pi).

Two small programs for comment
3 direct replies — Read more / Contribute
by Jambo Hamon
on Jul 07, 2017 at 08:10

    Two small programs. Just putting it out there for anyone who might be interested.

    First one posted generates the lexicographic ordering of balanced parenthesis. Second one finds the least number of block moves to turn one string into another string.

    Both are just initial sketches but I think they do what they should.

    $ perl 3 ()()() ()(()) (())() (()()) ((())) $ perl jamon hamon p=1 q=1 l=4 $ perl abcdef acdegh p=0 q=0 l=1 p=2 q=1 l=3
    #!/usr/bin/perl =begin Algorithm taken from: TAOCP - D.Knuth Vol 4 Fascicle 4 Generating All Trees History of Combinatorial Generation Algorithm P (Nested parenthesis in lexicographic order) =cut use strict; use warnings; use v5.10; my $n = shift || die "$!: need size"; my ( $l, $r ) = qw! ( ) !; my $m; ( $m, my @a ) = init( $n, $m ); my $j; while (1) { visit(@a); ( $m, @a ) = easy( $m, @a ); next if ( $a[$m] eq $l ); ( $m, $j, @a ) = findj( $m, @a ); last if ( $j == 0 ); ( $m, @a ) = incj( $m, $j, @a ); } sub easy { my $m = shift; my @a = @_; $a[$m] = $r; if ( $a[ $m - 1 ] eq $r ) { $a[ $m - 1 ] = $l, $m--; } return $m, @a; } sub incj { my $m = shift; my $j = shift; my @a = @_; $a[$j] = $l; $m = 2 * $n - 1; return $m, @a; } sub findj { my $m = shift; my @a = @_; my $j = $m - 1; my $k = 2 * $n - 1; while ( $a[$j] eq $l ) { $a[$j] = $r, $a[$k] = $l, $j--, $k -= 2; } return $m, $j, @a; } sub init { my $n = shift; my $m = shift; $m = 2 * $n - 1; my @a; for my $k ( 1 .. $n ) { @a[ 2 * $k - 1, 2 * $k ] = ( $l, $r ); } $a[0] = $r; return $m, @a; } sub visit { shift; print @_, "\n"; }
    #!/usr/bin/perl =begin How many block moves does it take to transform one string to another? algorithm taken from: the string-to-string correction probem by Walter F. Tichy ACM Transactions on Computer Systems Vol 2 No 4 Number 1984 p. 309-321 =cut use strict; use warnings; use v5.10; my @s = split //, shift || "shanghai rulez"; my @t = split //, shift || "sakhalin rulez"; # lengths my $n = $#t; my $m = $#s; my ( $p, $q, $l ) = ( 0, 0, 0 ); while ( $q <= $n ) { ( $p, $l ) = f($q); printf( "p=%d\tq=%d\tl=%d\n", $p, $q, $l ) if ( $l > 0 ); $q = $q + ( 1, $l )[ 1 < $l ]; # max(1,l) ... Perlmonks } sub f { my ($q) = @_; my $pCur = 0; my $l = 0; my $p = 0; while ( ( $pCur + $l <= $m ) and ( $q + $l <= $n ) ) { my $lCur = 0; while ( ( $pCur + $lCur <= $m ) and ( $q + $lCur <= $n ) and ( $s[ $pCur + $lCur ] eq $t[ $q + $lCur ] ) ) { $lCur++; } if ( $lCur > $l ) { $l = $lCur; $p = $pCur; } $pCur++; } return ( $p, $l ); }
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.

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 romping around the Monastery: (5)
    As of 2017-07-22 04:15 GMT
    Find Nodes?
      Voting Booth?
      I came, I saw, I ...

      Results (336 votes). Check out past polls.