I have been feeling rather deprived of Perl activity the last few months... so when I was playing a card game on my phone (a simple one that I have >95% win rate on), but had spent quite a few attempts (it allows undo/restart), I decided to program in as much of the "deal" as I could see, and see if I could get Perl to find a route to one or more of the as-of-yet unseen reserve cards (at which point, I'd be able to try to move forward and maybe even win this hand).

Canfield_(solitaire) variant:

• Infinite times through the stock
• Stock is 1-at-a-time (not the default 3-at-a-time)
• Foundations always start at Ace
• Tableau alternates color, descending, but allows wrapping from 2-A-K

With that, I hacked together a solver that gave a 50% chance at every "decision point", then went through thousands of games. It was never able to find a path to reveal the next card (the first ? in the deal), so I'm pretty confident that this particular deal isn't winnable.

I figured I might as well share this CUFP, even if it's not overly groundbreaking (and definitely not great code).

I recently changed my at home monitoring of the CISA Known Exploited Vulnerabilities feed (More information on KEV here) to make the alerting more accessible. While I monitor some products we use at work this is not a business critical service.

This quick and dirty script uses Mojolicious to hit this CISA KEV API, read a local file to match against target vendors, products or both, logging matches to a local cache so we don't keep reporting on the same thing and sending a notification to my local gotify instance (clients for web, Android etc.).

#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';

use Mojo::Log;
use Mojo::File;
use Mojo::JSON qw(decode_json encode_json);
use Mojo::UserAgent;

# cisa-kev-mon
# monitor the CISA KEV feed
# * Send notifications to gotify
# * Log them locally so we don't keep reporting on the same thing.
# For further info on CISA Known Exploited Vulnerablities visit:
# https://www.cisa.gov/known-exploited-vulnerabilities

# logging
my $log = Mojo::Log->new( path => 'cve_mon.log', level => 'debug' );

# read list software we're interested in 
unless ( -e 'targets.json' ){
    $log->fatal( 'no targets.json' );
    die 'No targets.json';
}

# get targets
my @targets = @{ decode_json( Mojo::File->new( 'targets.json' )->slurp
+ ) };

# gotify notification server config
unless ( $ENV{GOTIFY_URL} && $ENV{GOTIFY_TOKEN} ){
    $log->fatal( 'Check Gotify env vars, GOTIFY_URL & GOTIFY_TOKEN' );
    die 'Fail: Check Gotify env vars, GOTIFY_URL & GOTIFY_TOKEN';
}
my $gotify_url   = $ENV{GOTIFY_URL};
my $gotify_token = $ENV{GOTIFY_TOKEN};

# cve.org base url
my $cve_url = 'https://www.cve.org/CVERecord?id=';

# cisa recent json feed
my $cisa_url   = 'https://www.cisa.gov/sites/default/files/feeds/known
+_exploited_vulnerabilities.json';

# local cache so we don't report on already seen CVEs
my $cve_cache = Mojo::File->new( 'seen_cves.json' );

# Fetch JSON
my $ua = Mojo::UserAgent->new;
my $res = $ua->get( $cisa_url )->result;

# die if we can't get the JSON feed
unless ( $res->is_success ){
    $log->error( 'Failed to fetch CISA feed: ' . $res->message );
    die 'Failed to fetch CISA feed: ' . $res->message;
}

my $data = decode_json( $res->body );
my @vulns = @{ $data->{vulnerabilities} };

# Load existing CVEs from local cache
my %seen_cves;
if ( -e $cve_cache ){
    %seen_cves = %{ decode_json( $cve_cache->slurp ) };
}

# Filter existing & collect new CVEs
my @new_cves;

foreach my $vuln ( @vulns ) {
    my $vendor  = $vuln->{vendorProject};
    my $product = $vuln->{product};
    my $cve_id  = $vuln->{cveID};

    # skip if the CVE has been logged before
    next if $seen_cves{$cve_id};

    # for each target
    for my $target( @targets ){
        my $matches = 0;
        # Match both vendor and product
        if (defined $target->{vendor} && defined $target->{product}) {
+     
            $matches = ($vendor =~ /\Q$target->{vendor}\E/i && $produc
+t =~ /\Q$target->{product}\E/i);
        }
        # match vendor
        elsif (defined $target->{vendor}) {
            $matches = ($vendor =~ /\Q$target->{vendor}\E/i);
        }
        # match product
        elsif (defined $target->{product}) {
            $matches = ($product =~ /\Q$target->{product}\E/i);
        }

        if ($matches) {
            # post to gotify
            my $res = $ua->post( $gotify_url =>
                { 'X-Gotify-Key' => $gotify_token } =>
                form => {
                    title => 'cisa KEV CVE alert',
                    message => "New CVE: $vendor - $product $cve_url$c
+ve_id",
                    priority => 5,
                }
            )->result;

            unless ( $res->is_success ){
                $log->fatal( 'Failed to post to gotify: ' . $res->code
+ . ' - ' . $res->message ); 
                die 'Failed to post to gotify: ' . $res->code . ' - ' 
+. $res->message;
            }

        # add to local cache
            push @new_cves, $vuln;
            $seen_cves{$cve_id} = 1;
            last;
        }
    }
}

# Output
if ( @new_cves ) {
    say 'New vulnerabilities found:';
    foreach my $cve ( @new_cves ) {
        say "[$cve->{cveID}] $cve->{vendorProject} $cve->{product}: $c
+ve->{vulnerabilityName} (Added: $cve->{dateAdded})";
    }
} else {
    say 'No new vulnerabilities for your monitored vendors/products.';
}

# Save updated seen CVEs to local file
Mojo::File->new( 'seen_cves.json' )->spew( encode_json( \%seen_cves ) 
+);
[download]

targets.json example:

[
  { "vendor": "Microsoft", "product": "SharePoint" },
  { "vendor": "Microsoft", "product": "Windows 2012" },
  { "vendor": "Microsoft", "product": "Windows 10" },
  { "vendor": "Microsoft", "product": "CoPilot" },
  { "vendor": "Microsoft", "product": "Teams" },
  { "vendor": "Microsoft", "product": "Edge" },
  { "vendor": "Oracle", "product": "Solaris" }
  { "vendor": "Example Vendor"},
  { "product": "Example Product"}
]
[download]

Example output if you bother to leave that in:

New vulnerabilities found:
[CVE-2025-49704] Microsoft SharePoint: Microsoft SharePoint Code Injec
+tion Vulnerability (Added: 2025-07-22)
[CVE-2025-49706] Microsoft SharePoint: Microsoft SharePoint Improper A
+uthentication Vulnerability (Added: 2025-07-22)
[CVE-2025-53770] Microsoft SharePoint: Microsoft SharePoint Deserializ
+ation of Untrusted Data Vulnerability (Added: 2025-07-20)
[download]

Working in large multi vendor organisations, many of whom are outsourced, we don't always hear about things promptly, if at all. Forewarned is forearmed as the adage goes. Screenshot of the Gotify Android app output.

From the synopsis:

  use Sys::Export::CPIO;
  use Sys::Export -src => '/', -dst => Sys::Export::CPIO->new("initrd.
+cpio");
  
  rewrite_path '/sbin'     => '/bin';
  rewrite_path '/usr/sbin' => '/bin';
  rewrite_path '/usr/bin'  => '/bin';
  
  add '/bin/busybox';
  add ...;
  finish;
[download]

I even have a test (gated by environment variables) which can generate the initrd by exporting pieces of an Alpine docker container, and then run Linux with that initrd inside qemu.

  use GD;
  use JSON;
  use OCR::OcrSpace;
  
  sub write_image{
      my($s) = @_;
      my $width = 500;
      my $height = 500;
      my $image_file = q#/tmp/output_image.png#;
      my $image = GD::Image->new($width, $height);
      my $white = $image->colorAllocate(255, 255, 255);  
      my $black = $image->colorAllocate(0, 0, 0);        
      $image->filledRectangle(0, 0, $width - 1, $height - 1, $white);
      my $font_path = q#/System/Library/Fonts/Courier.ttc#;
      my $font_size = 14;
      $image->stringFT($black, $font_path, $font_size, 0, 10, 50, $s);
      open TEMP, q/>/, qq/$image_file/;
      binmode TEMP;
      print TEMP $image->png;
      close TEMP;
      return $image_file;
  }

  
  sub counter_integers{
      my($s) = @_;
      my @numbers;
      $s =~ tr/a-z/ /;
      my $image = write_image($s);
      my $ocrspace = OCR::OcrSpace->new(); 
      my $ocrspace_parameters = {  file      => qq/$image/,  
                                   apikey    => q/XXXXXXX/,
                                   filetype  => q/PNG/,
                                   scale     => q/True/,
                                   isOverlayRequired => q/True/,
                                   OCREngine => 2};
      my $result = $ocrspace->get_result($ocrspace_parameters);
      $result = decode_json($result); 
      my $lines = $result->{ParsedResults}[0]
                     ->{TextOverlay}
                     ->{Lines};
      for my $line (@{$lines}){
          for my $word (@{$line->{Words}}){
              push @numbers, $word->{WordText};
          }
      }
      return join q/, /, @numbers;
  }

  
MAIN:{
    print counter_integers q/the1weekly2challenge2/;
    print qq/\n/;
    print counter_integers q/go21od1lu5c7k/;
    print qq/\n/;
    print counter_integers q/4p3e2r1l/;
    print qq/\n/;
}
[download]

I don't know how "cool" this is (it's cool to me) but this is a small script I wrote 13 years ago. It simply converts and prints out the Perl version contained in the built-in variable $] to the string as we usually see it when we are discussing Perl releases. Just run it, you'll see what I mean ;-).

#!/usr/bin/env perl

# First created: 2012-05-08
# Last modified: 2012-08-26T01:37:48 UTC-04:00

use strict;
my $pow = 2;
my $test_v = $ARGV[0] || $];
my @qiu = split(q/[._]/ => $test_v);
@qiu[1 .. @qiu] = map {sprintf(q[%u],$_/10**$pow++)}
                    map {unpack "A4 A4",$_ * 10**3 } @qiu[1 .. $#qiu];
my $tuple_perlversion = join q[.], grep{length($_)} @qiu;

print "$tuple_perlversion\n";
[download]

    Soren

A third scheme could implement a little trick to speed up the conversion by looking for consecutive patches of 1s in the input string... So, let's say we have a number like this: "1111111111110000000000" In this case, we could calculate 2^22 and then subtract 2^10 like so:

 10000000000000000000000 = 4194304
-            10000000000 = 1024
---------------------------------------
  1111111111110000000000 = 4193280 <= This is the result we're looking
+ for!
[download]

The idea is that performing a single subtraction would be faster than performing an addition every time we encounter a '1' digit in the input string. But I'm not sure how much time this would gain. And the gain would be absolutely non-existent for numbers like "1010101011101010101000101010101010101010000000000101010100101010101001101100000101010101" in which there aren't too many repeating 1s.

#!/usr/bin/perl -w

use strict;
use warnings;
$| = 1;

RunTests(
     '', '0',
     'what?', '0',
     '0', '0',
     '1', '1',
     '11', '3',
     '0001', '1',
     '1011', '11',
     '1111', '15',
     '11111111', '255',
     'yay 1__1 Lol', '3',
     '11111111111111111111111111111111', '4294967295',
     '10101010101010101010101010101010', '2863311530',
     '00000000001111111111110000000000', '4193280',
     '100011111111110011111011001101000', '4831442536',               
+                       # 33-bit value
     '11111111111000111111111100111110110010001000110', '1406773524818
+62',                   # 47-bit value
     '111111111111000000000000000000000000000000000000', '281406257233
+920',                  # 48-bit value
     '1111111111110000000000000000000000000000000000000', '56281251446
+7840',                 # 49-bit value
     '0000111000111000111000111000111000111000111000111000111000111000
+', '1024819115206086200',     # 60-bit value
     '1111111111111111100000000000000001111111111111111000000000000000
+', '18446603338368647168',    # 64-bit value
     '1100111100100110000001111110111000110101010101010101010101010101
+', '14926626734644483413',    # 64-bit value
     '1111111111111111111111111111111111111111111111111111111111111111
+', '18446744073709551615',    # 64-bit value
     '1000000000000000000000000000000000000000000000000000000000000000
+0', '18446744073709551616',   # 65-bit value
  # 112-bit value:
     '1111111111111111111111111111111111111111111111111111111111111111
+111111111111111111111111111111111111111111111111', '51922968585348276
+28530496329220095',
     '1000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000', '5192296858534827
+628530496329220096',
  # 360-bit value:
     '1111111111111111111111111111111111111111111111111111111111111111
+111111111111111111111111111111111111111111111111111111111111111111111
+111111111111111111111111111111111111111111111111111111111111111111111
+111111111111111111111111111111111111111111111111111111111111111111111
+111111111111111111111111111111111111111111111111111111111111111111111
+11111111111111111111', '234854258277383322788948059678933702737568254
+8908319870707290971532209025114608443463698998384768703031934975',
  # 1500-bit value:
     '1000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000
+00000000000000000000000000000000000000000000000000000000', '175373310
+552170193738137939801404289967620079401654144120378990123954819252816
+611018285404432924846308265752033977187586996472744707349798770855194
+590023504239449782426645486322434013557917314732683410921700693147256
+777291324731712626918096946574803223325262758757211677546245866805651
+778980548549427903371569771051088289237163133803665023766376585960668
+373517816863916485209966135263316668342549760000875266777645294402170
+91269193357761841856604274688'
);

print "\nDon't panic. Your computer did not crash.\nThe following oper
+ation may take a few seconds.\n";
print "\nConverting 4096-digit binary number to decimal using Bin2Dec(
+) and Bin2BigInt()\nPlease wait...";

# Generate a 4096-digit binary number:
RunTests('1' . '0' x 4096, '104438888141315250669175271071662438257996
+424904738378038423348328395390797155745684882681193499755834089010671
+443926283798757343818579360726323608785136527794595697654370999834036
+159013438371831442807001185594622637631883939771274567233468434458661
+749680790870580370407128404874011860911446797778359802900668693897688
+178778594690563019026094059957945343282346930302669644305902501597239
+986771421554169383555988529148631823791443449673408781187263949647510
+018904134900841706167509366833385055103297208826955076998361636941193
+301521379682583718809183365675122131849284636812555022599830041234478
+486259567449219461702380650591324561082573183538008760862210283427019
+769820231316901767800667519548507992163641937028537512478401490715913
+545998279051339961155179427110683113409058427288427979155484978295432
+353451706522326906139490598769300212296339568778287894844061600741294
+567491982305057164237715481632138063104590291613692670834285644073044
+789997190178146576347322385026725305989979599609079946920177462481771
+844986745565925017832907047311943316555080756822184657174637329688491
+281952031745700244092661691087414838507841192980452298185733897764810
+312608590300130241346718972667321649151113160292078173803343609024380
+4708340403154190336');

print "\nConverting 8192-digit binary number to decimal using Bin2Dec(
+) and Bin2BigInt()\nPlease wait...";

# Generate a 8192-digit binary number:
RunTests('1' . '0' x 8192, '109074813561941592946298424473378286244826
+416199623269243183278618972133184911929521626423452520198722395729179
+615702527310987082017718406361097976507755479907890629884219298953860
+982522804820515969685161359163819677188654260932456012129055390188630
+101790025253579991720001007960002653583680090529780588095235050163019
+547565391100531236456001484742603529355124584392891875276869627934408
+805561751569434994540667782514081490061610592025643850457801332649356
+583604724240738244281224513151775751916489922636574372243227736807502
+762788304520650179276170094569916849725787968385173704999690096112051
+565505011556127149149251534210574896662954703278632150573082843022166
+497032439613863525162640951616800542762343599630892169144618118740639
+531066540488573943483287742816740749537099351186875635997039011702182
+361674945862096985700626361208270671540815706657513728102702231092756
+491027675916052087830463241104936456875492096732298245918476342738379
+027244843801852697776494107271561158043469082745933999196141424274141
+059911742606055648376375631452761136265862838336862115799363802087853
+767554533678991569423443395566631507008721353547025567031200413072549
+583450835743965382893607708097855057891296790735278005493562156109079
+584517295411597292747987752773856000820411855893000477774872776185381
+351049384058186159865221160596030835640594182118971403786872621948149
+872760365361629885617482241303348543878532402475141941718301228107820
+972930353737280457437209522870362277636394529086980625842235514850757
+103961938744962986680818876966281577815307939317909314364834076173858
+181956300299442279075495506128881830843007964869323217915876591803556
+521615711540299212027615560787310793747746684152836298770869945015203
+123186259420308569383894465706134623670423402682110295895495119708707
+654618662279629453645162075650935101890602377382153953277620867697858
+973196633030889330466516943618507835064156833694453005143749131129883
+436726523859540490427345592872394952522718461740436785475461047437701
+976802557660588103807727070771794222197709038543858584409549211609985
+253890397465570394397308609093059696336076752996493841459818570596375
+456149735582781362383328890630900428801732142480866396267133352800923
+275835087305961411872378142210146019861574738685509689608918918044133
+955852482286754111321263879367556765034036297003193002339782846531854
+723824423202801518968966041882297600081543761065225427016359565087543
+385114712321422726660540358178146909080657646895058766199718650566547
+5715792896');

print "\nNow we will convert 5000 random 128-bit binary numbers using 
+Bin2BigInt().\nPress ENTER to begin...";
$a = <STDIN>;

my $DEC;
my $TIME = time;
for (my $count = 0; $count < 5000; $count++)
{
  my $random = '';
  for (my $bits = 0; $bits < 128; $bits++)
  {
    $random .= (rand(300) > 150) ? '1' : '0';
  }
  $DEC = Bin2BigInt($random);
  print "\n $random => $DEC";
}
print("\n", time - $TIME, ' secs.');

print "\n\nNow we will convert 5000 random 128-bit binary numbers usin
+g Bin2Dec().\nPress ENTER to begin...";
$a = <STDIN>;

$TIME = time;
for (my $count = 0; $count < 5000; $count++)
{
  my $random = '';
  for (my $bits = 0; $bits < 128; $bits++)
  {
    $random .= (rand(300) > 150) ? '1' : '0';
  }
  $DEC = Bin2Dec($random);
  print "\n $random => $DEC";
}
print("\n", time - $TIME, ' secs.');

print "\n\n";

exit;

####################################################################
# RUN TESTS:
#
sub RunTests
{
  my $i = 0;
  my $ERR = 0;
  while ($i < @_)
  {
    my $THIS_OK = 1;
    my $BIN = $_[$i++];
    my $CORRECT = $_[$i++];
    my $DEC1 = Bin2Dec($BIN);
    my $DEC2 = Bin2BigInt($BIN);
    if ($CORRECT ne $DEC1)
    {
      print "\nBin2Dec('$BIN') outputs:\n$DEC1 when it should be:\n$CO
+RRECT\n";
      $THIS_OK = 0;
      $ERR++;
    }
    if ($CORRECT ne $DEC2)
    {
      print "\nBin2BigInt('$BIN') outputs:\n$DEC2 when it should be:\n
+$CORRECT\n";
      $THIS_OK = 0;
      $ERR++;
    }
    $THIS_OK and print "\nOK  $DEC1";
  }
  print "\n\n $ERR ERRORS.\n\n";
  return !$ERR;
}
####################################################################
#
# This function takes a binary number of any size made up of
# 1s and 0s and returns a decimal number (base 10).
#
# This function can convert a 64-bit or 128-bit binary number to
# a decimal number even when 32-bit processor is used. Regardless
# of processor architecture, it will work on any machine.
#
# The input string can contain any number of digits. Any character
# other than 1s and 0s is going to be ignored. The output number
# is going to be a big integer which may contain hundreds or
# even thousands of digits.
#
# Usage: STRING = Bin2Dec(STRING)
#
sub Bin2Dec
{
  defined $_[0] or return 0;
  my $B = $_[0];
  $B =~ tr|01||cd;                          # Remove illegal chars
  $B =~ s/^0+//;                            # Remove preceding zeros
  (my $L = length($B)) or return 0;         # Return 0
  $L > 32 or return oct('0b' . $B);         # Is it 32 bits or less?
  my $DEC = oct('0b' . substr($B, -32));    # Convert last 32 bits
  $B = substr($B, 0, -32);                  # Remove last 32 bits
  # Convert number up to 49 bits:
  $L < 50 and return $DEC + oct('0b' . $B) * 4294967296;

  my $i;
  my $N;
  my $PWR = "\x06\x09\x02\x07\x06\x09\x04\x09\x02\x04";  # 4294967296
  $DEC =~ tr|0-9|\x00-\x09|;
  $DEC = reverse($DEC);
  $L -= 32;
  my $PWR2 = 4294967296;
  while ($L-- >= 0)
  {
    if (chop($B))   # Is the next binary digit a '1' ?
    {
      # Perform simple addition: $DEC += $PWR
      $i = (length($PWR) >> 2) + 2;
      while ($i-- > 0)
      {
        vec($DEC, $i, 32) += vec($PWR, $i, 32);
      }
      # Perform carry operation:
      while ($DEC =~ s/([^\x00-\x09])(.)/ $N = ord($1); pack('CC', cho
+p($N), $N + ord($2)) /esg) {}
      $DEC =~ s/([^\x00-\x09])$/ $N = ord($1); pack('CC', chop($N), $N
+) /es;
    }

    # Here we calculate the next power of two.
    # We shift each byte of $PWR to the left by 1.
    # The fastest way to do this is using the tr/// operator.
    # Each digit 0-9 is represented as an ASCII character
    # from \0 to \x09 and so once shifted, the numbers then
    # become \x00 to \x12. After this, we perform a carry operation.
    # Note: $PWR stores numbers backwards, so "4096" would be
    # represented as "\x06\x09\x00\x04".

    # Multiply each digit by 2:
    $PWR =~ tr|\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0C\x0E\x1
+0\x12\x14\x18\x1C\x20\x24\x28\x30\x38\x40\x48\x70|\x00\x02\x04\x06\x0
+8\x0A\x0C\x0E\x10\x12\x14\x18\x1C\x20\x24\x28\x30\x38\x40\x48\x50\x60
+\x70\x80\x90\xE0|;

    # Next, we perform the carry operation again:
    while ($PWR =~ s/([^\x00-\x09]{1})(.)/ $N = ord($1); pack('CC', ch
+op($N), $N + ord($2)) /esg) {}
    $PWR =~ s/([^\x00-\x09]{1})$/ $N = ord($1); pack('CC', chop($N), $
+N) /es;
  }
  $DEC =~ tr|\x00-\x09|0-9|;
  $DEC =~ s/0+$//;
  $DEC = reverse($DEC);
  return $DEC;
}
####################################################################
#
# This function converts a binary number from base 2 to base 10
# using BIGADD() function which is slower.
# Accepts any number of digits.
#
# Usage: STRING = Bin2BigInt(STRING)
#
sub Bin2BigInt
{
  my $N = defined $_[0] ? $_[0] : '';
  $N =~ tr|01||cd;  # Remove everything except 1s and 0s
  $N =~ s/^0+//;    # Remove initial zeros
  my $L = length($N);
  if ($L == 0) { return '0'; }
  if ($L <= 32) { return oct('0b' . $N); }
  my $OUTPUT = oct('0b' . substr($N, -32));
  my $PWR = 4294967296;
  $L -= 32;
  while ($L--)
  {
    if (length($PWR) < 15)
    {
      if (vec($N, $L, 8) == 49) { $OUTPUT += $PWR; }
      $PWR += $PWR;
    }
    else
    {
      if (vec($N, $L, 8) == 49) { $OUTPUT = BIGADD($OUTPUT, $PWR); }
      $PWR = BIGADD($PWR, $PWR);
    }
  }
  return $OUTPUT;
}
####################################################################
#
# This function adds two big positive integers in base 10 and
# returns the sum. There is no error checking done, so make sure
# to only provide digits in the arguments. Any non-digit character
# will mess up the output.
#
# The 1st and 2nd arguments must contain two big integers that have
# to be added. The 3rd and 4th arguments shift these integers to
# the left or right before the addition. For example:
# BIGADD(4, 5, 1, 0) would shift 4 to the right by 1,
# so it would become 40, and then 40 + 5 = 45.
#
# Usage: BIGINT_SUM = BIGADD(BIGINT_A, BIGINT_B, SHIFT_A, SHIFT_B)
#
sub BIGADD
{
  no warnings;
  my $A = defined $_[0] ? $_[0] : '';
  my $B = defined $_[1] ? $_[1] : '';
  $A =~ s/^0//g; $A =~ tr|0-9||cd;
  $B =~ s/^0//g; $B =~ tr|0-9||cd;
  my $AL = length($A) + int($_[2]);
  my $BL = length($B) + int($_[3]);
  my $P = ($AL > $BL ? $AL : $BL) + 1;
  my $CARRY = 0;
  my $SUM = '';
  while ($P--)
  {
    my $DIGIT = (($CARRY >> 1) & 1) +
        (vec($A, --$AL, 8) & 15) +
        (vec($B, --$BL, 8) & 15);
    vec($SUM, $P, 8) = $DIGIT + ($CARRY = ($DIGIT > 9) ? 38 : 48);
  }
  $SUM =~ s/^0+//;  # Discard preceding zeros
  return (length($SUM)) ? $SUM : 0;
}
[download]

This tool would be cool if it worked flawlessly, and I am shamelessly fishing for help. Rather than Posting in SOPW I'm showing what I've got here so as not to duplicate the same code in two different parts of the Monastery.

Windows autoplay will run an application on a USB drive if set up there, but I don't want to. I want to leave autoplay alone so that it just harmlessly opens an explorer window when the drive is mounted. I have one drive (the "Dragon" drive referenced in the code) with a very cool free image program, the FastStone Image Viewer, portable edition, installed on it. When I had it plugged into a USB expansion doohicky I plugged another USB drive directly into a slot on the computer, and to my shock and amazement Windows "bumped" the already-inserted drive to a different volume letter! So I said to myself, "I haven't done any really specific Win32 perl scripting for a while, let me see if I can write code that will check for a drive with specific characteristics then, in this case, exec a command from the perl code to fire up the image viewer." Without knowing the drive letter.

What's really strange is that the code doesn't seem to iterate through the array @rmvbl unless I use reverse on it! It's the weirdest thing, I swear this code nearly had me tearing out my hair. Thus all the lines marked "# debugging".

To actually run the code you'll have to adapt it to a drive you have on hand and check for a characteristic that Win32::DriveInfo::VolumeInfo() can detect; the vars that receive the retvals of that call are named in a pretty self-explanatory way.

EDIT

I needed a few days to find other ways to mess up and not look at this code, and it came to me. I was returning undef inside the drive iteration loop instead of below it, where it needed to be.

One thing to note: the variable $VolumeName will not have a value for every drive. It's actually a property of the filesystem, not of the entire drive. A small distinction but important. Anyhow, I think that MS Windows-formatted USB drives won't have this property (I could be wrong). This drive, I had formatted on Gnu/Linux.

One final mystery remains unsolved, and maybe a reader knows something pertaining. The call to exec is never supposed to return if successful, according to Perl's documentation, it is just supposed to completely separate itself from the parent process. When I run this code from a terminal commandline , however, it hangs around until I close the spawned child. Why?

Here's the final code, corrected:

#!/usr/bin/env perl
# Last modified: Sat Jun 07 2025 01:57:01 PM -04:00 [EDT]

use strict;
use v5.18;
use utf8;
use warnings;
use Win32::DriveInfo;

=head1 NAME
DriveFinder

=head1 SYNOPSIS
  To be executed via a desktop shortcut.
  Command in shortcut:
      C:\perl\perl\bin\perl.exe "C:/Program Files/DriveFinder"
=cut

sub survey {
    my @rmvbl  = grep { Win32::DriveInfo::DriveType($_) == 2 ?
                       $_ : undef } Win32::DriveInfo::DrivesInUse(); 
    
    for my $drv (@rmvbl) {
        my ( $VolumeName,
             $VolumeSerialNumber,
             $MaximumComponentLength,
             $FileSystemName, @attr ) =
            Win32::DriveInfo::VolumeInfo($drv);
        return $drv .":" if $VolumeName eq "FirstFS";
    }
    return undef;
}
my $DriveVol = &survey;
# Maybe chdir to C:\Users\somia\OneDrive\Pictures? - makes no differen
+ce.

no warnings 'uninitialized';

while ( !exec($DriveVol.'/FS/FSViewer80/FSViewer.exe') )
{
    say qq[Plug the USB "Dragon" key drive into a USB slot],q[];
    sleep 4;
    $DriveVol = &survey;
}

__END__

=pod

=head1 Drive Types on Win32

0     - the drive type cannot be determined.
1     - the root directory does not exist.
2     - the drive can be removed from the drive (removable).
3     - the disk cannot be removed from the drive (fixed).
4     - the drive is a remote (network) drive.
5     - the drive is a CD-ROM drive.
6     - the drive is a RAM disk.

=cut
# vim: ft=perl et sw=4 ts=4 :
[download]

Many years ago I took this sudoku generator and started writing a Sudoku program using Tk. Every once in a while I'd pull it out and make some changes, add some features, fix some bugs. It has recently reached a fairly feature complete state so I'm posting it here. Some of the features I've added I don't use too often so they may have some bugs yet. Enjoy!

Recently, i've been battling with a few modules made by a former co-worker that are, how should i put it politely, garbage. The modules call a third party web API that could block up to a minute in a cyclic executive that is supposed the have a cycle time of under a second. So he used fork (via the "forks" module), that messes up all kinds of other things (open handles and stuff).

All i needed was a very simple HTTP(s) client that runs a single GET or POST call, non-blocking (except the initial TCP/SSL connect), single-threaded, with just frequent cyclic calls for processing. I couldn't find something that fit my requirements, so i spent a couple of hours writing my own. It's not fully finished and tested yet (haven't tested non-encrypted connection at all), but here it is so you can play with the code:

(Edit: Put the main code in readmore tags because of the length)

It's part of my PageCamel framework. Don't worry about the $self->{reph}->debuglog() calls, that's just the (rather complex) reporting handler i use for my stuff. The relevant function "debuglog" is easy to simulate. Here's the test program:

#/usr/bin/env perl

use v5.40;
use strict;
use warnings;
our $VERSION = 4.6;

# Simulate the PageCamel reporting handler without all the PostgreSQL 
+and Net::Clacks stuff
package Reporting;
sub new($proto, %config) {
    my $class = ref($proto) || $proto;
    
    my $self = bless \%config, $class;

    return $self;
} 

sub debuglog($self, @data) {
    print join('', @data), "\n";
    return;
}

# Test program here
package main;
use Data::Dumper;
use PageCamel::Helpers::AsyncUA;
use Time::HiRes qw(sleep);
use Carp;

my $reph = Reporting->new();

my $ua = PageCamel::Helpers::AsyncUA->new(host => 'cavac.at', use_ssl 
+=> 1, ua => 'PageCamel_AsyncUA/' . $VERSION, reph => $reph);

if(1){
    # Call the sleeptest with GET, this should return a json after a f
+ew seconds artificial delay
    print "############################## GET ########################
+\n";
    if(!$ua->get('/guest/sleeptest/asdjkhfashdflkahsdflhasas7d8687asd6
+f')) {
        croak("Failed to start request");
    }

    while(!$ua->finished()) {
        print "Do something else...\n";
        sleep(0.05);
    }

    my ($status, $headers, $body) = $ua->result();
    print "Return code: $status\n";
    #print Dumper($headers);
    print Dumper($body);
}

if(1){
    # Call the sleeptest with POST, this should return a our post data
+ in reverse ('dlroW olleH') after a few seconds artificial delay
    print "############################## POST #######################
+#\n";
    if(!$ua->post('/guest/sleeptest/asdjkhfashdflkahsdflhasas7d8687asd
+6f', 'application/octed-stream', 'Hello World')) {
        croak("Failed to start request");
    }

    while(!$ua->finished()) {
        print "Do something else...\n";
        sleep(0.05);
    }

    my ($status, $headers, $body) = $ua->result();
    print "Return code: $status\n";
    #print Dumper($headers);
    print Dumper($body);
}
[download]

I'm not sure this will be of use to anyone, but if it is, you're free to "borrow" it Captain Jack Sparrow style for your own purposes.

A really nice article:

"Perl Tone The approach described here will set up a new software-defined MIDI device which will proxy events from our hardware, while applying any number of filters to events before they are forwarded. These examples will make use of Perl bindings to RtMidi."

Attacca Quartet:1,2,3,4,5,6,7,8,10,11,12,13,14,15,16,17,18,19,20,22,23
+,24,25,26,27,28
John Patitucci:1,2,3,5,8,11,12,13,14,15,16,17,19,25,26,27,28
Roomful of Teeth:1,3,5,7,9,12,14,16,19,21,24,26,28
Sō Percussion:1,3,4,5,6,7,8,11,12,13,14,15,16,18,19,21,22,23,24,2
+5,26,27,28
[download]

Attacca Quartet:1-8,10-20,22-28
John Patitucci:1-3,5,8,11-17,19,25-28
Roomful of Teeth:1,3,5,7,9,12,14,16,19,21,24,26,28
Sō Percussion:1,3-8,11-16,18-19,21-28
[download]

So I thought: Perl must have an easy way to find consecutive numbers inside a regex. And indeed it does!

Here is my script, which was originally a one-liner. It consolidates ranges in text using the (??{code}) construct in the search pattern to find consecutive numbers, and leaves everything intact that doesn't look like a number range.

It passes all the tests I threw at it, as long as the ranges are sane, non-overlapping and sorted in ascending order. I made it so that it can handle pre-existing ranges in the input, since I needed some of that code anyway and now it looks cool and has some nice internal symmetry. It does not merge duplicate ranges, nor does it try to handle whitespace. So it is basically only useful if the input data for this stage is generated by your own code (or your own data manipulations in Vim, as in my case). Definitely don't use it for processing arbitrary user input, there are good modules for that!

#!/usr/bin/perl -wp
1 while s/-(\d+),(??{1+$1})-/-/
    or s/-(\d+),((??{1+$1}))\b/-$2/
    or s/\b(\d+),(??{1+$1})-/$1-/
    or s/\b(\d+),((??{1+$1}))\b/$1-$2/;
[download]

This was an interesting learning experience to use the (??{code}) construct! Note that I put capturing parentheses around the (?{...}) items only where it was necessary.

If you want to sort your data before consolidating the ranges, you could first do something like this, but note that this does not ignore extra text:

perl -pe 'chomp; $_ = join(",", sort { $a <=> $b } split /,/) . "\n"'
[download]

static inline SV *pdl2avref(pdl *x, char flatten) {
  int stop = 0, badflag = (x->state & PDL_BADVAL) > 0;
  volatile PDL_Anyval pdl_val = { PDL_INVALID, {0} }; /* same reason a
+s below */
  volatile PDL_Anyval pdl_badval = { PDL_INVALID, {0} };
  if (badflag) {
    if (!(x->has_badvalue && x->badvalue.type != x->datatype)) {
      if (x->has_badvalue)
        pdl_badval = x->badvalue;
      else {
#define X(datatype, ctype, ppsym, ...) \
         pdl_badval.type = datatype; pdl_badval.value.ppsym = PDL.bval
+s.ppsym;
        PDL_GENERICSWITCH(PDL_TYPELIST_ALL, x->datatype, X, )
#undef X
      }
    }
    if (pdl_badval.type < 0) barf("Error getting badvalue, type=%d", p
+dl_badval.type);
  }
  pdl_barf_if_error(pdl_make_physvaffine( x ));
  if (!x->nvals) return newRV_noinc((SV *)newAV());
  void *data = PDL_REPRP(x);
  PDL_Indx ind, inds[!x->ndims ? 1 : x->ndims];
  AV *avs[(flatten || !x->ndims) ? 1 : x->ndims];
  if (flatten || !x->ndims) {
    inds[0] = 0;
    avs[0] = newAV();
    av_extend(avs[0], flatten ? x->nvals : 1);
    if (flatten) for (ind=1; ind < x->ndims; ind++) inds[ind] = 0;
  } else
    for (ind=x->ndims-1; ind >= 0; ind--) {
      inds[ind] = 0;
      avs[ind] = newAV();
      av_extend(avs[ind], x->dims[ind]);
      if (ind < x->ndims-1) av_store(avs[ind+1], 0, newRV_noinc((SV *)
+avs[ind]));
    }
  PDL_Indx *incs = PDL_REPRINCS(x), offs = PDL_REPROFFS(x), lind = 0;
  while (!stop) {
    pdl_val.type = PDL_INVALID;
    PDL_Indx ioff = pdl_get_offset(inds, x->dims, incs, offs, x->ndims
+);
    if (ioff >= 0)
      ANYVAL_FROM_CTYPE_OFFSET(pdl_val, x->datatype, data, ioff);
    if (pdl_val.type < 0) croak("Position out of range");
    SV *sv;
    if (badflag) {
      /* volatile because gcc optimiser otherwise won't recalc for com
+plex double when long-double code added */
      volatile int isbad = ANYVAL_ISBAD(pdl_val, pdl_badval);
      if (isbad == -1) croak("ANYVAL_ISBAD error on types %d, %d", pdl
+_val.type, pdl_badval.type);
      if (isbad)
        sv = newSVpvn( "BAD", 3 );
      else {
        sv = newSV(0);
        ANYVAL_TO_SV(sv, pdl_val);
      }
    } else {
      sv = newSV(0);
      ANYVAL_TO_SV(sv, pdl_val);
    }
    av_store( avs[0], flatten ? lind++ : inds[0], sv );
    stop = 1;
    char didwrap[x->ndims];
    for (ind = 0; ind < x->ndims; ind++) didwrap[ind] = 0;
    for (ind = 0; ind < x->ndims; ind++) {
      if (++(inds[ind]) < x->dims[ind]) {
        stop = 0; break;
      }
      inds[ind] = 0;
      didwrap[ind] = 1;
    }
    if (stop) break;
    if (flatten) continue;
    for (ind=x->ndims-2; ind >= 0; ind--) { /* never redo outer so -2 
+*/
      if (!didwrap[ind]) continue;
      avs[ind] = newAV();
      av_extend(avs[ind], x->dims[ind]);
      av_store(avs[ind+1], inds[ind+1], newRV_noinc((SV *)avs[ind]));
    }
  }
  return newRV_noinc((SV *)avs[(flatten || !x->ndims) ? 0 : x->ndims-1
+]);
}

# ...
MODULE = PDL::Core     PACKAGE = PDL

SV *
unpdl(x)
  pdl *x
CODE:
  RETVAL = pdl2avref(x, 0);
OUTPUT:
  RETVAL
[download]

use strict;
use warnings;
use PDL;

# user params
my $floor = 100;
my $component = 0;
my $delta = 6;
my $elevation = 2;
my $camerapos = -1;
$| = 1;

my $alpha = 0;
my $srcdata = rpic($ARGV[0]);
my $destdata = $srcdata->zeroes; # "filled" with black
my (undef, $width, $height) = $srcdata->dims;
my $relord = $width / 255;
$delta = 1 if $delta < 1;

for (my $y = 0; $y < $height; $y++) {
  my $row = $srcdata->slice('', '', "($y)");
  my $drow = $destdata->slice('', '', "($y)");
  my $red = $row->slice("($component)");
  my $dred = $drow->slice("(0)");
  my $dgreen = $drow->slice("(1)");
  my $dblue = $drow->slice("(2)");
  $drow->slice(3) .= 255 if $alpha;
  for (my $x = 0; $x < $width; $x++) {
print "." unless $x%10;
    my $r = at($red, $x);
    next if $r <= $floor;
    my $remain = $r;
    my $currentx = $width - $r * $relord + ($x / $elevation);
    #Apply elevation following the x offset in original picture
    while ($remain > 0 && $currentx < $width) {
      if ($remain > 150) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, $remain);
        set ($dblue, $currentx, $remain);
      }
      if ($remain < 150 && $remain > 50) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, $remain + 55);
        set ($dblue, $currentx, 0);
      }
      if ($remain < 50) {
        set ($dred, $currentx, 0);
        set ($dgreen, $currentx, 0);
        set ($dblue, $currentx, $remain + 200);
      }
      $remain -= $delta;
      $currentx++;
    }
  }
print "\n";#  Gimp::Progress->update($y / $height);
}

$destdata->wpic("OUT$ARGV[0]");
[download]

The script worked and made interesting pictures, but it was terribly slow (15 secs+ for a 300x300 image). This is largely because it's written like C, and Perl-loops over all X and Y coordinates, reading each pixel value, etc. I knew (sort of) that PDL could be used to do better, but for a long time I didn't really have any clue how.

Encouraged by the screw thingy, and realising the similarity of problem might mean the approach for one could be applied to the other, I dug back into it. This is the more PDL-idiomatic version, which now runs in <4sec, and is actually shorter:

use strict;
use warnings;
use PDL;

# user params
my $floor = 100;
my $component = 0;
my $delta = 6;
my $elevation = 2;
my $camerapos = -1;
$| = 1;

my $alpha = 0;
my $srcdata = rpic($ARGV[0]);
my $destdata = $srcdata->zeroes; # "filled" with black
$destdata->slice(3) .= 255 if $alpha;
my $destmv = $destdata->mv(0,-1); # x y rgb
my (undef, $width, $height) = $srcdata->dims;
my $relord = $width / 255;
$delta = 1 if $delta < 1;

my $quant = ($srcdata->slice("($component)")->max / $delta)->floor->sc
+lr;
return if $quant <= 0;
for my $x (0..$width-1) {
  my $col = $srcdata->slice("($component),($x)");
  my $exceed_floor = ($col > $floor);
  my $r = $col->where($exceed_floor); # nvals
  my $destx = ($width - $r * $relord + ($x / $elevation))->long; # nva
+ls
  #Apply elevation following the x offset in original picture
  my $remain_s = zeroes(long, 3, $quant, $r->dim(0)); # xyr quant nval
+s
  my $yslice = $remain_s->slice("(1)") .= $exceed_floor->which->dummy(
+0); # quant nvals
  my $xslice = $remain_s->slice("(0)") .= $yslice->xvals + $destx->dum
+my(0); # quant nvals
  my $rslice = $remain_s->slice("(2)") .= $yslice->xlinvals(0,-1) * $q
+uant*$delta + $r->dummy(0); # quant nvals
  $rslice->whereND($xslice >= $width) .= -1;
  my $gt150_ind = whichND($rslice > 150);
  my $btwn_ind = whichND(($rslice <= 150) & ($rslice >= 50));
  my $lt50_ind = whichND(($rslice < 50) & ($rslice > 0));
  $destmv->slice(',,1:2')->indexND(cat(map $_->indexND($gt150_ind), $x
+slice, $yslice)->mv(-1,0)) .= $rslice->indexND($gt150_ind) if $gt150_
+ind->nelem;
  $destmv->slice(',,1')->indexND(cat(map $_->indexND($btwn_ind), $xsli
+ce, $yslice)->mv(-1,0)) .= $rslice->indexND($btwn_ind) + 55 if $btwn_
+ind->nelem;
  $destmv->slice(',,2')->indexND(cat(map $_->indexND($lt50_ind), $xsli
+ce, $yslice)->mv(-1,0)) .= $rslice->indexND($lt50_ind) + 200 if $lt50
+_ind->nelem;
#  Gimp::Progress->update($x / $height);
}

$destdata->wpic("OUT$ARGV[0]");
[download]

use PDL;
use PDL::Graphics::Simple;
use PDL::Graphics::ColorSpace;
sub as_heatmap {
  my ($d) = @_;
  my $max = $d->max;
  die "as_heatmap: can't work if max == 0" if $max == 0;
  $d /= $max; # negative OK
  my $hue   = (1 - $d)*240;
  $d = cat($hue, pdl(1), pdl(1));
  (hsv_to_rgb($d->mv(-1,0)) * 255)->byte->mv(0,-1);
}
imag as_heatmap(rvals 300,300);
[download]