Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number

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.

Creating X BitMap (XBM) images with directional gradients
No replies — Read more | Post response
by kcott
on Apr 02, 2021 at 04:34

    G'day All,

    I'm continuing my project to create interactive maps for RPGs with Tk generally and, for the main part, Tk::Canvas. I wrote a bit about that in "Tk::Canvas createGroup() Undocumented"; this CUFP post has nothing to do with the issue in that SoPW post; there is some backgound information and (very early, now substantially matured) code which may be of interest. The test code there to create creeks is related to the current work creating paths.

    I had created the basic paths, put nicely curved bends in them, and so on. All of this looked good except for where the paths terminated upon entering a glade, meadow, or whatever: all I had at the ends was solid lines; what I wanted was for these to gradually peter out. The sections for this needed to be solid (opaque) where the main path ended and gradually fade to nothingness (transparent) as the terrain moved away from the path. In addition, this gradient needed to have direction to match the direction of the path where it terminated.

    I made one futile attempt to do this manually in Gimp: the result looked horrible. I decided to let Perl do it for me. Here's the result which I knocked up this afternoon.

    — Ken

Modifying Image EXIF
No replies — Read more | Post response
by johngg
on Mar 24, 2021 at 12:23

    I was on the point of posting this anyway but BernieC's question makes it quite timely to do so now.

    I recently dug an old DSLR camera out of a cupboard to take some pictures, just to give it an outing really as I have newer cameras. Unfortunately I didn't notice that the camera had lost its date settings and had gone back to its epoch of January 1st, 2010. Not only were the dates wrong but also the filenames as the month and day is included in those, 1 .. 9, A .. C for the month then day number in offsets 1 through 3. The camera is usually configured to take only RAW files but sometimes I save both RAW and JPEG files so I had to cater for both. Luckily I knew the dates the camera had been used so I could modify filenames and EXIF dates but I also wanted the timestamps to have a sane time so I added a routine to increment the time from a starting point a random number of seconds for each successive photo. Here's the script:-

    use strict; use warnings; use Time::Piece; use Image::ExifTool qw{ :Public }; use feature qw{ say }; my $baseDir = q{/Path/To/Images/}; my @dirsToCorrect = ( { dir => q{20201206_JimBirthday/}, dateCode => q{C06}, dateStr => q{2020:12:06 17:49:11}, }, { dir => q{20210224_Garden/}, dateCode => q{224}, dateStr => q{2021:02:24 11:17:23}, }, ); foreach my $rhDir ( @dirsToCorrect ) { my $imgDir = $baseDir . $rhDir->{ dir }; my $dateSeq = makeDateSeq( $rhDir->{ dateStr } ); opendir my $imgDH, $imgDir or die qq{opendir: $imgDir: $!\n}; my @rawFiles = grep m{\.ORF$}, readdir $imgDH; closedir $imgDH or die qq{closedir: $imgDir: $!\n}; foreach my $rawFile ( @rawFiles ) { say qq{Processing $rawFile ...}; my $origPath = $imgDir . $rawFile; my $newRawFile = $rawFile; substr $newRawFile, 1, 3, $rhDir->{ dateCode }; my $newPath = $imgDir . $newRawFile; my $correctedDate = $dateSeq->(); my $exifTool = Image::ExifTool->new(); $exifTool->SetNewValue( q{CreateDate}, $correctedDate ); $exifTool->SetNewValue( q{DateTimeOriginal}, $correctedDate ); $exifTool->SetNewValue( q{FileName} => $newRawFile, Protected +=> 1 ); writeNewExif( $exifTool, $origPath, $newPath ); ( my $possJPGfile = $rawFile ) =~ s{ORF$}{JPG}; my $possJPGpath = $imgDir . $possJPGfile; next unless -e $possJPGpath; say qq{ ... and associated $possJPGfile ...}; my $newJPGfile = $possJPGfile; substr $newJPGfile, 1, 3, $rhDir->{ dateCode }; my $newJPGpath = $imgDir . $newJPGfile; $exifTool->SetNewValue( q{FileName} => $newJPGfile, Protected +=> 1 ); writeNewExif( $exifTool, $possJPGpath, $newJPGpath ); } } sub makeDateSeq { my $dateStr = shift; my $dateVal = Time::Piece->strptime( $dateStr, q{%Y:%m:%d %H:%M:%S +} ); return sub { $dateVal += ( int rand 75 ) + 10; return $dateVal->strftime( q{%Y:%m:%d %H:%M:%S} ); }; } sub writeNewExif { my( $exifTool, $origPath, $newPath ) = @_; print q{ } x 10, qq{writing $newPath ... }; my $success = $exifTool->WriteInfo( $origPath, $newPath ); if ( ! $success ) { say q{FAILED - }, $exifTool->GetValue( q{Error} ); } elsif ( $success == 1 ) { say q{OK, wrote changes}; print q{ } x 10, qq{removing $origPath ... }; say unlink( $origPath ) ? q{OK} : qq{FAILED - $!}; } else { say q{FAILED, wrote unchanged}; print q{ } x 10, qq{removing $newPath ... }; say unlink( $newPath ) ? q{OK} : qq{FAILED - $!}; } }

    Here's another script that pulls the EXIF out of files supplied as arguments and Data::Dumper->Dumpxs()'s the results. The files from my cameras include an embedded thumbnail image which I exclude from the dump as it just messes up the output.

    use strict; use warnings; use Image::ExifTool qw{ :Public }; use Data::Dumper; my %exif; while ( my $file = shift ) { do { warn qq{$file does not exist\n}; next; } unless -e $file; $exif{ $file } = ImageInfo( $file ); delete $exif{ $file }->{ ThumbnailImage }; } print Data::Dumper ->new( [ \ %exif ], [ qw{ *exif } ] ) ->Sortkeys( 1 ) ->Indent( 1 ) ->Dumpxs();

    I hope this is useful.

    Update: Note that the Image::ExifTool documentation states that the WriteInfo() method will accept a single filename argument in which case it will overwrite the original file with the new EXIF information included. It does encourage the user to make sure to have backups!



Tk and GD to custom rotate, resize and crop jpg images
No replies — Read more | Post response
by Discipulus
on Mar 15, 2021 at 11:57
    Hello folks!

    Tk and GD again. Imagine to have a lot of pictures of the same subject, let say historical Kawasaki motorcycles, but where this subject is off center, sometimes bigger sometimes smaller, other times the picture is rotated and you want to have them with the subject of the same size, always horizontal and all pictures centered. Dreadful hours of photo editing or.. tk-jepg-custom-rotator! :)


    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
A Random Fortune Cookie
4 direct replies — Read more / Contribute
by choroba
on Mar 10, 2021 at 04:03
    I follow the #perl hashtag on Mastodon. Few days ago, someone asked:

    > Trying to randomize entries in a fortune text file. Not the output--the text of the human-readable fortune file. "sort -R" works on individual lines, but I want to grab multiline entries delimited by %.

    To which someone else replied

    > I figured it would be a two step solution. Step 1: install perl.

    Another person reacted with

    > <3 #perl. If you'd use a Perl one-liner let me know, I'll see if I can get one working. :)

    The hashtag in this reply was why I was informed about the discussion.

    Here's a sample from a typical fortune file (from ruanyf/fortunes):

    You cannot achieve the impossible without attempting the absurd. % Assumption is the mother of all screw-ups. % Thinking you know something is a sure way to blind yourself. % Neckties strangle clear thinking. % The first principle is that you must not fool yourself -- and you are +the easiest person to fool. -- Richard Feynman % The greater danger for most of us lies not in setting our aim too high + and falling short; but in setting our aim too low, and achieving our + mark. -- Michelangelo % I would rather have a mind opened by wonder than one closed by belief. -- Gerry Spence % What you are is what you have been. What you'll be is what you do now. -- Buddha % What we see is mainly what we look for. %

    And here's my solution:

    perl -0x25 -MList::Util=shuffle -e 'print +(shuffle<>)[0]'

    Update: As noted by hippo, the original request was more probably just to randomly sort the whole file. To do that, just remove the [0].

    Update 2: Unfortunately, there's the trailing empty cookie problem.

    perl -0x25 -MList::Util=shuffle -e '@f=<>;pop@f;print shuffle@f'

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
Simple CLI calculator based on Perl's eval()
6 direct replies — Read more / Contribute
by reisinge
on Mar 03, 2021 at 12:27

    Sometimes I need to do a quick calculation. I'm too lazy to open a GUI calculator and I never remember whether it's bc or dc (not mentioning the syntax). So I placed this code into ~/bin/calc:

    #!/usr/bin/perl -sT use strict; use warnings; use bignum; # Command line options... our ($h, $b, $x, $c, $l); # Help message... if ($h) { print <<'EOF'; Simple CLI calculator based on Perl's eval() calc [options] <expression> -h help -b convert expression (or its result) to binary -x convert expression (or its result) to hexadecimal -c convert expression (or its result) to character -l calculate base 2 logarithm of expression calc 149,600,000/299 792 458*1000/60 # comma or space are thousands + separator calc 2x2 + 2*2 # x is the same as * (multipli +cation) calc 'sqrt(V(3+3+3) * 3)' # V is the same as sqrt (squar +e root) calc -b 2^8 # ^ is the same as ** (exponen +tiation) calc -x $RANDOM calc -c 2**17-3030 calc -l 256 EOF exit 0; } # Allowed input characters regex... my $allowed = qr'\d\+\-\/\*\.x(sqrt)V'; # Transform input a bit... @ARGV = ( "@ARGV" =~ /[$allowed]/g ); # un-taint my $expr = "@ARGV"; $expr =~ s/\s+//g; # allow whitespace in input $expr =~ s/x/*/gi; # allow x for multiplication $expr =~ s/\^/**/g; # allow ^ for exponentiation $expr =~ s/V/sqrt/g; # allow V for square root $expr =~ s/sqrt/sqrt /g; # Do the calculation... my $res = eval "$expr"; die "Does not compute...$expr\n" unless defined $res; if ($b) { # Show result in binary... printf "%s = %b\n", $expr, $res; exit } elsif ($x) { # Show result in hex... printf "%s = %x\n", $expr, $res; exit } elsif ($c) { # Show result as character... binmode(STDOUT, ':utf8'); printf "%s = %c\n", $expr, $res; exit } if ($l) { # Calculate base 2 logarithm... $res = log($res)/log(2.0); } # Show thousands in result but not in the decimal part... my ( $before_dot, $after_dot ) = split /\./, $res; $before_dot =~ s/(\d{1,3}?)(?=(\d{3})+$)/$1 /g; printf "%s = %s.%s\n", $expr, $before_dot, $after_dot // 0;
    Solve the biggest problem you can. -- Nick Hanauer
Finding old copies of files
2 direct replies — Read more / Contribute
by Leitz
on Feb 24, 2021 at 05:35

    I write science-fiction for teens, and sometimes have to save documents into a non-text format. Not really an issue, but I like to make backups, and backups of my backups, because I've lost work before. I thought I had a slight problem, maybe a dozen or so files with five or six copies. No worries! I could save them as text, put them into version control, and then get rid of the old files. Life is good.

    The first pass at code said I had 21 files and 167 copies. Not good, but doable. Then I looked at the directory list and saw a lot of directories that should be searched were missing from the list. Going back to the code, I realized that there wasn't anything to recurse into a directory to see if there were more directories to be searched. Fixed that. Proud of myself, I ran the code again:

    With 161 unique files, there are 7621 copies.

    Oh boy...maybe I have a problem...

    The code below is a work in progress. I'm setting it up so that I can exclude the version controlled originals. Future steps include removing duplicate files and empty directories. Feedback is welcome! Code Repo

    #!/usr/bin/env perl # name: # version: 0.0.2 # date: 20210223 # desc: Tool to help clean up old versions of files. ## TODO use strict; use warnings; use File::Basename; use Data::Dumper; use Getopt::Long; my %known_dirs; my %known_files; my @dir_queue; # Used to see how many copies we have. my $total_file_count = 0; my $actual_file_count = 0; my $log = 0; # set to 1 with the --log option. my $exclude_list_file; my %exclude_list; my $exclude_dir_file; my %exclude_dir; my $seed_file; # This is just a seed file, the results of 'locate +<filename>' sub usage { print "Usage: --file <path/seed_file> [ --log | --exc +lude_list <file of files to not deal with> ] \n"; exit; }; # Pretty sure these could be made into one method. sub build_exclude_dir { open my $exclude_dirs, '<', $exclude_dir_file or die "Can't open $ex +clude_dir_file: $!"; for my $dir ( <$exclude_dirs> ) { chomp $dir; if ( -d $dir ) { $exclude_dir{$dir} = 1; } } close $exclude_dirs; } sub build_exclude_list { open my $exclude_files, '<', $exclude_list_file or die "Can't open $ +exclude_list_file: $!"; for my $file ( <$exclude_files> ) { chomp $file; $exclude_list{$file} = 1; } close $exclude_files; } sub build_file_list { foreach my $search_dir ( @dir_queue ) { opendir( my $dir, $search_dir ) or die "Can't open $search_dir: $! +"; foreach my $file ( readdir($dir)) { next if $file =~ m/^\.\.?$/; if ( -d "$search_dir/$file" ) { next if ( defined ($exclude_dir{"$search_dir/$file"}) ); $known_dirs{"$search_dir/$file"} = 1; push ( @dir_queue, "$search_dir/$file"); } else { next if ( defined( $exclude_list{$file} )); $total_file_count++; my $size = -s "$search_dir/$file"; $known_files{$file}{$size} = 1; } } closedir($dir); } } sub show_log { print Dumper(%known_files); $actual_file_count = scalar(keys(%known_files)); print "With $actual_file_count unique files, there are $total_file_c +ount copies.\n"; my @single_version_files; my @multiple_version_files; foreach my $file ( keys( %known_files ) ){ my @values = keys(%{$known_files{$file}}); if ( scalar(@values) > 1 ) { push @multiple_version_files, $file; } else { push @single_version_files, $file; } } @multiple_version_files = sort(@multiple_version_files); @single_version_files = sort(@single_version_files); if ( scalar( @multiple_version_files ) ) { print "Files with multiple versions:\n"; foreach my $f ( @multiple_version_files ) { print "\t $f \n"; } } if ( scalar( @single_version_files ) ){ print "Files with a single version:\n"; foreach my $f ( @single_version_files ) { print "\t $f \n"; } } if ( keys(%exclude_dir) ){ print "excluded directories:\n"; foreach my $dir ( keys(%exclude_dir) ){ print "\t $dir\n"; } } if ( keys( %exclude_list ) ) { print "excluded files:\n"; foreach my $file ( keys( %exclude_list ) ){ print "\t $file\n"; } } if ( keys(%known_dirs) ) { print "directory search list:\n"; foreach my $dir ( keys( %known_dirs )) { print "\t $dir\n"; } } } GetOptions( "--log" => \$log, "--file=s" => \$seed_file, "--exclude_files=s" => \$exclude_list_file, "--exclude_dirs=s" => \$exclude_dir_file, ); usage() unless ( defined($seed_file) ); open my $seed_data_file, '<', $seed_file or die "Can't open $seed_file +: $!"; build_exclude_list() if $exclude_list_file; build_exclude_dir() if $exclude_dir_file; # Build the list of directories to search. for my $line ( <$seed_data_file>) { chomp $line; my $dirname = dirname($line); $known_dirs{$dirname} = 1 unless defined( $exclude_dir{$dirname} ); push( @dir_queue, $dirname); } close $seed_data_file; build_file_list(); show_log() if $log;

    Chronicler: The Domici War (

    General Ne'er-do-well (

Calculating resistor pairs to generate a range of voltages
2 direct replies — Read more / Contribute
by GrandFather
on Feb 15, 2021 at 20:11

    I needed to generate resistor pairings for a resistor voltage divider to generate voltages from 0 to full scale in 256 steps for use with configuration on a PCB. The following script parses a CSV file dumped out from component supplier DigiKey and from the over 500 resistor values selects 58 that can be used to generate the 254 pairings needed (255 and 0 are special cases that aren't included).


    58 values used excluding 0 Ohm and 'DNF' 301: ERJ-PB3B3010V 340: ERJ-PB3B3400V ... 90900: ERJ-PB3B9092V 95300: ERJ-PB3B9532V 1: R1 90900, R2 357 = 1.00 (err 0.002: 1.00 - 1.00 = 0.00), +z = 356 2: R1 95300, R2 750 = 1.99 (err 0.009: 1.99 - 2.00 = 0.01), +z = 744 3: R1 49900, R2 590 = 2.98 (err 0.020: 2.97 - 2.99 = 0.01), +z = 583 4: R1 80600, R2 1270 = 3.96 (err 0.044: 3.95 - 3.96 = 0.02), +z = 1250 5: R1 80600, R2 1620 = 5.02 (err 0.024: 5.01 - 5.03 = 0.02), +z = 1588 ... 253: R1 340, R2 43200 = 253.01 (err 0.009: 253.00 - 253.01 = 0.01), +z = 337 254: R1 357, R2 90900 = 254.00 (err 0.002: 254.00 - 254.00 = 0.00), +z = 356 Max Z: 36437, min R: 602

    The report shows the actual values generated with ideal resistors and the range of values taking resistor tolerances into account. The z value is the effective impedance the ADC input sees. min R is the minimum series resistance of any resistor pair which relates to the maximum current through the resistors.

    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
POE::Filter for Tor control protocol
No replies — Read more | Post response
by jcb
on Feb 12, 2021 at 22:24

    This is a rough draft of a module I intend to submit to CPAN soon, posted here for review and comments from the community.

    This is an early step towards using POE and Tk to write a Tor controller for my own use. The controller itself may or may not ever be worth publishing; it is an "excuse to learn POE" project for me, so it will probably be a bit of a mess.

    The interface is still in development; this "version 0.001" might not be the same code that is eventually uploaded to CPAN and the interface might change in later versions.


    I note with some amusement that the test file is longer than the module itself. :-)


Quick script to check data logger data
1 direct reply — Read more / Contribute
by GrandFather
on Feb 10, 2021 at 04:54

    The coolness factor in this script is more to do with the utility of Perl for whipping up a tool than very much that is special in the script. That said, the script does demonstrate why Perl is a great "whip it up language".

    The back story is that the astronomical society I'm a member of hosts a number of space weather related data collection systems at our dark sky site. The systems belong to researchers in Japan and the instruments we operate are part of an international network of similar instruments. About a year ago we added an induction magnetometer to the collection of instruments. Unfortunately it has been nothing but trouble. Over the period of a year we got about three days of data off it. Long story short - there was a hardware fault with the data logger. I've fixed that and now we are starting to collect data so I needed a way to check that the data is sensible. Enter Perl.

    As it happens the file format for the data is documented - as a C++ header containing a couple of C++ structs. That's OK. Perl is quite happy to read fixed size chunks from files then convert the chunks using unpack. Turned out that for the current task I needn't have bothered, but I'll use that code for another task in the future anyway. The data itself is kinda meaningless. It becomes interesting when passed through a FFT (Fast Fourier Transform). Hey, what do ya know, CPAN has a FFT module (several actually). And the data from an FFT is kinda unintelligible without plotting it - Tk, please step up.

    So the following (abridged) script is the result of a couple of hours work and lets me drag and drop files off the data logger onto a shortcut and make a visual check that the data looks sane.

    use strict; use warnings; use Math::FFT; use Tk; use Tk::Canvas; package ATSComments80_s; sub new { my ($class, $fileHandle) = @_; my $self = bless {fh => $fileHandle}, $class; $self->load(); return $self; } sub load { my ($self) = @_; read $self->{fh}, $self->{achClient}, 16; read $self->{fh}, $self->{achContractor}, 16; read $self->{fh}, $self->{achArea}, 16; read $self->{fh}, $self->{achSurveyID}, 16; read $self->{fh}, $self->{achOperator}, 16; read $self->{fh}, $self->{achReserved}, 112; read $self->{fh}, $self->{achXmlHeader}, 64; read $self->{fh}, $self->{achComments}, 512; } package ATSHeader80_s; sub new { my ($class, $fileHandle) = @_; my $self = bless {fh => $fileHandle}, $class; $self->load(); return $self; } sub load { my ($self) = @_; read $self->{fh}, $self->{siHeaderLength}, 2; $self->{siHeaderLength} = unpack 's<', $self->{siHeaderLength}; ...; read $self->{fh}, $self->{abyADBBoardType}, 4; $self->{tscComment} = ATSComments80_s->new($self->{fh}); } package main; my $filePath = $ARGV[0] // "testData.ats"; open my $fh, '<:raw', $filePath or die "Can't open $filePath: $!"; my $header = ATSHeader80_s->new($fh); my $itemCount = 0; my @data; while ($itemCount++ < 1024 && read $fh, my ($value), 4) { $value = unpack 'l<', $value; push @data, $value; } my $fft = Math::FFT->new(\@data); my $mw = MainWindow->new (-title => "Magnetometer Plotter"); my $canvas = $mw->Canvas (-height => 700, -width => 1024)->pack (); my $spectrum = $fft->spctrm; # Remove DC signal component shift @$spectrum; $spectrum = NormData($spectrum, 680); $canvas->createLine( (map {2 + 2 * $_, $spectrum->[$_]} 0 .. $#$spectrum), -fill => 'blue' ); $mw->MainLoop (); sub NormData { my ($data, $span) = @_; my $min; my $max; for my $datum (@$data) { $min //= $datum; $max //= $datum; $min = $datum if $min > $datum; $max = $datum if $max < $datum; } my $scale = $span / ($max - $min); $_ = $span - ($_ - $min) * $scale + 10 for @$data; return $data; }
    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
Who you gonna call? Google Civic Information client & website
6 direct replies — Read more / Contribute
by 1nickt
on Feb 06, 2021 at 23:27

    Google has an API called Civic Information from which one can obtain all the elected officials (from head of state to city council) for a given US address. It's a very cool tool designed to facilitate citizen engagement in government, and I strongly support that.

    I wrote the Perl client for the API (Net::Google::CivicInformation), and based a Dancer2 web app on it, online now at

    (At the urging of some of the Dancer2 team I made public the source code repository for the web app. Hope it comes in handy for someone learning to build with Dancer2.)

    In a future release I plan to implement the elections information the API provides. Because silence betokes consent ✌️


    edit: removed planned feature that's now implemented; added note about public github repo

    The way forward always starts with a minimal test.
Emoji Progress Spinners
5 direct replies — Read more / Contribute
by kcott
on Feb 06, 2021 at 18:19

    When doing some tests for "Emoji can be hard to see on the command line", I typed in an incorrect character for a Unicode® code point and was presented with a clock face. That reminded me of something I've been meaning to do for quite some time, so here it is.

    The basic idea is to have a progress spinner that is a little more visually appealing than the usual text versions which cycle through "| / - \".

    There are two versions: one with clock faces and one with phases of the moon. I've provided all of the code points, so that's one job anyone wanting to use this doesn't need to do. The code points for the clock faces are not sequential, so I've provided the order from 12:00 to 11:30; again, another fiddly job taken care of. The logic is simple and probably well-known to many; but, if not, that's done as well.

    I've specified 'use 5.018;'. All of the characters were introduced in Unicode® v6.0 (determined via Unicode::UCD::charprops_all()). You may actually get away with 'use 5.014;'. I chose 5.18 based on the deltas (my emphasis throughout):

    • 5.12: "Perl 5.12 comes with Unicode 5.2"
    • 5.14: "Unicode Version 6.0 is now supported (mostly)"
    • 5.16: "Supports (almost) Unicode 6.1"
    • 5.18: "Perl now supports Unicode 6.2."

    The following script is barebones and is really only intended as an example demo. Anyone wishing to use this will likely want additional output text — e.g. percentages, "done X of Y", and the like — so I saw no point in trying to guess such requirements.

    #!/usr/bin/env perl use 5.018; use warnings; use open qw{:std :encoding(UTF-8)}; use Time::HiRes 'usleep'; { my @code_points = qw{ 1f55b 1f567 1f550 1f55c 1f551 1f55d 1f552 1f55e 1f553 1f55f 1f554 1f560 1f555 1f561 1f556 1f562 1f557 1f563 1f558 1f564 1f559 1f565 1f55a 1f566 }; my @chars = map chr hex, @code_points; my $total = @chars; my $index = $total; for (1 .. 50) { local $| = 1; $index %= $total; print "\b\b", $chars[$index++]; usleep 250_000; } print "\n"; } { my @code_points = qw{ 1f311 1f312 1f313 1f314 1f315 1f316 1f317 1f318 }; my @chars = map chr hex, @code_points; my $total = @chars; my $index = $total; for (1 .. 25) { local $| = 1; $index %= $total; print "\b\b", $chars[$index++]; usleep 500_000; } print "\n"; }

    — Ken

Extract IP addresses
2 direct replies — Read more / Contribute
by reisinge
on Jan 29, 2021 at 03:14

    In my blog post I used a Perl one-liner to extract IP addresses from logs:

    journalctl --since "00:00" | perl -lne '/((?:\d{1,3}\.){3}\d{1,3})/ & +& print $1'
    A tiny code but pretty useful.
    Noi siamo quello che facciamo. -- L. Sciascia
A dice roller system with Marpa::R2
1 direct reply — Read more / Contribute
by Discipulus
on Jan 16, 2021 at 09:49
    Hello folks!

    I recently asked for your wisdom in First steps with Marpa::R2 and BNF and I got nice answers. I'm playing with dice in these days as you can see in the post is rand random enough to simulate dice rolls?. The module I finally crafted as toy project is Games::Dice::Roller (with its gitlab repository).

    But I had a sudden desire to reimplement the whole in Marpa::R2 and evolvig duelafn's example and following precious GrandFather's suggestions I ended with the following working code.

    I left in it a lot of debug messages in case someone comes here to look for Marpa::R2 examples.

    It actually mimicry the beahaviour of my Games::Dice::Roller for input received (it still does not accept multistring arguments like 3d6 4d4+1 12 kh as the module does) and it outputs in the same way 3 elements: the result, a descriptive string and the internal datastructure.

    The following code is different from Games::Dice::Roller because it has less constraints in received inputs: for example it accepts something like 6d4r1kh3+3 and computes also a correct result, but messing the description. My mudule would reject an input like this.

    Possible inputs given as argument of the program:

    3d6 # simplest one 3d6+3 # with a result modifier 3d8r1 # reroll and discard any 1 3d8rlt3 # reroll and discard any lesser than 3 3d8rgt6 # reroll and discard any greater than 6 3d8rgt6+2 # reroll and discard any greater than 6 and add +2 to the f +inal result 4d6x1 # explode (a new roll is done) each 1 rolled 4d6xlt3 # explode lesser than 3 4d6xgt4 # explode greater than 4 4d12kh3 # keep highest 3 rolls 4d12kl3 # keep lowest 3 rolls 4d12dh3 # drop highest 3 rolls 4d12dl3 # drop lowest 3 rolls 4d20kh3+7 # keep hishets 3 rolls then add 7

    Alea iacta est!


    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Dynamically generate setter/getter methods
1 direct reply — Read more / Contribute
by stevieb
on Dec 20, 2020 at 04:03

    This isn't really a cool use for Perl, but more of a cool use of Perl.

    I was making some updates to my Hook::Output::Tiny software, in which I have a couple of subs that do the exact same thing, but the names are different. One thing I like to do in cases such as this is auto generate the subs dynamically.

    For example... you've got a module that has subs one(), two(), three() etc, and they all do the same thing... accept an optional value to stash into the object (setter), and return the value (getter). Each sub has the same (or perhaps different) default values. I always use the old-fashioned Perl way of writing OO code, so that would look like this:

    sub one { my ($self, $value) = @_; $self->{one} = $value if defined $value; return $self->{one} // 1; } sub two { my ($self, $value) = @_; $self->{two} = $value if defined $value; return $self->{two} // 2; } # and so on...

    That gets tedious and frustrating, and is prone to mistypes and other mistakes. What I often do in cases such as this, is auto generate these types of subs within a BEGIN block dynamically, using the magical no strict 'refs';, which allows us to muck with the symbol table directly and do very dangerous stuff in ways that one shouldn't normally do. Here's an example module:

    package Dynamic; use warnings; use strict; BEGIN { my %sub_info = ( one => 1, two => 2, three => 3, four => 4, five => 5, ); no strict 'refs'; for (keys %sub_info) { my $sub_name = $_; # Take a copy of the key, which is the sub +name *$_ = sub { my ($self, $value) = @_; $self->{$sub_name} = $value if defined $value; return $self->{$sub_name} // $sub_info{$sub_name}; }; } } sub new { return bless {}, $_[0]; } 1; __END__

    First, we set things up near the top of the file so it's easily visible within a BEGIN block to ensure the code is compiled first. Here's what's happening:

    • %sub_info is a hash that contains each sub name as the key, and the default value we'll return if the user doesn't change it
    • We disable strict's reference checking with no strict 'refs' so that we can perform super-dangerous stuff, like using a string as a symbol reference
    • Iterate over the hash and copy the key name into a separate variable
    • Set the current key name as the name of the new subroutine by prepending an asterisk to signify a symbol table entry, and assign it a new anonymous sub
    • Just like any other method, we put the code in exactly as we would if we were manually writing it out. Note the use of $sub_name instead of using just $_. This is because we've clobbered $_ by assigning a sub to it. This is why we made a copy of it above
    • Done! Looks just like any other setter/getter, but instead of typing out five subs that look near identical, we've only typed it out once, and let Perl write them for us in a loop

    Here's a script that puts the new module into action. Note that both the module and script are in the same directory for this demonstration:

    use warnings; use strict; use feature 'say'; use lib '.'; use Dynamic; my $dyn = Dynamic->new; say "Manual calls"; say $dyn->one; say $dyn->two; # Or even say "Stringified calls"; for (qw(one two three four five)) { if ($_ eq 'three') { # Update the value of the 'three' method $dyn->three(99); } printf "sub $_: %d\n", $dyn->$_(); }


    spek@scelia ~/repos/scripts/perl/dynamically_auto_generate_subs $ perl + Manual calls 1 2 Stringified calls sub one: 1 sub two: 2 sub three: 99 sub four: 4 sub five: 5

    In closing, if you're only doing a couple of subs, it probably isn't worth the hassle, but when you are doing several, it makes things very simple, especially if you need to add new ones in the future. You simply have to enter a new record into the hash.

    Here's the code section that I just wrote that inspired me to write this post. It's from my Hook::Output::Tiny distribution. I am dynamically creating four methods... stdout() and stderr() which effectively do the same thing but act on different things, and their helper counterparts _stdout() and _stderr():

    BEGIN { # Auto generate the stdout() and stderr() methods, and their priva +te # helper counterparts no strict 'refs'; for ('stdout', 'stderr') { my $sub_name = $_; # Public *$_ = sub { my ($self) = @_; if (! wantarray) { warn "Calling $sub_name() in non-list context is depre +cated!\n"; } return defined $self->{$sub_name}{data} ? split /\n/, $self->{$sub_name}{data} : @{[ () ]}; # Empty list }; # Private my $private_sub_name = "_$sub_name"; *$private_sub_name = sub { my ($self) = @_; my $HANDLE = uc $sub_name; open $self->{$sub_name}{handle}, ">&$HANDLE" or die "can't hook " . uc $sub_name . ": $!"; close $HANDLE; open $HANDLE, '>>', \$self->{$sub_name}{data} or die $!; }; } }
    Disclaimer: I'm not joking about hacking at the symbol table directly in ways perl doesn't normally allow being dangerous. It's very easy to clobber stuff far away in your code when you do these things.
Link push/digital signage server+client
No replies — Read more | Post response
by Corion
on Nov 27, 2020 at 09:32

    Sometimes I want to display the same HTML page on multiple devices. Think photo album or something else.

    Sometimes I want to "push" an URL, and then pick it up from a single device.

    This server does both:

    The /set URL is where you can enter the URL, and where you also can find a bookmarklet to send whatever current page to the server.

    The /iframe URL will be used by any client for the digital signage.

    The / URL will directly redirect to the target URL. I use that when I'm watching a stream on one device but want to continue to watch it on another device.

    The repository is at

    use Mojolicious::Lite '-signatures'; use Mojo::JSON 'encode_json'; our $VERSION = '0.01'; our $url; get '/' => sub($c) { return $c->redirect_to($url); }; get '/set' => sub( $c ) { if( my $url = $c->param('url')) { $url = $c->param('url'); warn "Set URL to <$url>"; notify_clients({ src => $url }); }; $c->stash( url => $url ); $c->render( template => 'set'); }; post '/set' => sub($c) { $url = $c->param('url'); $c->stash( url => $url ); warn "Set URL to <$url>"; notify_clients({ src => $url }); }; get '/iframe' => sub( $c ) { $c->stash( url => $url ); $c->render( template => 'iframe'); }; my %clients; my $id = 0; websocket '/cnc' => sub( $c ) { $clients{ $id++ } = $c; $c->on( message => sub( $c, $msg ) { # we don't handle clients talking to us }); }; sub notify_clients( $msg ) { my $str = encode_json( $msg ); for my $id (keys %clients) { eval { $clients{ $id }->send($str); }; if( $@ ) { delete $clients{ $id }; }; }; } app->start; __DATA__ @@ set.html.ep <html> <body> <form method="POST" url="/set"> <label for="url">Enter URL to share:</label> <input id="url" type="text" name="url" placeholder=" +" value="<%= $url %>" /> <input type="submit"/> </form> <a href="javascript:void(new Image().src='<%= $c->url_for('/set')->to_ +abs %>?url='+encodeURIComponent(document.location))">Bookmarklet for +setting a link to the current page</a> </body> </html> @@ iframe.html.ep <!DOCTYPE html> <html> <head> <!-- just in case the ws breaks down --> <meta http-equiv="refresh" content="300; URL=<%= $c->url_for('/iframe' +) %>"> <title>URL receiver</title> <script> let ws_uri = "<%= $c->url_for('/cnc')->to_abs() =~ s!^http!ws!r %>"; window.uplink = new WebSocket(ws_uri); window.uplink.onmessage = (event) => { let target = document.getElementById('iframe'); console.log(; let msg = JSON.parse(; try { target.src = msg.src; } catch(e) { console.log(e); }; }; </script> </head> <body style="margin:0px; padding:0px;"> <iframe id="iframe" style="width: 100%; height: 100%; position: absolu +te; border: none;" frameborder="0" allowfullscreen allow='autoplay' s +rc="<%= $url %>"/> </body> </html>

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 the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others having an uproarious good time at the Monastery: (5)
    As of 2021-04-20 11:29 GMT
    Find Nodes?
      Voting Booth?

      No recent polls found