Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked

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.

Ssh and qx
1 direct reply — Read more / Contribute
by cbeckley
on Mar 30, 2017 at 14:04

    It actually took a little digging to find out how to properly handle the output and the various return codes of qx when executing an ssh command.

    Why would you actually want to do such a thing to begin with? You wouldn't. Don't do it. Stop! For the love of ...

    If, however, you have a machine who's operating system hasn't had a vendor supported upgrade any time this century, you may not have a choice.

    I feel your pain. It runs deep, share it with me.

    sub ops_do_ssh_qx { my ($cmd) = @_; $cmd->{ssh_cmd_qx} = 'ssh ' . $cmd->{user} . '\@' . $cmd->{host} . + ' \'' . $cmd->{command} . '\'' . ' 2>/dev/null'; $cmd->{output} = qx($cmd->{ssh_cmd_qx}); if ( defined $cmd->{output} ) { $cmd->{cmd_ret_code} = $?; chomp $cmd->{output}; if ( $cmd->{cmd_ret_code} ) { $cmd->{success} = FAILURE; } } else { ($cmd->{ssh_ret_code}, $cmd->{ssh_ret_msg}) = (0 + $!, '' . $!); $cmd->{success} = FAILURE; } return $cmd; }

    The hash you pass in looks like this:

    my $cmd = { name => 'foo', user => 'foo_user', host => '', command => 'do_something_useful_here', success => SUCCESS };

    And you invoke it thusly:

    my $cmd_status = ops_do_ssh_qx($cmd); if ( $cmd_status->{success} ) { do_something_with $cmd_status->{output}; } else { do_something_with $cmd_status->{cmd_ret_code}, $cmd_status->{ssh_re +t_code}, $cmd_status->{ssh_ret_msg}; }

    Unfortunately the values you end up with in

    $cmd_status->{cmd_ret_code} $cmd_status->{ssh_ret_code} $cmd_status->{ssh_ret_msg}
    are, for both the OS and SSH, implementation dependent, which is just one of the reasons you shouldn't be doing this if you have a choice.

    If anybody finds this useful, you have my condolences.


    Update: haukex has a great write up regarding alternatives to qx/backticks here Re: curl without backticks and system() (updated x2). My Perl was too old for the ones I tried, but afoken has indicated that piped opens are available even in 5.004.

Automatically ensure your CPAN dists have up-to-date prereq version numbers
No replies — Read more | Post response
by stevieb
on Mar 26, 2017 at 19:29

    So... one of my distribution relies heavily on other distributions I've written, and it's hard to ensure my dependencies for my own modules are up-to-date in the prerequisite list in the build system. Sometimes I forget to bump a prereq before I do a release, which means I have to immediately do a one-line release the next day, because I'll have emails from CPAN Testers because tests are failing.

    I've been toying with a few ways to automatically check this for me. Below is one such hack I came up with. There's two vars that need to be set: $dist and $author. It then pulls the distribution from the CPAN, extracts all of it's prerequisite dependency information. Then, it fetches the list of all distributions I've put on the CPAN, and creates a dist/version hash.

    Note that this compares *only* the prereqs that I personally have uploaded. It'd be trivial to modify a bit to check them all.

    After the data is collected, it iterates the known dependencies, and if there's a match with one of my own other distributions, I compare versions. Currently, it just prints out the list, but I'm going to hack this into my Test::BrewBuild system as another command line option so that every build run, I'll be notified of any discrepancies. Eventually, I'll likely make it auto-update the Makefile.PL files for me with the new dep versions, as well as have it review the prereq versions in the current repo of the dist I'm working on, instead of comparing to the latest CPAN release, so I can correct the issues *before* pushing to PAUSE :)

    use warnings; use strict; use MetaCPAN::Client; my $c = MetaCPAN::Client->new; my $dist = 'RPi-WiringPi'; my $author = 'STEVEB'; check_deps($dist, $author); sub check_deps { my ($dist, $author) = @_; if ($dist =~ /:/){ die "\$dist must be hyphenated... don't use ::\n"; } my $release = $c->release($dist); my $deps = $release->{data}{dependency}; my $author_modules = author_modules($author); for my $dep (@$deps){ my $dep_mod = $dep->{module}; my $dep_ver = $dep->{version}; if (exists $author_modules->{$dep_mod}){ my $cur_ver = $author_modules->{$dep_mod}; print "$dep_mod: \n" . "\tdep ver: $dep_ver\n" . "\tcur ver: $cur_ver\n\n"; } } } sub author_modules { my ($author) = @_; my $query = { all => [ { author => $author }, { status => 'latest' }, ], }; my $limit = { '_source' => [ qw(distribution version) ] }; my $releases = $c->release($query, $limit); my %rel_info; while (my $rel = $releases->next){ my $dist = $rel->distribution; $dist =~ s/-/::/g; $rel_info{$dist} = $rel->version; } return \%rel_info; }


    perl perl/dependency_version_compare/ RPi::DigiPot::MCP4XXXX: dep ver: 2.3603 cur ver: 2.3603 RPi::BMP180: dep ver: 2.3603 cur ver: 2.3603 RPi::ADC::MCP3008: dep ver: 2.3603 cur ver: 2.3603 RPi::SPI: dep ver: 2.3606 cur ver: 2.3606 RPi::DAC::MCP4922: dep ver: 2.3604 cur ver: 2.3604 RPi::WiringPi::Constant: dep ver: 0.02 cur ver: 0.02 RPi::DHT11: dep ver: 1.02 cur ver: 1.02 WiringPi::API: dep ver: 2.3609 cur ver: 2.3609 RPi::ADC::ADS: dep ver: 1.01 cur ver: 1.01
oneliner: autorun script when I save it in the editor
3 direct replies — Read more / Contribute
by FreeBeerReekingMonk
on Mar 26, 2017 at 18:08
    Sometimes you get spoiled by IDE's that have F5 to save and run what you have scripted so far... so... what can you do if you have 2 xterms (one for vi, the other for the output)?

    perl -E 'while(-f $ARGV[0]){ $now=(stat(_))[9]; system($^X,@ARGV) if($ +now-$prev); $prev=$now; sleep 1}' /home/user/ foo bar

    with having:

    #! env perl my $p1 = $ARGV[0]; my $p2 = $ARGV[1]; print "param1=$p1 param2=$p2\n";


    param1=foo param2=bar

    Tested to work under Win10 and Linux

    Of course, there are better implementations. inotifywait or auditd if available on your system...

    any perl golfers?

    Update: we now incorporate the improvement made by haukex. Feel free to add more parameters if you need these

Sparrow - your own script manager
3 direct replies — Read more / Contribute
by melezhik
on Mar 23, 2017 at 16:06

    Sparrow - script manager. One can easily create and distributes scripts using Sparrow/Outthentic tool chain.

    Here are some examples. ( You may find a detailed information at Sparrow docs )

    # install sparrow

    $ cpanm Sparrow

    # create useful script

    $ cat story.bash
    /etc/init.d/nginx status # tell me if nginx server is running
    $ touch story.check

    # upload script to SparrowHub repository

    $ cat sparrow.json
      "name" : "nginx-check",
      "version" : "0.0.1",
      "description" : "nginx check script"
    $ sparrow plg upload

    # run sparrow script at other host

    $ ssh
    $ sparrow plg install nginx-check
    $ sparrow plg run  nginx-check
    p> nginx-check at 2017-03-23 23:00:27
    ● nginx.service - A high performance web server and a reverse proxy server
       Loaded: loaded (/lib/systemd/system/nginx.service; enabled)
       Active: active (running) since Thu 2017-03-23 23:00:20 MSK; 6s ago
      Process: 10062 ExecStart=/usr/sbin/nginx -g daemon on; master_process on; (code=exited, status=0/SUCCESS)
      Process: 10060 ExecStartPre=/usr/sbin/nginx -t -q -g daemon on; master_process on; (code=exited, status=0/SUCCESS)
     Main PID: 10064 (nginx)
       CGroup: /system.slice/nginx.service
               ├─10064 nginx: master process /usr/sbin/nginx -g daemon on; master_process on
               └─10065 nginx: worker process
    ok      scenario succeeded

    Interested? You may know more - other plugins ready to use, tasks, cron jobs, check lists, YAML/JSON/Config::General configuration, other languages support and even more! Follow

Mutex::Flock - Fcntl advisory locking supporting processes and threads.
2 direct replies — Read more / Contribute
by marioroy
on Mar 23, 2017 at 02:59


    Re: Scheduling Perl Tasks

    This is a nice to have module for anybody that wants it. Lately, I lack the time to make a module and publish on CPAN. It is well tested on all supported platfoms including support for threads. It is also optimized, thus low overhead.

    ## Mutex::Flock - Fcntl-based advisory locking. package Mutex::Flock; use strict; use warnings; no warnings qw( threads recursion uninitialized once ); our $VERSION = '0.007'; use Fcntl ':flock'; use Carp (); my $has_threads = $INC{''} ? 1 : 0; my $tid = $has_threads ? threads->tid() : 0; sub CLONE { $tid = threads->tid() if $has_threads; } sub DESTROY { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->unlock(), close(delete $obj->{_fh}) if $obj->{ $pid }; unlink $obj->{path} if ($obj->{_init} && $obj->{_init} eq $pid); return; } sub _open { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); return if exists $obj->{ $pid }; open $obj->{_fh}, '+>>:raw:stdio', $obj->{path} or Carp::croak("Could not create temp file $obj->{path}: $!"); return; } ## Public methods. my ($id, $prog_name) = (0); $prog_name = $0; $prog_name =~ s{^.*[\\/]}{}g; $prog_name = 'perl' if ($prog_name eq '-e' || $prog_name eq '-'); sub new { my ($class, %obj) = (@_); if (! defined $obj{path}) { my ($pid, $tmp_dir, $tmp_file) = ( abs($$) ); if ($ENV{TEMP} && -d $ENV{TEMP} && -w _) { $tmp_dir = $ENV{TEMP}; } elsif ($ENV{TMPDIR} && -d $ENV{TMPDIR} && -w _) { $tmp_dir = $ENV{TMPDIR}; } elsif (-d '/tmp' && -w _) { $tmp_dir = '/tmp'; } else { Carp::croak("no writable dir found for temp file"); } $id++, $tmp_dir =~ s{/$}{}; # remove tainted'ness from $tmp_dir if ($^O eq 'MSWin32') { ($tmp_file) = "$tmp_dir\\$prog_name.$pid.$tid.$id" =~ /(.* +)/; } else { ($tmp_file) = "$tmp_dir/$prog_name.$pid.$tid.$id" =~ /(.*) +/; } $obj{_init} = $has_threads ? $$ .'.'. $tid : $$; $obj{ path} = $tmp_file.'.lock'; } # test open open my $fh, '+>>:raw:stdio', $obj{path} or Carp::croak("Could not create temp file $obj{path}: $!"); close $fh; # update permission chmod 0600, $obj{path} if $obj{_init}; return bless(\%obj, $class); } sub lock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } *lock_exclusive = \&lock; sub lock_shared { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); $obj->_open() unless exists $obj->{ $pid }; flock ($obj->{_fh}, LOCK_SH), $obj->{ $pid } = 1 unless $obj->{ $pid }; return; } sub unlock { my ($pid, $obj) = ($has_threads ? $$ .'.'. $tid : $$, @_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0 if $obj->{ $pid }; return; } sub synchronize { my ($pid, $obj, $code, @ret) = ( $has_threads ? $$ .'.'. $tid : $$, shift, shift ); return if ref($code) ne 'CODE'; $obj->_open() unless exists $obj->{ $pid }; # lock, run, unlock - inlined for performance flock ($obj->{_fh}, LOCK_EX), $obj->{ $pid } = 1 unless $obj->{ $p +id }; defined wantarray ? @ret = $code->(@_) : $code->(@_); flock ($obj->{_fh}, LOCK_UN), $obj->{ $pid } = 0; return wantarray ? @ret : $ret[-1]; } *enter = \&synchronize; sub timedwait { my ($obj, $timeout) = @_; local $@; local $SIG{'ALRM'} = sub { alarm 0; die "timed out\n" }; eval { alarm $timeout || 1; $obj->lock_exclusive }; alarm 0; ( $@ && $@ eq "timed out\n" ) ? '' : 1; } 1; __END__ =head1 NAME Mutex::Flock - Fcntl advisory locking =head1 SYNOPSIS { use Mutex::Flock; ( my $mutex = Mutex::Flock->new( path => $0 ) )->lock_exclusive +; ... } { my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... } { use threads; use Mutex::Flock; my $mutex = Mutex::Flock->new; threads->create('task', $_) for 1..4; $_->join for ( threads->list ); } { use MCE::Hobo; use Mutex::Flock; my $mutex = Mutex::Flock->new; MCE::Hobo->create('task', $_) for 5..8; MCE::Hobo->waitall; } sub task { my ($id) = @_; $mutex->lock; # access shared resource print $id, "\n"; sleep 1; $mutex->unlock; } =head1 DESCRIPTION This module implements locking methods that can be used to coordinate +access to shared data from multiple workers spawned as processes or threads. =head1 API DOCUMENTATION =head2 Mutex::Flock->new ( [ path => "/tmp/file.lock" ] ) Creates a new mutex. When path is given, it is the responsibility of t +he caller to remove the file. Otherwise, it establishes a C<tempfile> internally + including removal on scope exit. =head2 $mutex->lock ( void ) =head2 $mutex->lock_exclusive ( void ) Attempts to grab an exclusive lock and waits if not available. Multipl +e calls to mutex->lock by the same process or thread is safe. The mutex will r +emain locked until mutex->unlock is called. The method C<lock_exclusive> is an alias for C<lock>. =head2 $mutex->lock_shared ( void ) Like C<lock_exclusive>, but attempts to grab a shared lock instead. =head2 $mutex->unlock ( void ) Releases the lock. A held lock by an exiting process or thread is rele +ased automatically. =head2 $mutex->synchronize ( sub { ... }, @_ ) =head2 $mutex->enter ( sub { ... }, @_ ) Obtains a lock, runs the code block, and releases the lock after the b +lock completes. Optionally, the method is C<wantarray> aware. my $val = $mutex->synchronize( sub { # access shared resource return 'scalar'; }); my @ret = $mutex->enter( sub { # access shared resource return @list; }); The method C<enter> is an alias for C<synchronize>. =head2 $mutex->timedwait ( timeout ) Blocks until taking obtaining an exclusive lock. A false value is retu +rned if the timeout is reached, and a true value otherwise. my $mutex = MCE::Mutex::Flock->new( path => $0 ); # terminate script if a previous instance is still running exit unless $mutex->timedwait(2); ... =head1 AUTHOR Mario E. Roy, S<E<lt>marioeroy AT gmail DOT comE<gt>> =cut

    Regards, Mario

    Edit: Removed the underscore after the sigil in variables.
    Edit: Updated synopsis and code for construction.
    Edit: Added timedwait method. Completed documentation.

Solaris: make iostat output clearer
1 direct reply — Read more / Contribute
by johngg
on Mar 22, 2017 at 18:49

    This might be useful for sysadmins who manage Solaris servers. The iostat -En command can be used to check for cumulative disk errors but the output is rather dense so it can be difficult to sort the wood from the trees. This script uses Term::ANSIColor to make errors easier to spot.

    use strict; use warnings; use Term::ANSIColor qw{ :constants }; my $rxTriggers = do { my @triggers = ( q{Soft Errors: }, q{Hard Errors: }, q{Transport Errors: }, q{Media Error: }, q{Device Not Ready: }, q{No Device: }, q{Recoverable: }, q{Illegal Request: }, q{Predictive Failure Analysis: }, ); local $" = q{|}; qr{(@triggers)(\d+)} }; my @iostatCmd = qw{ /usr/bin/iostat -En }; open my $iostatFH, q{-|}, @iostatCmd or die qq{open: @iostatCmd |: $!\n}; print q{-} x 60, qq{\n}; while ( not eof $iostatFH ) { my $record; $record .= $_ for map { eof $iostatFH ? () : scalar <$iostatFH> } 1 .. 5; substr $record, 16, 0, RESET; substr $record, 0, 0, BOLD; $record =~ s{$rxTriggers} { $2 eq q{0} ? $1 . GREEN . $2 . RESET : YELLOW . $1 . RED . $2 . RESET }eg; print $record; print q{-} x 60, qq{\n}; } close $iostatFH or die qq{close: @iostatCmd |: $!\n};

    I no longer have a working Solaris box to provide example output but I hope this will be useful for somebody out there.



Wrapping a C shared library with Perl and XS
3 direct replies — Read more / Contribute
by stevieb
on Mar 17, 2017 at 14:23

    So, I've been asked by a couple of people now if I would take some of the experience I've gained over the last half year or so, and put together some form of tutorial on wrapping a C library, and more generally, XS. This is the first cut of that tutorial.

    Relatively, I am still very new to all of this, as it's a pretty complex world. Before I started, I didn't have any real C experience, so I've been dealing with that learning curve at the same time, so I know there are better and more efficient ways of doing what I do, and would appreciate any feedback.

    I'll get right to it. Here's an overview:

    • find something to wrap. In this case, I've written a shared C library called xswrap (I'll detail that whole procedure in the first reply to this node)
    • create a shell distribution that'll allow us to load our eventual XS code, which in turn has wrapped the C library
    • update relevant files to make things hang together
    • run into a function that can't be returned to Perl as-is, so we learn how to write our own C/XS wrapper so we can get what we need
    • package it all together into a distribution

    The actual C code is irrelevant at this point, but knowing the definitions in use is, so here they are for the xswrap library:

    int mult (int x, int y); void speak (const char* str); unsigned char* arr (); // returns (0, 1, 2)

    Create a new shell distribution

    I use Module::Starter:

    module-starter \ --module=XS::Wrap \ --author="Steve Bertrand" \ \ --license=perl

    Now change into the new XS-Wrap directory, which is the root directory of the new dist. The Perl module file is located at lib/XS/ I've removed a bunch of stuff for brevity, but the shell looks something like this:

    package XS::Wrap; use warnings; use strict; our $VERSION = '0.01';

    Create the base XS file

    I use Inline::C to do this for me, as like most Perl hackers, I'm often lazy. Note the flags in use. clean_after_build tells Inline to not clean up the build directory (_Inline after build). This allows us to fetch our new .xs file. name is the name of the module we're creating this XS file for.

    use warnings; use strict; use Inline Config => disable => clean_after_build => name => 'XS::Wrap'; use Inline 'C'; __END__ __C__ #include <stdio.h> #include <xswrap.h>

    The resulting XS file is located in _Inline/build/XS/Wrap/Wrap.xs. Copy it to the root directory of the dist:

    cp _Inline/build/XS/Wrap/Wrap.xs .

    Here's what our base XS file looks like. It doesn't do anything yet, but we'll get there:

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> MODULE = XS::Wrap PACKAGE = main PROTOTYPES: DISABLE

    See the PACKAGE = main there? Change main to the name of our dist, XS::Wrap.

    Adding the functions from the shared library to XS

    Now we need to define our C functions within the XS file. After I've done that using the C definitions for the functions above, my XS file now looks like this

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> MODULE = XS::Wrap PACKAGE = XS::Wrap PROTOTYPES: DISABLE int mult (x, y) int x int y void speak (str) const char* str unsigned char* arr ()

    Note that at this point, because we're not using Inline anymore, you can remove the include for the INLINE.h header file. However, in our case, we're going to be using some Inline functionality a bit later on, so instead of removing that, copy the INLINE.h file to the same directory we copied our XS file into: cp _Inline/build/XS/Wrap/INLINE.h .

    Readying the module file for use

    Now we have some work to do to pull in the XS, wrap the functions, and export them. Note that you do not *need* to wrap the functions with Perl, you can export them directly as depicted in the XS file if you wish, as long as you know you don't need to add any further validation or functionality before the XS imported C function is called. I'll wrap all three. The functions that each wrapped function calls is the literal C function, as advertised through the XS file we hacked above.

    use warnings; use strict; our $VERSION = '0.01'; require XSLoader; XSLoader::load('XS::Wrap', $VERSION); use Exporter qw(import); our @EXPORT_OK = qw( my_mult my_speak my_arr ); our %EXPORT_TAGS; $EXPORT_TAGS{all} = [@EXPORT_OK]; sub my_mult { my ($x, $y) = @_; return mult($x, $y); } sub my_speak { my ($str) = @_; speak($str); } sub my_arr { my @array = arr(); return @array; }

    Telling the Makefile to load the external C library

    Because we're using an external shared library, we need to add a directive to the Makefile.PL file. Put the following line anywhere in the Makefile.PL's WriteMakefile() routine:

    LIBS => ['-lxswrap'],

    Building, installing and initial test

    Let's build, install and write a test script for our new distribution.

    perl Makefile.PL make make install

    At this point, if everything works as expected, you're pretty well done. However, in the case here, we're going to unexpectedly run into some issues, and we'll need to do other things before we finalize our distribution.

    Test script ( Very basic, it just tests all three wrapped functions:

    use warnings; use strict; use feature 'say'; use XS::Wrap qw(:all); say my_mult(5, 5); my_speak("hello, world!\n"); my @arr = my_arr(); say $_ for @arr;


    25 hello, world!

    Hmmm, something is not right. The arr() C function was supposed to return an array of three elements, 0, 1, 2, but we get no output.

    This is because arr() returns an unsigned char* which we can't handle correctly/directly in Perl.

    In this case, I will just wrap the arr() function with a new C function (I've called it simply _arr()) that returns a real Perl array based on the output from the original C arr() function. Technically, I won't be returning anything, I'm going to just use functionality from Inline to push the list onto the stack (one element at a time), where Perl will automatically pluck it back off of the stack.

    To do this, I'll be leveraging Inline again, but with a couple of changes. We change the name, and add also bring in our shared library because we need it directly now.

    Returning a Perl array from a C function

    use warnings; use strict; use Inline config => disable => clean_after_build => name => 'Test'; use Inline ('C' => 'DATA', libs => '-lxswrap'); print "$_\n" for _arr(); __END__ __C__ #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; }

    After I execute that Perl script, I'm left with a new XS file within the _Inline/build/Test/Test.xs.. It looks like this:

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; } MODULE = Test PACKAGE = main PROTOTYPES: DISABLE void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; /* assume stack size is correct */

    We only need a couple of pieces of it, so get out your CTRL-V and CTRL-C. Here are the sections (cleaned up a bit for brevity) that we need to copy into our real Wrap.xs file.

    The C portion:

    void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; }

    The XS portion:

    void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { PL_markstack_ptr = temp; XSRETURN_EMPTY; } return;

    The C part goes near the top of the XS file, and the XS part goes in the XS section at the bottom. Here's our full XS file after I've merged in these changes.

    Finalized XS file

    #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "INLINE.h" #include <stdio.h> #include <xswrap.h> void _arr (){ unsigned char* c_array = arr(); inline_stack_vars; inline_stack_reset; int i; for (i=0; i<3; i++){ inline_stack_push(sv_2mortal(newSViv(c_array[i]))); } free(c_array); inline_stack_done; } MODULE = XS::Wrap PACKAGE = XS::Wrap PROTOTYPES: DISABLE int mult (x, y) int x int y void speak (str) const char* str unsigned char* arr () void _arr () PREINIT: I32* temp; PPCODE: temp = PL_markstack_ptr++; _arr(); if (PL_markstack_ptr != temp) { PL_markstack_ptr = temp; XSRETURN_EMPTY; } return;

    So, in our XS, we have four functions. Three that are imported directly from the C shared lib (mult(), speak() and arr()) and one new one written in C locally that wraps an imported XS function (_arr()).

    We need to do a quick update to the wrapper in the module file. Change the call to arr() to _arr() in the .pm file within the my_arr() function:

    sub my_arr { my @array = _arr(); return @array; }

    Repeat the build/install steps, then test again:

    perl 25 hello, world! 0 1 2

    Cool! Our custom C wrapper for arr() works exactly how we want it to.

    We're ready for release!

    Creating a release of our distribution

    It's very trivial to do:

    rm -rf _Inline perl Makefile.PL make make test make manifest make install make dist

    Of course, you have written all of your POD and unit tests before reaching this point, but I digress :)

    I've also posted this at

    update: I want to thank all of the Monks here who have provided me help, feedback, advice and in a couple of cases, some ego-kicking. I will not name said Monks because I'm very afraid of leaving someone out, but you know who you are.

Given my Raspberry Pi work, Happy Pi day Perlmonks!
1 direct reply — Read more / Contribute
by stevieb
on Mar 15, 2017 at 00:23

    Pi day isn't quite over, but given that most know about my Raspberry Pi work, I thought I'd share something.

    I have been focusing on creating a physical layout for all of the supported Integrated Circuits and other peripherals that are available to Perl under the Pi, so that I can create a full-blown automated test regimen that runs continuously against the code using my Test::BrewBuild software.

    Because the work is very precise and requires diligence to ensure everything is as connected properly as it is confirmed that numbers match up so that when proper tests are finally written everything aligns, I thought I'd share a tiny piece of what I was working on before Pi day is over.

    Given this diagram, which utilizes a RPi 3, an MCP3008 analog to digital converter, an MCP4922 digital to analog converter and a 74HC595 shift register as a baseline, here's some base initial test code that produces human-readable output so I can ensure the setup is reasonable:

    use warnings; use strict; use feature 'say'; use RPi::WiringPi; use RPi::WiringPi::Constant qw(:all); my ($dac_cs_pin, $adc_cs_pin) = (12, 26); my $adc_shiftreg_in = 0; my $adc_dac_in = 1; my $pi = RPi::WiringPi->new; my $dac = $pi->dac( model => 'MCP4922', channel => 0, cs => $dac_cs_pin ); my $adc = $pi->adc( model => 'MCP3008', channel => $adc_cs_pin ); print "DAC...\n\n"; for (0..4095){ $dac->set(0, $_); if ($_ % 1000 == 0 || $_ == 4095){ say $adc->percent($adc_dac_in); } } my $sr = $pi->shift_register(100, 8, 21, 20, 16); print "\nShift Resgister...\n\n"; my $sr_pin = $pi->pin(100); $sr_pin->write(HIGH); say $adc->percent($adc_shiftreg_in);


    DAC... 0.00 24.24 48.68 73.02 97.46 99.80 Shift Resgister... 100.00

    Much is on the chopping block for change, but I am making no fundamental changes until my CI is complete, and I get a much better understanding of what isn't working properly, and where. I know that PWM requires root which actually crashes the Pi if you don't sudo, and I know that Interrupts aren't doing the right thing.

    This step back from coding to focus on tests first, is how I usually do things. Having wrapped a lot of this code, it's come off as a bit of a new challenge to me (because it isn't write tests first then code, it's been code first, then think tests), but I've realized I need to get back to basics; test it first, then move on.

    Anyways, as I said early this morning, I'll say the same thing heading out. Happy Pi day ;)

Enlighten by Abigail-II's example. Tis a MCE::Hobo demonstration.
2 direct replies — Read more / Contribute
by marioroy
on Mar 13, 2017 at 07:42


    I came across a cool post by Abigail-II and thought to try it with MCE::Hobo. Thank you, trippledubs for posting the link.

    On Windows, MCE::Hobo spawns threads. Otherwise, childrens on Cygwin and other platforms. The following is a demonstration for many hobos, but never more than a fixed number at a given time.

    use strict; use warnings; use MCE::Hobo; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Based on ( by Abigail-II ). # Currently, MCE::Hobo emits a message to STDERR if unable to spawn. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub mhobo ($$&) { my ($count, $max, $code) = @_; foreach my $c (1 .. $count) { MCE::Hobo->waitone() unless $c <= $max; exit(255) unless defined (my $h = MCE::Hobo->create($code, $c)); } MCE::Hobo->waitall(); } sub ahobo (\@$&) { my ($data, $max, $code) = @_; my $c = 0; foreach my $data (@$data) { MCE::Hobo->waitone() unless ++$c <= $max; exit(255) unless defined (my $h = MCE::Hobo->create($code, $data)) +; } MCE::Hobo->waitall(); } STDOUT->autoflush(1); # Perl 5.14 or higher mhobo 9, 3, sub { print $_[0]."\n"; for (1 .. 4e7) { 1 } # simulate busy }; my @input = ( 'a' .. 'i' ); ahobo @input, 3, sub { print $_[0]."\n"; for (1 .. 4e7) { 1 } # ditto };

    Regards, Mario.

Finally! Perl code for the MCP3008 Analog to Digital Converters
No replies — Read more | Post response
by stevieb
on Mar 11, 2017 at 16:38

    I had issues a month ago trying to get this to work, so I left it knowing I'd come back to it. I had a one-off issue that was throwing me off. Now, RPi::ADC::MCP3008 is available.

    This SPI-connected device has a very handy feature I've incorporated. You can connect its CS pin to either of the two built-in hardware SPI Slave Select (CE aka CS) pins on the Pi and the Pi will handle the bridging of the communication, or, if those two pins are already in use, you can set the channel to an unused GPIO pin, connect that to the ICs CS pin, and we'll automagically bit-bang the SPI bus for you. Essentially, this trick allows you to connect as many ICs as you have GPIO, plus the two onboard hardware SPI bus pins.

    my $spi_channel = 0; my $adc = RPi::ADC::MCP3008->new($spi_channel); my $adc_channel = 0; # 0-7 single ended, 8-15 differential my $raw = $adc->raw($adc_channel); my $percent = $adc->percent($adc_channel); print "input value: $raw, $percent\n"; __END__ input value: 776, 78.49

    The above example uses pin CE0 on the RPi, which is the first of the two hardware SPI slave select channels. To use a GPIO pin instead and to free up the hardware SPI pins, use a GPIO pin number higher than 1, and connect that GPIO pin to the CS pin on the chip:

    my $chan = 26; # (GPIO pin 26) my $adc = RPi::ADC::MCP3008->new($chan); ...

    ...we'll do the bit-banging of the bus automatically, so you don't have to.

    The documentation includes the different ADC input channels and modes, a simplistic Rasperry Pi 3 breadboard layout, and a link to the datasheet if you're interested.

    I have expanded my RPi::SPI with this auto bit-banging trick, and didn't even have to change the API at all. 2.36.5 of that distribution includes the new feature, and should hit a CPAN mirror near you shortly.

    The trickery starts in the module, but the implementation and math is written in C, using calls to the base library. Feedback welcome on my C implementation.

AD&D worlds, recursive gameobjects
No replies — Read more | Post response
by holyghost
on Mar 09, 2017 at 01:59
    Back with some game programming : if you make a dungeons & dragons world you might want to put a room inside e.g. a bag of wonders, that room could already contain the same bag of wonders. Below is some code which morphs an Gameobject which is a dimension in a place in the world e.g. an Entity/MovingEntity becomes a EntityRec, a recursive entity. You only need an interrupt and a loop for checking whether there is recursion in the world. Note that it is perl6 :
    class PaganVision2::Entity is GameObject { has $!staticimagelib ### StateImagelibrary.pm6 method update(%keys, %keydefs) { } method draw($renderer) { $!staticimagelib.getImage().display($renderer); } } class PaganVision2::MovingEntity is GameObject { has $!direction; has $!moving; has $!dx; ### move x + dx has $!dy; has $!leftstaticimagelib ### StateImagelibrary.pm6 has $!righttstaticimagelib has $!upstaticimagelib has $!downstaticimagelib has $!leftimagelib has $!rightimagelib has $!upimagelib has $!downimagelib has $!currentlibrary; method update(%keys, %keydefs) { foreach $e in %keydefs.keys { if (not $e[0]) { ### UP $!currentlibrary = $upstaticimagelib; } elif (not $[1]) { ### DOWN $!currentlibrary = $downstaticimagelib +; } elif (not $e[2]) { ### LEFT $!currentlibrary = $leftstaticimagelib +; } elif (not $e[3]) { ### RIGHT $!currentlibrary = $rightstaticimageli +b; } } } method draw($renderer) { $!currentlibrary.getImage().display($renderer); } } ### Note that Room is a GameObject and that it can be put in e.g. a ba +g of wonders class PaganVision2::Room is GameObject { method BUILD() { ### Image $!bg_image .= new; } } ### This entity is recursive which means that ### it contains things that contain this entity ### If an Entity becomes recursive it ### morphs into EntityRec in the game engine class PaganVision2::EntityRec : is Entity { method update(%keys, %keydefs) { } method draw($renderer) { $!staticimagelib.getImage().display($renderer); } }
Lower-Level Serial Port Access on *NIX
1 direct reply — Read more / Contribute
by haukex
on Mar 01, 2017 at 10:07

    Dear Monks,

    Most likely, everyone who's needed to access a serial port on *NIX systems has used, or at least come across, Device::SerialPort. It's nice because it provides a decent level of portability, being designed to be a replacement for Win32::SerialPort. However, it's always bugged me a little bit that the module is a bit unwieldy, with a lot of configuration and functions I never use, several documented as being experimental, and that its filehandle interface is tied instead of native. So, I'd like to present an alternative that has been working well for me over the past months, IO::Termios. It's a subclass of IO::Handle, and the handles can be used directly in IO::Select loops, which can be used to implement nonblocking I/O and timeouts, or for example a POE POE::Wheel::ReadWrite, just to mention two possibilities. (Note: I'm not saying IO::Termios is "better" than Device::SerialPort, just that so far it has been a viable alternative.)

    Here's a basic example:

    use IO::Termios (); my $handle = IO::Termios->open('/tmp/fakepty', '4800,8,n,1') or die "IO::Termios->open: $!"; while (<$handle>) { # read the port line-by-line chomp; print time." <$_>\n"; # write something to the port print {$handle} "Three!\n" if /3/; } close $handle;

    An Aside: Fake Serial Ports on *NIX

    You may have noticed that in the above example, instead of the usual device names like e.g. /dev/ttyAMA*, /dev/ttyS*, or /dev/ttyUSB*, I used "/tmp/fakepty". I created this for testing using the versatile tool socat, here are two examples:

    # connect the fake pty to a process that generates output $ socat pty,raw,echo=0,link=/tmp/fakepty \ exec:'perl -e "$|=1;while(1){print q{Foo },$x++,qq{\n};sleep 2}"' # connect the fake pty to the current terminal $ socat pty,raw,echo=0,link=/tmp/fakepty -,icanon=0,min=1

    More Fine-Grained Control

    It's also possible to use sysopen for the ports, if you want to have control over the exact flags used to open the port. Also, if you need to set some stty modes, you can do so with IO::Stty. I've found that for several of the USB-to-Serial converters I've used that it's necessary to set the mode -echo for them to work correctly, and raw is necessary for binary data streams.

    use Fcntl qw/:DEFAULT/; use IO::Termios (); use IO::Stty (); sysopen my $fh, '/tmp/fakepty', O_RDWR or die "sysopen: $!"; my $handle = IO::Termios->new($fh) or die "IO::Termios->new: $!"; $handle->set_mode('4800,8,n,1'); IO::Stty::stty($handle, qw/ raw -echo /); my $tosend = "Hello, World!\n"; $handle->syswrite($tosend) == length($tosend) or die "syswrite"; for (1..3) { my $toread = 1; $handle->sysread(my $in, $toread) == $toread or die "sysread"; print "Read $_: <$in>\n"; } $handle->close;

    My error checking in the above example is a little simplistic, but I just wanted to demonstrate that using sysread and syswrite is possible like on any other handle.

    I've noticed that there is some interaction between IO::Termios and IO::Stty - for example, when I had to connect to a serial device using 7-bit and even parity, I hat to set the termios mode to 4800,7,e,1 and set the stty modes cs7 parenb -parodd raw -echo for things to work correctly.

    I have written a module that wraps an IO::Termios handle and provides read timeout, flexible readline, signal handling support, and a few other things. However, I need to point out that while I've been using the module successfully in several data loggers over the past few months in a research environment, it should not yet be considered production quality! The major reason is that it's not (yet?) a real CPAN distro, and it has zero tests! But if you're still curious, for example how I implemented a read timeout with IO::Select, you can find the code here.

    Update: Added mention of some /dev/* device names.

Fast gzip log reader with MCE
1 direct reply — Read more / Contribute
by marioroy
on Mar 01, 2017 at 05:54

    Greetings, fellow Monks.

    I came across an old thread. One might do the following to consume extra CPU cores. The pigz binary is useful and depending on the data, may run faster than gzip. The requirement may be to have each MCE worker process a single file inside the MCE loop. So we set chunk size accordingly (chunk_size => 1).

    To make this more interesting, workers send data to STDOUT and gather key-value pairs.

    use strict; use warnings; use feature qw(say); use MCE::Loop chunk_size => 1, max_workers => 4; my @files = glob '*.gz'; my %result = mce_loop { my ($mce, $chunk_ref, $chunk_id) = @_; ## $file = $_; same thing when chunk_size => 1 my $file = $chunk_ref->[0]; ## ## For pigz, we want -p1 to run on one core only. ## open my $fh, '-|', 'pigz', '-dc', '-p1', $file or do { ... } open my $fh, '-|', 'gzip', '-dc', $file or do { warn "open error ($file): $!\n"; MCE->next(); }; my $count = 0; while ( my $line = <$fh> ) { $count++; # simulate filtering or processing } close $fh; ## Send output to the manager process. ## Ensures workers do not garble STDOUT. MCE->say("$file: $count lines"); ## Gather key-value pair. MCE->gather($file, $count); } @files; ## Workers may persist after running. Request workers to exit. MCE::Loop->finish(); ## Ditto, same output using gathered data. for my $file (@files) { say "$file: ", $result{$file}, " lines"; }

    Regards, Mario.

How much disk space would be freed?
1 direct reply — Read more / Contribute
by reisinge
on Feb 21, 2017 at 04:41

    Is your (Unix/Linux) filesystem getting full and you wonder whether removing some old log files would help? Use this one-liner to find out how much space would be freed:

    find /opt/app/logs -iname "*log*" -type f -mtime +30 | perl -lne '$sum + += (stat)[7] }{ print $sum'
    It's nice to be important, but it's more important to be nice. -- Tommy
Adding without Addition
1 direct reply — Read more / Contribute
by GotToBTru
on Feb 15, 2017 at 13:06

    Wasn't sure if this belongs here, or in Obfuscations.

    Having once run:

    use strict; use warnings; use Storable; my (%table); foreach my $i (0..9) { foreach my $j ($i..9) { $table{$i}{$j} = $table{$j}{$i} = $i + $j } } store \%table, 'addition_table';

    I present to you: addition!

    use strict; use warnings; use Storable; my %table = %{retrieve('addition_table')}; my @problem = @ARGV; my (%matrix); foreach my $number (@problem) { my $log = 0; push @{$matrix{$log++}}, $_ for reverse (split //, $number); } my $col = 0; while (exists $matrix{$col}) { my @column = @{$matrix{$col}}; my $first = shift @column; while(scalar @column > 0) { my $second = shift @column; $first = $table{$first}{$second}; if (length($first) > 1) { $first = substr($first,-1,1); push @{$matrix{$col + 1}}, 1; } } $matrix{$col++} = $first; } printf "%s",$matrix{$col - $_} for (1..$col); print "\n";
    H:\perl>perl 1 1 H:\perl>perl 21 14 99 6 12 152 H:\perl>perl 999999999999999999999999999999999999999999 1 1000000000000000000000000000000000000000000

    Addition tables for other number systems are left as an exercise for the (extremely bored) reader. Vaguely apropos of Multiply Hex values. I started to write a program to do multiplication and realized I needed to figure out how to add first.

    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

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 chilling in the Monastery: (7)
    As of 2017-05-26 20:12 GMT
    Find Nodes?
      Voting Booth?