One of the steps of debugging Perl can be to find out what is actually in a string. There are a number of more-or-less informative ways to do this, and I thought I would compare them.

For this I used two short strings. The first was just the concatenation of the characters whose ordinals are 24 through 39; that is, 16 ASCII characters straddling the divide between control characters and printable characters. The second was a small variation on the first, made by removing the last character and appending "\N{U+100}" (a.k.a. "\N{LATIN CAPITAL A WITH MACRON}") to force the string's internal representation to be upgraded.

The results given below include the version of the module used, the actual code snippet that generated the output, the output itself, and any comments I thought relevant. All subroutines used to dump strings are exportable except for those called as methods. The sample code makes fully-qualified calls because of duplication of subroutine names between different modules.

Data::Dumper 2.183 (core since 5.005)

local $Data::Dumper::Useqq = 1;
print Data::Dumper::Dumper( $_ );

$VAR1 = "\30\31\32\e\34\35\36\37 !\"#\$%&'";

$VAR1 = "\30\31\32\e\34\35\36\37 !\"#\$%&\x{100}";

Data::Dumper is probably the default debug output tool. One of its goals is the ability to recover the original data by eval()-ing the output of Dumper(). But note the need to set $Data::Dumper::Useqq true to actually see all characters in the dumped string. If this is not done, the control characters are not converted into escape sequences, so the only way to see them is to pipe your output through hexdump -C. For more general-purpose debugging you may also want to set $Data::Dumper::Sortkeys to 1 so that hash keys come out in non-random order.

B 1.82 (core since 5.005)

print B::perlstring( $_ ), "\n";

"\030\031\032\033\034\035\036\037 !\"#\$%&'"

"\x{18}\x{19}\x{1a}\e\x{1c}\x{1d}\x{1e}\x{1f} !\"#\$%&\x{100}"

The primary purpose of the B module is to support rummaging around in Perl's internals. This use as a casual debugging tool is more a happy accident than the actual intent of the module. If you prefer the C language representation of a string, this module also provides cstring().

Devel::Peek 1.3 (core since 5.006)

Devel::Peek::Dump( $_ );

SV = PV(0x7f7c1222a2b0) at 0x7f7c1200fee0

  REFCNT = 2

  FLAGS = (POK,IsCOW,pPOK)

  PV = 0x600003e3d760 "\30\31\32\33\34\35\36\37 !\"#$%&'"\0

  CUR = 16

  LEN = 18

  COW_REFCNT = 0

SV = PVMG(0x7f7c135c75e0) at 0x7f7c1100ac48

  REFCNT = 2

  FLAGS = (SMG,POK,pPOK,UTF8)

  IV = 0

  NV = 0

  PV = 0x600003e3d580 "\30\31\32\33\34\35\36\37 !\"#$%&\304\200"\0 [UTF8 "\x{18}\x{19}\x{1a}\e\x{1c}\x{1d}\x{1e}\x{1f} !"#$%&\x{100}"]

  CUR = 17

  LEN = 18

  MAGIC = 0x60000307e310

    MG_VIRTUAL = &PL_vtbl_utf8

    MG_TYPE = PERL_MAGIC_utf8(w)

    MG_LEN = -1

Devel::Peek tells you much more than you probably need to know about a string for casual debugging. Unlike the other modules presented here, it does its output directly to STDERR instead of just returning another string.

Data::Dump 1.25 (not in core)

print Data::Dump::dump( $_ ), "\n";

"\30\31\32\e\34\35\36\37 !\"#\$%&'"

"\30\31\32\e\34\35\36\37 !\"#\$%&\x{100}"

Data::Dump is a non-core module written as an alternative to Data::Dumper. Its focus is more on ease of configuration and readability of output.

JSON 4.05 (not in core)

state $json = JSON->new->allow_nonref;
print $json->encode( $_ ), "\n";

"\u0018\u0019\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&'"

"\u0018\u0019\u001a\u001b\u001c\u001d\u001e\u001f !\"#$%&Ā"

JSON is a general-purpose serializer whose output can be made fairly readable.

Note the need to turn on allow_nonref to dump a string, and to turn on pretty and canonical to get indented structures with hash keys in order. Note also that the "\N{U+100}" is represented literally; you will need to set your output encoding (say, by binmode STDERR, ':encoding(utf-8)';) to avoid the dreaded Wide character in print warning.

There are a number of JSON modules available. Output of untried modules may differ from the output I have presented here.

YAML 1.30 (not in core)

print YAML::Dump( $_ );

--- "\x18\x19\x1a\e\x1c\x1d\x1e\x1f !\"#$%&'"

--- "\x18\x19\x1a\e\x1c\x1d\x1e\x1f !\"#$%&Ā"

YAML is a general-purpose serializer whose output is fairly readable with minimal to no configuration. Note that the "\N{U+100}" is represented literally; you will need to set your output encoding (say, by binmode STDERR, ':encoding(utf-8)';) to avoid the dreaded Wide character in print warning.

There are a number of YAML modules available. Output of untried modules may differ from the output I have presented here.

unpack() (Perl built-in)

print unpack( 'H*', $_ ), "\n";

18191a1b1c1d1e1f2021222324252627

Character in 'H' format wrapped in unpack at (eval 28) line 1 (#1)

    (W unpack) You tried something like

    

       unpack("H", "\x{2a1}")

    

    where the format expects to process a byte (a character with a value

    below 256), but a higher value was provided instead.  Perl uses the

    value modulus 256 instead, as if you had provided:

    

       unpack("H", "\x{a1}")

    

18191a1b1c1d1e1f2021222324252600

The unpack() built-in is included so I can say I think it is a bad idea unless you know your string is bytes, not characters. The big, fat warning (courtesy of the diagnostics module) makes this perfectly clear. In this specific case, the output of "\N{U+100}" is the same as the output of "\N{U+00}", and suppressing the warning does not change this.

It is possible to use the bytes pragma to force byte semantics on the unpack and get the whole string. But what you get is the internal representation, subject to change without notice.

My best advice is to avoid this one unless you really, really know what you are doing.

If you must use this method (and I did warn you) you can make it a little easier on yourself by using

say unpack( 'H*', $_ ) =~ s/..\K/ /gr;

which produces (for the ASCII string)

18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24 25 26 27

The /r causes the substitution to return the modified string rather than modifying it in-place, and requires Perl 5.14. Since I knew I was requiring 5.14 I replaced print() with say().

Part of the Dancer2 video course available both to Pro subscribers and attendees of the Perl Dancer course on Leanpub.

Hi there!

Two weeks ago I wrote about the issues we are facing with the Perl Weekly. I got a lot of responses and then yesterday I also noticed there were quite few comments on Reddit as well. Let me thank all the responses now.

Many people suggested that we could switch to sending out every 2 weeks or once a month, but I don't think either of those would be a good idea. Some people suggested we (Mohammad and myself) should write more articles or interview people. Well, no. The Perl Weekly is specifically about collecting your content and sharing it. So it is the wider Perl community that could solve the content-problem by writing more articles. Which brings me to one of our posts today. Dave Cross had another nice idea, linking to tutorials of CPAN modules from MetaCPAN. You don't need to write some article on a topic that has never been mentioned. It would be enough to take one of the modules you use anyway. Put together an example on how to use it. Add some explanations and then post it on your blog. (Which could be very simple using GitHub pages.) Send us the link and also include it in the CSV file of Dave.

Some people suggested to have a (better) web version and RSS feed. You are welcome to send a PR changing the web version to be better. The source of the Perl Weekly is here. We also have two different RSS feeds: latest edition, 10 most recent editions. However these get updated only once a week. If you really like RSS, you might want to use the Perl Planetarium by who else, Dave Cross.

There was some back-and-forth on Reddit whether the Perl-related Facebook groups are the best thing on earth or the worst thing on Earth. I think both sides are right. On one hand Facebook is a black hole that anything going there is invisible from the outside world - that's why I don't often link to it. On the other hand the Perl Community and the Perl programmers Facebook groups seem to be the most active locations for discussing anything about Perl. So let's thank those Perl Mongers who spend time in these groups helping the newcomers. If I may suggest something, if you are not doing it yet: You could also try to direct them to the Perl Weekly and you could also work with them to set up a public blog (or use dev.to) and write a post about something Perl related.

Finally, some people suggested to ask for a grant from The Perl Foundation. Here is the thing. Money in itself is not an issue, but feeling that the work we do is appreciated goes a long way. The many responses I got show that there are at least a few people who value our work. Thank you!. However, if the issue of money was already raised you could use some money to show your appreciation. Mohammad S Anwar has Patreon account with currently 23 supporters. Can we double this number? I also have a Patreon account, but for me a much better boost would be if you checked out the web-site of my son and became a user and a paying subscriber. It is called torto.ai. That will make me a lot happier than any money you might send to my Patreon account.

So that's about it for now.

Enjoy your week!

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

Plot lines and points in SVG format.

Solution

use strict;
use warnings;
sub svg_begin{
    return <<BEGIN;
        <?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}

sub svg_end{
    return "";
}

sub svg_point{
    my($x, $y) = @_;
    return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}

sub svg_line{
    my($x0, $y0, $x1, $y1) = @_;
    return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";          
}

sub svg{
    my @lines = @_;
    my $svg = svg_begin;
    for my $line (@_){
        $svg .= svg_point(@{$line}) if @{$line} == 2;
        $svg .= svg_line(@{$line})  if @{$line} == 4;
    }
    return $svg . svg_end;
}


MAIN:{
    my @lines;
    while(){
        chomp;
        push @lines, [split(/,/, $_)];
    }
    print svg(@lines);
}


__DATA__
53,10
53,10,23,30
23,30

Sample Run

$ perl perl/ch-1.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="53" cy="10" r="1" /><line x1="53" x2="23" y1="10" y2="30" /><circle cx="23" cy="30" r="1" /></svg>

Notes

Doing the SVG formatting from scratch is not so bad, especially when sticking only to points and lines. The boiler plate XML is taken from a known good SVG example and used as a template.

Part 2

Compute a linear regression and output an SVG plot of the points and regression line.

Solution

use strict;
use warnings;
sub svg_begin{
    return <<BEGIN;
        <?xml version="1.0" encoding="UTF-8" standalone="yes"?>                                   <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">                                                                          <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
BEGIN
}

sub svg_end{
    return "";
}

sub svg_point{
    my($x, $y) = @_;
    return "<circle cx=\"$x\" cy=\"$y\" r=\"1\" />";
}

sub svg_line{
    my($x0, $y0, $x1, $y1) = @_;
    return "<line x1=\"$x0\" x2=\"$x1\" y1=\"$y0\" y2=\"$y1\" style=\"stroke:#006600;\" />";          
}

sub svg{
    my @lines = @_;
    my $svg = svg_begin;
    for my $line (@_){
        $svg .= svg_point(@{$line}) if @{$line} == 2;
        $svg .= svg_line(@{$line})  if @{$line} == 4;
    }
    return $svg . svg_end;
}

sub linear_regression{
    my(@points) = @_;
    # 1. Calculate average of your X variable.
    my $sum = 0;
    my $x_avg;
    map{$sum += $_->[0]} @points;
    $x_avg = $sum / @points;
    # 2. Calculate the difference between each X and the average X.
    my @x_differences = map{$_->[0] - $x_avg} @points;
    # 3. Square the differences and add it all up. This is Sx.
    my $sx = 0;
    my @squares = map{$_ * $_} @x_differences;
    map{$sx += $_} @squares;
    # 4. Calculate average of your Y variable.
    $sum = 0;
    my $y_avg;
    map{$sum += $_->[1]} @points;
    $y_avg = $sum / @points;
    my @y_differences = map{$_->[1] - $y_avg} @points;
    # 5. Multiply the differences (of X and Y from their respective averages) and add them all together.  This is Sxy.
    my $sxy = 0;
    @squares = map {$y_differences[$_] * $x_differences[$_]} 0 .. @points - 1;
    map {$sxy += $_} @squares;
    # 6. Using Sx and Sxy, you calculate the intercept by subtracting Sx / Sxy * AVG(X) from AVG(Y).
    my $m = $sxy / $sx;
    my $y_intercept = $y_avg - ($sxy / $sx * $x_avg);
    my @sorted = sort {$a->[0] <=> $b->[0]} @points;
    my $max_x = $sorted[@points - 1]->[0];
    return [0, $y_intercept, $max_x + 10, $m * ($max_x + 10) + $y_intercept];
}

MAIN:{
    my @points;
    while(){
        chomp;
        push @points, [split(/,/, $_)];
    }
    push @points, linear_regression(@points);
    print svg(@points);    
}


__DATA__
333,129
39,189
140,156
292,134
393,52
160,166
362,122
13,193
341,104
320,113
109,177
203,152
343,100
225,110
23,186
282,102
284,98
205,133
297,114
292,126
339,112
327,79
253,136
61,169
128,176
346,72
316,103
124,162
65,181
159,137
212,116
337,86
215,136
153,137
390,104
100,180
76,188
77,181
69,195
92,186
275,96
250,147
34,174
213,134
186,129
189,154
361,82
363,89

Sample Run

$ perl perl/ch-2.pl
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
           <!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.0//EN" "http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">
           <svg height="100%" width="100%" xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<circle cx="333" cy="129" r="1" /><circle cx="39" cy="189" r="1" /><circle cx="140" cy="156" r="1" /><circle cx="292" cy="134" r="1" /><circle cx="393" cy="52" r="1" /><circle cx="160" cy="166" r="1" /><circle cx="362" cy="122" r="1" /><circle cx="13" cy="193" r="1" /><circle cx="341" cy="104" r="1" /><circle cx="320" cy="113" r="1" /><circle cx="109" cy="177" r="1" /><circle cx="203" cy="152" r="1" /><circle cx="343" cy="100" r="1" /><circle cx="225" cy="110" r="1" /><circle cx="23" cy="186" r="1" /><circle cx="282" cy="102" r="1" /><circle cx="284" cy="98" r="1" /><circle cx="205" cy="133" r="1" /><circle cx="297" cy="114" r="1" /><circle cx="292" cy="126" r="1" /><circle cx="339" cy="112" r="1" /><circle cx="327" cy="79" r="1" /><circle cx="253" cy="136" r="1" /><circle cx="61" cy="169" r="1" /><circle cx="128" cy="176" r="1" /><circle cx="346" cy="72" r="1" /><circle cx="316" cy="103" r="1" /><circle cx="124" cy="162" r="1" /><circle cx="65" cy="181" r="1" /><circle cx="159" cy="137" r="1" /><circle cx="212" cy="116" r="1" /><circle cx="337" cy="86" r="1" /><circle cx="215" cy="136" r="1" /><circle cx="153" cy="137" r="1" /><circle cx="390" cy="104" r="1" /><circle cx="100" cy="180" r="1" /><circle cx="76" cy="188" r="1" /><circle cx="77" cy="181" r="1" /><circle cx="69" cy="195" r="1" /><circle cx="92" cy="186" r="1" /><circle cx="275" cy="96" r="1" /><circle cx="250" cy="147" r="1" /><circle cx="34" cy="174" r="1" /><circle cx="213" cy="134" r="1" /><circle cx="186" cy="129" r="1" /><circle cx="189" cy="154" r="1" /><circle cx="361" cy="82" r="1" /><circle cx="363" cy="89" r="1" /><line x1="0" x2="403" y1="200.132272535582" y2="79.2498029303056" /></svg>

Notes

I re-use the SVG code from Part 1 and add in the linear regression calculation. Continuing a small habit from the past few weeks of these challenges I am making much use of map to keep the code as small, and yet still readable, as possible. The linear regression calculation is fairly straightforward, as much as I hate having a terse writeup on this I am not sure I have much more to say!

References

Challenge 165

Linear Regression Calculation

These are some answers to the Week 165 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

This week, Task 1 and part of Task 2 relate to Scalable Vector Graphics (SVG). I’d been using SVG a very long time ago and certainly didn’t remember any of the details. So, in my first blog relating to PWC 165, I stated that I didn’t have time for that and covered only the part of the challenge not related to SVG. I also said that, in the event that I find some time over the weekend, I might come back and fulfill the SVG part. I thought at the time that this was rather unlikely, but I was finally able to cover the SVG part, at least in Raku.

Task 1: Scalable Vector Graphics (SVG)

Scalable Vector Graphics (SVG) are not made of pixels, but lines, ellipses, and curves, that can be scaled to any size without any loss of quality. If you have ever tried to resize a small JPG or PNG, you know what I mean by “loss of quality”! What many people do not know about SVG files is, they are simply XML files, so they can easily be generated programmatically.

For this task, you may use external library, such as Perl’s SVG library, maintained in recent years by our very own Mohammad S Anwar. You can instead generate the XML yourself; it’s actually quite simple. The source for the example image for Task #2 might be instructive.

Your task is to accept a series of points and lines in the following format, one per line, in arbitrary order:

Point: x,y

Line: x1,y1,x2,y2

Example:

53,10
53,10,23,30
23,30

Then, generate an SVG file plotting all points, and all lines. If done correctly, you can view the output .svg file in your browser.

Scalable Vector Graphics (SVG) in Raku

I created two subroutines, make-point and make-line, to create the necessary data structures. The last item of the @input has three parts and should generate a warning, since input items should have either 2 or 4 parts.

Note that SVG probably includes a scaling factor, but I couldn’t find any information about it. So I rolled out my own \SCALE scaling factor to make the output larger and more readable.

use SVG;
my \SCALE = 5;

my ( @points, @lines);
my @input = <53,10  53,10,23,30  23,30  34,35,36>;
for @input -> $val {
    my @items = split /','/, $val;
    if @items.elems == 2 {
        make-point(@items)
    } elsif @items.elems == 4 {
        make-line(@items);
    } else { 
        note "Error on item ", @items;
    }
}

say ( SVG.serialize(svg => [ width => 500, height => 500, |@points, |@lines ] ));

sub make-point (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $point = circle =>  
        [ cx => @dots[0],
          cy => @dots[1],
          r => 3,
          fill => 'forestgreen' ];
    push @points, $point;
}

sub make-line (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $line = line => 
        [ x1 => @dots[0],
          y1 => @dots[1],
          x2 => @dots[2],
          y2 => @dots[3],
          stroke => 'navy' ];
    push @lines, $line;
}

The SVG output, slightly reformatted for better readability, is as follows:

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx="265" cy="50" r="3" fill="forestgreen" />
<circle cx="115" cy="150" r="3" fill="forestgreen" />
<line x1="265" y1="50" x2="115" y2="150" stroke="navy" /></svg>

And this is a graphical rendering of it:

Scalable Vector Graphics (SVG) in Perl

In Perl, for a change, we will write directly the SVG data.

use strict;
use warnings;
use feature "say";
use constant SCALE => 5;

my ( @points, @lines);
my $out = qq{<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">\n};
my @input = qw<53,10 53,10,23,30  23,30  34,35,36>;
for my $val (@input) {
    my @items = split /,/, $val;
    # say "@items";
    if (@items == 2) {
        make_point(@items)
    } elsif (@items == 4) {
        make_line(@items);
    } else { 
        warn "Error on item ", @items;
    }
}
$out .= "</svg>";
say $out;

sub make_point {
    my @dots = map $_ * SCALE, @_;
    my $point = qq{<circle cx= "$dots[0]" cy="$dots[1]" r="3" fill="forestgreen"/>\n};
    $out .= $point;
}

sub make_line {
    my @dots = map $_ * SCALE, @_;
    my $line = qq{<line x1="$dots[0]" y1="$dots[1]" x2="$dots[2]" y2="$dots[3]" };
    $line .= qq{stroke="navy" />\n};
    $out .= $line
}

This program displays the following SVG output:

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg"
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx= "265" cy="50" r="3" fill="forestgreen"/>
<line x1="265" y1="50" x2="115" y2="150" stroke="navy" />
<circle cx= "115" cy="150" r="3" fill="forestgreen"/>
</svg>

And this is the graphgical rendering:

Task 2: Line of Best Fit

When you have a scatter plot of points, a line of best fit is the line that best describes the relationship between the points, and is very useful in statistics. Otherwise known as linear regression, here is an example of what such a line might look like:

The method most often used is known as the least squares method, as it is straightforward and efficient, but you may use any method that generates the correct result.

Calculate the line of best fit for the following 48 points:

333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89

Using your rudimentary graphing engine from Task #1, graph all points, as well as the line of best fit.

So, Task 2 is about line of best fit or linear regression.

If we consider a cloud of n points with coordinates (x, y), the line of best fit is defined as follows:

The equation for the slope m is:

    n * sum(xy) - sum(x) * sum(y)
m = -----------------------------
    n * sum(x²) - sum(x) * sum(x)

The y-intercept (i.e. value of y on the vertical axis, when x = 0) b is:

    sum(y) - m * sum(x)
b = -------------------
           n

The equation of the line is:

y = mx + b

Line of Best Fit in Raku

The following program is an application of the explanations above. We split the input string on spaces and on commas, to get an array of (x, y) values. The lsm subroutine applies the above least square method formulas to find the slope and intercept. Note that for displaying line of best fit equation, we had to handle two different cases, depending on whether the intercept is positive or negative. Otherwise, for a negative intercept, we would display the line equation as follows:

The equation of the line of best fit is: y = 1.00 x + -1.00

which is not satisfactory.

Also note the use of the » hyper operator when reading the input data to apply the second split to each of the values returned by the first split.

Besides, we reuse the make-point and make-line subroutines created above (slightly modified) for preparing the SVG output.

use SVG;
my \SCALE = 1;

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

my @points = $input.split(/\s+/)>>.split(/','/);
my (@dots, @lines);
make-point($_) for @points;
my ($slope, $intercept) = lsm(@points);
say "Slope: $slope, intercept = $intercept";
my $sign = $intercept < 0 ?? '-' !! '+';
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n\n", $slope, $sign, $intercept.abs;
# compute some arbitrary values for the line - say for x = 400
my $x = 400;
my $y = $slope * $x + $intercept;
make-line([0, $intercept, $x, $y]);
say ( SVG.serialize(svg => [ width => 500, height => 500, |@dots, |@lines ]));

sub lsm (@points) {
    my ($s-x, $s-y, $s-xy, $s-x2) = 0 xx 4;
    for @points -> $point {
        my ($x, $y) = $point[0, 1];
        # say "$x $y";
        $s-x += $x;
        $s-y += $y;
        $s-xy += $x * $y;
        $s-x2 += $x ** 2;
    }
    my $n = @points.elems;
    my $slope = ($n * $s-xy - $s-x * $s-y) / ($n * $s-x2 - $s-x ** 2);
    my $intercept = ($s-y - $slope * $s-x) / $n;
    return $slope, $intercept;
}

sub make-point (@points is copy) {
    @points = map { $_ * SCALE }, @points;
    my $point = circle =>  
        [ cx => @points[0],
          cy => @points[1],
          r => 3,
          fill => 'forestgreen' ];
    push @dots, $point;
}

sub make-line (@dots) {
    @dots = map { $_ * SCALE }, @dots;
    my $line = line => 
        [ x1 => @dots[0],
          y1 => @dots[1],
          x2 => @dots[2],
          y2 => @dots[3],
          stroke => 'navy' ];
    push @lines, $line;
}

This program displays the following output:

$ ./raku lsm2.raku
Slope: -0.2999565, intercept = 200.132272536
The equation of the line of best fit is: y = -0.30 x + 200.13

<svg xmlns="http://www.w3.org/2000/svg" xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:xlink="http://www.w3.org/1999/xlink" width="500" height="500">
<circle cx="333" cy="129" r="3" fill="forestgreen" /><circle cx="39" cy="189" r="3" fill="forestgreen" />
<circle cx="140" cy="156" r="3" fill="forestgreen" /><circle cx="292" cy="134" r="3" fill="forestgreen" />
<circle cx="393" cy="52" r="3" fill="forestgreen" /><circle cx="160" cy="166" r="3" fill="forestgreen" />
<circle cx="362" cy="122" r="3" fill="forestgreen" /><circle cx="13" cy="193" r="3" fill="forestgreen" />
<circle cx="341" cy="104" r="3" fill="forestgreen" /><circle cx="320" cy="113" r="3" fill="forestgreen" />
<circle cx="109" cy="177" r="3" fill="forestgreen" /><circle cx="203" cy="152" r="3" fill="forestgreen" />
<circle cx="343" cy="100" r="3" fill="forestgreen" /><circle cx="225" cy="110" r="3" fill="forestgreen" />
<circle cx="23" cy="186" r="3" fill="forestgreen" /><circle cx="282" cy="102" r="3" fill="forestgreen" />
<circle cx="284" cy="98" r="3" fill="forestgreen" /><circle cx="205" cy="133" r="3" fill="forestgreen" />
<circle cx="297" cy="114" r="3" fill="forestgreen" /><circle cx="292" cy="126" r="3" fill="forestgreen" />
<circle cx="339" cy="112" r="3" fill="forestgreen" /><circle cx="327" cy="79" r="3" fill="forestgreen" />
<circle cx="253" cy="136" r="3" fill="forestgreen" /><circle cx="61" cy="169" r="3" fill="forestgreen" />
<circle cx="128" cy="176" r="3" fill="forestgreen" /><circle cx="346" cy="72" r="3" fill="forestgreen" />
<circle cx="316" cy="103" r="3" fill="forestgreen" /><circle cx="124" cy="162" r="3" fill="forestgreen" />
<circle cx="65" cy="181" r="3" fill="forestgreen" /><circle cx="159" cy="137" r="3" fill="forestgreen" />
<circle cx="212" cy="116" r="3" fill="forestgreen" /><circle cx="337" cy="86" r="3" fill="forestgreen" />
<circle cx="215" cy="136" r="3" fill="forestgreen" /><circle cx="153" cy="137" r="3" fill="forestgreen" />
<circle cx="390" cy="104" r="3" fill="forestgreen" /><circle cx="100" cy="180" r="3" fill="forestgreen" />
<circle cx="76" cy="188" r="3" fill="forestgreen" /><circle cx="77" cy="181" r="3" fill="forestgreen" />
<circle cx="69" cy="195" r="3" fill="forestgreen" /><circle cx="92" cy="186" r="3" fill="forestgreen" />
<circle cx="275" cy="96" r="3" fill="forestgreen" /><circle cx="250" cy="147" r="3" fill="forestgreen" />
<circle cx="34" cy="174" r="3" fill="forestgreen" /><circle cx="213" cy="134" r="3" fill="forestgreen" />
<circle cx="186" cy="129" r="3" fill="forestgreen" /><circle cx="189" cy="154" r="3" fill="forestgreen" />
<circle cx="361" cy="82" r="3" fill="forestgreen" /><circle cx="363" cy="89" r="3" fill="forestgreen" />
<line x1="0" y1="200.132272536" x2="400" y2="80.149672431" stroke="navy" />
</svg>

And this is a graphiical rendering of it:

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on May 29, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

On github, I've released MooseX::Extreme.

It's based on years of experience being the lead designer of the Corinna project and trying to figure out how we can get a version of Moose which is safer and easier to use, including removing a lot of boilerplate. This code:

package My::Class {
    use MooseX::Extreme;

    ... your code here
}

Is sort of the equivalent to:

package My::Class {
    use v5.20.0;
    use Moose;
    use MooseX::StrictConstructor;
    use feature qw(signatures postderef);
    no warnings qw(experimental::signatures experimental::postderef);
    use namespace::autoclean;
    use Carp;
    use mro 'c3';

    ... your code here

    __PACKAGE__->meta->make_immutable;
}

There's not need to end packages with a true value and MooseX::Extreme makes your class immutable for you.

But what's allowed in the constructor? I've regularly face the following problem:

package Some::Class;

use Moose;

has name     => (...);
has uuid     => (...);
has id       => (...);
has backlog  => (...);
has auth     => (...);
has username => (...);
has password => (...);
has cache    => (...);
has this     => (...);
has that     => (...);

Which of those should be passed to the constructor and which should not? Just because you can pass something to the constructor doesn't mean you should. Unfortunately, Moose defaults to "opt-out" rather than "opt-in" for constructor arguments. This makes it really easy to build objects, but means that you can pass things to the constructor and it won't always work the way you want it to.

There's an arcane init_arg => undef pair to pass to each to say "this cannot be set via the constructor," but many developers are either unaware of this is simply forget about it. MooseX::Extreme solves this by separating has into param (allowed in the constructor, but you can also use default or builder) and field, which is forbidden in the constructor. We can rewrite the above as this:

package Some::Class;

use MooseX::Extreme;

param name     => (...);
param backlog  => (...);
param auth     => (...);
param username => (...);
param password => (...);

field cache    => (...);
field this     => (...);
field that     => (...);
field uuid     => (...);
field id       => (...);

(Note: has is still available)

And now you can instantly see what is and is not intended to be allowed in the constructor.

It works with Perl versions from v5.20.0 onwards, has CI setup on github against all major Perl versions it supports, and even has some interesting fixes to make it work in the debugger.

In short, I'm trying to apply a list of safe (and conservative) defaults to Moose--I've deliberately omitted some features that would probably be overkill--and mostly just uses normal, sane modules.

It still needs more tests, so I won't release it right away, but it reduces boilerplate and and applies defaults that are generally popular. So what I should I rename it to before releasing to the CPAN?

These are some answers to the Week 165 of the Perl Weekly Challenge organized by Mohammad S. Anwar.

Spoiler Alert: This weekly challenge deadline is due in a few of days from now (on May 22, 2022 at 24:00). This blog post offers some (partial) solutions to this challenge, please don’t read on if you intend to complete the challenge on your own.

This week, Task 1 and part of Task 2 relate to Scalable Vector Graphics (SVG). I’ve been using SVG a very long time ago and certainly don’t remember any of the details. SVG is certainly not very difficult, and I would be delighted to refresh my memory on this subject, but it takes quite a bit of time to assimilate all the possibilities and options, and I don’t have time for that now. So, I will only cover for the moment the part of the challenge not related to SVG. In the (relatively unlikely) event that I find some time over the weekend, I might come back and fulfill the SVG part.

Update: I eventually covered the SVG part in Raku here.

So, Task 2 is about line of best fit or linear regression.

When you have a scatter plot of points, a line of best fit is the line that best describes the relationship between the points, and is very useful in statistics. Otherwise known as linear regression, here is an example of what such a line might look like:

The method most often used is known as the least squares method, as it is straightforward and efficient, but you may use any method that generates the correct result.

Calculate the line of best fit for the following 48 points:

333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89

If we consider a cloud of n points with coordinates (x, y), the line of best fit is defined as follows:

The equation for the slope m is:

    n * sum(xy) - sum(x) * sum(y)
m = -----------------------------
    n * sum(x²) - sum(x) * sum(x)

The y-intercept (i.e. value of y on the vertical axis, when x = 0) b is:

    sum(y) - m * sum(x)
b = -------------------
           n

The equation of the line is:

y = mx + b

Line of Best Fit in Raku

The following program is just an application of the explanations above. We split the input string on spaces and on commas, to get an array of (x, y) values. The lsm subroutine applies the above least square method formulas to find the slope and intercept. Note that for displaying line of best fit equation, we had to handle two different cases, depending on whether the intercept is positive or negative. Otherwise, for a negative intercept, we would display the line equation as follows:

The equation of the line of best fit is: y = 1.00 x + -1.00

which is not satisfactory.

Also note the use of the » hyper operator when reading the input data to apply the second split to each of the values returned by the first split.

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

# $input = '1,0 2,1 3,2 4,3'; # test with a negative intercept

my @points = $input.split(/\s+/)».split(/','/);
my ($slope, $intercept) = lsm(@points);
say "Slope: $slope, intercept = $intercept";
my $sign = $intercept < 0 ?? '-' !! '+'; 
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n", $slope, $sign, $intercept.abs;

sub lsm (@points) {
    my ($s-x, $s-y, $s-xy, $s-x2) = 0 xx 4;
    for @points -> $point {
        my ($x, $y) = $point[0, 1];
        $s-x += $x;
        $s-y += $y;
        $s-xy += $x * $y;
        $s-x2 += $x ** 2;
    }
    my $n = @points.elems;
    my $slope = ($n * $s-xy - $s-x * $s-y) / ($n * $s-x2 - $s-x ** 2);
    my $intercept = ($s-y - $slope * $s-x) / $n;
    return $slope, $intercept;
}

This program displays the following output:

$ raku ./lsm.raku
10366, 6497, 1220463, 2847440
Slope: -0.2999565, intercept = 200.132272536
The equation of the line of best fit is: y = -0.30 x + 200.13

Uncomment the line redefining the input string to display the result with a negative intercept:

$ raku ./lsm.raku
Slope: 1, intercept = -1
The equation of the line of best fit is: y = 1.00 x - 1.00

Line of Best Fit in Perl

We are applying here the same equations as before in Raku. For the final display of the line equation, we also have to handle separate cases, depending on whether the intercept is positive or negative. Perl doesn’t have the » hyper-operator, but it is quite easy to replace it with a map.

use strict;
use warnings;
use feature "say";

my $input =
   '333,129  39,189 140,156 292,134 393,52  160,166 362,122  13,193
    341,104 320,113 109,177 203,152 343,100 225,110  23,186 282,102
    284,98  205,133 297,114 292,126 339,112 327,79  253,136  61,169
    128,176 346,72  316,103 124,162  65,181 159,137 212,116 337,86
    215,136 153,137 390,104 100,180  76,188  77,181  69,195  92,186
    275,96  250,147  34,174 213,134 186,129 189,154 361,82  363,89';

# $input = '1,0 2,1 3,2 4,3';   # test with a negative intercept

my @points = map { [split /,/, $_] } split /\s+/, $input;
my ($sl, $inter) = lsm(@points);
say "Slope: $sl, intercept = $inter";
my $sign = $inter < 0 ? '-' : '+';
printf "The equation of the line of best fit is: y = %.2f x %s %.2f \n", $sl, $sign, abs $inter;

sub lsm {
    my @points = @_;
    my ($s_x, $s_y, $s_xy, $s_x2) = (0, 0, 0, 0);
    for my $point (@points) {
        my ($x, $y) = ($point->[0], $point->[1]);
        $s_x += $x;
        $s_y += $y;
        $s_xy += $x * $y;
        $s_x2 += $x ** 2;
    }
    my $n = scalar @points;
    my $slope = ($n * $s_xy - $s_x * $s_y) / ($n * $s_x2 - $s_x ** 2);
    my $intercept = ($s_y - $slope * $s_x) / $n;
    return $slope, $intercept;
}

This program displays the following output:

$ perl ./lsm.pl
Slope: -0.299956500261231, intercept = 200.132272535582
The equation of the line of best fit is: y = -0.30 x + 200.13

Uncomment the line redefining the input string to display the result with a negative intercept:

$ perl ./lsm.pl
Slope: 1, intercept = -1
The equation of the line of best fit is: y = 1.00 x - 1.00

Wrapping up

The next week Perl Weekly Challenge will start soon. If you want to participate in this challenge, please check https://perlweeklychallenge.org/ and make sure you answer the challenge before 23:59 BST (British summer time) on May 29, 2022. And, please, also spread the word about the Perl Weekly Challenge if you can.

1. App::Netdisco - An open source web-based network management tool.
   • Version: 2.052006 on 2022-05-17
   • Votes: 14
   • Previous version: 2.052005 was 25 days before
2. App::perlbrew - Manage perl installations in your $HOME
   • Version: 0.95 on 2022-05-15
   • Votes: 168
   • Previous version: 0.94 was 5 months, 11 days before
3. DBIx::Class - Extensible and flexible object <-> relational mapper.
   • Version: 0.082843 on 2022-05-17
   • Votes: 279
   • Previous version: 0.08271 was 5 years, 11 months before
4. LWP - The World-Wide Web library for Perl
   • Version: 6.66 on 2022-05-18
   • Votes: 156
   • Previous version: 6.65 was 9 days before
5. Modern::Perl - enable all of the features of Modern Perl with one import
   • Version: 1.20220515 on 2022-05-15
   • Votes: 47
   • Previous version: 1.20200211 was 2 years, 3 months, 4 days before
6. SPVM - SPVM Language
   • Version: 0.9517 on 2022-05-19
   • Votes: 26
   • Previous version: 0.9516 was 8 days before
7. SVG - Perl extension for generating Scalable Vector Graphics (SVG) documents.
   • Version: 2.87 on 2022-05-19
   • Votes: 18
   • Previous version: 2.86 was 1 year, 27 days before

This is the weekly favourites list of CPAN distributions. Votes count: 54

This week there isn't any remarkable distribution

Build date: 2022/05/21 13:37:15 GMT

Clicked for first time:

• Addr::MyIP - Get your public facing IPv4 or IPv6 address
• App::Pod - The great new App::Pod!
• App::ProxyThat - Proxy an URL from the command line
• Dancer2::Plugin::Auth::Extensible::Provider::DBIC - authenticate via the Dancer2::Plugin::DBIC plugin
• Stat::lsMode - format file modes like the ls -l command does
• Text::Abbrev - abbrev - create an abbreviation table from a list
• WebService::HashiCorp::Vault - Perl API for HashiCorp's Vault

Increasing its reputation:

• ack (+1=126)
• App::cpanminus (+1=264)
• App::MultiSsh (+1=3)
• App::perlbrew (+1=168)
• App::Uni (+1=15)
• Archive::Tar (+1=16)
• Carmel (+1=24)
• Carp::Always (+1=34)
• Carton (+1=114)
• CPAN (+1=34)
• Data::Dumper (+1=95)
• DateTime::Format::Natural (+1=16)
• DBI (+1=253)
• DBIx::Class::AuditAny (+1=2)
• Deep::Hash::Utils (+1=6)
• Devel::NYTProf (+1=175)
• Devel::PatchPerl (+1=7)
• Devel::Profile (+1=5)
• Excel::Grinder (+1=2)
• File::Fetch (+1=4)
• Getopt::Long (+1=110)
• Getopt::Mini (+1=7)
• Import::Into (+1=36)
• Inline::Files (+1=3)
• JavaScript::QuickJS (+1=2)
• lib::relative::to (+1=3)
• Linux::ACL (+1=2)
• List::UtilsBy (+1=36)
• Log::ger::App (+1=2)
• Map::Tube (+1=6)
• Modern::Perl (+1=47)
• Module::CoreList (+1=38)
• MooX::Private::Attribute (+1=2)
• MooX::Struct (+1=7)
• MooX::TO_JSON (+1=3)
• Net::Server (+1=30)
• Object::Pad (+1=28)
• Path::Tiny (+1=170)
• Perinci::CmdLine (+1=3)
• Perinci::CmdLine::Lite (+1=5)
• Pod::Perldoc (+1=8)
• Scalar::List::Utils (+1=159)
• Test::Output (+1=13)
• Win32::GUI (+1=8)
• XML::XPath (+1=7)
• XS::Parse::Keyword (+1=6)

These are the five most rated questions at Stack Overflow last week.
Between brackets: [question score / answers count]
Build date: 2022-05-21 13:35:54 GMT

1. How do you match \' - [3/2]
2. Problem accessing hash imported from CSV in Perl - [2/2]
3. Perl Split Function - How to assign a specify array value to a variable in one line - [1/1]
4. Perl - substring keywords - [1/1]
5. Perl print does not output to screen (when using Socket) - [1/1]

Here's a nice little project that went from a good idea to something useable in a couple of hours.

We all know (I hope) that there are lots of great libraries available on MetaCPAN. What isn't sometimes quite as obvious is how to use those libraries. The documentation is usually a pretty good reference but in many cases, what you really want is a good tutorial. And they seem pretty rare on CPAN.

There are, however, hundreds of good tutorials out there on the web. But that doesn't really help the people looking for documentation on MetaCPAN.

Yesterday there was a discussion on the TPF Slack about this very problem. Olaf Alders (who leads the team behind MetaCPAN) said that he would be happy to link to quality posts about modules that are on other sites.

This sounded interesting to me. And I started thinking about a web app where users could submit links to tutorials. The site would then produce an API which MetaCPAN (or, indeed, anyone else) could use to add links to those sites.

I was thinking about a Dancer2 app. Which would require users and authentication and hosting and all the stuff that comes with a web app. But then we realised that (at least as a proof of concept) none of that was actually needed. We could do it all on GitHub.

So now we have LearnCPAN. It's just a CSV file with three columns (distribution name, tutorial URL and tutorial title). If you want to submit a new tutorial, then you can simply create a pull request against the repo. Once your PR is merged, there's a simple GitHub Action which parses the CSV file and produces a JSON file which MetaCPAN can use to add tutorials to a distribution's page.

I've seeded the CSV with a couple of years of examples from the Perl Advent Calendar. But it's ready to take your submissions now.

Time::Piece is a date/time module that replaces the built-in functions gmtime() and localtime(). The replaced functions return a Time::Piece object, with accessors for the compontents of the time. Time::Piece also provides formatting, parsing, and arithmetic.

This module has been in core since Perl 5.9.5. I was able to get it to pass tests as far back as 5.8.1, though not 5.8.0 or 5.6.2.

Without this module, you would obtain the current Gregorian year in your local zone like this

my $year = ( localtime() )[5] + 1900;

or maybe

my ( undef, undef, undef, undef, undef, $year ) = localtime();
$year += 1900;

Neither is particularly self-documenting, and the latter is much more verbose than we expect of Perl.

But with Time::Piece, the code looks like this:

use Time::Piece;

my $year = localtime->year();

Yes, this actually gives you the Gregorian year. If you want the Perl year (Gregorian - 1900), you can use the _year() method instead. This is documented and therefore public, despite the leading underscore.

There are, of course, accessors for everything returned by the replaced core functions. In cases where the core function returns a value offset from the usually-displayed value, there are accessors for both.

Date arithmetic is implemented using operator overloading. Subtracting a Time::Piece from another yields a Time::Seconds object, which is also part of the Time-Piece distribution. You can also add seconds to a Time::Piece. Arithmetic takes account of summer time. If executed in zone America/New_York, the following

use 5.010;

use Time::Local;

use Time::Piece;

# Noon the day before the switch to daylight saving time (in America/New_York)

my $before = localtime( timelocal( 0, 0, 12, 12, 2, 2022 ) );

# Noon the day of the switch to daylight saving time (in America/New_York)

my $after  = localtime( timelocal( 0, 0, 12, 13, 2, 2022 ) );

say 'Before: ', $before->strftime();

say ' After: ', $after ->strftime();

my $delta = $after - $before;	# A Time::Seconds

say ' Delta: ', $delta->pretty();	# Only 23 hours.

prints

Before: Sat, 12 Mar 2022 12:00:00 EST
 After: Sun, 13 Mar 2022 12:00:00 EDT
 Delta: 23 hours, 0 minutes, 0 seconds

Note that Time::Piece is smart enough to handle objects from different zones. If one of the calls to localtime() in the above code is changed to gmtime() the corresponding time output will change, but the delta will remain the same.

The strftime() method takes the same format string as the strftime() POSIX subroutine, but without needing to load the POSIX module.

Date parsing is strptime()-style, and by default only parses American English. You can change this to your locale by calling Time::Piece->use_locale();, but be aware that this is a global setting.

Previous entries in this series:

1. if
2. diagnostics
3. Term::ReadLine::Perl
4. re
5. Devel::NYTProf
6. Errno

I started with a new project recently, which means I have to use yet another Google Workspace (i.e. gmail for businesses). While having the gmail webapp open in multiple Firefox Multi-Account Containers is an option, it's not something I like to do. And I don't really like the gmail web interface anyway. I prefer mutt (and use it since forever,,,). Some years ago I sort of managed to read gmail mails via IMAP, but couldn't get sending to work. So I decided to give this another try. And it worked!

Overview

• I have multiple separate gmail accounts
• I use mutt to read and write email
• I use offlineimap to download mails via IMAP onto my laptop (so I can read my mails while offline, and search through them on my disk)
• To send mails, I drop them into an exim running on my laptop, which then sends them via the mail service I use
  • This did not work for gmail, but I found something that works (see below)

Syncing gmail via offlineimap and an "app password"

This seems rather easy, but google does not really like you to use your regular password in automated tools. One solution is to use OAuth2, as described here. But this seems a bit to much hassle, so I choose the other route, i.e. setting up an "app password". An "app password" is a password that google generates for you so you can use it in various apps (of dubious security).

To get such an app password, you first have to secure your account with Two Factor Authentication (2FA) (if you haven't already done that):

• Go to https://myaccount.google.com
• Find "2-Step Verification" under the Security headline
• Go through the process. I use the "Google Authenticator" app on my mobile phone
• After you've set this up, you'll find the new option "App passwords" under "Security" / "Signing into Google"
• Select an app ("Mail") and give it a custom name (eg "offlineimap"), click on "generate" and copy the password (you'll never see it again!)

Now you can add a new Account to your .offlineimaprc:

[Account FOO]
localrepository = LocalFoo
remoterepository = RemoteFoo
synclabels = yes

[Repository LocalFoo]
type = Maildir
localfolders = /path/to/mails/Foo

[Repository RemoteFoo]
type = IMAP
remotehost = imap.gmail.com
# if you have a custom domain set up:
remoteuser = foo@example.com
# if you use a plain gmail account:
# remoteuser = foo@gmail.com
remotepass = your-app-password
ssl = yes
sslcacertfile = /etc/ssl/certs/ca-certificates.crt

Before you run offlineimap you might want to consider configuring your gmail labels (i.e. what google uses for mail folders). Google sets up a bunch of (IMO stupid) default labels. It will also duplicate mails, because all mails stay in the Inbox and will be sort-of-copied into folders (if the label matches). So go to your gmail settings (click on the gear-wheel, then "See all settings"), go to "Labels" and uncheck the "Show in IMAP" box on all labels (except Inbox, which you cannot uncheck anyway..). If you have set up mail filters, make sure they have the "Skip Inbox" flag set, otherwise you'll get them twice.

Now is also a good time to clean up your Inbox (or you'll wait a long time on the first sync..)

Configuring mutt

The first thing we need to do is to tell mutt about the new folder / labels / mailboxes (in mutt language..):

+mailboxes =Foo/INBOX +Foo/'[Gmail].Sent Mail' +Foo/some_label

Foo here is the actual directory name of the maildir you specified in offlineimap: localfolders = /path/to/mails/Foo. You can list all the labels you enabled for IMAP here, and mutt will automatically jump to the mail folder if there is new mail after an offlineimap run.

Another thing I like to do is to set up a separate "profile" for each account, using a different color and sender for each project. For this I set up a file like this in my ~/.mutt/:

# file: ~/.mutt/profile_foo
set from="Thomas Klausner <domm@example.net>"
set use_from
set envelope_from
set signature=~/.foo_signature
color indicator black brightgreen

This will make sure I use the right sender, and will also alert me as who I am currently writing by setting the indicator to a specific color.

But how do we enable this profile? Via a folder-hook:

folder-hook =Foo "source ~/.mutt/profile_foo\n"

Anytime we enter a folder under Foo, we source this profile. Nice!

Sending mail

But how can we now actually send mail using the gmail sender? Thanks to spammers, you cannot just use any sender address with any SMTP server anymore, they are much stricter now (and gmail even more so). So we need to send mails via gmail, using the correct set of credentials. I assume that exim has some setting to do this, but I found an easier way:

Mutt can send mail not only via localhost, but also directly via SMTP!

All we have to do is add something like this to our ~/.mutt/profile_foo

set smtp_url = "smtps://foo@example.com:your-app-password@smtp.gmail.com:465"

And we also need to unset smtp_url for the default account (which uses the local exim). So in the default_profile just add unset smtp_url. And load the default profile via another folder hook:

folder-hook . "source ~/.mutt/profile_default\n"

And that's how I prevented going crazy having to juggle multiple gmail accounts!

One downside of this approach is that the app passwords are now lying around on my disk, so anybody with access to my disk can read/send mails. In case I know my disk has been compromised, I could disable the app passwords in my google account settings. But a nicer approach would be to store them in some password store (I use gopass) and somehow inject them after unlocking them. This will have to wait for another time...

Durante um ano e meio trabalhei com o mojolicious em um projeto legado dentro de uma empresa de telecomunicações. Aprendi a fazer diversas coisas com ele e hoje vim contar para vocês como ele funciona.

O que é?

O mojolicious é um framework composto de um conjunto de componentes para desenvolvimento Web em tempo real com Perl usando um MVC bem estruturado. Abaixo podemos observar alguns dos seus recursos disponíveis:

• Implementação cliente/servidor HTTP e WebSocket com IPv6, TLS, SNI, IDNA, proxy HTTP/SOCKS5, socket de domínio UNIX, Comet (long polling), Promises/A+, async/await, keep-alive, timeout, suporte a compressão cookie, multipart e gzip.
• Servidor da Web de E/S sem bloqueio integrado, com suporte a vários loops de eventos, bem como pré-bifurcação opcional, perfeito para criar serviços da Web altamente escaláveis.
• Analisador JSON e HTML/XML com suporte a seletores CSS.

Como usar?

Perlbrew

Recomendo que como primeiro passo para programar em Perl baixem o gerenciador de instalação Perlbrew. Ele vai te ajuda-los a ter várias versões do perl instaladas no seu computador e te auxiliar a administra-las de maneira bem simples.

Para instalar o Perlbrew basta executar o seguinte comando no terminal:

$ curl -L https://install.perlbrew.pl | bash

Para instalar a versão estável mais recente e usá-la a partir de agora:

$ perlbrew install perl-5.34.0
$ perlbrew switch perl-5.34.0

Para programar com a versão mais atualizada, mas apenas no terminal atual:

$ perlbrew install perl-blead
$ perlbrew use perl-blead

Para executar meuprograma.pl em todas as instalações do perl, muito útil ao fazer testes:

$ perlbrew exec perl meuprograma.pl

Para a folha de dicas de uso básico:

$ perlbrew -h

Para mais descrições sobre comandos:

$ perlbrew help

Instalação

A instalação do mojolicious pode ser feita de maneira rápida no terminal por meio de apenas uma linha:

$ curl -L https://cpanmin.us | perl - -M https://cpan.metacpan.org -n Mojolicious

Hello Word!

Como prometido, abaixo mostro a vocês como é simples escrever uma aplicação Web completa com o mojolicious utilizando apenas as linhas a seguir:

#!/usr/bin/env perl
use Mojolicious::Lite;

get '/' => {text => 'Hello Word!'};

app->start;

Basta salvar o arquivo com a extensão .pl e executa-lo usando morbo para inicia-lo com servidor web integrado.

$ morbo hello.pl
Web application available at http://127.0.0.1:3000

$ curl http://127.0.0.1:3000/
Hello Word!

👋🏻 Então pessoal, como viram a cima usar o mojolícious não é tão difícil, e como disse no começo ele pode nos ajudar em diversas coisas. Nos próximos posts irei ensinar a vocês todos os principais recursos desse framework e as classes que o compõem. fiquem ligados para os próximos posts. Até a próxima.

Hi there,

I am a big fan OOP and can't wait to see Modern Object in Perl, Corinna, to be part of core Perl. Last update I had was in early January by Curtis. You can checkout the details here.

If you are new to Corinna then I would recommend you checkout this post by Curtis. Those who don't know, Curtis is leading the team working on Corinna.

Talking about OOP, I came across another post by none other than Curtis himself sharing the common issues with OO code. This should be taught to anyone starting OO in any language and not just Perl, in my humble opinion. Having read it few times already from start to end in one go, I keep going back to it to keep myself reminded about it all the time. You would definitely want to bookmark it for future reference.

Few weeks ago, I shared post Why is Object-Oriented Programming Bad? by Curtis. My favourite line in the post, "I think there’s a good case to be made that OOP is not nearly as useful as it’s claimed.". Mind you, this is coming from Curtis.

Enough of OO, lets talk about Exceptions in Perl, I would like to share the blog post by Curtis (once again), where he points out the common issue in Perl. It reminded me about my recent post sharing the new try/catch block in Perl v5.34.

Last but not the least, please find this gem by Curtis talking about testing database operations with a fresh instance of SQLite everytime. I wonder, if this can be shared as CPAN module. Just thinking out loud, I know.

Enjoy the rest of the newsletter.

Part of the Dancer2 video course available both to Pro subscribers and attendees of the Perl Dancer course on Leanpub.

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1

Write a script to find all prime numbers less than 1000, which are also palindromes in base 10.

Solution

use strict;
use warnings;
use Math::Primality qw/is_prime/;

sub palindrome_primes_under{
    my($n) = shift;
    my @palindrome_primes;
    {
        $n--;
        unshift @palindrome_primes, $n if(is_prime($n) && join("", reverse(split(//, $n))) == $n);
        redo if $n > 1;  
    }
    return @palindrome_primes;
}

MAIN:{
    print join(", ", palindrome_primes_under(1000));
}

Sample Run

$ perl perl/ch-1.pl
2, 3, 5, 7, 11, 101, 131, 151, 181, 191, 313, 353, 373, 383, 727, 757, 787, 797, 919, 929

Notes

I have become incorrigible in my use of redo! The novelty just hasn't worn off I suppose. There is nothing really wrong with it, of course, it's just not particularly modern convention what with it's vaguely goto like behavior. Anyway, there's not a whole lot to cover here. All the real work is done in the one line which tests both primality and, uh, palindromedary.

Part 2

Write a script to find the first 8 Happy Numbers in base 10.

Solution

use strict;
use warnings;
use boolean;
use constant N => 8;

sub happy{
    my $n = shift;
    my @seen;
    my $pdi = sub{
        my $n = shift;
        my $total = 0;
        {
            $total += ($n % 10)**2;
            $n = int($n / 10);
            redo if $n > 0;
        }
        return $total;
    };
    {
        push @seen, $n;
        $n = $pdi->($n);
        redo if $n > 1 && (grep {$_ == $n} @seen) == 0; 
    }
    return boolean($n == 1);
}

MAIN:{
    my $i = 0;
    my @happy;
    {
        $i++;
        push @happy, $i if happy($i);
        redo if @happy < N;
    }
    print join(", ", @happy) . "\n";
}

Sample Run

$ perl perl/ch-2.pl
1, 7, 10, 13, 19, 23, 28, 31

Notes

This solution has even more redo, huzzah! Again, fairly straightforward bit of code which follows the definitions. The happiness check is done using a perfect digit invariant (PDI) function, here rendered as an anonymous inner subroutine. A good chance here when looking at this code to remind ourselves that $n inside that anonymous subroutine is in a different scope and does not effect the outer $n!

References

Challenge 164

1. App::lcpan - Manage your local CPAN mirror
   • Version: 1.070 on 2022-05-09
   • Votes: 14
   • Previous version: 1.069 was 3 days before
2. Carmel - CPAN Artifact Repository Manager
   • Version: v0.1.56 on 2022-05-11
   • Votes: 23
   • Previous version: v0.1.46 was 4 days before
3. Kelp - A web framework light, yet rich in nutrients.
   • Version: 1.06 on 2022-05-09
   • Votes: 44
   • Previous version: 1.05 was 1 year, 3 months, 19 days before
4. LWP - The World-Wide Web library for Perl
   • Version: 6.65 on 2022-05-09
   • Votes: 156
   • Previous version: 6.64 was 13 days before
5. Minilla - CPAN module authoring tool
   • Version: v3.1.18 on 2022-05-10
   • Votes: 54
   • Previous version: v3.1.17 was 9 days before
6. Object::Pad - a simple syntax for lexical field-based objects
   • Version: 0.65 on 2022-05-10
   • Votes: 27
   • Previous version: 0.64 was 1 month, 8 days before
7. SPVM - SPVM Language
   • Version: 0.9516 on 2022-05-11
   • Votes: 26
   • Previous version: 0.9514 was 10 days before

This is the weekly favourites list of CPAN distributions. Votes count: 37

Week's winner: Carmel (+5)

Build date: 2022/05/14 13:08:54 GMT

Clicked for first time:

• Devel::DTrace::Provider - Create DTrace providers for Perl programs.
• Net::OpenSRS - Domain registration via the Tucows OpenSRS HTTPS XML API
• OO::DateTime - Lightweight normalised datetime data type
• Quantum::Superpositions::Lazy - Weighted QM-like superpositions with lazy evaluation
• Sys::Utmp - Object(ish) Interface to UTMP files.

Increasing its reputation:

• App::ModuleBuildTiny (+1=11)
• Carmel (+5=23)
• Carton (+2=113)
• CPAN::Meta (+1=24)
• Dancer2::Plugin::CSRF (+1=2)
• Dist::Zilla (+1=176)
• Domain::PublicSuffix (+1=6)
• Feature::Compat::Try (+1=9)
• Getopt::Long (+2=110)
• HTTP::CookieJar (+1=7)
• Import::Base (+1=16)
• IO (+1=57)
• IPTables::ChainMgr (+1=2)
• Keyword::Simple (+1=15)
• lib::relative::to (+1=2)
• Moo (+1=286)
• Moose (+1=320)
• Net::DRI (+1=3)
• Net::Whois::Parser (+1=2)
• Net::Whois::Raw (+1=8)
• perl (+1=392)
• Template::Toolkit (+1=136)
• Text::ANSITable (+1=18)
• Time::Date (+1=2)
• Win32 (+1=11)
• XML::XPath (+1=6)

Hi,

Two weeks ago I switched the email sending from an old mailman installation on my own server to Sendgrid. I was hoping to fix the delivery issues, but that did not happen. Some subscribers who have not received the newsletter earlier started to receive it, others stopped receiving it. The big difference is that now I see a report of who has not received it. For example I see many @cpan.org addresses in the bounce list. That's just sad. I got some offers to use other services, free of charge, but frankly I am quite tired of fighting the SPAM filters.

In other news, we really hardly have any items to include in the newsletter. Well, except of the responsed to The Weekly Challenge, the job posts, and the posts of Flavio Poletti.

These two issues together, and I really started to wonder if we should continue publishing the newsletter. What do you think?

Enjoy your week!

Part of the Dancer2 video course available both to Pro subscribers and attendees of the Perl Dancer course on Leanpub.

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

You are given a list of numbers. Write a script to calculate the sum of the bitwise & operator for all unique pairs.

Solution

use strict;
use warnings; 

sub sum_bitwise{
    my $sum = 0;
    for my $i (0 .. @_ - 2){
        my $x = $_[$i];
	map {$sum += ($x & $_)} @_[$i + 1 .. @_ - 1];
    }
    return $sum; 
}

MAIN:{
    print sum_bitwise(1, 2, 3) . "\n";  
    print sum_bitwise(2, 3, 4) . "\n";
}  

Sample Run

$ perl perl/ch-1.pl
3
2

Notes

Part 2

Given a list of numbers @n, generate the skip summations.

use strict;
use  warnings;

sub skip_summations{
    my @lines = ([@_]);
    for my $i (1 .. @_ - 1){
        my @skip = @{$lines[$i - 1]}[1 .. @{$lines[$i - 1]} - 1];
        my $line = [map {my $j = $_; $skip[$j] + unpack("%32I*", pack("I*", @skip[0 .. $j - 1]))} 0 .. @skip - 1];
        push @lines, $line;
    }
    return @lines;
}

MAIN:{
    for my $line (skip_summations(1, 2, 3, 4, 5)){
        print join(" ", @{$line}) . "\n";
    }
    print "\n";
    for my $line (skip_summations(1, 3, 5, 7, 9)){
        print join(" ", @{$line}) . "\n";
    }
}

Sample Run

$ perl perl/ch-2.pl
1 2 3 4 5
2 5 9 14
5 14 28
14 42
42

1 3 5 7 9
3 8 15 24
8 23 47
23 70
70

Notes

References

Challenge 163

A new release of the Perl distribution Crypt::OpenSSL::X509 have been uploaded to CPAN.

The release contains contributions from 5 separate people including myself.

• 9 PRs merged
• 4 issues addressed

The PRs had been building up for some time, so I am very happy I was able to find the time to go through them all. There are still 10 open issues and I hope they can get some attention too.

The biggest challenge is OpenSSL 3 support, where we are not exactly there, but I believe we are at a more stable point now, which is a good starting point for this work.

From the trial release was made (2022-04-26) to now, two bugs were addressed and fixed. Both where introduced with 1.9.14-TRIAL.

• One should have been caught by me in my review
• Another was introduced by me in an attempt to streamline some code

So in retrospect, just like with the improvements to the CI work and use of the trial release process, I will work to improve in this area - I am thankful for the PRs, which corrected my errors, but the issues where... obvious and should never have been there.

Luckily the contributors, were quick in addressing these and PRs where received an processed, making it into the final release.

Thanks to all who contributed:

• @ikedas
• @timlegge
• @michal-josef-spacek
• @skaji

Change log

1.9.14 2022-05-03

• Applied PR #109 from @ikedas fixing a bug found in 1.9.14-TRIAL, where the wrong API was called, propably due to a typo in the name

• Applied PR #108 from @skaji a bug found in 1.9.14-TRIAL, where a possible interpolatation was probibited due to quoting

• Applied patch from @ikedas PR #105 make the pattern match for LLVM version number in the 12 series a bit more liberal. This was followed up by PR #107 by @jonasbn

• Applied patch from @timlegge PR #102 adressing issues: #45 and #95 with only a more strict use of compiler flags if environment variable AUTHOR_TESTING is set to true

• Added enhancement from @michal-josef-spacek introducing use of Crypt::OpenSSL::Guess, which can be used to determine placement of OpenSSL libraries via PR #104. The idea originates from issue #97 raised by @ikedas and addresses: #94 also from @ikedas

• The above was followed up by a PR from @jonasbn #106 enabling installation of configure section for CI jobs for both cpanm and cpm

• Metadata on bug tracker was updated with release 1.9.13, documentation updated with this release. Addressing issue #80 raised by @skaji, update by @jonasbn

• Patch from @timlegge via PR #103 improving handling of OpenSSL API versions

• Patch from @skaji via PR #100 making use of constants in XS code

Hi there,

I wish all the readers of the weekly newsletter, a very Happy Idd. We are celebrating Idd today in England and luckily it is a Bank Holiday as well.

I have seen Facebook post about the upcoming The Perl and Raku Conference 2022, Houston, TX. With this, I kept wondering why not have London Perl Workshop 2022 too? Being member of the LPW organizing team, I discussed it with fellow member, Julien. Good news is he seems positive about it as well. I don't know whether we have enough time to kickstart the process. Just hoping we get the opportunity to organize the conference. It has been a long time since we last had the gatherings in London. We had German Perl Workshop organized successfully only recently. Although I didn't see a single event report published by attending members unfortunately. I remember last time when I attended the German Perl Workshop, there were plenty of post event reports published as per the tradition.

Enjoy rest of the newsletter.

The examples used here are from The Weekly Challenge problem statement and demonstrate the working solution.

Part 1

Write a script to generate the check digit of a given ISBN-13 code.

Solution

use strict;
use warnings;

sub isbn_check_digit{
    my($isbn) = @_;
    my $i = 0;
    my @weights = (1, 3);
    my $check_sum = 0;
    my $check_digit;
    map {$check_sum += $_ * $weights[$i]; $i = $i == 0 ? 1 : 0} split(//, $isbn);
    $check_digit = $check_sum % 10;
    return 10 - $check_digit;
}

MAIN:{
    print isbn_check_digit(978030640615) . "\n";
}

Sample Run

$ perl perl/ch-1.pl
7   

References

Challenge 162

Stats

Number of new CPAN distributions this period: 54

Number of authors releasing new CPAN distributions this period: 33

Authors by number of new CPAN distributions this period:

I was getting more and more annoyed with twitter in the last few months (mostly because I had to click "See [some annoying feature] less often" several times a day) and the whole Musk-takeover finally pushed me over the edge. I've set up an account on Mastodon Technology and plan to use this nice, open source, federated tool more and more, and leave twitter behind.

I never really used twitter as a primary platform, but used it to automatically "promote" some of the stuff that's happening on this website. So now I have to port this tools to use Mastodon. Which turned out to be quite easy:

Mastodon API

Mastodon obviously has an API and a nice Perl client, Mastodon::Client. To access the API I had to set up an "app" and get an access token. Easy.

Blio Integration

This static website is generated using my static site generator, Blio. I run Blio via a build.pl script, that does various things besides just building the HTML. Among those things is auto-posting new posts to Twitter:

sub tweet_new_post {
    my $node = shift;

    my $status = $node->stash->{tweet};
    if (!$status && $node->stash->{autotweet}) {
        $status = "New blog post: ".$node->title;
    }
    return unless $status;
    return if $tweeted{$node->url};

    my $link = ' '.$blio->site_url.'/'.$node->url;

    my $tweet = length($status) > 250  ? substr($status,0,145) : $status;
    $tweet.=$link;
    _tweet($tweet);

    my $fh = $index_file->opena;
    say $fh $node->url;
    close $fh;
}

This checks if a node either contains an explicit tweet or has the autotweet flag set (in which case the status is generated from the node title). It checks in a very simple file-based database if this node ($node->url) has already been posted and aborts if it has (so I don't end up tweeting the same post multiple times).

Then I append the link to the new post to the tweet, after maybe shortening the status if it is too long. Now I call _tweet($tweet), which uses Net::Twitter::Lite::WithAPIv1_1 to post the message. Finally I add the current node url to the file DB.

toot!

Posting to Mastodon is called tooting, so let's do that:

   my $toot = length($status) > 450  ? substr($status,0,450) : $status;
   $toot.=$link;
   _toot($toot);

Toots can be longer than tweets, so I've adapted the truncation a bit.

sub _toot {
    my ( $status ) = @_;

    eval {
        my $conf = do $blio->output_dir->parent->file('mastodon.conf')->stringify;
        my $client = Mastodon::Client->new({
            %$conf,
            coerce_entities => 1,
        });

        my $post = $client->post_status( $status );
        return $post;
    };
    if (!$post || $@) {
        say "error while tooting: ".$@;
        return;
    }
    else {
        say "successfully tooted: ".$post->content;
        return 1;
    }
}

The file mastodon.conf contains the instance URL, access token etc and is in fact a small Perl snippet which I just load using do. Using this config, I initiate a new Mastodon::Client, and call post_status. Very easy!

Now I'm very curious if it will work when I publish this post...

This post describes the actual Like/Dislike mechanism in the program based on Mojolicious. Web pages style is created using the Bootstrap framework. The full version of the Mojolicious like-dislike demo can be downloaded at: https://github.com/arslonga/like-dislike

So, in the start package Vote.pm we create routers for the post with a certain ID in the section named 'first-section' (for example), and also for like and dislike:

sub startup {
my $self = shift;

my $r = $self->routes;
...
$r->any('/first-section/:id' => [ id => qr/[0-9]+/ ] )->to('post#article');
...
$r->any('/likeartcl')->to('voting#like');
$r->any('/dislikeartcl')->to('voting#dislike');
...
}

A snippet of code in the Post.pm package that describes the 'article' method:

package Vote::Controller::Post;
use Mojo::Base 'Mojolicious::Controller';
use Session;
use SessCheck;
...
#---------------------------------
sub article {
#---------------------------------
my $self = shift;
my $id = $self->stash('id');
my($nickname, $status, $client_check, $user_id, $title_alias);


eval{
$nickname = $self->session('client')->[0];
$user_id = $self->session('client')->[2]; 
};
$client_check = SessCheck->client( $self, $nickname );
if( !$client_check ){
    $status = ' disabled';
}
$title_alias = (split(/\//, $self->req->url))[1];
my $data = $self->db->select( 'posts', ['*'], {id => $id} )->hash;

$self->render( 
dat             => $data,
section_ident   => $title_alias,
id              => $id,
like_id         => 'like_'.$title_alias.'_'.$id,
unlike_id       => 'unlike_'.$title_alias.'_'.$id,
client_id       => $user_id,
unlike_btn_name => 'unlike'.$title_alias.'_'.$id,
like_btn_name   => 'like'.$title_alias.'_'.$id,
status          => $status,
liked_cnt       => $data->{liked} || 0,
unliked_cnt     => $data->{unliked} || 0
);
}#---------------
...
1;

Template article.html.ep in /templates/post

% layout 'vote';

<hr>
<a class="btn btn-info" href="/first-section" role="button">
<span class="glyphicon glyphicon-arrow-left"></span>
</a>
<hr>
<div>
    <h2><%= $dat->{title} %></h2>
    <%= $dat->{body} %>
</div>
<hr>
<div class="ld-box text-right">

%# Rendering a template that describes a block of code
%# that contains two buttons:
%# 'like' and 'dislike'

<%= include 'voting/vote' %>
</div>

<script>
//---------- Like/Dislike block ---
async function LikeArtcl(titleAlias, articleId, vote_span, user_id) {
let likedislikeBox = document.querySelector('.ld-box');

  let response = await fetch("/likeartcl?title_alias=" + 
  titleAlias + 
  '&article_id=' + 
  articleId + 
  '&vote_span=' + 
  vote_span + 
  '&user_id=' + 
  user_id);

  if (response.ok) {
    let respRendr = await response.text(); 
    likedislikeBox.innerHTML = respRendr;
  }else {
    alert("Error HTTP: " + response.status);
  }
}

async function UnlikeArtcl(titleAlias, articleId, vote_span, user_id) {
let likedislikeBox = document.querySelector('.ld-box');

  let response = await fetch("/dislikeartcl?title_alias=" + 
  titleAlias + 
  '&article_id=' + 
  articleId + 
  '&vote_span=' + 
  vote_span + 
  '&user_id=' + 
  user_id);

  if (response.ok) {
    let respRendr = await response.text(); 
    likedislikeBox.innerHTML = respRendr;
  }else {
    alert("Error HTTP: " + response.status);
  }
}
//---------- Like/Dislike block END ---
</script>

Package Session.pm:

package Session;
use Mojo::Base -base;

#---------------------------------
sub user {
#---------------------------------
my($self, $c, $login, $password, $id) = @_;

$c->session( client => [$login, $password, $id], expiration => 120);
return 1;
}#---------------

# 'voting' method of Session called in 'Voting.pm' package (see code fragment below)
#---------------------------------
sub voting {
#---------------------------------
my($self, $c, $user_vote_id, $title_alias_and_id) = @_;
$c->signed_cookie( $user_vote_id => $title_alias_and_id, {expires => time + 120});
return 1;
}#---------------

#---------------------------------
sub client_expire {
#---------------------------------
my($self, $c) = @_;
delete $c->session->{'client'};
return 1;
}#---------------
1;

Package Vote/Voting.pm
Here we render template 'voting/vote.html.ep' that describes code block with 'like' and 'dislike' buttons and 'like' and 'dislike' counts

package Vote::Voting;
use Mojo::Base 'Mojolicious::Controller';
use Mojo::Util qw(trim encode decode);
use Mojo::Cookie;
use Session;

#---------------------------------
sub like {
#---------------------------------
my $self = shift;
my($nickname, $status);
eval{
$nickname = $self->session('client')->[0];  
};
my $client_check = SessCheck->client( $self, $nickname );

my $title_alias = $self->param('title_alias');
my $article_id  = $self->param('article_id');
my $user_id     = $self->param('user_id');

$status = !$client_check ? ' disabled' : '';

my $like_count = $self->db->select( 'posts', 
                                  ['liked'], 
                                  {id => $article_id} )
                                  ->hash->{liked};
my $unlike_count = $self->db->select( 'posts', 
                                    ['unliked'], 
                                    {id => $article_id} )
                                    ->hash->{unliked};
my $like_cookie_name = 'like_user'.$user_id.'_'.$title_alias.'_'.$article_id;
my $unlike_cookie_name = 'unlike_user'.$user_id.'_'.$title_alias.'_'.$article_id;

if( !$self->signed_cookie( $like_cookie_name ) && $client_check ){
    ++$like_count;
    $self->db->update( 'posts', 
                     {'liked' => $like_count}, 
                     {'id' => $article_id} );
}

if( $self->signed_cookie( $unlike_cookie_name ) ){
    --$unlike_count;
    $self->db->update( 'posts', 
                     {'unliked' => $unlike_count}, 
                     {'id' => $article_id} );
    $self->signed_cookie( $unlike_cookie_name => '', {expires => 1});
}

# Store session for 'like' action where key is 
#'like_user'.$user_id.'_'.$title_alias.'_'.$article_id
# and value is $title_alias.'_'.$article_id
Session->voting( $self, 
                 'like_user'.$user_id.'_'.$title_alias.'_'.$article_id, 
                 $title_alias.'_'.$article_id 
               );

$self->render(
template        => 'voting/vote',
section_ident   => $title_alias,
id              => $article_id,
like_id         => 'like_'.$title_alias.'_'.$article_id,
unlike_id       => 'unlike_'.$title_alias.'_'.$article_id,
client_id       => $user_id,
unlike_btn_name => 'unlike'.$title_alias.'_'.$article_id,
like_btn_name   => 'like'.$title_alias.'_'.$article_id,
status          => $status,
liked_cnt       => $like_count,
unliked_cnt     => $unlike_count
);
}#---------------

#---------------------------------
sub dislike {
#---------------------------------
my $self = shift;
my($nickname, $status);
eval{
$nickname = $self->session('client')->[0];  
};
my $client_check = SessCheck->client( $self, $nickname );

my $title_alias = $self->param('title_alias');
my $article_id  = $self->param('article_id');
my $user_id     = $self->param('user_id');

$status = !$client_check ? ' disabled' : '';

my $unlike_count = $self->db->select( 'posts', 
                                    ['unliked'], 
                                    {id => $article_id} )
                                    ->hash->{unliked};
my $like_count = $self->db->select( 'posts', 
                                  ['liked'], 
                                  {id => $article_id} )
                                  ->hash->{liked};
my $like_cookie_name = 'like_user'.$user_id.'_'.$title_alias.'_'.$article_id;
my $unlike_cookie_name = 'unlike_user'.$user_id.'_'.$title_alias.'_'.$article_id;

if( !$self->signed_cookie( $unlike_cookie_name ) && $client_check ){
    ++$unlike_count;
    $self->db->update( 'posts', 
                     {'unliked' => $unlike_count}, 
                     {'id' => $article_id} );
}

if( $self->signed_cookie( $like_cookie_name ) ){
    --$like_count;
    $self->db->update( 'posts', 
                     {'liked' => $like_count}, 
                     {'id' => $article_id} );
    $self->signed_cookie( $like_cookie_name => '', {expires => 1});
}

# Store session for 'dislike' action where key is 
#'unlike_user'.$user_id.'_'.$title_alias.'_'.$article_id
# and value is $title_alias.'_'.$article_id
Session->voting( $self, 
                 'unlike_user'.$user_id.'_'.$title_alias.'_'.$article_id, 
                 $title_alias.'_'.$article_id );

$self->render(
template        => 'voting/vote',
section_ident   => $title_alias,
id              => $article_id,
like_id         => 'like_'.$title_alias.'_'.$article_id,
unlike_id       => 'unlike_'.$title_alias.'_'.$article_id,
client_id       => $user_id,
unlike_btn_name => 'unlike'.$title_alias.'_'.$article_id,
like_btn_name   => 'like'.$title_alias.'_'.$article_id,
status          => $status,
unliked_cnt     => $unlike_count,
liked_cnt       => $like_count
);
}#---------------
1;

Template voting/vote.html.ep
Use it for both rendering 'like' and 'dislike' actions

%# voting/vote.html.ep

<button type="button" name="<%= $like_btn_name %>" 
onclick="Voting('<%= $section_ident %>', 
                   '<%= $id %>', 
                   '<%= $like_id %>', 
                   '<%= $client_id %>'); 
                   this.disabled='disabled';" 
                   id="chevron_stl"<%= $status %>>
<span id="<%= $section_ident.'_'.$client_id.'-up' %>" 
class="glyphicon glyphicon-chevron-up" aria-hidden="true"></span>
</button>
<span id="<%= $like_id %>" class="like_unlike"><%= $liked_cnt %></span>

<button type="button" name="<%= $unlike_btn_name %>" 
onclick="Voting('<%= $section_ident %>', 
                     '<%= $id %>', 
                     '<%= $unlike_id %>', 
                     '<%= $client_id %>'); 
                     this.disabled='disabled';" 
                     id="chevron_stl"<%= $status %>>
<span id="<%= $section_ident.'_'.$client_id.'-down' %>" 
class="glyphicon glyphicon-chevron-down" aria-hidden="true"></span>
</button>
<span id="<%= $unlike_id %>" class="like_unlike"><%= $unliked_cnt %></span>

Conclusion

Use the combination of article ID, user ID, and kind of action (like or dislike) to create a unique voting ID. This voting ID can be a key of signed cookie.

A simplified like/dislike system implemented in my project MornCat CMS at https://github.com/arslonga/my_blog

Como começar a programar em Perl da maneira correta. (Diferente de mim)

Perl Orientado a Objeto Part I

Perl Orientado a Objeto Part II

Perl Orientado a Objeto Part III

Moo - Orientação de objeto minimalista

O que é o Moo

Diferente do Moose, que vimos anteriormente, o Moo é um sistema de orientação a objetos extremamente leve. Permitindo definições de objetos e funções de maneira bem simples. Tem um sub-conjunto do Moose o Moo evita depender de qualquer módulo XS para permitir implantações simples. Fornece quase dois terços do Moose.

Quando usar o Moo

Como dito a cima, o Moo deve ser utilizado quando a aplicação preza por rapidez ao carregar pacotes e não tem necessidade de utilização de todos os metaprotocolos do Moose. A seguir exemplifico alguns casos que o podemos escolher o Moo:

• Quando uma linha de comando ou script CGI onde a inicialização rápida é essencial;
• Código projetado para ser implantado como um único arquivo via App::FatPacker;
• Um módulo CPAN que pode ser usado por outros nas situações acima;

Incompatibilidades do Moo para o Moose

Se o Moo detectar que o Moose está sendo carregado, ele registrará automaticamente metaclasses para seus pacotes Moo , então você poderá usá-los no código do Moose sem modificação.

O Moo não dará suporte para initializer, super, override, inner e augment pelos seus criadores considerarem más idéias ou práticas de programação no Perl.

Usando o Moo nos exemplos dos artigos anteriores

package Performances;
use strict;
use warnings;
use Moo;

# Declare the attributes
has 'name' => (is  => 'rw', # Declare read and write at runtime
    default =>'No name', # Attribute default value
);

has 'audience' => (isa =>'Int', # Declare as integer
  is => 'rw',
  default => sub { 
      my $self = shift; 
      my $qtd = shift;
      return $qtd if defined $qtd and $qtd > 0;
      return 'No audience or invalid value';
  } # Attribute default value
); # Declare read and write at runtime

Sub-rotinas importadas

Extends

Declara uma classe base. A classe será carregada, mas nenhum erro será acionado se a classe não puder ser encontrada e já houver subs na classe.

Chamar extends mais de uma vez irá SUBSTITUIR suas superclasses, não adicionar a elas como 'use base' ou ‘use parent’ faria.

extends 'Performances';

With

with 'Performances::Tragedy', 'Performances::Comedy';

Indica que a classe atual compõe uma ou mais funções da Performances . Um erro será gerado se essas funções não puderem ser compostas porque possuem definições de método conflitantes. As funções serão carregadas usando o mesmo mecanismo que os extends.

Has

Declara um atributo para a Classe.

is

Obrigatório para a declaração , pode ser ro, lazy, rwp ou rw.

• ro - significa "somente leitura" e gera um acessador que morre se você tentar escrever nele - ou seja, apenas um getter - padronizando reader o nome do atributo.
• lazy - gera um leitor como ro, mas também define lazy como 1 e builder como build${attribute_name} permitir atributos gerados sob demanda.
• rwp -significa "ler-escrever protegido" e gera um leitor como ro, mas também define writer para set${attribute_name} atributos que são projetados para serem escritos de dentro da classe, mas somente leitura de fora.
• rw - significa "ler-escrever" e gera um getter/setter normal padronizando o accessor o nome do atributo especificado.

isa

Recebe um coderef que é usado para validar o atributo. Ao contrário do Moose, o Moo não inclui um sistema de tipo básico, então ao invés de fazer isa ⇒ ‘str’, deve-se fazer:

package Performances;
...
# Declare the attributes
has 'name' => (is  => 'rw', # Declare read and write at runtime
    default =>'No name',
    isa => sub {
            die "$_[0] is not a name!" unless looks_like_name $_[0]
        } # Attribute type
);

coerce

Recebe um coderef que se destina a coagir o atributo. A ideia básica é fazer algo como o seguinte:

package Performances;
...
# Declare the attributes
has 'audience' => (
    isa => sub {
        die "$_[0] is not a number!" unless looks_like_number $_[0]
        },
    coerce => sub {
            $_[0] % 2 ? $_[0] : $_[0] + 1
        } # Attribute type for audience always ever 
);

Observe que o Moo sempre executará sua coerção: isso é para permitir que as entradas de isa sejam usadas puramente para captura de bugs, enquanto as coerções são sempre estruturais para seu código. No entanto, aplicamos a verificação de isa após a execução da coerção para garantir que ela retornou um valor válido.

trigger

Recebe um coderef que será chamado sempre que o atributo for definido. Isso inclui o construtor, mas não os valores padrão ou construídos. O coderef será invocado no objeto com o novo valor como argumento.

default

Recebe um coderef que será chamado com $self como seu único argumento para preencher um atributo se nenhum valor para esse atributo for fornecido ao construtor. Como alternativa, se o atributo for lazy, será default executado quando o atributo for recuperado pela primeira vez se nenhum valor ainda tiver sido fornecido.

predicate

Recebe um nome de método que retornará true se um atributo tiver um valor. Se você definir como apenas 1, o predicate será nomeado automaticamente has_${attr_name} se o nome do seu atributo não começar com um sublinhado ou has_${attr_name_without_underscore} se começar.

clear

Recebe um nome de método que limpará o atributo. Se você definir como apenas 1, o clear será nomeado automaticamente clear_${attr_name} se o nome do seu atributo não começar com um sublinhado ou  clear${attr_name_without_the_underscore} se começar. 
NOTA: Se o atributo for laze, ele será gerado novamente default ou  buider na próxima vez que for acessado. Se não for, será undef.

lazy

Recebe um booleano. Definir se desejar que os valores do atributo sejam capturados lentamente. Isso geralmente é uma boa ideia se você tiver um "construtor" que requer que outro atributo seja definido.

required

Recebe um booleano . Definir se o atributo deve ser passado na instanciação do objeto.

reader

O valor deste atributo será p nome do método que retorna o valor do atributo. 

writer

O valor deste atributo será o nome do método para definir o valor do atributo. 

weak_ref

Recebe um booleano . Definir se desejar que a referência que o atributo contém seja enfraquecida. Use isso quando referências circulares, que causam vazamentos de memória, são possíveis.

init_arg

Recebe o nome da chave a ser procurada no momento da instanciação do objeto. Um uso comum disso é fazer com que um atributo sublinhado tenha um nome de inicialização não sublinhado. undef significa que passar o valor na instanciação é ignorado.

moosify

Recebe um coderef ou uma matriz de coderefs que se destina a transformar as especificações de atributos fornecidas, se necessário, ao atualizar para uma função ou classe Moose. Você não deve precisar disso por padrão, mas é fornecido como um meio de extensibilidade possível.

before, around e after

before chamado antes do método que está modificando. 

around chamado em vez do método que está modificando. O método que você está substituindo é passado como o primeiro argumento (chamado $orig por convenção). Cuidado com os valores de retorno contextuais de $orig.

after é chamado após o método que está modificando. 

👋🏻 Então pessoal, hoje definimos o Moo, mostramos onde ele pode ser usado e quais suas incompatibilidades com o Moose. Qualquer dúvida, ou sugestão para os próximos artigos, podem deixar nos comentários. Até a próxima.