Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

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.

CUFP's
Dynamic DNS for your GoDaddy domains
No replies — Read more | Post response
by stevieb
on May 17, 2022 at 14:26

    With its API, GoDaddy makes it easy to do dynamic DNS updates for your domain's hostnames. I made it easy to do with Perl with Net::DynDNS::GoDaddy (which uses my new Addr::MyIP to get your current external IP address). I'll give an example, then an example use of the distribution's packaged binary script.

    use Addr::MyIP; use Net::DynDNS::GoDaddy; my $hostname = 'home'; my $domain = 'example.com'; my $current_host_ip = host_ip_get($hostname, $domain); my $my_ip = myip(); if ($current_host_ip ne $my_ip) { host_ip_set($host, $domain, $my_ip); }

    Simple. The library requires a godaddy_api.json file in your home directory (MacOS, Unix or Windows, the software has 100% test coverage on all systems) that looks like this:

    { "api_key" : "api_key", "api_secret" : "api_secret" }

    Using the binary we'll install when you install the library, it will prompt you for this information on its initial run:

    > update-ip home example.com Please enter your GoDaddy API key and hit ENTER: ...api_key... Please enter your GoDaddy API secret and hit ENTER: ..api_secret... Updated record for 'home.example.com' from x.x.x.x to x.x.x.x

    ...after the initial run, it won't prompt anymore:

    > update-ip home example.com Not updating the 'home.example.com' record, IPs are the same

    You can specify the IP if you don't want to use your current public-facing one we automatically get for you:

    > update-ip home example.com 10.7.10.2

    The most useful use for me is to have multiple hostnames ('home', 'office', 'roaming' etc) and just run the program through cron:

    # Home storage server */15 * * * * update-ip home example.com >> /tmp/update-home_cron.log 2 +>&1

    My laptop:

    */15 * * * * update-ip roaming example.com >> /tmp/update-roaming_cron +.log 2>&1

    Usage:

    Usage: update-ip host domain.name [ip.addr]

    Have fun!

    -stevieb

IndexedFaceSet to 3D lines in two lines of PDL
1 direct reply — Read more / Contribute
by etj
on Apr 17, 2022 at 17:12
    I was digging through some bit-rotted PDL::Graphics::TriD stuff to finish/fix it, and looked at PDL::Graphics::TriD::Logo. It was intended to be used with the non-functional-right-now PDL VRML support, in particular VRML's IndexedFaceSet feature. It had 3D point coordinates, then triplets of indexes into those to describe triangles.

    Gripped - nay, seized - by a desire to see what the logo looked like, I needed to turn that into something the current TriD code can show me. I knew line3d could take a set of 4-point tuples to draw triangles if the 4th point was the same as the 1st. But how to turn points+indexes into that?

    I often say that in PDL, the "right" solution to problems involves slices and dimension-mangling. This was no exception!

    use PDL::Graphics::TriD; use PDL::Graphics::TriD::Logo; $p = $PDL::Graphics::TriD::Logo::POINTS; # dims: xyz, i $i = $PDL::Graphics::TriD::Logo::FACES; # dims: i1to3, ntriangles # 1: duplicate 0-th index onto end of each vector completing triangle $i = $i->append($i->slice('0')); # change to i1to3to1 # 2: flatten indices, slice points with those, restore 4-tuples shape $tri = $p->slice(':',$i->clump(-1))->splitdim(1,$i->dim(0)); line3d($tri); # visualise
    Coda: the logo is just "PDL" in a serif font, given "depth" as if in a stick of rock.

    I'm intending to update the VRML support to:

    1. generalise that plus the OpenGL support of each specific thing (lines, points, etc) to go via an intermediate description to make this easy;
    2. work at all;
    3. switch it to use X3D;
    4. use that to generate updated 3d demos for the PDL website.
    If anyone wants to help, please say so!
Running user-provided JavaScript code
2 direct replies — Read more / Contribute
by cavac
on Apr 11, 2022 at 11:31

    Sometimes you have to allow the end user to provide some (server side) program code, but you don't want them to allow system access. This could be anything, from custom formatting stuff, smart contracts, whatever. The solution is usually a sandbox. Now, Perl itself is a little to powerful and flexible to allow you to do that somewhat safely, but you can use something like the Duktape javascript engine.

    In our case, let's take a look at JavaScript::Duktape. One thing i wanted to implement is "simulated persistance", meaning the JavaScript would be coded as if it is kept in memory, yet the perl program can unload and load it whenever needed. For this, we will define a "memory" object, which the JavaScript can use to keep data in memory.

    Our Javascript program looks like this:

    function initMemory() { memory.counter = 0; } function incCounter(amount) { memory.counter = memory.counter + amount; } function printCounter() { log("Current count is " + memory.counter); }

    To test this, let's write a small test program that uses PageCamel::Helpers::JavaScript. Don't worry about the "PageCamel" part, it's just a helper function in my framework and i didn't have the time to pull it out into a standalone thing. It's pretty much self contained though, code included in this post. Because the PageCamel framework requires a ReportingHandler, for simplicity reasons out test program will just bring it's own.

    perl -e 'use Crypt::Digest::SHA256 qw[sha256_hex]; print substr(sha256_hex("the Answer To Life, The Universe And Everything"), 6, 2), "\n";'
Making a reloadable module, allowing "live" edits
3 direct replies — Read more / Contribute
by pryrt
on Apr 09, 2022 at 18:44
    I was recently watching this youtube video on a simple PID controller implemented in Python (it was in a watchlist of math-related videos, though his PID was more math-adjacent than math-focused). But instead of focusing on the controller algorithm, I was intrigued by his demo environment, where he was able to update his python code live, and have the demo program automatically incorporate the changes immediately, without reloading the demo program.

    I followed his link to the repo for his demo, where he explains his reloadable.py module and how that portion works.

    "That should be doable in Perl," said I. "And I might even be able to do it." And indeed, after some effort, I could.

    He basically used a class variable to store the state of the module-under-development ("mod"), then used a loop in his demo program that every loop would check the timestamp on the mod's file, and if it was newer, he would store the state, then reload the mod and return a new instance of the mod object initialized to the stored state.

    In my example, which I will replicate in the spoiler, I did something similar, but I just stored the state in the instance of my reloadable object, and had the loop read the state from there and pass it as an option when creating the instance from the reloaded package. (My implementation isn't clean enough for CPAN or anything like that, but as toy, I thought it was a pretty cool usage of Perl, and is good enough for a proof-of-concept.)

    The funny thing is, a few days after I implemented it, as I was finishing up debug of something or other, where I was reloading my program quite frequently, I realized just as I was finishing up, "that would have been a perfect time to use Reloadoadable. DOH!".

    If this has piqued your interest, I would love to see, and learn from, how some of the other monks would implement this. You don't have to use the sine calculator as your example; I just thought it was a simple enough example for the proof of concept. If you wanted to do all the graphics to replicate his PID ship controller instead, by all means... ;-)

XPD - Do more with your PerlMonks XP
5 direct replies — Read more / Contribute
by cavac
on Apr 04, 2022 at 15:37

    As some of you know, i have been playing around with the PerlMonks API to create my own fake internet money. Basically, it's a way to play around with NFT without actually wasting money on that stuff.

    Presenting: XPD

    XPD is the Perlmonks XP Derivative. It's sort of fake monopoly money for PerlMonks. Currently, it supports sending XPD between registered accounts, creating NFT and selling them on the market for a fixed price.

    Edit: If you encounter a bug, post a reply to this post. I have fixed some bugs already, but there are probably more of them around.

    Here is the link: https://cav.ac

    FAQ:

    Is is real (crypto) currency?
    Nope. This is just a play thing for PerlMonks. Just as PM XP, it has no monetary value. But it's fun.

    Is it blockchain?
    Nope. Blockchains are slow and cumbersome. I use the age old model of central banking. E.g. it's a PostgreSQL database.

    Is it a crypto currency?
    Nope. I mean, i could add checksums and stuff, but what's the point? If you want to make sure i don't mess around, there is a public ledger will all transactions available. You could copy the data. It's currently a bit cumbersome, public API coming soon.

    How do i earn XPD. Mining? Proof of Work?
    Nope. XPD uses Proof of Monk.

    Proof of Monk?????
    XPD is linked to your account on PerlMonks. Be a nice person and help others on PM. This will earn you XP. And earned XP is added to your XPD account. Be naughty and loose XP, and XPD will be deducted.

    How do i register an account?
    Go to https://cav.ac/user/register. You will need a PM account with at least 500 XP, at least 30 posts and a XP-per-post average of at least 4. Fill in the form. Use a password you don't use anywhere else. If you have a password manager that can generate unique random passwords, use that. You username must match your PerlMonks username exactly, because that's how you earn XPD. For validation, you will also temporarily need to add a randomly generated text to your PM homenode.

    How often is generated XP added to my XPD account?
    It's currently set at 72 hour. But, on account creation all XP you already have is added to your XPD account within a minute or so.

    How long does it take to send XPD to another user?
    You select the username and amount, then click "Send". Then the backend checks if have the required funds in your account, does a database insert and it's done. Depending on the other workloads, takes a few seconds usually.

    How does NFT work?
    It's PNG files, 128x128 pixels. It costs 1 XPD to create one NFT.

    How long does it take to create an NFT?
    Similar to sending XPD to someone. You select the PNG file, fill in title and description and hit upload. Then the backend checks (asynchronously) if your file is valid and that you have the required 1 XPD in your account, does a database insert and it's done. Depending on the other workloads, takes a few seconds usually.

    Transaction fees?
    Huh? Why would i charge fees for doing a few database statements that take a few milliseconds. No, the only thing that "costs" a fee is NFT creation. Mostly because i want you lot not completely filling my ancient server with PNG files within the first 24 hours.

    API?
    Uhm, yes, coming soon. It's currently missing a few features, like the ability to not crash the server on every other call.

    Selling NFT via an auction?
    Not yet. The backend if half finished, should be online in a few days.

    Smart contracts? Scripting?
    That's in the late design phase. Pretty much anything you can do in the web interface, you will be able to do in the scripting engine. Plus some. You'll be able to buy and sell NFTs, send XPD to someone, bid on an auction, implement a piggy bank, run a Ponzi scheme(*), ...

    (*) It's not real money, XPD is a fun learning experience. If you know how to implement an automated Ponzi scheme, go for it.

    perl -e 'use Crypt::Digest::SHA256 qw[sha256_hex]; print substr(sha256_hex("the Answer To Life, The Universe And Everything"), 6, 2), "\n";'
Shameless plug and QR japh
2 direct replies — Read more / Contribute
by bliako
on Mar 15, 2022 at 11:29

    My pride for Image::DecodeQR::WeChat I have just submitted on CPAN inspired
    this blitz-style QR japh. Lame as it may be, enjoy.

    Said module is my first to use XS and a significant milestone for
    me as I have managed finally to port OpenCV API into Perl.

    It's been adjusted for PM's rendering particularities and hopefully copy+pasting
    the text from the Download link will produce the correct output.
    Tested on a Linux unicode-enabled terminal. If there is no download link for below code
    then click on Download code below
    https://perlmonks.org/?node_id=11142119;displaytype=displaycode

    If anyone has suggestions on how to fix this monstrosity
    between code tags let me know
    (edit: pre tags shows the unicode but breaks other things).
    Apropos the QR-code below: ideally I would just use the black brick
    and a white space but unfortunately whatever i do the space gets shrinked
    i tried various unicode spaces but nothing worked, they all got shrinked
    below I am using a thin horizontal line as space which will most likely
    confuse the decoder.

    ██████████████▁▁▁▁▁▁██▁▁▁▁▁▁██████▁▁██████████████
    ██▁▁▁▁▁▁▁▁▁▁██▁▁██████▁▁▁▁▁▁▁▁████▁▁██▁▁▁▁▁▁▁▁▁▁██
    ██▁▁██████▁▁██▁▁██▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁██▁▁██████▁▁██
    ██▁▁██████▁▁██▁▁▁▁██▁▁▁▁██▁▁██▁▁▁▁▁▁██▁▁██████▁▁██
    ██▁▁██████▁▁██▁▁██████▁▁██▁▁██████▁▁██▁▁██████▁▁██
    ██▁▁▁▁▁▁▁▁▁▁██▁▁██▁▁██▁▁████████▁▁▁▁██▁▁▁▁▁▁▁▁▁▁██
    ██████████████▁▁██▁▁██▁▁██▁▁██▁▁██▁▁██████████████
    ▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁██▁▁████▁▁▁▁▁▁▁▁██▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁
    ████▁▁██▁▁▁▁████▁▁▁▁▁▁████████▁▁▁▁▁▁██████▁▁████▁▁
    ████▁▁██████▁▁██████▁▁██████▁▁▁▁██████▁▁▁▁██▁▁▁▁██
    ▁▁▁▁▁▁▁▁▁▁▁▁██████▁▁▁▁████████▁▁██▁▁▁▁████████████
    ▁▁▁▁▁▁▁▁██▁▁▁▁██████████████▁▁████▁▁▁▁▁▁██▁▁▁▁██▁▁
    ▁▁▁▁████▁▁████████▁▁████▁▁██▁▁▁▁████████▁▁██▁▁████
    ▁▁▁▁████████▁▁██▁▁██▁▁██▁▁▁▁▁▁▁▁▁▁██████▁▁▁▁██▁▁██
    ██▁▁██▁▁██▁▁██▁▁████▁▁██▁▁██▁▁▁▁██▁▁██████▁▁██▁▁██
    ▁▁██▁▁▁▁▁▁▁▁▁▁▁▁▁▁██████▁▁██████▁▁▁▁▁▁▁▁████▁▁████
    ████▁▁██▁▁████▁▁██▁▁██▁▁██▁▁▁▁▁▁██████████▁▁██▁▁▁▁
    ▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁▁██████▁▁██▁▁██▁▁██▁▁▁▁▁▁████▁▁▁▁▁▁
    ██████████████▁▁████▁▁████████▁▁██▁▁██▁▁██▁▁██████
    ██▁▁▁▁▁▁▁▁▁▁██▁▁▁▁████▁▁██▁▁██▁▁██▁▁▁▁▁▁██▁▁████▁▁
    ██▁▁██████▁▁██▁▁▁▁████▁▁██████▁▁██████████▁▁▁▁██▁▁
    ██▁▁██████▁▁██▁▁██▁▁▁▁██▁▁██▁▁██▁▁▁▁▁▁██████▁▁▁▁▁▁
    ██▁▁██████▁▁██▁▁▁▁▁▁▁▁▁▁████▁▁▁▁▁▁██▁▁▁▁████▁▁▁▁██
    ██▁▁▁▁▁▁▁▁▁▁██▁▁██▁▁▁▁██▁▁██▁▁████▁▁▁▁██▁▁▁▁▁▁▁▁▁▁
    ██████████████▁▁████▁▁▁▁▁▁██▁▁▁▁██▁▁▁▁██▁▁▁▁▁▁████

    here is the more readable japh (Above I am "shaping" perl script as a QR code):

    use Text::QRCode; use utf8; binmode(STDOUT, ':encoding(utf8)'); binmode(STDERR, ':encoding(utf8)'); my @a = map { [split//,$_] } split(" ", "anopheles cog, true archon of + junk"); print join "\n", map { y/* /\x{2588}\x{2591}/; $_ } map { join undef, map { $_.$_ } @$_ } @{Text::QRCode->new()->plo +t( join "", map { join("",@$_) =~ m([^^>>]*(.)(.)(.)[<<^^]?(oO(iouuuu))?) and join "", map { ($1+$3==4-$2) ? " " : (42%11-$2==$1+$3) ? uc : +lc } ($a[$2]->[$3]) } map { [m$[950618371>>!42!<<173861059]$g] } "45022250852010350010130232073310513122060312323150640053370 +0710353123331" =~ m$x?.y?.z?.[wrong]?$g )} ;

    bw, bliako

MCE::Channels 1.878 adds fast channel implementations
No replies — Read more | Post response
by marioroy
on Feb 21, 2022 at 08:02

    Greetings,

    MCE::Channels has been there for some time. But missing were fast implementations without involving serialization i.e. non-Unicode strings. For implementations that involve serialization, MCE::Channel uses Sereal::Encoder and Sereal::Decoder if available. Otherwise, defaults to Storable for handling serialization.

    How this came about is that someone wrote me and asked what does MCE provide for low-latency IPC communication. I replied nothing because involving serialization. So I took the existing implementations and removed the bits involving serialization, added Fast suffix to the name, and added corresponding test files.

    I have been wanting to compare them all. Folks are not likely to notice a difference between a second or two for a long running application.

    Below, channel implementations Threads and Mutex involve locking and serialization. ThreadsFast and MutexFast are similar but without serialization i.e. non-Unicode strings only. The Simple implementations lack locking supporting one worker on either end of the channel.

    Threads

    use strict; use warnings; use threads; use MCE::Channel; #my $chnl = MCE::Channel->new(impl => "ThreadsFast"); # 1.734s none #my $chnl = MCE::Channel->new(impl => "Threads"); # 2.247s Sereal # 3.232s Storab +le my $chnl = MCE::Channel->new(impl => "SimpleFast"); # 0.965s none #my $chnl = MCE::Channel->new(impl => "Simple"); # 1.940s Sereal # 3.305s Storab +le my $size = 1_000_000; my $thrd = threads->create(sub { my $ret; $ret = $chnl->recv() for 1..$size; }); $chnl->send("this is something $_") for 1..$size; $thrd->join();

    Child process

    use strict; use warnings; use MCE::Child; use MCE::Channel; #my $chnl = MCE::Channel->new(impl => "MutexFast"); # 3.552s none #my $chnl = MCE::Channel->new(impl => "Mutex"); # 4.025s Sereal # 4.815s Storab +le my $chnl = MCE::Channel->new(impl => "SimpleFast"); # 0.949s none #my $chnl = MCE::Channel->new(impl => "Simple"); # 1.644s Sereal # 3.286s Storab +le my $size = 1_000_000; my $proc = MCE::Child->create(sub { my $ret; $ret = $chnl->recv() for 1..$size; }); $chnl->send("this is something $_") for 1..$size; $proc->join();

    Pretty much everything in MCE involves serialization. That is numbers remain numbers and not converted to a string. Likewise, Unicode strings and data structures are preserved as well. The fast channel implementations fill a void when serialization is not required.

    Okay, this is nothing major. But I needed to let folks know.

Hex numbers (e.g. memory addresses) pseudonymising for comparable logging output
3 direct replies — Read more / Contribute
by etj
on Feb 18, 2022 at 07:23
    PDL has a debug mode which tells you in some detail what it's doing, including giving memory addresses (the joy of working in C). I'm currently tracking down the underlying cause of https://github.com/PDLPorters/pdl/issues/356, and have narrowed it down to a small repro case where a command-line switch makes it either croak, or not. Either mode produces several hundred lines of debug output. Diffing the two cases is useless because the addresses get randomised by https://en.wikipedia.org/wiki/Address_space_layout_randomization. If only there were a tool that could consistently pseudonymise those addresses so they get replaced by ADDR1 for the first one, etc, for easier diffing.

    Perl to the rescue!

    #!/usr/bin/env perl # address-pseudonymise [file] or read STDIN use strict; use warnings; my (%addr2number, $i); while (<>) { s:^==\d+==:==[PID]==:; # if you used valgrind, replace process ID s:0x([0-9a-f]+): '[ADDR'.($addr2number{$1} //= ++$i).']' :gie; print; }
A Word Game (Update 3)
6 direct replies — Read more / Contribute
by jwkrahn
on Feb 09, 2022 at 00:09

    Yes I play this game every day on the web. I just wanted to see if I could do it.

    There are probably still bugs!

    Tested with xterm on Debian.

    If this is a copyright violation please remove it.

    Update

    I think I've fixed the bugs pointed out by toolic. Let me know if you find any more.

    Update number 2

    I think that this now works correctly, but if you find any bugs please let me know. TIA

    Update number 3

    Thanks to toolic and wazoox for helping to find bugs. I hope that this fix is the last.     :)

    #!/usr/bin/perl use warnings; use strict; use Term::ANSIColor ':constants'; my $clear = `clear`; my $reset = RESET; my $white_on_red = BRIGHT_WHITE . ON_RED; my $white_on_green = BRIGHT_WHITE . ON_GREEN; my $white_on_yellow = BRIGHT_WHITE . ON_YELLOW; my $white_on_gray = BRIGHT_WHITE . ON_BRIGHT_BLACK; my $divider = " --- --- --- --- ---\n"; my $kb = <<KB; Q W E R T Y U I O P A S D F G H J K L Z X C V B N M KB my @lines = ( [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], ); my $curr_line = 0; my %dict; { open my $FH, '<', '/usr/share/dict/words' or die "Cannot open '/us +r/share/dict/words' because: $!"; @dict{ map uc, grep /[aeiou]|.y./, map /^([a-z]{5})$/, <$FH> } = ( +); } my $curr_word = ( keys %dict )[ rand keys %dict ]; { local $| = 1; print $clear, " ${white_on_gray}Letter not used.$reset\n", " ${white_on_yellow}Letter is used.$reset\n", " ${white_on_green}Letter in correct place.$reset\n", " ${white_on_red}Not a valid word.$reset\n", "\n", map( { my $line = $_; $divider, ' ', map( " |$_|", @{ $lines[ +$line ] } ), "\n", $divider } 0 .. $#lines ), "\n\n", $kb, "\n"; if ( $curr_line == @lines ) { #print "\L$curr_word\n"; last; } print 'Enter five letter word: '; my ( $word ) = map uc, <STDIN> =~ /^([a-zA-Z]{5})/; my @letters = split //, $word; @letters == 5 or redo; # Not a valid five letter word unless ( exists $dict{ $word } ) { $lines[ $curr_line ] = [ map "$white_on_red $_ $reset", @lette +rs ]; redo; } # The correct answer if ( $word eq $curr_word ) { $lines[ $curr_line ] = [ map "$white_on_green $_ $reset", @let +ters ]; for my $letter ( @letters ) { $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_ +on_green $letter $reset/; } $curr_line = @lines; redo; } # Default; all letters to white on gray $lines[ $curr_line ] = [ map "$white_on_gray $_ $reset", @letters +]; for my $letter ( @letters ) { $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_on_g +ray $letter $reset/; } # Find exact matches my @found = ( 0 ) x 5; my $xor_word = $word ^ $curr_word; while ( $xor_word =~ /\0/g ) { $found[ $-[ 0 ] ] = 1; my $letter = $letters[ $-[ 0 ] ]; $lines[ $curr_line ][ $-[ 0 ] ] = "$white_on_green $letter $re +set"; $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_on_g +reen $letter $reset/; } my $curr_remains = join '', ( split //, $curr_word )[ grep !$found +[ $_ ], 0 .. $#found ]; # Find other correct letters for my $index ( 0 .. $#letters ) { next if $found[ $index ]; my $letter = $letters[ $index ]; if ( $curr_remains =~ s/$letter/ / ) { $lines[ $curr_line ][ $index ] = "$white_on_yellow $letter + $reset"; $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_ +on_yellow $letter $reset/; } } ++$curr_line; redo; }
Perl Tk Amateur Radio Contest Duplicate Contact Checker
1 direct reply — Read more / Contribute
by jmlynesjr
on Feb 03, 2022 at 20:48

    Yet another Perl Tk example

    I recently worked the Amateur Radio Winter Field Day Contest. In these contests, a station may only be worked for credit once per band (and mode if you want to get picky). This requires that some method of duplicate checking be used. As a low power station, 50 contacts over a weekend would be an accomplishment. I log on paper(and later enter the contacts into my Perl based logging program for upload to QRZ.COM and LoTW) so up to a page of contacts can be visually dupe checked. Over a page it gets tedious.

    So, after the contest, I thought about what I could do to be better prepared for the next contest.

    I have played with wxPerl in the past but I've never used Tk. So why not try building a Tk application? Posted below is the result. It's somewhat brut force, and I need to explore frames and -pack options in the future. Performance is good to at least 100 entries.

    (Aside: I am aware of using a hash for duplicate checking, but I decided to go a different route.)

    James

    There's never enough time to do it right, but always enough time to do it over...

Shell and Perl searching logs for Log4Shell
2 direct replies — Read more / Contribute
by reisinge
on Dec 23, 2021 at 07:21

    In a blog post I show how I use Perl (among other tools) to find indicators of compromise related to Log4Shell.

    Always rewrite your code from scratch, prefefably twice. -- Tom Christiansen
Announcing WWW::KeePassHttp
No replies — Read more | Post response
by pryrt
on Nov 17, 2021 at 09:53

    Some years ago, I saw and bookmarked the discussion at Best way to store passwords, for making use of KeePass for accessing passwords in a perl script. I recently had a script where I was hardcoding a password to access one machine at $work which wouldn't allow me to set up ssh-key-based login, and decided to try to make it work with WWW::KeePassRest. I had it mostly working when I happened to glance again at the plugin page and noticed its license required a SmartFTP Ultimate or Enterprise license, which I didn't have. Since $work would frown on using unlicensed software, and I'm not making $work pay for a license just to access my free password manager's passwords for my own convenience, I deleted that KeePassRest plugin. Looking through the KeePass plugins list, I found a few that looked promising for me having the skills to communicate with, and I got my script at $work correctly interfacing with KeePassHttp.

    I then took the same concepts, and re-wrote it at home with all the trappings of a public module and unit testing, and as of last night, released it to CPAN as WWW::KeePassHttp v0.01


    NAME

    WWW::KeePassHttp - Interface with KeePass PasswordSafe through the KeePassHttp plugin

    SYNOPSIS

    use WWW::KeePassHttp; my $kph = WWW::KeePassHttp->new(Key => $key); $kph->associate() unless $kph->test_associate(); my $entries = $kph->get_logins($search_string); print "$_ => $entries->[0]{$_}\n" for qw/Name Login Password/;

    DESCRIPTION

    Interface with KeePass PasswordSafe through the KeePassHttp plugin. Allows reading entries based on URL or TITLE. Allows creating a new entry as well.

    REQUIREMENTS

    You need to have KeePass (or compatible) on your system, with the KeePassHttp plugin installed.


    Yes, I know that the returned entries should be objects rather than plain-old-hashes. That was the first issue I created as I was getting ready to release last night. I needed a sense of accomplishment, so decided to do a v0.01 release. Right now, the entry-object is my primary task before considering this module good enough for a "v1.0" release. But if anyone else has suggestions, let me know. Also, I don't have any of the linux ports for KeePass, so I don't know if the KeePassHttp plugin works on the linux port... but if it does, and if any of you could test with a live linux+KeePass+KeePassHttp system, that would be great.

    I also had the fun when developing my test coverage of this being my first foray into mocking another module during testing: KeePassHttp uses HTTP requests for communicating with the plugin, but I didn't want to require that CI and smoketesting machines have KeePass+KeePassHttp installed and working before I could get test coverage. I really like Test::MockObject's ability to queue up a list of return values, so that I can easily define my list of HTTP::Tiny->get() replies without having to have an HTTP server available to give me the answers that I want to test.

Simple data-store with Perl
1 direct reply — Read more / Contribute
by bliako
on Nov 10, 2021 at 07:38

    I was in need of a data-store for clients to read and write short blobs (Edit: i.e. share data between them, that data can be simple strings, including json, or binary data. If the clients are in Perl, serialised nested perl data structure is also a possibility). A shared-memory hashtable seems ideal in my case. A DB seems far-fetched, especially because I need to keep these operations ultra-fast and do not need persistency, ACIDity, and frankly, neither I want to think how to do SQL which invariably, in my case, is googled out and ends up a hit-and-miss and inefficient. OTOH, building a C shared-memory framework with IPC from scratch will take long time. I am leaning towards using Redis especially because it has a C api as my app is in C. It also has a Perl api.

    But here is a Pure Perl solution (yet another example of programming sitting on the hunched shoulders of Giants). It seems very fast to me with 100_000 inserts in 0.35 secs within same machine:

    # simple-perl-server.pl package MyPackage; # base reapped from (with thanks): # https://metacpan.org/pod/Net::Server use base qw(Net::Server); my %Store; my $port = shift or die "No port\n"; sub process_request { my $self = shift; while (<STDIN>) { s/[\r\n]+$//; if( /^(.+?)=(.+?)$/ ){ my $x = $1; my $y = $2; #print "Added '$x' => '$y'\015\012"; print STDERR "Added '$x' => '$y'\n"; $Store{$x} = $y; } elsif( /^(.+?)=$/ ){ my $x = $1; if( exists $Store{$x} ){ print "'$x' => '".$Store{$x}."'\015\012"; } else { print "'$x' => <undef>\015\012"; } } elsif( /quit/i ){ print STDERR "$0 : quitting ...\n"; exit(0); } } # while <STDIN> } MyPackage->run(port => $port, ipv => '*');
    # simple-perl-client.pl # EDIT: this has been edited an hour after posting to set N=100_000 # time reported is correct though # mostly from here: # https://codereview.stackexchange.com/questions/106421/network-chat +-in-perl # and here: # https://gist.github.com/chankeypathak/1b1b9b3a27799eb5e277 use strict; use warnings; use IO::Socket::INET; use Time::HiRes qw/gettimeofday/; my $N = 100_000; # number of inserts my $start_time = Time::HiRes::gettimeofday(); my $server = shift or die "No server\n"; my $port = shift or die "No port\n"; my $client_socket = IO::Socket::INET->new( PeerPort => $port, PeerAddr => $server, Proto => 'tcp' ) or die "Can't create send socket: $!!\n"; print "Connected to $server:$port!\n"; my $child; if($child = fork) { while( 1 ){ my $received = <$client_socket>; exit unless defined $received; print $received; } } die "fork: $!\n" unless defined $child; # set print "$0 : doing $N sets ...\n"; for my $i (1..$N){ $client_socket->send("x$i=$i\n"); } print "$0 : done $N sets.\n"; print "$0 : doing $N gets ...\n"; # get for my $i (1..$N){ $client_socket->send("x$i=\n"); } print "$0 : done $N gets.\n"; my $end_time = Time::HiRes::gettimeofday(); print "Closing connection ...\n"; $client_socket->send("quit\n\n"); close $client_socket; sleep(1); print "$0 : done $N sets/gets in ".($end_time-$start_time)." seconds.\ +n";

    Run the server as: perl simple-perl-server.pl 16001

    Run the client as: perl simple-perl-client.pl 127.0.0.1 16001

    It's quite fast: 0.345 secs for 100_000 inserts, (out-of-the-box redis needed 10x that)

    bw, bliako

Connecting OBS to my home automation network
1 direct reply — Read more / Contribute
by cavac
on Nov 04, 2021 at 11:05

    There are always two principle ways to implement a project:
    a) Do a clean, well-designed, easy-to-understand project by investing a lot of time and money
    b) Fudge it in an evening

    I sometimes stream on Youtube. Sometimes i play early access games that are rather allergic to tabbing out. So, controlling my streaming software, OBS, has always been a bit complicated. But what i DO have is my Apollo DSKY inspired home automation console next to my main keyboard, which is connected to rest rest of my house via Net::Clacks.

    Implementing the GUI is a whole other story for another day. The DSKY project code is weird, even for my standards. This time, we are just looking into controlling some functionality of OBS via Net::Clacks.

    First, you'll need to install OBS, install the OBS websocket plugin and configure OBS to your liking (scenes, sources, streaming config and whatever else).

    Next, we'll write some config files.

    obsconfig.xml:

    <obs> <ip>10.0.0.17</ip> <port>4444</port> <password>secretobspassword</password> </obs>

    dskyconfig.xml (or rather only the relevant parts of it):

    <dsky> <clackssocket>/home/monastery/temp/clacksproxy.sock</clackssocket> <clacksuser>monasterygates</clacksuser> <clackspassword>opensesame</clackspassword> ... </dsky>

    Start with the usual boilerplate stuff:

    #!/usr/bin/env perl #---AUTOPRAGMASTART--- use 5.020; use strict; use warnings; use diagnostics; use mro 'c3'; use English qw(-no_match_vars); use Carp; our $VERSION = 2.4; use Fatal qw( close ); use Array::Contains; #---AUTOPRAGMAEND--- use IO::Socket::IP; use Data::Dumper; use Protocol::WebSocket::Frame; use Time::HiRes qw[sleep]; use JSON::XS; use XML::Simple; use Net::Clacks::Client; use Crypt::Digest::SHA256 qw[sha256_b64]; use Encode qw[encode_utf8 decode_utf8 is_utf8];

    Next step is to try to connect to the OBS websocket. If this doesn't work, we just sleep for a bit and try again. This way, the client can just run in the background all the time and we can start OBS when we need it.

    my $clacksconfig = XMLin('dskyconfig.xml'); my $obsconfig = XMLin('obsconfig.xml'); my $sock; while(1) { $sock = IO::Socket::IP->new( PeerHost => $obsconfig->{ip}, PeerPort => $obsconfig->{port}, Type => SOCK_STREAM, Blocking => 1, ); last if(defined($sock)); print "OBS not available...\n"; sleep(10); } binmode($sock); $sock->blocking(0);

    perl -e 'use Crypt::Digest::SHA256 qw[sha256_hex]; print substr(sha256_hex("the Answer To Life, The Universe And Everything"), 6, 2), "\n";'
Moon phase on historical events
2 direct replies — Read more / Contribute
by bliako
on Oct 07, 2021 at 07:55

    While I was watching the moon at a place away from civilisation I wondered what phase was the moon on certain historical events. I am not into astrology. I was curious to see how military planners make use of the moon and its effect on illumination and the tides. Invasions primarily...

    Thankfully Perl and the wonderful playground of CPAN provide all the tools one needs for an application which calculates the moon phase given date and, optionally, time and timezone or location. Thank you Astro::MoonPhase and DateTime and Geo::Location::TimeZone. All is needed is the date. Time defaults to the beginning of the day (00:00:01) and the timezone defaults to UTC. If the event's time is critical then supply it along with a timezone to make the conversion to unix-epoch-seconds (assumes UTC) accurate. In starting this I was not aware that Moon phase for a specific time is more-or-less the same for anywhere on the surface of our planet, irrespective of standpoint. With the caveat that our antipodean fellows will see it, well ... , antipodeanly.

    It looks that some military invasions took advantage of the full moon (invasion of Libya/2011, invasion of Iraq/2003 which, btw, both happened on the same day 8 years apart) while others planned for a "dark" moon (Invasion of Bay of Pigs, Cuba/1961). Normandy Landing/1944 (D-Day) planners chose a full moon (in the output: illuminated fraction: 99.4 % of full disc and also Moon age: 14.0637595011504 days which is just about half the moon cycle, i.e. full-moon) because the way it affected the tide, although the illumination would have been unwanted.

    The basic module used is Astro::MoonPhase and seems to work fine as I confirmed its output with an online calculator. Although its input is unix-epoch-seconds, it seems to handle well cases older than 1970, with a negative epoch.

    A moon phase calculator has also been posted here some time in 2007, phoon - show the phase of the moon by jima, based on previous program by Jef Poskanzer.

    Some results:

    Normandy Landing on 1944-06-06T05:00:00 (-806965200 seconds unix-epoch +) timezone: Europe/Paris (lat: 49.18, lon: -0.37) Moon age: 14.0637595011504 days Moon phase: 47.6 % of cycle (birth-to-death) Moon's illuminated fraction: 99.4 % of full disc important moon phases around the event: New Moon = Mon May 22 08:14:24 1944 First quarter = Tue May 30 02:06:14 1944 Full moon = Tue Jun 6 20:59:37 1944 Last quarter = Tue Jun 13 17:57:49 1944 New Moon = Tue Jun 20 19:01:26 1944 end event. US Invasion of Cuba, Bay of Pigs on 1961-04-15T05:00:00 (-274975200 se +conds unix-epoch) timezone: America/Havana Moon age: 0.207041969010797 days Moon phase: 0.7 % of cycle (birth-to-death) Moon's illuminated fraction: 0.0 % of full disc end event. Invasion of Libya on 2011-03-19T05:00:00 (1300503600 seconds unix-epoc +h) timezone: Africa/Tripoli Moon age: 14.0213525003449 days Moon phase: 47.5 % of cycle (birth-to-death) Moon's illuminated fraction: 99.4 % of full disc end event. Invasion of Iraq on 2003-03-19T05:00:00 (1048039200 seconds unix-epoch +) timezone: Asia/Baghdad Moon age: 15.4878029842796 days Moon phase: 52.4 % of cycle (birth-to-death) Moon's illuminated fraction: 99.4 % of full disc end event.

    Edit: caveat: the most reliable way to get the timezone right is to set it manually using a string that DateTime::TimeZone understands. Getting timezone from coordinates via Geo::Location::TimeZone is less reliable (case in point is Cuba's Bay of Pigs which gets the timezone of Pacific/Norfolk, I have edited the results to correct this.). Another edit: made example output terse and added readmore tags around the code. And added some more thanks to the existing modules my lame app relies on because they deserve it.

    The driver script follows. The input is provided in-script by an event hash which specifies a name and date, optional are time, timezone, location coordinates. Enjoy:

    bw, bliako


Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (5)
As of 2022-05-24 12:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (82 votes). Check out past polls.

    Notices?