Bod's user image
User since: Nov 15, 2020 at 00:48 UTC (10 weeks ago)
Last here: Jan 21, 2021 at 20:14 UTC (15 hours ago)
Experience: 1216
Level: Friar (9)
Writeups: 265
Location:Coventry, UK
User's localtime: Jan 22, 2021 at 11:13 UTC
Scratchpad: View
For this user:Search nodes

Long time amateur coder since growing up with a ZX Spectrum and BBC Micro...

Introduced to Perl in the early 1990's which quickly became the language of choice. Built many websites and backend applications using Perl including the sites for my property business:
Lets Delight - company site
Lets Stay - booking site
Also a few simple TK based desktop apps to speed things up.

Guilty of only learning what I need to get the job done - a recipe for propagating bad practice and difficult to maintain code...difficult for me so good luck to anyone else!

Now (Nov 2020) decided to improve my coding skills although I'm not really sure what "improve" means in this context. It seems Perl and best practice have come along way since I last checked in and my programming is approach is stuck in the last decade.

Onwards and upwards...

Find me on LinkedIn

Posts by Bod
Factory classes in Perl in Seekers of Perl Wisdom
5 direct replies — Read more / Contribute
by Bod
on Jan 08, 2021 at 17:28

    I've been reading some of the Perl Advent Calendar trying to expand my learning.

    On this day there is the problem of Cyber-Santa having to create classes of either Robo-Reindeer or Bio-Reindeer depending on which is available. The module tries to use Robo-Reindeer but if they are not available because their lamp batteries are not charged (or the module just isn't installed) then use Bio-Reindeer instead.

    I think I understand what this Reindeer Factory Class does and why it might be useful in other languages. However, in Perl we have CPAN from which we install our modules...this allows us to specify dependencies be be installed when we install our module.

    In this Perl Advent Calendar example, why would we create a ReindeerFactory instead of just forcing our module to install Robo-Reindeer if that's the one we prefer?

Adding a watermark to an image with GD::Image in Seekers of Perl Wisdom
4 direct replies — Read more / Contribute
by Bod
on Jan 06, 2021 at 17:14

    I again seek your wisdom fellow Monks...

    As part of the website for my partner's artwork, I am producing two copies of each image that she will upload. One is a small thumbnail with quite high JPEG compression so that it is deliberately pixelated if it is enlarged. The other image is high resolution and large, but with a watermark copyright notice on it. I am using GD for the image processing and Image::Resize to make the sizing easier.

    GD is being used because I know my way around it better than the alternatives like Image::Magick and I know GD better because it is available to me by default.

    All the resizing works fine and I am able to add a watermark in two parts to get two different font sizes. However, regardless of what I add in the first parameter of ->stringFT() the text is always black. This is fine for some images...

    this watermark looks fine

    But the black watermark doesn't work very well on artwork where a significant amount of the background is black or close to black.

    this watermark doesn't look right

    My first thought was to try to have semi-transparent text for the watermark. However, searching suggests that this isn't possible although I haven't found anything which categorically rules it out. So instead I thought of trying to read the general "darkness" of areas of the background where the watermark is going to be and programmatically choose a colour that will contrast against this. Detecting the "darkness" seems far from trivial...

    Here is the code...

    sub XHRupload { no strict 'subs'; my $full; my $image = Image::Resize->new(GD::Image->new($file{'joolzimage', +'file'})); if ($image->width() > 1800) { $full = $image->resize(1800, 99999); } else { $full = $image->gd(); } my $year = (localtime)[5] + 1900; my $watermark = 'Artwork by Joolz'; my $copyright = "copyright $year"; # Centre text components and centre on image my @bounds = new GD::Image->stringFT('silver', "$ENV{'DOCUM +ENT_ROOT'}/cgi-bin/Image/watermark.ttf", 140, 0.18, 0, 0, $watermark) +; my $left = ($full->width() / 2) - (($bounds[2] - $bounds +[0]) / 2) + 5; my $top = ($full->height() / 2); $full->stringFT('white', "$ENV{'DOCUMENT_ROOT'}/cgi-bin/Image/wate +rmark.ttf", 140, 0.18, $left, $top, $watermark); @bounds = new GD::Image->stringFT('silver', "$ENV{'DOCUMENT +_ROOT'}/cgi-bin/Image/watermark.ttf", 80, 0.18, 0, 0, $copyright); $left = ($full->width() / 2) - (($bounds[2] - $bounds[0] +) / 2) + 5; $top = ($full->height() / 2) + 120; $full->stringFT('blue', "$ENV{'DOCUMENT_ROOT'}/cgi-bin/Image/water +mark.ttf", 80, 0.18, $left, $top, $copyright); open my $fh, '>', "$ENV{'DOCUMENT_ROOT'}/artwork/full/$data{'id'}. +jpg"; print $fh $full->jpeg(100); close $fh; my $thumb = $image->resize(300, 1000); open $fh, '>', "$ENV{'DOCUMENT_ROOT'}/artwork/thumbs/$data{'id'}.j +pg"; print $fh $thumb->jpeg(32); close $fh; print "Content-type: text/plain\n\n"; print $data{'id'}; exit 0; }
    Can you suggest either a better way to accomplish what I am trying to do or a relatively simple way to detect how dark the background is, select a colour for the text that will show up on that background and then actually create text in that colour?

    As always, any other advice on improving my code would be welcome.

CPAN uninstall in Seekers of Perl Wisdom
2 direct replies — Read more / Contribute
by Bod
on Jan 04, 2021 at 11:09

    In trying to help installing WWW::Mechanize::Chrome in Strawberry Perl I was trying to install IO::Async but made a typo! I left it doing its thing whilst walking the hound and returned a little over an hour later to find lots if Tk windows popping up during the tests for one of the many dependencies that are being installed...

    1. Is there a simple way to see all the modules that have been recently installed?
    2. Is it possible to delete (some of) them?
    3. Does it matter that there are modules installed that I don't know what they are or what they do?

    Disc space is not at a premium so I an sort of assuming that all these modules will just sit there worrying nobody so long as I don't actually use them.

    Edited to correct typo in question and to add that the typo I initially made was cpan --force install IO::ASnyc

Calling module function from within a blessed module in Seekers of Perl Wisdom
5 direct replies — Read more / Contribute
by Bod
on Jan 02, 2021 at 10:31

    I'm looking for the 'right' way to call a function from within the module when that module is usually blessed. I've been putting an empty string as the first parameter passed to the function but I feel sure there is a nicer way to do this.

    package Some::Module; use strict; sub new { return bless {}; } sub do_something { my ($self, $param) = @_; # something... return $param; } sub do_more { my $self = shift; return do_something('example'); }

    If we create an instance of this then call the function

    my $instance = Some::Module->new; $instance->do_something('testing');
    a reference to $instance is passed to $self in the function (I think) and 'testing' is passed to $param.

    But when the same function is called from within the module by do_more();, there isn't a reference to anything to be passed to do_something as the first argument so the argument list is out. Do we just add a dummy argument to the call within do_more like this

    sub do_more { my $self = shift; return do_something('', 'example'); }
    or is there a more elegant solution?

Alexa 'retrievable' (not all strictly Perl) in Seekers of Perl Wisdom
2 direct replies — Read more / Contribute
by Bod
on Jan 02, 2021 at 08:47

    Happy New Year to all in and visiting the Monastery

    This isn't all a strictly Perl question but I know that here we have a huge diversity of knowledge and skill and I am really hoping someone can point me in the right direction as I seem to be getting absolutely nowhere. I've hit the point where "it isn't doing what the documentation says it does" which usually means I am missing something obvious!

    As part of the Controlling USB on Raspberry Pi project, I have connected the RPi to Alexa using ngrok to provide the tunnel to the remote device and HTTP::Server::Simple to handle instructions from Alexa. I specifically wanted to use Smart Home instead of a Skill so that we can use Alexa, open the curtains instead of having to use Alexa, ask the curtains to open. The major downside of this choice is having to use AWS Lambda to handle the calls. But...*sigh of relief* is all working and Alexa can open and close the curtains :)

    What Alexa cannot do is report whether or not the curtains are open.

    Within the Discovery.Response directive that I send to Alexa, I set "retrievable": true which should allow me to ask Alexa, are the curtains open?. When I ask that I get Sorry, curtains doesn't support that and no ReportState directive is passed to my code on Lambda.

    This is the relevant part of the "capabilities" section of the Discovery.Response directive.

    "capabilities": [ { "type": "AlexaInterface", "interface": "Alexa.ToggleController", "instance": "Curtains", "version": "3", "properties": { "supported": [ { "name": "toggleState" } ], "proactivelyReported": false, "retrievable": true, "nonControllable": false }, "semantics": { "actionMappings": [ { "@type": "ActionsToDirective", "actions": [ "Alexa.Actions.Close" ], "directive": { "name": "TurnOff", "payload": {} } }, { "@type": "ActionsToDirective", "actions": [ "Alexa.Actions.Open" ], "directive": { "name": "TurnOn", "payload": {} } } ] } } ]
    Any suggestions of what I can try to debug the problem would be greatly appreciated.

    Back to Perl - does anyone have any experience of using Perl within the AWS Lambda ecosystem using AWS::Lambda? Is it as easy an the documentation makes out? I can foresee all sorts of issues with creating an EC2 instance and trying to ensure all the paths are correct when deploying the Perl build.

Preparing data for Template in Seekers of Perl Wisdom
1 direct reply — Read more / Contribute
by Bod
on Dec 30, 2020 at 17:38

    I have been following this tutorial for creating dynamic content with Template and trying to apply this to my own needs. But I've hit a problem in preparing the data for the template.

    Template file

    [% SET menuframe = ' menuselect' %] [% PROCESS %] [% FOREACH frame IN frames %] <hr> <p><b>[% %]</b><br> [% frame.colour %]</p> [% END %]
    This does not generate any output for anything within the [% FOREACH ... %] block

    Here is the code that extracts some data from the database and prepares it for passing to the Template display code

    #!/usr/bin/perl use Site::Common; use Site::HTML; use strict; my $site = Site::Common->new; my $html = Site::HTML->new; my $dbh = $site->db; if ($data{'command'} eq 'frames') { my $vars = { 'frames' => \&list_frames, }; warn "Displaying template"; # This gets called $html->display("admin_frames", $vars); } else { $html->display("admin_pictures"); } sub list_frames { warn "Building list of frames"; # This is not called my @frames; my $query = $dbh->prepare("SELECT idFrame, name, colour FROM Frame +"); $query->execute(); while (my ($id, $name, $colour) = $query->fetchrow_array()) { my $frame = { 'id' => $id, 'name' => $name, 'colour' => $colour, }; push @frames, $frame; } return \@frames; }
    There are a couple of warn statements in there so I can see something of what the code is doing.

    Here is the relevant part of Site::HTML...

    package Site::HTML; use Template; use Site::Variables; use strict; my $template = Template->new(INCLUDE_PATH => $Site::Variables::templat +e_path); sub display { my $self = shift; my $file = shift; my %vars = @_; $template->process("$", \%vars); } 1;

    I'm not sure when list_frames is supposed to get called but I'm guessing at the time the hash reference $vars is generated.

How long to PAUSE? in Seekers of Perl Wisdom
2 direct replies — Read more / Contribute
by Bod
on Dec 30, 2020 at 07:08

    How long does a PAUSE account generally take to be approved?
    I submitted an application at the start of the month and, other than the automated acknowledgement email, I've heard nothing this normal?

Debugging CPAN problem in Seekers of Perl Wisdom
6 direct replies — Read more / Contribute
by Bod
on Dec 22, 2020 at 13:08

    The Raspberry Pi based Curtain Controller project for my blind uncle is complete and almost ready to go to its new home. I have two RPi's - the one that is boxed up with the relay controller and one that is setup as a test environment so I can deal with any future problems or extra features.

    In setting up the controller unit I obviously made a mess somewhere as nothing would install from CPAN whereas this was not a problem on the development unit. The development unit also has an HTTP server which is accessible via an ngrok tunnel ready for the unit at be Alexa enabled once I get Device Discovery working. This server needs adding to the controler and requires HTTP::Server::Simple so CPAN is necessary.

    The development unit used an OS image with the network credentials added. This same image has now been used for the controller unit. So everything should be identical except that one has header pins soldered in and the other one doesn't!
    Once the OS had installed and an SSH connection made I have changed the password then updated with:

    sudo apt-get update sudo apt-get upgrade cpan install CPAN
    With the development unit, running CPAN and typing install HTTP::Server::Simple installed lots and lots of dependencies taking nearly 4 hours but eventually installed.

    On the unit that is to be shipped imminently, CPAN gets 'Killed' - this is the last block of what CPAN prints out:

    Configuring E/ET/ETHER/Try-Tiny-0.30.tar.gz with Makefile.PL Checking if your kit is complete... Looks good Generating a Unix-style Makefile Writing Makefile for Try::Tiny Writing MYMETA.yml and MYMETA.json ETHER/Try-Tiny-0.30.tar.gz /usr/bin/perl Makefile.PL INSTALLDIRS=site -- OK Running make for E/ET/ETHER/Try-Tiny-0.30.tar.gz cp lib/Try/ blib/lib/Try/ Manifying 1 pod document ETHER/Try-Tiny-0.30.tar.gz /usr/bin/make -- OK The current configuration of allow_installing_outdated_dists is 'ask/y +es', but for this option we would need 'CPAN::DistnameInfo' installed +. Please install 'CPAN::DistnameInfo' as soon as possible. As long as + we are not equipped with 'CPAN::DistnameInfo' this option does not t +ake effect Running make test for ETHER/Try-Tiny-0.30.tar.gz PERL_DL_NONLAZY=1 "/usr/bin/perl" "-MExtUtils::Command::MM" "-MTest::H +arness" "-e" "undef *Test::Harness::Switches; test_harness(0, 'blib/l +ib', 'blib/arch')" t/*.t t/00-report-prereqs.t .......... # # Versions for all modules listed in MYMETA.json (including optional o +nes): # # === Configure Requires === # # Module Want Have # ------------------- ---- ---- # ExtUtils::MakeMaker any 7.34 # # === Configure Suggests === # # Module Want Have # -------- ------- ------- # JSON::PP 2.27300 2.97001 # # === Build Requires === # # Module Want Have # ------------------- ---- ---- # ExtUtils::MakeMaker any 7.34 # # === Test Requires === # # Module Want Have # ------------------- ---- -------- # ExtUtils::MakeMaker any 7.34 # File::Spec any 3.74 # Test::More any 1.302133 # if any 0.0608 # # === Test Recommends === # # Module Want Have # ---------- -------- -------- # CPAN::Meta 2.120900 2.150010 # # === Test Suggests === # # Module Want Have # ------------------------ ----- ------- # CPAN::Meta::Check 0.011 missing # CPAN::Meta::Requirements any 2.140 # Capture::Tiny 0.12 missing # # === Runtime Requires === # # Module Want Have # -------- ---- ---- # Carp any 1.50 # Exporter 5.57 5.73 # constant any 1.33 # strict any 1.11 # warnings any 1.42 # # === Runtime Suggests === # # Module Want Have # --------- ---- ------- # Sub::Name 0.08 missing # Sub::Util any 1.50 # # === Other Modules === # # Module Have # ------------- ------- # JSON::PP 2.97001 # Pod::Coverage missing # Sub::Name missing # YAML missing # autodie 2.29 # t/00-report-prereqs.t .......... ok t/basic.t ...................... ok t/context.t .................... ok t/erroneous_usage.t ............ ok t/finally.t .................... ok t/given_when.t ................. skipped: Tests skipped on perl 5.27.7 ++, pending resolution of smartmatch changes t/global_destruction_forked.t .. ok t/global_destruction_load.t .... skipped: Capture::Tiny 0.12 required t/named.t ...................... ok t/when.t ....................... skipped: Tests skipped on perl 5.27.7 ++, pending resolution of smartmatch changes t/zzz-check-breaks.t ........... ok All tests successful. Files=11, Tests=97, 21 wallclock secs ( 0.78 usr 0.10 sys + 17.95 cus +r 1.02 csys = 19.85 CPU) Result: PASS Killed pi@eric:~ $
    I've tried using CPAN to install just Try::Tiny as this seems to be where things are failing. When I do this I get almost the same output with different wallclock values reported and Lockfile removed. displayed on the line before Killed and several minutes between them.

    Searching for an answer suggests that this is the OS killing CPAN and the most probable cause is lack of memory. The development unit has a 32Gb SD card whereas the controller has 16Gb. But, there is plenty of space on the card:

    pi@eric:~ $ df Filesystem 1K-blocks Used Available Use% Mounted on /dev/root 14989480 3552696 10774908 25% / devtmpfs 188088 0 188088 0% /dev tmpfs 221112 0 221112 0% /dev/shm tmpfs 221112 3212 217900 2% /run tmpfs 5120 0 5120 0% /run/lock tmpfs 221112 0 221112 0% /sys/fs/cgroup /dev/mmcblk0p1 258095 55052 203043 22% /boot tmpfs 44220 4 44216 1% /run/user/1000

    Two ostensibly identical units seem to be working differently.
    Can you suggest anything I can try to debug this problem?

Here documents in blocks in Seekers of Perl Wisdom
10 direct replies — Read more / Contribute
by Bod
on Dec 19, 2020 at 11:25

    When I created an account here some five weeks ago, little did I realise just how much varied learning I would receive in such a short I am asking for advice on an issue that has had me scratching my head many times over the years. How best to lay out code when quite a bit of text output is required, such as when dynamically creating a webpage, inside an indented block.

    In the main body of the code I usually use an interpolating heredoc with any runtime variations defined in variables ahead of printing it all out.

    my $login_text = $user_number?'logout':'login'; print<<"END_HTML"; <div> ...part of webpage... <input type="button" name="log" value="$login_text" onClick="doSomethi +ng();"> ...more of webpage... </div> END_HTML
    That works and looks fine for a block of procedural code but I run into difficulties when I want to put something similar into an indented block for any reason. It could be a subroutine that is called to display a largely different page based on the query string or a significant block of content that is only shown under some conditions.
    if (isAdmin($user_number)) { print ...some extra content... }
    Heredocs don't work so well in these circumstances. I am using Perl 5.16 so don't get to use the print<<~"END_HTML"; syntax introduced in Perl 5.26.

    This leaves a few option.
    The one that most of my legacy code has is to simply put every line in a separate print statement

    if (isAdmin($user_number)) { print "<table>\n"; print "<tr>\n"; print "<td class=\"someclass\" style=\"text-align:center\">Some Co +ntent</td>\n"; print "</tr><tr>\n<td class=\"someClass\">Restricted</td>\n" if $u +ser_number == 20; print "</tr>\n"; print "</table>"; }
    Not very pretty and quite difficult to follow as it becomes more involved, especially as more and more HTML gets added over time. So a slight improvement that I used for a short time is with qq to save having to escape the quotation marks.
    print qq[<td class="someclass" style="text-align:center">Some Conte +nt</td>\n]; print qq[</tr><tr>\n<td class="someClass">Restricted</td>\n] if $us +er_number == 20;
    Slightly better - but still not very nice...

    I have tried having a subroutine to strip out leading spaces but this has the disadvantage of always stripping leading spaces even when they are wanted! In this format it also strips out blank lines although this is not too tricky to solve.

    #!/usr/bin/perl use strict; print "Content-type: text/plain\n\n"; print "Test\n\n"; sub indent { my $text = shift; $text =~ s/^\s+//gm; return $text; } if (1) { print indent(<<"END_TEXT"); Here is some test text with plenty of space at the start END_TEXT } exit 0;
    This still requires END_TEXT to be written without an indent.

    Many times I have searched for a solution and found several references to the issue but nothing offering a 'proper' solution. The topic of indentation in some form or another crops up periodically in all sorts of forms including Mandatory indenting which was interesting despite not being directly relevant.

    Other than upgrading to Perl 5.26 or later, is there an elegant solution to laying out code to print a lot of text in an indented block?

Preventing multiple instances in Seekers of Perl Wisdom
10 direct replies — Read more / Contribute
by Bod
on Dec 16, 2020 at 16:36

    Because the Raspberry Pi does not have an onboard time clock (thanks Marshall for pointing this out), the first thing my script does is to check that it has a valid time that has been obtained from the network. It does this by comparing the current year as given by localtime to 2020. I've written some code which is probably unnecessary in this application but I'm asking about this as a wider learning point.

    How can I prevent more than one instance of a script from running?
    I have at times used a lockfile but there is always the risk that the power could go off or some other catastrophe could occur between the lockfile being created and being removed. So is there a better way to do it?

    This is the code to check is the RPi has a valid date and to wait ever increasing intervals before checking again and eventually to reboot as a possible cause after this amount of time is that the WiFi 'card' hasn't properly initialised.

    my @time = localtime; $control->log("Starting Curtain Controller") if $DEBUG > 1; # Check Pi has valid time my $wait = 1; while ($time[5] + 1900 < 2020) { if ($wait > 30) { $control->log("Still no valid time. Aborting!"); sleep(2); system("sudo reboot"); exit 0; } my $plural = $wait == 1?'':'s'; $control->log("No valid time. Waiting $wait minute$plural"); print "Waiting for $wait minutes$plural\n" if $DEBUG; sleep ($wait * 60); $wait = int(0.5 + $wait * 1.5); @time = localtime; }

    At present I am unable to install any modules from CPAN although this will be solved in time - it is more important to get this project working, built in a nice box and set up in its new home before Christmas.

    As this Raspberry Pi script is running from CRON every 2 minutes, the delay code is probably not necessary. Instead I will just make the check and if the time is invalid, log that and exit. 2 minutes later it will try again anyway. But I would be interested to learn of other ways of preventing two instances of the same script running because not all scripts run so regularly from cron as this one does.