Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?

Cool Uses for Perl

( [id://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.

Tree::RB::XS now doubles as a LRU cache
No replies — Read more | Post response
on Jul 08, 2024 at 04:59

    So, I was experimenting with LRU caches (where the least-recently-used elements get discarded if the cache is full) and realized I could implement it much more efficiently inside of my Red/Black Tree module, and at almost no extra cost. (well, 16 bytes per tree node, but they were already big)

    The short version is that there is now an optional linked list running through the tree nodes in the order of insertion, and you may also omit nodes from that list (if you want them to persist in the cache) and you may re-order the list however you like.

    I'm currently using it for marking positions within a log file, where I parse the timestamp at a given address while performing a binary search of the log, and write down the timestamps and addresses in the cache to speed up later seeks. This problem requires a tree so that I can say "what is the timestamp address before and after my desired timestamp", followed by a binary search of the records in that range.

    Meanwhile, you can also insert duplicates for things like statistical tracking over time, such as inserting IP addresses who are abusing your system, and then answer queries about how many violations they've had in the cache's time window (maybe causing you to add them to a firewall blacklist), then expire the events individually. Being a tree, you can also sum up the violations for arbitrary subnets in Log(N) time.

    My implementation fares rather excellently vs. the other LRU cache implementations benchmarked by the script in Hash::Ordered.
    Benchmark code:

Net::Clacks for IPC (2024 tutorial)
No replies — Read more | Post response
by cavac
on Jul 05, 2024 at 07:15


    IPC (inter-process communication) is a large part of most application i maintain, and so is in-memory caching (key/value store). To do this in a way i like, i created Net::Clacks. In fact, in 2018 i wrote a simple tutorial on PerlMonks: Interprocess messaging with Net::Clacks, but i guess a more up-to-date version could be useful for someone out there.

    Before we start with the code, i'll have to explain a few concepts. The protocol has two different way to handle data. The first thing is "somewhat real time" messaging, the other is to provide an in-memory key/value store. Everything is based on, what boils to, named variables. You can name the variables pretty much anything, as long as they don't contain spaces and equal signs. Altough i highly suggest you avoid Unicode, as this not not well tested. In my programs, i usually use "fake perl classnames" ("PerlMonks::Chatterbot::messagecount"), but that's just a convention for my own stuff. You can be as boring or creative as you like with this stuff.

    Real-time messages come in two different flavours: NOTIFY ("some event has happened") and SET ("this is the new value for a thing"). To receive those messages from the server, you have to LISTEN to them.

    The key/value part of this is just like what it says on the label. You can STORE, RETRIEVE, REMOVE, INCREMENT and DECREMENT them. Other clients will not get automatically notified, you will have to do that yourself. One exception (for the case i use most) is the SETANDSTORE command, which stores a variable and broadcasts it to other clients, all in one go.

    Most commands are fire-and-forget commands (the client doesn't have to wait for the server to process them). The exception is where the clients actively retrieves data from the server.

    To optimize network efficiency, commands are buffered in memory. You have to call doNetwork() on the client side to trigger a send/receive cycle.

    To better check for timeouts (including clients that don't disconnect but hang in some other way), the client has to regularly send PING commands, but it can temporarily disable this requirement by sending a NOPING command.

    If you have to handle a lot of clients, or clients on multiple servers, you can run clacks servers in master/slave mode. This uses an expanded set of commands to implement what i call "interclacks mode", which includes cache sync and simple time offset calculations. But this is a bit outside this tutorial...

    The last thing to note is that the clacks server can use a persistance file for the in-memory key/value store. So it can (mostly) restart-protect the data. This isn't perfectly real-time, so if you store a value and then immediately kill the server, those changes may or may not be available when the server is started again.

    It's also possible to configure a few caching timeframes, that say how often stale entries are purged from the key/value store, how long entries are kept if they are not accessed in any way (default=1 day) and how long the server(s) remember that a key was deleted (for the purpose of interclacks resync). But again, advanced topic. I recommend leaving the defaults unless you run into problems.

    Net::Clacks requires at least Perl 5.36 at the time of writing, because a) i switched to sub-signatures and b) i generally don't support completely outdated Perl versions. (If you want to run Net::Clacks on a completely outdated RedHat box, you might have to add some money to RedHats pay-to-win "Enterprise" racket so they can make you a broken, backported version.)

    (Info for newbies to PerlMonks: Click on the "Read more" link below to see the rest of the article)

Example of PDL dataflow to implement 3D space calculations
1 direct reply — Read more / Contribute
by etj
on Jun 30, 2024 at 10:20
    This (from the PDL::Dataflow doc, not yet updated to CPAN) is a complete, working example that demonstrates the use of enduring flowing relationships to model 3D entities, through a few transformations:
    {package PDL::3Space; use PDL; sub new { my ($class, $parent) = @_; my $self = bless {basis_local=>identity(3), origin_local=>zeroes(3)} +, $class; if (defined $parent) { $self->{parent} = $parent; $self->{basis} = $self->{basis_local}->flowing x $parent->{basis}- +>flowing; $self->{origin} = ($self->{origin_local}->flowing x $self->{basis} +->flowing)->flowing + $parent->{origin}->flowing; } else { $self->{basis} = $self->{basis_local}; $self->{origin} = $self->{origin_local}->flowing x $self->{basis}- +>flowing; } $self; } use overload '""' => sub {$_[0]{basis}->glue(1,$_[0]{origin}).''}; sub basis_update { $_[0]{basis_local} .= $_[1] x $_[0]{basis_local} } sub origin_move { $_[0]{origin_local} += $_[1] } sub local { my $local = PDL::3Space->new; $local->{$_} .= $_[0]{$_} fo +r qw(basis_local origin_local); $local} }
    This is the class, heavily inspired by Math::3Space, and following discussions on interoperation between that and PDL (see The basis and origin members are "subscribed" to both their own local basis and origin, and their parent's if any. The basis_update and origin_move methods only update the local members, both in terms of previous values.

    The demonstrating code has a boat, and a bird within its frame of reference. Note that the "local" origin still gets affected by its local basis.

    The basis and origin are always in global coordinates, and thanks to dataflow, are only recalculated on demand.

    $rot_90_about_z = PDL->pdl([0,1,0], [-1,0,0], [0,0,1]); $boat = PDL::3Space->new; print "boat=$boat"; $bird = PDL::3Space->new($boat); print "bird=$bird"; # boat= # [ # [1 0 0] # [0 1 0] # [0 0 1] # [0 0 0] # ] # bird= # [ # [1 0 0] # [0 1 0] # [0 0 1] # [0 0 0] # ] $boat->basis_update($rot_90_about_z); print "after boat rot:\nboat=$boat"; print "bird=$bird"; # after boat rot: # boat= # [ # [ 0 1 0] # [-1 0 0] # [ 0 0 1] # [ 0 0 0] # ] # bird= # [ # [ 0 1 0] # [-1 0 0] # [ 0 0 1] # [ 0 0 0] # ] $boat->origin_move(PDL->pdl(1,0,0)); print "after boat move:\nboat=$boat"; print "bird=$bird"; print "bird local=".$bird->local; # after boat move: # boat= # [ # [ 0 1 0] # [-1 0 0] # [ 0 0 1] # [ 0 1 0] # ] # bird= # [ # [ 0 1 0] # [-1 0 0] # [ 0 0 1] # [ 0 1 0] # ] # bird local= # [ # [1 0 0] # [0 1 0] # [0 0 1] # [0 0 0] # ] $bird->basis_update($rot_90_about_z); $bird->origin_move(PDL->pdl(1,0,1)); print "after bird rot and move:\nbird=$bird"; print "bird local=".$bird->local; # after bird rot and move: # bird= # [ # [-1 0 0] # [ 0 -1 0] # [ 0 0 1] # [-1 1 1] # ] # bird local= # [ # [ 0 1 0] # [-1 0 0] # [ 0 0 1] # [ 0 1 1] # ] $boat->basis_update(PDL::MatrixOps::identity(3) * 2); print "after boat expand:\nboat=$boat"; print "bird=$bird"; # after boat expand: # boat= # [ # [ 0 2 0] # [-2 0 0] # [ 0 0 2] # [ 0 2 0] # ] # bird= # [ # [-2 0 0] # [ 0 -2 0] # [ 0 0 2] # [-2 2 2] # ]
Impress your children with Perl
4 direct replies — Read more / Contribute
by Anonymous Monk
on May 21, 2024 at 04:46
    Every child in America, and several other countries, have access to an Apple Mac. Tell them to open Finder, then open Applications, then open Utilites, then open Terminal and type this:
    perl -MHTTP::Tiny -e 'eval HTTP::Tiny->new->get(shift)->{content}' htt +ps://;displaytype=displaycode
    Hit return and wow kid genius you just wrote a computer program that downloads another program that runs and looks super cool! What else can this thing do? Type: perldoc perlintro

    ( links the source of the amazing spiraling quine)

Parsing Ada Based Constants
No replies — Read more | Post response
by RonW
on May 06, 2024 at 07:27
    A while back, the materials lab got some surplus instruments for materials testing. Interestingly, the data files produced have a mix of base 10, base 16 and base 2 numbers in Ada based numeric constant format:

    10#86# 16#FA61# 2#10010110#

    After they tried using LabView and Excel to covert the numbers, they came to us software engineers.

    My (3/32 baked) solution was using a regular expression to parse out the base and number, then convert using hex and oct as appropriate.

    While this worked fine for what was needed, some one asked "Why didn't you make a proper implementation?" My reply, of course, was "This serves our needs" and left it as is. For about a week. My thoughts kept drifting back to it, so I gave in and said "Challenge accepted."

    So, I made the "proper implementation" per the Ada standard, including floating point conversion. There is a base converter in CPAN I might have used, but Horner's Method is simple and efficient - and almost habitual to use. I haven't tested whether using a hash or using index (with lc or uc) would be more efficient. I used a hash.

    Looking at the CPAN listings, I think Language::Ada is the right namespace. (Though I noticed that C, for example, is top level, rather than Language::C)

Marching Squares (for contouring) with a PDL convolution
No replies — Read more | Post response
by etj
on May 05, 2024 at 12:12
    This implements a partial Marching Squares algorithm (see Limitations:
    • It doesn't do the linear interpolation bit, because I couldn't figure a lazy way of getting it to do that. Probably doubling the coordinate offsets and using those as index offsets would work.
    • Making a bunch of individual line-segments and drawing each one is very slow in PGS. Joining them into polylines is possible with the not-yet-released next version of PDL (there's a path_join which allows this), which goes much quicker.
    If you change the if (0) to 1, it shows you its lookup table instead of drawing contours.
    use strict; use warnings; use PDL; use PDL::Image2D; use PDL::Graphics::Simple; my $LOOKUP = pdl( # relative to cell, x1,y1,x2,y2 for each line; 0 is invalid: lines s +tart edge [[ 0, 0, 0, 0],[ 0, 0, 0, 0]], # 0 [[-0.5, 0, 0,-0.5],[ 0, 0, 0, 0]], [[ 0,-0.5, 0.5, 0],[ 0, 0, 0, 0]], # 2 [[-0.5, 0, 0.5, 0],[ 0, 0, 0, 0]], [[ 0, 0.5, 0.5, 0],[ 0, 0, 0, 0]], # 4 [[ 0,-0.5, 0.5, 0],[-0.5, 0, 0, 0.5]], [[ 0,-0.5, 0, 0.5],[ 0, 0, 0, 0]], # 6 [[-0.5, 0, 0, 0.5],[ 0, 0, 0, 0]], [[-0.5, 0, 0, 0.5],[ 0, 0, 0, 0]], # 8 [[ 0,-0.5, 0, 0.5],[ 0, 0, 0, 0]], [[-0.5, 0, 0,-0.5],[ 0, 0.5, 0.5, 0]], # 10 [[ 0, 0.5, 0.5, 0],[ 0, 0, 0, 0]], [[-0.5, 0, 0.5, 0],[ 0, 0, 0, 0]], # 12 [[ 0,-0.5, 0.5, 0],[ 0, 0, 0, 0]], [[-0.5, 0, 0,-0.5],[ 0, 0, 0, 0]], # 14 [[ 0, 0, 0, 0],[ 0, 0, 0, 0]], ); sub marching_squares { my ($c, $data, $points) = @_; my $kernel = pdl q[4 8; 2 1]; my $contcells = conv2d($data < $c, $kernel)->slice(':-2,:-2'); my $segs = $LOOKUP->slice([],[],$contcells->flat)->clump(1..2); my $segsinds = $segs->orover; my $segsmask = $segsinds->dummy(0,4); my $contcoords = +($contcells->ndcoords->inflateN(1,2)->dupN(2) + 0. +5)->clump(1,2); my $segscoords = ($segs + $contcoords)->whereND($segsmask); $segscoords->splitdim(0,4)->clump(1,2); } if (0) { my $win = pgswin(multi=>[4,4]); my $xrange = [-0.5,0.5]; my $yrange = [-0.5,0.5]; my $i = 0; for my $lines ($LOOKUP->dog) { $win->plot( (map +(with=>'lines', $_->splitdim(0,2)->mv(0,-1)->dog), $lines->d +og), {xrange=>$xrange,yrange=>$yrange,j=>1,title=>$i++}, ); } print "ret> "; <>; exit; } my $SIZE = 50; my $vals = rvals($SIZE,$SIZE)->divide($SIZE/12.5)->sin; my $cntr_cnt = 9; my @cntr_threshes = zeroes($cntr_cnt+2)->xlinvals($vals->minmax)->list +; @cntr_threshes = @cntr_threshes[1..$#cntr_threshes-1]; my $win = pgswin(); my $xrange = [0,$vals->dim(0)-1]; my $yrange = [0,$vals->dim(1)-1]; $win->plot(with=>'image', $vals, {xrange=>$xrange,yrange=>$yrange,j=>1 +},); for my $thresh (@cntr_threshes) { my $segscoords = marching_squares($thresh, $vals); $win->oplot( (map +(with=>'lines', $_->splitdim(0,2)->mv(0,-1)->dog), $segscoor +ds->splitdim(0,4)->clump(1,2)->dog), {xrange=>$xrange,yrange=>$yrange,j=>1}, ); } print "ret> "; <>;
AI in Perl...
No replies — Read more | Post response
by The_Dj
on Apr 18, 2024 at 10:59
    Nowadays AIs tend to use TensorFlow.
    Sadly Perl's AI::TensorFlow module can't create new models. It can only load pre-trained models. (Well, it probably can if you know all the deepest magic of Tensorflow, C, MX and I don't)

    AI::MXNet was a perfectly good solution until cuda 12 broke the entire build- and tool chains and Apache retired the MXNet project.

    So visit this node for a Dockerfile that builds and runs AI::MXNet and get Perl to create your next AI!

    best of luck!
Runtime::Debugger New Release
No replies — Read more | Post response
by Timka
on Mar 30, 2024 at 15:44
"Terminal Velocity", a better Linux terminal graphics demo
4 direct replies — Read more / Contribute
by cavac
on Feb 18, 2024 at 07:36

    Last week i released a simple graphics demo for the Linux terminal (Fun with terminal color).

    The low framerate and the mostly static graphics bothered me a bit. So, i , uhm did it yet again. Another demo, this time using Inline::CPP and massaged versions of tinyraytracer and tinyraycaster to provide some actual graphical content. As a matter of fact, Inline::CPP didn't work for my borrowed(*) code, and my understanding of CPP is a 20 years out of date. So i override the Inline::CPP RecDescent module to ignore my bugs. Hey, it's not production code, just a demo...

    As in the last demo, your Terminal needs to support full RGB colors and have a size of at least 270x60 in size (characters, not pixels). SDL is sort-of-optional this time; the demo will run without sound if it can't load SDL. And as said above, you'll need to install Inline::CPP as well.

    Here's the mercurial repository:

    And the YouTube video: OBS and YT compression did munge the quality a bit, though. Probably my fault for not understanding the OBS settings...

    (*) "but with every intention of giving it back"

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Color die and warn messages
1 direct reply — Read more / Contribute
by Anonymous Monk
on Feb 15, 2024 at 18:50
    This scratched an itch for me, no guarantees.
    use warnings::colored; warn "warning"; # yellow system "non-existant-command"; # red say "test"; # none eval { die "caught" }; # none say $@; # none die "died"; # red
    And the implementation:
Fun with terminal color
2 direct replies — Read more / Contribute
by cavac
on Feb 09, 2024 at 18:10

    Yesterday i thought i might fix some bugs in my imagecat routine (printing images to the terminal). But somehow i, uhm, improved things a little too far. If you're now thinking "Oh no, he did it again!", i'm afraid, yes, i did.

    This time, i made a 3 minute animated demo with sound, running at (some) FPS in a Linux terminal.

    You can find a download of the current version as a tarball or you could clone my public mercurial repo if you prefer that. (Edit: Link to mercurial has changed/updated)

    The demo needs quite a few CPAN modules, i'm afraid, including the somewhat hard-to-install SDL bindings. (For SDL, you might have to change a checksum in the Alien::SDL Build.PL and ignore some test errors in SDL as well.) I'm using SDL for the sound output.

    Also, your Terminal needs to support full RGB colors /see the Imagecat - show color images in a terminal thread) and have a size of at least 270x60 in size (characters, not pixels).

    If you want to avoid the hassle of getting it to work on your system, you can watch the YouTube video instead.

    PerlMonks XP is useless? Not anymore: XPD - Do more with your PerlMonks XP
Streaming download from S3 compatible storage
1 direct reply — Read more / Contribute
by kikuchiyo
on Feb 08, 2024 at 10:51

    $subject came up at $work.

    The following minimal example appears to work:

    #!/usr/bin/perl use Modern::Perl '2021'; use Net::Amazon::S3::Client; # edit these my $aws_access_key_id = '...'; my $aws_secret_access_key = '...'; my $host = '...'; my $bucket_name = '...'; my $secure = 1; my $client = Net::Amazon::S3::Client->new ( host => $host, aws_access_key_id => $aws_access_key_id, aws_secret_access_key => $aws_secret_access_key, secure => $secure, retry => 1, ); my $bucket = $client->bucket( name => $bucket_name ); my $object = $bucket->object( key => $ARGV[0] ); $object->get_callback(sub { my $s = length($_[0]); print STDERR "Got chunk size $s\n"; # do something with $_[0] });

    This is applicable if you want to serve a file from an S3 compatible storage via an async backend.

    The get_callback method is not documented (it is mentioned in passing only in Net::Amazon::S3::Client::Object::Range), but in the end it works. - Shoots Holes in Files
1 direct reply — Read more / Contribute
by BlueSquare23
on Jan 29, 2024 at 18:27

    Shoots Holes in Files

      Cyber weapon! For home defense purposes only!

    Have you ever had a file you just wanted to blast with a shotgun? Now you can!

    Can play audio files via aplay or mpv (tested on Ubuntu). Or use -quiet to run with no sound effects.

    Source on My Github Video of Script in Action
Acceleration ETA algorithm
3 direct replies — Read more / Contribute
by phizel
on Jan 27, 2024 at 12:49
    Was looking for a decent algorithm for determining the ETA of a long-running process, but everything on CPAN uses simplistic and inaccurate algorithms. Found this great article Benchmarking I/O ETA algorithms and converted the Acceleration algorithm to perl. And yes, it would be better to extract the state components into an object.
    use Time::HiRes qw(time); sub eta { my ($cur, $total, $time) = @_; return unless $cur and $time; state ($last_progress, $last_time, $last_v, $last_eta); state (@v, @eta, $window_size, $window_idx); state $init = do { ($last_progress, $last_time, $last_v, $last_eta) = (0, 0, 0, - +1); ($window_size, $window_idx) = (10, 0); }; state $sub_v_weight = sub { 1 + $_[0] }; state $sub_eta_weight = sub { $_[0] ? 2 * $_[1] : 1 }; state $sub_weighted_avg = sub { my ($sub_weight, $avg, $total_weight, $w) = (shift, 0, 0, 0); for my $i (0 .. $#_) { # first version messed up the index. my $j = ($i + @_ - $window_idx - 1) % @_; $w = $sub_weight->($j, $w); $avg += $w * $_[$i]; $total_weight += $w; } return $avg / $total_weight; }; my $v = ($cur - $last_progress) / (($time - $last_time) || 1); $v[$window_idx] = $v; $v = $sub_weighted_avg->($sub_v_weight, @v); if ($v and $last_v) { my ($min_v, $max_v) = $v < $last_v ? ($v, $last_v) : ($last_v, + $v); $v = $last_v + ($v - $last_v) * $min_v / $max_v; } my $a = ($v - $last_v) / ($last_time ? ($time - $last_time) : 1); my $r = $total - $cur; my $eta = $last_eta; if ($a and 0 < (my $d = ($v * $v + 2 * $a * $r))) { $eta = (sqrt($d) - $v) / $a; } elsif ($v) { $eta = $r / $v } $eta[$window_idx] = $eta; $eta = $sub_weighted_avg->($sub_eta_weight, @eta); ($last_progress, $last_time, $last_v, $last_eta, $window_idx) = ($cur, $time, $v, $eta, ($window_idx + 1) % $window_size); return $eta > 0 ? $eta : 0; }
Munging file name, to be safe- & usable enough on Unix-like OSen & FAT32 file system
2 direct replies — Read more / Contribute
by parv
on Nov 25, 2023 at 23:12

    A program written in a hurry some time ago to munge file paths generally for file systems for Unix(-like) OSen & specifically for FAT32.

    Learned the hard way that NTFS would allow file names to be written to FAT32 even if some characters are outside of FAT32 specification. Problematic characters seemed to be en- & em-dash, fancy quotes, pipe, Unicode "?", & possibly few others (web pages saved with title as the file name). Mounting FAT32 file system on FreeBSD with specific codepage(s), or "nowin95" or "shortnames" mount options did not help (mount_msdosfs(8)). Munging it was then🤷🏽‍♂️

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
    Domain Nodelet?
    and the web crawler heard nothing...

    How do I use this?Last hourOther CB clients
    Other Users?
    Others imbibing at the Monastery: (1)
    As of 2024-07-21 00:58 GMT
    Find Nodes?
      Voting Booth?

      No recent polls found

      erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.