This is my first post here and I hope it is more positive than a rant to the readers eyes...

It was 2017 when I had installed Jenkins locally in my notebook for a series of experiments. The notebook was running Ubuntu configured in Brazilian Portuguese and Jenkins automatically presented me with a translation to my native language. After 15 minutes trying, I changed Ubuntu settings to English and never went back.

It took me a while to jump into the project repository and start translating the missing parts, about four years... and the translation hasn't improved since.

You might be asking yourself what this has to do with Perl and why I'm blogging about it here... well, Jenkins project uses (at least) since 2010 a Perl script to help with the translation work.

The current translation process is not really friendly for non-programmers and the script was still using syntax and style prior to the first edition of Learning Perl (the "lhama" book) that I could put my hands into. Giving the lacking of documentation about the translation process, it didn't took me long to start reading the code to figure out what to do and I decided to start refactoring the program while I was translating.

The idea was to not only fix small bugs, but making it easier for newcomers to offer revisions.

After some initial pull requests (with very simple refactorings) were accepted, to my surprise making the script a module (with h2xs!) became too complex to be accepted!

I was initially frustrated enough to not even try a reply on that PR. It took me a while to properly answer to it, after all, people back there were pretty respectful to state "thanks, but no, thanks".

It still strikes me that a helping hand offered might be rejected, but even more that the only reason for such rejection is about having to learn only enough Perl to keep using the same tool being used for more than 10 years!

Would that happen if I tried rewritten it with Haskell or Erlang? In fact, there are also scripts over the project written in Ruby and Python, so my guess is the problem is really with Perl.

It wouldn't surprise me if I got this kind of feedback from a programmer in Brazil: in fact I've already met people (with all range of programming experience) that consider Perl a "write-only" programming language that nobody uses. I usually tell this people that their Linux and/or "fancy" MacOS X already comes with Perl installed. And if they insist on that, I suggest to just uninstall it and see what happens next.

The good news is that the translation to Brazilian Portuguese is complete (as much one can consider such a thing) by now and I there is a fork for the translation-tool.pl available for download. Hopefully I'll be able to keep it going for a while, adding new features that I consider that could be useful.

But I'm still thinking if this was the best answer I could give for such situation. What do you think about?

MooseX::Extended is coming along well and is ready for testing. See Introducing MooseX::Extended for a decent introduction on how to make writing your Moose code safer and easier.

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().

With Perl 5.36.0 just around the corner, we thought that this is a good time to clarify plans for the future of the Perl programming language. We realised that the future was hammered out in a number of steps, across several months. This meant that there hasn't been a single statement we could refer people to. This post is to fill that gap.

Two years ago Perl 7 was announced. A key idea for Perl 7 was to significantly reduce the boilerplate needed at the top of your code, by enabling a lot of widely used modules / pragmas, but this would have come at the price of breaking some backwards compatibility. This would have meant that some existing code wouldn't have worked without modification.

This prompted a lot of heated discussions: some thought this was a great idea, and some thought it a terrible idea to throw away one of Perl's key strengths. Ultimately this led to a discussion about who had the right to make this decision, now that Larry is no longer involved in Perl (and hasn't been for about 20 years). The end result of all those discussions was a new governance structure.

The Perl 5 Porters ("p5p") mailing list is still where the future of Perl is discussed, and we aim to build consensus, but where that's not possible, the three-person Perl Steering Council (PSC) has ultimate decision making authority on the future of Perl. The PSC is elected annually by the core team (the subset of p5p who have contributed most to Perl "recently"). The trigger for an election is the annual release of Perl, so the next election will happen after 5.36.0 is released.

The first PSC was elected in late 2020, and one of our first tasks was to create a plan for the future of Perl, and to put that in motion. A lot of discussion and iteration followed, but the strategy we agreed is:

1. Existing sensibly-written Perl 5 code should continue to run under future releases of Perl. Sometimes this won't be possible, for example if a security bug requires a change that breaks backward compatibility.
2. We want to drive the language forwards, increasing the rate at which new features are introduced. This resulted in the introduction of the RFC process, which anyone can use to propose language changes.
3. We want to make it easy for people to use these new features, and want to do what we can to encourage their adoption.

At the heart of this strategy are feature guards and version bundles.

Features

If a new language feature isn't backwards compatible, then it is protected with a feature guard. For example, Perl 5.010 introduced the say keyword. But it couldn't be enabled by default, as someone might have a say function in their code, which it would conflict with. So if you want to use say, you have to request it using the feature pragma:

    use feature 'say';
    say "hello, world";

Unguarded features

Not all new language features have a guard. If new syntax is introduced which would result in a syntax error in all previous versions of Perl, then it doesn't need a guard. For example, 5.36.0 introduces new syntax which lets you process N items at a time from a list:

    foreach my ($key, $value) (%hash) {
    …
    }

This new syntax doesn't have a feature guard, so it's available to use at line 0 (i.e. before you use v5.36).

Experimental features

Sometimes a feature will be marked as experimental, which means that we're not sure whether it's in the final form, and we'd like people to play with it and give feedback. The experimental status means that we reserve the right to change everything about it in a subsequent release, or even to remove it. If you use such a feature, you'll get a warning, which you can suppress with an extra line of code:

    use feature 'try';
    no warnings "experimental::try";

In general you shouldn't use experimental features in production code.

Version bundles

A lot of features have been added since 5.10.0, and a bunch more have been added in 5.36.0. That can mean that you end up putting a lot of use … lines at the top of all your code. Instead, you can enable all the stable (i.e. non-experimental) features provided in Perl 5.36.0 that weren't included in the original Perl 5 release, with just put this one line at the top of your code:

    use v5.36;

This does three things:

1. it tells the perl interpreter (and human readers), that your code requires perl 5.36.0 or later to run;
2. it enables all additional non-experimental features provided by Perl;
3. it uses a number of additional pragmas that have been accepted as good practice.

That one line is equivalent to:

    require v5.36;
    use strict;
    use warnings;
    use feature 'say';
    use feature 'state';
    use feature 'current_sub';
    use feature 'fc';
    use feature 'lexical_subs';
    use feature 'signatures';
    use feature 'isa';
    use feature 'bareword_filehandles';
    use feature 'bitwise';
    use feature 'evalbytes';
    use feature 'postderef_qq';
    use feature 'unicode_eval';
    use feature 'unicode_strings';
    no feature 'indirect';
    no feature 'multidimensional';

Code that starts with use v5.36 will run against future versions of Perl – all versions of Perl know about the version bundles of previous versions of Perl.

Version bundles have two main benefits:

• they greatly reduce the boilerplate you have to write at the top of your code, and
• they document what version of Perl your code was written to. Version bundles have been supported since 5.10.0, but not widely understood or used. With the release of 5.36 we hope to change that.

We have a lot more proposals in the pipeline, including the introduction of richer OO syntax. We expect 5.38 to include another swathe of new features.

What about Perl 7?

For now, our plan is to continue introducing new features and to resolve all existing experimental features, so they're either dropped, or become non-experimental features (and so are included in the version bundle).

The downside with this is that people often can't remember which version of Perl introduced which feature(s).

At some point in the future, the PSC may decide that the set of features, taken together, represent a big enough step forward to justify a new baseline for Perl. If that happens, then the version will be bumped to 7.0.

If this happens, Perl 7 will still be backwards compatible with Perl 5 by default – you'll have to put use v7; at the top of your code to use all the new features.

Think of use v7 like Modern::Perl and similar modules.

Annual releases would continue, so it would then be followed by 7.2, 7.4, etc. We have a lot of good ideas in the works, and if we can keep up the momentum of the last year, then things look promising. And in the meantime we'll continue with 5.XX releases.

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.

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.

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