This isn't really all that cool, but I'm posting it just in case someone might be interested. I'm trying to get back to my QRP transmitter/receiver project and had just wanted to convince myself that Pi attenuators properly reduced to the expected input and output impedance. Rather than do a couple by hand, I went full nerd and wrote code to do it instead.
Essentially, the code lets you create a network of resistors (via the build_impedance() function) and pi_pads (via build_pad()) and attach them together via the named ports. Once you've got the network built, remove all named nodes you don't care about and then tell it to generate the simplified network.
I introduce a Game AI statistics package on GitHub next week, here is some code for it, it was written in Perl6. It uses evolvable distribution populations for the math formulas :
class Population
{
has @.population;
method BUILD() {
.population = <>;
}
method add($x) {
push(.population, $x);
}
}
use Covariance;
role ThisCovariance { method cov($xpop,$ypop) {
return Covariance().Covariance($xpop,$ypop);
}
}
class Correlation does ThisCovariance {
method BUILD() {
}
method correlation($xpop,$ypop) { ### These are distribution a
+rgs
my $varx = $xpop.Variance(), $vary = $ypop.Variance();
my $cov = .cov($xpop, $ypop);
return $cov / (sqrt($varx) * sqrt($vary));
}
}
So I've been doing quite a bit of web development recently, and several of my HTML files use resources from CDNs, like jQuery or normalize.css.
While I'm developing, I refresh pages quite often, and also usually use my browser's development tools to disable caching.
This means that I hit the CDNs quite often, and aside from the speed and bandwidth usage, one of the CDNs actually started rate limiting me... oops.
In other projects, I'd usually just pull those resources onto my local server, keep them there, and be done with it.
But the stuff I'm currently working on is for distribution, so I'd like to keep the CDN URLs in the HTML, and not have to rewrite them by hand.
Enter git filters: Documented in the Git Book Chapter 8.2 and in
gitattributes, they provide a way to pipe source code files through an external program
on checkout, as well as on diff, checkin, and so on. This allows you to have one version of a file checked into the repository, but to
use a filter to make changes to the files that actually end up in the working copy on your machine. These changes are also reversed by the filter
and not checked back into the repository on checkin, and don't show up in any commands like git diff, git status, etc.
So in this case, the files I want to have in the repository will have lines that look something like this:
So, your project is going fine, your codebase is groing fast. But now your have the problem
that some of your processes have to communicate with each other. Maybe, some temperature
sensor needs to report its sensor value every few seconds to the central heating system.
Maybe the central heating system needs to know if the windows are open and close them
before heating the house. Another process wants to count how many times the door has been
opened and log the sum once a minute...
Net::Clacks to the rescue!
The Net::Clacks modules implement a client/server based interprocess messaging. Without going
too much into the internals of the protocol, a client can either send notifications ("event
xy has just happened") or values ("the reading for sensor xy is now 42"). Other clients may (or may not)
choose to listen to those broadcasts.
Net::Clacks also implements Memcached-like value storage and retrieval. So instead of broadcasting,
a value can be stored, read out, incremented, decremented and deleted.
A note on security: Currently, the system only implements a shared-secret type thing (all clients in a clacks network use the same
username/password). This will get changed in the future. I'm planning to make it so that you can override the authentication checks with
your own function and return which permissions the client has. But that is not yet implemented.
Let's do a simple example project: Server, chatclient, chatbot and a clock process to trigger some actions at the start of every minute.
Read more... Click to see the rest of the rather long post (15 kB)
"For me, programming in Perl is like my cooking. The result may not always taste nice, but it's quick, painless and it get's food on the table."
I've been working quite a lot with ZPL compatible label printers (Zebra, TSC) the last few years. When working with complex forms or large graphics, printing can be quite slow, because the printer has to - basically - calculate everything pixel-by-pixel for every single label. Not to mention the fact that the standard ZPL image format is not... well "nice" to work with with standard open source tools.
ZPL has a way to store a rendered label, which it can reuse later quite a bit faster (in most cases). Basically, you load in the saved, pre-rendered label and then add you dynamic content.
Here is the Perl script to convert a PNG file to ZPL, including the "save" command. E.g. this generates the ZPL file to pre-render the image and save it to the printers flash memory.
#!/usr/bin/env perl
use strict;
use warnings;
use GD;
use Data::Dumper;
my $xoffs = 20;
my $yoffs = 20;
my $minwhite = 200;
my $verbose = 0;
my $image = GD::Image->new('examplelogo.png');
my $w = $image->width();
my $h = $image->height();
print "Image size: $w x $h\n";
open(my $ofh, '>', 'savelogo.zpl') or die($!);
# Start of form;
print $ofh "^XA\n";
for(my $x = 0; $x < $w; $x++) {
for(my $y = 0; $y < $h; $y++) {
my $index = $image->getPixel($x,$y);
my ($r,$g,$b) = $image->rgb($index);
if($r < $minwhite) {
print "#" if $verbose;
print $ofh '^FO' , ($x*1) + $xoffs, ',' , ($y*1) + $yoffs,
+ '^GB1,1,1,B,0^FS', "\n";
} else {
print " " if $verbose;
}
}
print "\n" if $verbose;
}
# Save graphic to flash mem
print $ofh "^ISR:LOGO.GRF,Y\n";
# End of form
print $ofh "^XZ\n";
close $ofh;
$xoffs and $yoffs change the upper left starting point where the image is drawn and $minwhite sets the threshold of what is considered a white vs. black pixel. This generates ZPL code like this (abbreviated), setting one pixel black per line:
Of course, this can trivially be used for dynamic content. But i leave it to the reader to figure out how to load label.zpl, replace XXCAPTIONXX with an increasing number, saving it to tmp.zpl and calling lpr...
You also can get the whole example (including a badly made example png) with Mercurial SCM:
In addition to Perl and PDL, one of my favourite topics is cryptography, specifically cryptanalysis.
One 'common' cryptanalytical attack, for which modern ciphers are designed against is differential cryptanalysis. Some older ciphers are vulnerable to this attack and various tutorials exist to teach differential cryptanalysis. One of these is by Jon King against the FEAL cipher and is located here.
One aspect of the differential cryptanalysis attack is to enumerate all potential differentials against the non-linear round function. The below code performs this analysis against the FEAL-4 cipher's round sub-function 'G'. It successfully identifies the two fixed input differentials.
Enjoy!
#!/usr/bin/env perl
use 5.020;
use warnings;
use autodie;
use PDL;
use PDL::NiceSlice;
# This code attempts to find all differential characteristics in the
# FEAL-4 cipher round subfunction 'G'.
#
# Reference: http://theamazingking.com/crypto-feal.php
#
#
# 'G' function is addition of a, b and x, then bitwise rotate left
# by 2 bits
# a, b, x and the final value are all 8 bits.
# For our purposes, x can be ignored, as it's constant 0 or 1
#
# a
# |
# x -> [+] <- b
# |
# [<<<]
# |
# OUT
#
# Perform addition
my $G = sequence( byte, 256 ) + sequence( byte, 256 )->transpose;
# Bitwise rotation
$G = ( $G << 2 ) | ( $G >> 6 );
# At this point, $G contains all possible inputs for a and b, and
# the associated output value
#
# Now we wish to find all differentials throughout this function
#
# To do this, we need to find differentials between each possible
# inputs to 'a', and 'b' and observe the differential in the result
#
# There are two known differentials for this function. A differential
# value of 0 and 0x80 (128) for 'a' will always return a constant
# differential output (0 and 2) respectively.
# Calculate the differential table
my $diffs = $G ^ $G ( (0) );
# Find the minimum and maximum value for each differential
my ( $min, $max ) = minmaxover($diffs);
# Print index of differentials where minimum and maximum value are
# equal. As the index is also in the input value, this returns the
# actual differential:
print "Contant differentials for input differentials of: ",
which( $min == $max ), "\n";
Sparrowdo is a universal task runner and CM tool written on Perl6/Perl5. It enables configuration and automation tasks with efficient and simple way.
I have created a fresh post on dev.to introducing Sparrowdo automation for Windows OS. Everyone is interested in Windows automation by Perl5/Perl6 are welcome to read.
This is so small compared to the rest of the posts here in CUFP, I hesitated for a while before deciding to submit anyway:
package cache {
# no particular reason to use them,
# but the syntax sugar is *so* sweet
use experimental 'signatures';
use base 'Storable';
my %paths;
sub new($class,$path) {
my $self = eval { return Storable::retrieve($path) }
|| bless {}, $class;
$paths{$self} = $path;
return $self;
}
sub DESTROY($self) {
$self->store($paths{$self});
}
}
create the object as you usually would: my $cache = cache::->new("store.db");
anywhere you might find it useful to cache results in a hash between runs of a function, use defined-or assignment to retrieve the value if it's already cached: my $val = $cache->{$argument} //= func($argument);
next time you run the script again the cached values are still there, no need to recalculate
The class uses inside-out objects so you could use objects as ordinary hashes with no reserved fields. This will get slower the bigger your cache gets because there is no RLU eviction, everything is stored in memory and the whole store has to be loaded from disk on startup and serialised on shutdown. Still, for small scripts I find it useful.
Here's a bit of random nonsense. Create a random number of lines with a random number of random words from a dictionary. Repeated words are acceptable.
I recently published a beta of WebPerl, and now I've written my first full web app with it: a browser-based regex tester.
Since WebPerl is a full build of Perl, you have the full power of core Perl at your disposal, and it runs entirely in the browser - unlike some other online regex testers, which either run perl on a server, or only support PCRE (Perl Compatible Regular Expressions). It should work in modern browsers like Firefox and Chrome (not tested in IE yet, it might have issues there). Try it out, and let me know what you think, and report any issues you might find. I'd also be happy to accept issues and patches on GitHub. Please consider it a beta.
http://webperl.zero-g.net/regex.html
(It may take a few seconds to load and initialize, WebPerl is currently a ~4MB download, but once it's in your cache it should be fine.)
You can even create URLs to examples, here I'll use that to show off some features:
A basic example, showing the match highlighting and some generated Perl code that a user can easily copy and try out. Also try clicking the use re "debug"; button for debug output.
Hi, another Perl/Tk app. :-) Any comments or improvements welcome. The details are at the top of the script. Basically, this tutor forces you to use your ear to recognize letters, forcing the brain to make a direct auditory connection to the letter. It also demonstrates how to make PCM tones of any frequency and duration without the obsolete /dev/dsp.
Type::Tiny is probably best known as a way of having Moose-like type constraints in Moo, but it can be used for so much more. This is the fifth in a series of posts showing other things you can use Type::Tiny for. This article along with the earlier ones in the series can be found on my blog and in the Cool Uses for Perl section of PerlMonks.
It's pretty common to do things like this:
use Types::Standard qw( is_ArrayRef is_HashRef );
use Carp qw( croak );
sub process_data {
my ($self, $data) = @_;
if (is_ArrayRef($data)) {
$self->_process_value($_) for @$data;
}
elsif (is_HashRef($data)) {
$self->_process_value($_) for values %$data;
}
else {
croak "Could not grok data";
}
}
Type::Utils provides a perhaps slightly neater way to do this:
use Types::Standard qw( ArrayRef HashRef Any );
use Type::Utils qw( match_on_type );
use Carp qw( croak );
sub process_data {
my ($self, $data) = @_;
match_on_type $data,
ArrayRef, sub { $self->_process_value($_) for @$data },
HashRef, sub { $self->_process_value($_) for values %$data }
+,
Any, sub { croak "Could not grok data" };
}
The match_on_type function takes a value and a set of type–coderef pairs, dispatching to the first coderef where the value matches the type constraint. This function is stolen from Moose::Util::TypeConstraints.
You can get an order of magnitude faster though by doing something similar to what Type::Params does — compiling the match once, then calling it as needed.
Let's look at a naïve (and wrong) way to do this first and examine the problems:
use Types::Standard qw( ArrayRef HashRef Any );
use Type::Utils qw( compile_match_on_type );
use Carp qw( croak );
sub process_data {
my ($self, $data) = @_;
state $matcher = compile_match_on_type
ArrayRef, sub { $self->_process_value($_) for @$data },
HashRef, sub { $self->_process_value($_) for values %$data }
+,
Any, sub { croak "Could not grok data" };
$matcher->($data);
}
The big problem here is that the first time process_data is called, the matcher will close over$self and $data. Subsequent calls to $matcher will reuse the same closed over variables. Oops.
The simplest way of solving this is to take advantage of the fact that a compiled matcher (unlike match_on_type) can take a list of arguments, not just one. Only the first argument is used for the type matching, but all arguments are passed to the coderefs on dispatch.
use Types::Standard qw( ArrayRef HashRef Any );
use Type::Utils qw( compile_match_on_type );
use Carp qw( croak );
sub process_data {
my ($self, $data) = @_;
state $matcher = compile_match_on_type
ArrayRef, sub { my ($d, $s) = @_; $s->_process_value($_) for
+@$d },
HashRef, sub { my ($d, $s) = @_; $s->_process_value($_) for
+values %$d },
Any, sub { croak "Could not grok data" };
$matcher->($data, $self);
}
Like many Type::Tiny interfaces that expect coderefs, compile_match_on_type also accepts strings of Perl code as an alternative, and is able to optimize things better if those are supplied:
use Types::Standard qw( ArrayRef HashRef Any );
use Type::Utils qw( compile_match_on_type );
use Carp qw();
sub process_data {
my ($self, $data) = @_;
state $matcher = compile_match_on_type
ArrayRef, q{ my ($d, $s) = @_; $s->_process_value($_) for @$d
+ },
HashRef, q{ my ($d, $s) = @_; $s->_process_value($_) for val
+ues %$d },
Any, q{ Carp::croak("Could not grok data") };
$matcher->($data, $self);
}
If this could be done in a 'better' way, I'd enjoy hearing it. Criticisms welcome.
Recently needed to basically cache the output of almost every class method in one of my modules that is part of a web app. Every method runs a different database query and encodes the results to JSON. The results change daily, so upstream of the module implementation there is logic that enforces a 12 hour TTL for anything any method returns. In the interim time though, there's no reason for the app to run these database queries at all when it already did the work. Reading about possible approaches to the problem on stack overflow yesterday I saw that use of autoload was discouraged, so this is what I came up with and as far as I can tell, after running two days in DEV, it appears to have no issues. I'm actually quite pleased, because this approach allowed me to be 'clever' without an implementation that is unmaintainable and unintelligible by others...
Gist here
use strict;
use warnings;
package My::Class::Proxy; # Drop-in replacement for 'Some Class'
# Proxies all public method calls to Some::Class in order to provide s
+mart
# caching and memoization, e.g.- avoiding expensive DB queries when no
+t required
use 5.020;
use Moose;
extends 'Some::Class';
use Moose::Util qw();
my $meta = Moose::Util::find_meta( 'Some::Class' );
my @nocache = qw( new meta DESTROY AUTOLOAD );
state $outputs = {};
for my $method ( $meta->get_method_list )
{
# don't memo-ize blaclisted or private methods
next if ( grep { $_ eq $method } @nocache or $method =~ /^_/ );
around $method => sub
{
my ( $orig, $self, $refresh, @args ) = @_;
$outputs = {} if !!$refresh;
@args = map { $_ // '' } @args;
my $call_key = join '', $orig, @args;
return $outputs->{ $call_key } if defined $outputs->{ $call_key
+};
$outputs->{ $call_key } = $self->$orig( @args );
return $outputs->{ $call_key };
};
}
# Moose-specific optimization
__PACKAGE__->meta->make_immutable();
1;
I've been fighting with Net::SSH2 trying to get it to do simple stuff -- in particular all I needed was for it to be ablet execute commands on the server. I've gotten it all working {the biggest hangup was that, apparently, password auth doesn't work in Net::SSH2 and switching to public_key make things magically work}. Here's the skeleton of a little program that'll execute shell commands:
#!/usr/bin/perl
# run shell commands remotely over an SSH connection
use strict;
use warnings ;
use Net::SSH2 ;
use constant HOST => "YOURHOST" ;
use constant USER => "YOURLOGIN" ;
use constant HOSTKEY => "Path to your known_hosts keys file" ;
## To enable the public key login, append your 'pub' key file to the
## authorized_keys file in ~/.ssh on the server
use constant PUBLICKEY => "Path to your public key" ;
use constant PRIVATEKEY => "path to your private key" ;
# Set up the SSH connection
my $ssh2 = Net::SSH2->new() ;
$ssh2->connect(HOST) or $ssh2->die_with_error ;
$ssh2->check_hostkey(tofu => HOSTKEY)
or $ssh2->die_with_error ;
$ssh2->auth_publickey(USER, PUBLICKEY, PRIVATEKEY)
or $ssh2->die_with_error ;
$ssh2->auth_ok() ;
# Logged in -- now you can execute commands
print docmd("cd bin; ls") ;
$ssh2->disconnect() ;
exit ;
# do the command and return the output
## NB: you can only do one command on a channel so we get a channel
## do the command, collect the output and close the channel
## The command must be a fully "punctuated and escaped" shell comman
+d.
sub docmd
{ my $chan = $ssh2->channel() or $ssh2->die_with_error ;
$chan->exec("($_[0]) 2>&1") ;
my $out = "";
while (!$chan->eof)
{ my $buffer = "";
if (not defined ($chan->read($buffer, 100)))
{ $ssh2->die_with_error() ; }
$out .= $buffer ;
}
return $out ;
}
