Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery

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.

moon illumination and eclipses
2 direct replies — Read more / Contribute
by no_slogan
on Aug 20, 2017 at 16:00
    Here's a relatively short program that calculates the fraction of illumination of the moon at a given time. This is relevant right now because it's a function of the angle between the sun and the moon. When the angle is small enough, there's a solar eclipse, as we will get a chance to see tomorrow. Unfortunately, the moon wobbles around in the sky too much for a simple program like this to cope with, so it can't produce high-accuracy eclipse predictions, but it might be interesting to some people. Visit JPL for more information.
Colour/color sampler
2 direct replies — Read more / Contribute
by Nige
on Aug 20, 2017 at 06:38

    So, an XML file or web post lists a bunch of colour specs like; 0x1e93c6, 0xf2b827, 0xd6563c, 0x6a5c9e, 0x31a35f; and you want to see what they look like.

    You could paste each one into a colour viewer, but I couldn't find any tool to take them all at once. The following code takes random text containing hex colour strings, and creates an HTML file of square colour swatches.

    #!/usr/bin/perl -w # # - Extract colour strings from random code or HTML. # Currently only looks for 0xRRGGBB and #RRGGBB. # # perl < source.txt > swatch.html # # and then open swatch.html in a browser! # # Chars that make up a colour string: # my $hexRegex = '0-9a-zA-Z'; my $colRegex = "#x$hexRegex"; my @hexSs = (); while ( <STDIN> ) { chomp; my @words = split /[^$colRegex]/; push @hexSs, (grep /^(0x|#)[$hexRegex]{6}$/, @words); } map { s/^(0x|#)(......)/$2/ } @hexSs; #print "Content-type: text/html\n\n"; print "<HTML>\n\n"; print "<HEAD>\n"; print "<TITLE>Colour swatches from random text</TITLE>\n"; print "</HEAD>\n\n"; print "<BODY><TABLE BORDER=1>\n"; print "<TR>"; my $cell = 0; foreach my $hex ( @hexSs ) { print "<TD BGCOLOR='#$hex'>", "<FONT COLOR='white'>$hex</FONT><BR><BR>", "<FONT COLOR='black'>$hex</FONT></TD>"; if ( $cell++ gt 4 ) { $cell=0; print "</TR>\n</TR>" } } print "</TR></TABLE></BODY></HTML>\n";
How RPi::WiringPi suite is automagically unit tested
1 direct reply — Read more / Contribute
by stevieb
on Aug 17, 2017 at 20:57

    A while ago, we were talking about my desire to write a tutorial about "Perl and Raspberry Pi". To kick it off, I thought I'd write a blog post covering some of the aspects of how I ensure full automatic unit test coverage of the software, and its core functionality.

    I posted it over on my blog, so for now, I'm just going to link to it as it's just a one-off that I quickly put together. If anyone is interested in how this software is tested, have a look. If you have feedback, all the better. Questions? That's the best I could ask for.

    How RPi::WiringPi distribution gets tested


Number Grid Fillin
3 direct replies — Read more / Contribute
by QM
on Aug 14, 2017 at 04:41
    Saw this idea recently. Wondered how susceptible it would be to a brute force approach.

    Given a square grid size N, and a list of numbers 2*N**2 2*N, find a fillin (like a crossword), and report the digits in the major diagonal (as an easy proof of solution).

    The reference in the spoiler took an hour or two to find the solution. I won't post the solution here, you'll have to do the work yourself.

    Quantum Mechanics: The dreams stuff is made of

Reading/writing Arduino pins over I2C with Perl
No replies — Read more | Post response
by stevieb
on Jul 23, 2017 at 14:25

    In today's episode of Cool Uses for Perl, loosely inspired by this thread, I'm going to show how to set up an Arduino (Uno in this test case) with a pseudo-register that allows toggling one if its digital pins on and off, and another pseudo-register to read an analog pin that the digital pin is connected to, over I2C. Because it's digital to analog, the only possible values of the analog read will be 0 (off) or 1023 (full on, ie. 5v). This is an exceptionally basic example, but with some thought, one can imagine the possibilities (read/write EEPROM, set PWM etc etc).

    We'll then use RPi::I2C to toggle the digital pin and read the analog pin over the I2C bus. Note I'm not using the encompassing RPi::WiringPi distribution in this case. The benefit to using that is to clean up Raspberry Pi's GPIO pins, which we aren't using any. In fact, any Linux device with I2C can be used for this example, I just so happen to be using one of my Pi 3 boards.

    First, the simple Arduino sketch. All I2C devices require putting themselves on the "wire" with a unique address. I'm using 0x04, which is how the Pi will identify the Arduino on the I2C bus.

    #include <Wire.h> // Arduino I2C address #define SLAVE_ADDR 0x04 // pseudo register addresses #define READ_A0 0x05 #define WRITE_D2 0x0A uint8_t reg = 0; void read_analog_pin (){ switch (reg){ case READ_A0: { __read_analog(A0); break; } } } void __read_analog (int pin){ int val = analogRead(pin); uint8_t buf[2]; // reverse endian so we're little endian going out buf[0] = (val >> 8) & 0xFF; buf[1] = val & 0xFF; Wire.write(buf, 2); } void write_digital_pin (int num_bytes){ reg =; // global register addr while(Wire.available()){ uint8_t state =; switch (reg){ case WRITE_D2: { digitalWrite(2, state); break; } } } } void setup(){ Wire.begin(SLAVE_ADDR); // set up the I2C callbacks Wire.onReceive(write_digital_pin); Wire.onRequest(read_analog_pin); // set up the pins pinMode(2, OUTPUT); pinMode(A0, INPUT); } void loop(){ delay(10000); }

    Now, I'll show a simple script that loops 10 times, toggling the digital pin then displaying the value from the analog pin. Arudino's Wire library sends data a byte at a time, so we have to do some bit manipulation to turn the two bytes returned in the read_block() call back together into a single 16-bit integer. I wrote the merge() sub to take care of this job.

    use warnings; use strict; use RPi::Const qw(:all); use RPi::I2C; use constant { ARDUINO_ADDR => 0x04, READ_REGISTER => 0x05, WRITE_REGISTER => 0x0A, }; my $device = RPi::I2C->new(ARDUINO_ADDR); for (0..9){ my (@bytes_read, $value); $device->write_byte(HIGH, WRITE_REGISTER); @bytes_read = $device->read_block(2, READ_REGISTER); $value = merge(@bytes_read); print "$value\n"; # 1023 $device->write_byte(LOW, WRITE_REGISTER); @bytes_read = $device->read_block(2, READ_REGISTER); $value = merge(@bytes_read); print "$value\n"; # 0 } sub merge { return ($_[0] << 8) & 0xFF00 | ($_[1] & 0xFF); }


    1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0

    update: I must acknowledge Slava Volkov (SVOLKOV) for the actual XS code. Most of the low-level hardware code I've been working on over the last year has been wrapping C/C++ libraries, a decent chunk of it has had me following datasheets to write my own, but in this case, I bit the whole XS file from Device::I2C and just presented a new Perl face to it so it fit in under the RPi::WiringPi umbrella. It just worked.

Download free Microsoft ebooks, fun with Mojolicious and CSS selectors
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 epub 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/'; =head1 NAME ms-ebook-dl - Download free Microsoft ebooks =head1 DESCRIPTION A quick hack using L<Mojolicious> to download and properly name a bunc +h of free ebooks from Microsoft. =head1 INSTALLATION Ensure you have an up to date L<Mojolicious> installed: C<cpanm Mojolicious> Clone the repo: C<git clone> =head1 LICENSE This is released under the Artistic License. See L<perlartistic>. =head1 AUTHOR marto L<> =head1 SEE ALSO L<> L< +microsoft-ebook-giveaway-im-giving-away-millions-of-free-microsoft-eb +ooks-again-including-windows-10-office-365-office-2016-power-bi-azure +-windows-8-1-office-2013-sharepo/> =cut 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); });

    Update: code updated with some POD, also on on github.

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

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
    [Corion]: Hi marto!
    choroba greets
    [choroba]: .org and .com not working for me today, only .net
    Eily is connected on .org

    How do I use this? | Other CB clients
    Other Users?
    Others having an uproarious good time at the Monastery: (8)
    As of 2017-10-23 09:14 GMT
    Find Nodes?
      Voting Booth?
      My fridge is mostly full of:

      Results (277 votes). Check out past polls.