Visualizzazione post con etichetta perl. Mostra tutti i post
Visualizzazione post con etichetta perl. Mostra tutti i post

martedì 4 dicembre 2018

PostgreSQL 11 Server Side Programming Quick Start Guide

Last week my book PostgreSQL 11 Server Side Programming Quick Start Guide was released.



The book is a Quick Start Guide, that means it goes straight to the point, in this case, programming on the server-side of PostgreSQL.

Why is this related to Perl?
Well, one very cool feature of PostgreSQL is the capability to execute functions, and therefore triggers and procedures, in pretty much any programming language available out there. And this of course, means Perl!
In fact, Perl is very well supported in PostgreSQL to the point that the DO statement does allow you to use PL/Perl code instead of the PL/pgSQL one.

The other language I show, as a "foreign" language, in this book, is Java. My idea was to show to the readers the differences between using a language like Perl and one that requires a full compile-deploy cycle.

Hope the book can be useful.

sabato 24 giugno 2017

Perl _ filehandle

Leggendo la documentazione di :Find mi sono accorto di una frase nella sezione di esempio:


the "_" is a magical filehandle
that caches the information from the preceding "stat()", "lstat()", or
filetest.

e così incuriosito sono andato subito ad approfondire nella documentazione di stat:


If "stat" is passed the special filehandle consisting of an
underline, no stat is done, but the current contents of the stat
structure from the last "stat", "lstat", or filetest are returned.

Diciamo che _, a differenza della variabile topic non è una vera variabile ma un segnaposto particolare che viene interpretato come accesso alla cache dell'ultima operazione stat effettuata. E' facile costruire un esempio che mostri questi:



#!env perl

use v5.20;

my $file_name = $0; # myself

my @stat_values   = stat $file_name;
my @cached_values = stat _;

say "Same values for $file_name!" if ( $stat_values[1] == $cached_values[1] # inode
           && $stat_values[7] == $cached_values[7] # size
           && $stat_values[8] == $cached_values[8]  ); # atime

Lo stesso utilizzo non può essere effettuato con File::stat, che infatti riporta nella documentazione:


As of Perl 5.8.0 after using this module you cannot use the implicit $_ or
the special filehandle "_" with stat() or lstat(), trying to do so leads
into strange errors.

venerdì 16 giugno 2017

Perl and regexps are too much verbose (!)

A colleague asked me a quick Perl way to check if a string contains only a predefined set of chars excluding a few ones.
Easy pal!
Regexp to the rescue!

Then I was asked for a way that did no use a regular expression, because "you know, regular expression can be somehow verbose".
Gosh!
My answer was simply "you don't use regexps a lot!".

I don't believe I have to explain to any (Perl) programmer that regexps have been designed to express in short a whole set of choices,
more in general an alphabet (in the most wider concept).

But let's move on, and after showing a quick and dirty one liner such as:


perl -E 'say "Wrong $_" unless ( /^[0-9]+$/ ); ' -F

I got another strange sentence as "yeah, but I don't like Perl too much, it is somehow verbose as a language".
And again, my answer was: "you don't use it regularly!".

It is clear Perl was seen in the wrong way, since both the language as well as regular expressions can be really short, as well as
a one liner…
No other comments required!

Distanza fra date "note" in Perl

Come si può fare a conoscere se una serie di date note si trovano ad una distanza interessante l'una dall'altra?
Facile con un po' di Perl!


Anzitutto la definizione: per distanza interessante intendo un numero di giorni multiplo di 10, anzi meglio, potenza di 10, ovvero 100, 1000, ecc.
Detto questo, costruiamo la struttura base:



#!env perl

use v5.20;
use DateTime;

my $begin = DateTime->new( year => ..., month => .., day => .. );
my $now = $begin->clone();
my $dates = [
    { day => 4, month => 7 }
    , { day => 19, month => 7 }
   ...
    ];

push @$dates, { day => $begin->day, month => $begin->month };
my $base = 10;

Con $begin si indica la data di partenza, mentre in $dates si inseriscono giorno e mese di alcune date a voi significative.
Per capirsi, $begin potrebbe essere la data di nascita di vostro figlio e $dates contenere il vostro matrimonio, laurea, ecc.
Da notare che inserisco automaticamente la data di partenza nell'array delle date da cercare, così da valutare la data contro se stessa
spostata chiaramente di alcuni anni.
Fino a qui, nulla di sorprendente. Beh, anche il resto è abbstanza noioso:



for ( 1 .. 100 ){
    $now->add( years => 1 );
    for my $when ( @$dates ){
 $now->set( day => $when->{ day }, month =>  $when->{month} );
 my $delta = ( $now->epoch - $begin->epoch ) / ( 60 * 60 * 24 );
 next if ( $delta % $base != 0 );
 say "La data " . $now->dmy . " si trova a $delta giorni da " . $begin->dmy 
           if ( ( log( $delta )/log( $base ) ) =~ /^\d+$/ );
    }
}

In un ciclo di 100 anni (perché oltre diventa poco interessante, almeno per voi visto che non ci sarete piu') si processa un anno alla volta
sommandolo alla data di partenza $now (clone della vera data). Contro tale "annata" si testano tutte le date ricercate per vedere se
la distanza in giorni $delta è multiplo di 10 ($base) e piu' precisamente se è un logaritmo in base 10.
Solo di quelle date si effettua una stampa a video.

domenica 11 giugno 2017

Perl blogs will be powered by PostgreSQL

There is a grant request aiming at revamping blogs.perl.org.
I have to admit that blogs.perl.org is in a bad shape, and in fact I do not use it anymore for my personal contents since the well known
login issues.
Well, the important part about the grant request, at least with regard to the PostgreSQL community, is that…surpise! The new platform will store content on a PostgreSQL backend:

[…]
will be written on top of Dancer2,
DBIx::Class, and DBI,
with a PostgreSQL database
imported from the existing
[…]


A great news for two of my favourite Open Source projects (Perl and PostgreSQL) and a great wat to spread the word thru our own content!

venerdì 19 maggio 2017

Arabic to Roman number converter in Perl 5

Puzzled by a post on the Planet KDE about GCompris and roman numbers, and needing an easy way to explain to my six-years old son about roman numbers, I thought it would be an easy task to make a simple program in Perl to convert an arabic number into its roman notation.
Not so easy, pal!
Well, it's not a problem about Perl, of course, rather I found it required a quite brainpower for me to write down rules to convert numbers, and I did not search for the web for a copy-and-paste alghoritm. Please note: if you need a rock-solid way to handle conversions, have a look at CPAN that is full of modules for this particular aim.
Here I'm going to discuss the solution I found and how I implemented it. It is not supposed to be the best one, or the faster one, it's just my solution from scratch.

The program

I split the problem of converting an arabic number into a roman one into three steps, with one dedicated subroutine for each step, so that the main loop reduces to something like the following:
say "$_ = " . $roman_string->( $reassemble->( $disassemble->( $_ ) ) )
              for ( 1..30 );
that produces the following output:
1 = I
2 = II
3 = III
4 = IV
5 = V
6 = VI
7 = VII
8 = VIII
9 = IX
10 = X
11 = XI
12 = XII
13 = XIII
14 = XIV
15 = XV
16 = XVI
17 = XVII
18 = XVIII
19 = XIX
20 = XX
21 = XXI
22 = XXII
23 = XXIII
24 = XXIV
25 = XXV
26 = XXVI
27 = XXVII
28 = XXVIII
29 = XXIX
30 = XXX
The steps must be read from the inner subroutine to the outer, of course, and therefore we have:
  • disassemble that translates an arabic number into roman basis, that is computes how many units, tens, hundreds and thousands are required. In this phase there is no application of roman rules, so numbers are decomposed into a linear string of letters. As an example the number 4 is translated into IIII, which is of course a non-existent roman number.
  • reassemble applies roman rules, in particular promoting numbers so that groups are translated, when needed, into higher order letters. For instance IIII is promoted into two groups: I and V.
  • roman_string compose the promoted groups into the final string. The main difficulty of this part is to understand when a letter has to be placed on the right (addition) or on the left (subtraction) of another letter. For instance, having the groups I and V the function must understand if the output have to be VI (6) or IV (4).
To speed up the writing of the code, I placed main roman letters and their correspondance with arabic numbers into a global hash:
my $roman = {
    1    => 'I',
    5    => 'V',
    10   => 'X',
    50   => 'L',
    100  => 'C',
    500  => 'D',
    1000 => 'M',
};
Each method references $roman when needing to convert from an arabic number to its roman letter. In order to allow method to cooperate together, they accept and return an hash keyed by a roman letter and the number of occurences such letter must appear in the final string. The following is an example of the hash for a few numbers:
# 4 (IV)
{ 'I' => 1, 'V' => 1 }
# 19 (XIX)
{ 'I' => 1, 'X' => 2 }
# 5 (V)
{ 'V' => 1 }
# 17 (XVII)
{ 'X' => 1, 'V' => 1, 'I' => 2 }

The disassemble function

The following is the code for the disassemble function, that accepts as only input the arabic number.
# Accepts the arabic number and provides an hash
# keyed by each letter, with the value of how many times
# such letter should be summed in order to obtain the
# starting number.
my $disassemble = sub{
    my ( $number ) = @_;
    my $items = {};

    # sort the keys, that are arabic thresolds, from
    # the greater to the smaller one
    for my $current_value ( sort { $b <=> $a } keys $roman->%* ){

        my $how_many = int( $number / $current_value );
        next unless ( $how_many );

        my $letter = $roman->%{ $current_value };
        $items->{ $letter } = $how_many;

        $number -= $current_value * $how_many;
    }

    return $items;
};
The first thing the method does it to create the hash $items that is what it will return to allow other methods to consume. Each key of the $roman hash is passed ordered by the bigger to the smaller (please note that sort has $b first!). In this way we can surely scompose the number from the thousands, hundreds, tens, and units in this exact order. The $how_many variable contains the integer part of each letter. For example the number 29 is processed as follows:
  1. 29 / 10 that drives $how_many to be 2 and the remaining to be a 9;
  2. 9 / 5 that makes $how_many to be 1 and the remaining to be a 4;
  3. 4 / 1 that makes $how_many to be 4 and there's nothing more to do.
At each step the roman letter and the $how_many value is inserted into the $items has, that in the above ecample becomes:
# 29 (XIX)
{ 'X' => 2,
  'V' => 1,
  'I' => 4
}

The reassemble method

The reassemble method takes as input the hash produced by disassemble and checks if any letter requires a promotion. Here it is the code:
# Accepts an hash with keys the letters and values the number
# of times each letter should appear.
# Traverse the hash from the smaller to the greater
# in order to "promote" smaller aggregates. For instance
# 'IIII' (4) is aggregated and therefore the hash is modified
# so there's only an 'I' and another 'V', in such case
# the quantity of the promoted letter is negative to indicate
# it has been promoted.
my $reassemble = sub{
    my ( $items ) = @_;
    my @sorted_thresolds = sort { $a <=> $b } keys $roman->%*;

    for ( my $i = 0; $i < @sorted_thresolds; $i++ ){
        my $current_value = $sorted_thresolds[ $i ];
        my $key      = $roman->%{ $current_value };
        my $how_many = $items->%{ $key };

        next unless ( $how_many );

        my $greater_value = ( $i + 1 > @sorted_thresolds ? 1000 : $sorted_thresolds[ $i + 1 ] );
        my $greater_key   = $roman->%{ $greater_value };


        my $need_to_promote = $how_many == 4
            || ( $greater_value / $current_value == $how_many );

        if ( $need_to_promote ){
            $items->{ $greater_key }++;
            $how_many = $greater_value - $how_many * $current_value;
            $items->{ $key } = $how_many * -1;

        }

    }

    return $items;
};
The promotion must be done from the smaller letter to the greater one, so this time the letters are walked in ascending order (i.e., sort has $a first!). Since to promote a letter I need to access the following one, I need a C-style for loop.
A letter requires to be promoted if its quantity is 4 or /it is 2 and the right bigger value is exactly the double of the current one~, that is while ( $greater_value / $current_value == $how_many ). This makes, for instance IIII to be promoted (the quantity is 4), and VV to be promoted into X (because the quantity is 2 and the X is exactly the double of V). The promotion manipulates the hash increasing by one the right bigger letter and leaving a single current letter. In order to flag the promoted letter, I decided to use a negative quantity (where the absolute value is the exact one).
So for instance, the 29 hash of the previous paragraph is passed as follows:
# input to the method
{ 'X' => 2,
  'V' => 1,
  'I' => 4
}


# first for step (I)
{ 'X' => 2,
  'V' => 2,
  'I' => -1  # promoted, keep 1 and increase 'V'
}

# second step (V)
{ 'X' => 3,
  'V' => 0,  # promoted, increase X by one
  'I' => -1
}
At the end of method we know the final string will be made by three X and one I, the point now is to understand how to render them in the correct order. This is the aim of the roman_string method.

The roman_string method

The method accepts the normalized hash (i.e., groups are already formed) and compose the final string placing letter on the left or the right of each other depending on their quantity. The following is the code of the method:
# Do the hard work of composing
# each group of letters in order to compose the roman string.
my $roman_string = sub {
    my ( $items ) = @_;
    my @chars;

    for my $current_value ( sort { $b <=> $a } keys $roman->%* ){
        my $letter   = $roman->%{ $current_value };
        my $how_many = $items->%{ $letter };

        next unless ( $how_many );


        if ( $how_many > 0 ){
            push @chars, $letter for ( 1 .. $how_many );
        }
        else{
            # this is promoted, so it has to be inserted as last-to-last
            # in the previous chain
            # example: @chars( X, X ) and here I've 'I' to make XIX (19)
            push @chars, ( $letter, pop @chars );
        }

    }

    return join "", @chars;
};
In order to be able to manipulate easily the final string, moving letters from left to right and vice-versa, I decided to place each single letter into the @chars array, that is then join -ed into a single string.
Let's suppose we need just to add letters: in this case we need to write letters from the greater to the smaller from left to right, and this is the order I traverse the letters of $roman (again, note that sort has $b first!). If the quantity of the letter is positive the letter has not been promoted and therefore it will not be placed to the left of another letter, so just insert into @chars the $letter for the $how_many quantity. On the other hand, if $how_many is negative, the letter has been promoted and therefore have to be printed on the left of the last printed letter. This is as easy as doing:
push @chars, ( $letter, pop @chars );
that inserts into @chars the $letter and the previous last character that has been removed via pop.
With regards to the previous example of 29 we have that:
# method input
{ 'X' => 3,
  'I' => -1
}

# first step: prints X
# with quantity 3 (not promoted)
@chars = ( 'X', 'X', 'X' );

# second step: prints I
# that has been promoted
# and must be inserted ascending
# as last-to-last
@chars = ( 'X', 'X' ,
           ( 'I', # $letter
             'X'  # pop @chars
         ) );

Conclusions

Well, it has been much code that I expected to write. Using an object notation, instead of plain hashes, could surely make the program more robust. I'm pretty sure there's a way to shrink the code down and to avoid that ugly C-style for loop, as well as the promotion part could be simplified keeping in mind that it often reduces to -1 for the current letter and +1 for the greater one. Anyway, it does what I need and seems correct!

venerdì 12 maggio 2017

Postfix dereference operator

Starting from Perl 5.20 it is allowed to use a postfix dereference notation, first as an explicit feature, and since Perl 5.24 it is enabled by default.
The postfix dereference notation allows you to use the arrow operator -> on a reference (as often used when combined with references) specifying the type of the deferencing you want to. Types are indicated by their well know sigils, so for instance a $ means a scalar, a @ an array, & is for a subroutine, % for an hash and * for a typeglob. The sigil on the right of the arrow operator is enhanced by a star, so it really becomes type and *, as in $*. In the special case of arrays and hashes the star can be dropped in favor of a slicing operator, e.g., the square brackets.
The following is a sample program that prints out the values of an array using full access (->@*) and slicing (->@[]):

#!env perl
use v5.24;

my @array = ( 'a' .. 'z' );
my $ref   = \@array;
say "Here comes the array @{ $ref }";
say "And post dereferences is $ref->@*";

say "Here comes a slice @{ $ref }[ 0 .. 5 ]";
say "And using it as post dereference is $ref->@[ 0 .. 5 ]";
 
 
As you can see, $ref->@* is the equivalent of @{ $ref }, while $ref->@[] is the same as @{ $ref }[]. The same applies to hash references.
Code and subroutine references are a little more controversial, at least to my understanding of references. First of all there is only the star operator, so ->&*, and the behavior is such that $ref->&* is the same as &{ $ref }. This makes me think there is no short way of passing method arguments thru a postfix deference, as the following code demonstrates:

#!env perl
use v5.24;

my $sub_ref = sub { say "Hello sir @_ !" };
$sub_ref->( 'Luca' );         # Hello sir Luca !
&{ $sub_ref }( 'Luca' );      # Hello sir Luca !
$sub_ref->&* ;                # Hello sir  !
{ $sub_ref->&* }( 'Luca' );   # Hello sir  !
&$sub_ref( 'Luca' );          # Hello sir Luca !

If you try to pass arguments in any way to the ->&* dereferencing, you got either a compile time error or a code that does not what you expect:

{ $sub_ref->&>* }( 'Luca ');   # Hello sir  !
$sub_ref->&( 'Luca' );        # syntax error at tmp/ref.pl line 19, near "->&"
$sub_ref->&*( 'Luca' );       # syntax error at tmp/ref.pl line 20, near "&*( "
{ $sub_ref->& }( 'Luca ');    # syntax error at tmp/ref.pl line 21, near "->&"

The only catch-all way of passing arguments, as suggested on irc.perl.org, is to use the @_, so I suggest to localize it:

{ 
  local @_ = qw( Luca ); 
  $sub_ref->&*; # Hello sir Luca ! 
}

I must admit this is a little too much for my poor brain in order to efficiently use the references, so if anyone has something to comment is truly welcome!
Now, back to the main topic, it seems to me that the postfix dereference notation is a way of managing reference more like objects, at least it reminds me a kind of as_xx methods (yes, Ruby-ers, I'm looking at you). If we read the arrow operator like as and the type on sigil on the right as the type name, we have that, for instance:
  • $ref->$* is $ref as scalar;
  • $ref->@* is $ref as array or $ref>@[] becomes $ref as array slice
and so on. While I'm pretty sure this is not the real meaning of this notation, it is sure most readable than the "usual" one, where we have the type on the left and the reference on the right (or better in the middle), as in @$ref or @{ $ref }.

mercoledì 10 maggio 2017

Diamonds in Perl

A diamond ascii is a geometric structure represented as, ehm, a diamond. For example, in the case of letters it becomes something like:


      a
    b  b
   c    c
  d      d
 e        e
f          f
 e        e
  d      d
   c    c
    b  b
     a

How hard can it be to build a Perl program to represent a diamond like the above one?
Well, not so much hard, but we have to observe some geometric properties:

  • the diamond is simmetric (in the sense it becomes and ends with the same letters), but the
    central row is reproduced only once (that is, the f appears only on one line, not two!);
  • each letter or couple of letters is vertically centered around the number of letters in the whole diamond, that is
    the letter a (vertical centre) is shifted to right of 6 chars (the total number of letters is a..f = 6);
  • each couple of letters has a left and right position, and both are equally distant from the vertical
    centre of the diamond.

Ok, so here it comes my shorter solution:



#!env perl

use v5.20;

my @letters = qw( a b c d e f );

my %index;
@index{ @letters } = ( 0 .. $#letters );


    say {*STDOUT}
  " " x ( $#letters - $index{ $_ } )
 , $_
 , " " x ( $index{ $_ } * 2 )
 ,( $index{ $_ } > 0 ? $_ : '' )
     for  ( ( @letters, reverse @letters[ 0 .. $#letters - 1 ] ) );

Allow me to explain it in all its pieces.


First of all, @letters contains the letters to be printed in the right order, and this of course could come from user's input, a sequence, an array slice, or whatever, it does not mind here. Since I have to place letters depending on where they are in the array of @letters, I need to have an handy way to get the index within the array for each letter, so I build up an hash where the keys are the letters themselves and the values are the positions of such letters. In other words, $index{a} = 0, $index{f] = 5 and so on.


Finally, I print a line every time I need with say. Let's dissect the say statement:

  • " " x ( $#letters - $index{ $_ } ) shifts to right a number of spaces required to reach the vertical centre or the right distance from it, in other words it is the left position. For example, for the letter a it comes
    down to 5 - 0 = 5, while for b it comes to 5 - 1 = 4 and so on.
  • then I print $_ that is the current char;
  • then I move again to the right of " " x ( $index{ $_ } * 2 ), that is in the case of a nothing, in the case of b by 2, and so on;
  • then if required I print again the char. Here "required" means the char is not the first one (i.e., not the one at index 0), since that is the only one character printed exactly one time per line.

The say is repeated over the whole @letters array, so this produces the first part of the diamond:


      a
    b  b
   c    c
  d      d
 e        e
f          f

then I need to get the bottom, so I need to iterate over the reverse @letters with the exception of the last element, that is I need to iterate over a reversed slice of @letters with the missing f: reverse @letters[ 0 .. $#letters - 1 ] ). This provides me the whole bottom of the diamond.

L'importanza dell'operatore qq

Non si finisce mai di imparare!
Guardando uno script Perl per la gestione di backup testuali PostgreSQL
sono rimast incuriosito dall'uso massivo di printf legato all'operatore qq:
A double-quoted, interpolated string. Ebbene una utilita' di questo operatore
è nell'utilizzo delle virgolette doppie, che non devono ovviamente essere
legate a sequenze di escape. Quindi invece che scrivere:


printf "Un esempio di stringa \"%s\" ", 'quotata';

si può scrivere la versione molto piu' semplice e leggibile


printf qq( Un esempio di stringa "%s" ), 'quotata';

Sembra una banalità, ma non essendo abituato ad usare qq come invece
lo sono per q e qw, non mi sono mai posto il problema di come
semplificare ulteriormente le mie stringhe con doppi apici.


Ora diventerò anche io un avido utilizzatore di qq!

domenica 7 maggio 2017

Ti ricordi dei formati Perl?

Chi si ricorda della variabile $~?
perlvar viene in aiuto:


HANDLE->format_name(EXPR)
$FORMAT_NAME
$~      The name of the current report format for the currently selected
        output channel. The default format name is the same as the
        filehandle name. For example, the default format name for the
        "STDOUT" filehandle is just "STDOUT".

Da piccolo usavo molto i formati Perl, anche se li trovavo poco leggibili. Probabilmente
proveniendo dal mondo della carta stampata su modulo continuo avevo l'abitudine mentale di
voler "immaginare" l'output in formato tabellare (non saprei pensare ad altro
utilizzo dei formati).
Ecco quindi che spesso i miei programmi assumevano la forma:


format most_called_format=
|@<<<<<<<<<<<<<<<<<<<<<|@>>>>>>|
$number,                  $call
.

Ormai, almeno per me (ma penso anche per moltissimi sviluppatori Perl), i formati non sono altro
che un ricordo!

venerdì 5 maggio 2017

perlcritic and allowing simple double sigils dereferencing

I found out, while not searching for it, an interesting policy for Perl::Critic
named Perl::Critic::Policy::References::ProhibitComplexDoubleSigils. The idea is quite simple and I find myself agreeing with it:
when dereferencing a reference you can omit braces; while this is often not a good habit (because it can become
quite difficult to read a complex reference), it can work out on simpler cases:



#!env perl
use v5.20;

my %hash = (
    key1 => "value1"
    , key2 => "value2"
    , key3 => "value3"
    );

my $hash_ref = \%hash;

while ( my ( $k, $v ) = each %$hash_ref ){
    say "$k --> $v";
}

In the above code it is quite simple to understand that @$hash_ref refers to the whole hash without the need to use
the braces around.


I recognize the advantages of using the braces as:

  • a good habit;
  • a way to do a good refactoring in the case the reference points to a multidimensional structure.

Anyway simple idioms should stay simple and so should the checkers manage them.
If I run perlcritic against the above piece of code, the Perl::Critic::Policy::References::ProhibitDoubleSigils
will report


% perlcritic --single-policy=ProhibitDoubleSigils p.pl
Double-sigil dereference at line 12, column 30.  See page 228 of PBP.  (Severity: 2)

Now, using the above mentioned Perl::Critic::Policy::References::ProhibitComplexDoubleSigils the result becomes:


% perlcritic --single-policy=ProhibitComplexDoubleSigils p.pl
p.pl source OK

Ok, let's refactor the program and transform the plain hash in a multidimensional one:




#!env perl
use v5.20;

my %hash = (
    key1 => "value1"
    , key2 => "value2"
    , key3 => "value3"
    );

my %outer_hash = ( config1 => \%hash );
my $hash_ref = \%outer_hash;

while ( my ( $k, $v ) = each %{ $hash_ref->{config1} } ){
    say "$k --> $v";
}

The above part is the right way of dereferencing the reference to the inner hash, and it does use curly braces
and makes Perl::Critic, both policies, not complaining at all.


If, instead, we pretend to use double sigils (that is removing the arrow operator) the code becomes:



#!env perl
use v5.20;

my %hash = (
    key1 => "value1"
    , key2 => "value2"
    , key3 => "value3"
    );

my %outer_hash = ( config1 => \%hash );
my $hash_ref = \%outer_hash;

while ( my ( $k, $v ) = each %{ $$hash_ref{config1} } ){
    say "$k --> $v";
}

and of course both policies complain about:


% perlcritic --single-policy=ProhibitDoubleSigils p.pl
Double-sigil dereference at line 13, column 33.  See page 228 of PBP.  (Severity: 2)

% perlcritic --single-policy=ProhibitComplexDoubleSigils p.pl
Complex double-sigil dereferences at line 13, column 33.  Found complex double-sigil dereference without curly braces.  (Severity: 2)


Something similar happens when you try to extract a single scalar value from the nested hash:



...
# line 20
my $k1 = $$hash_ref{ config1 }->{ key1 };
say "key1 is $k1";

# line 23
$k1 = $hash_ref->{ config1 }->{ key1 };
say "key1 is $k1";

both the above instructions place the correct value into the $k1 variable, and the policies both complain about the first line
(the one with the $$):


% perlcritic --single-policy=ProhibitDoubleSigils p.pl
Double-sigil dereference at line 20, column 10.  See page 228 of PBP.  (Severity: 2)

% perlcritic --single-policy=ProhibitDoubleComplexSigils p.pl
The value for the global "single-policy" option ("ProhibitDoubleComplexSigils") did not match any policies (in combination with other policy restrictions).


Summing up the idea is to allow double sigils only when you are dereferencing a single level, not for complex data structures.

domenica 30 aprile 2017

Baby-Perl

Ecco un altro esempio, questa volta in italiano, di uso infantile di Perl e in generale scorretto della formattazione di stringhe.

L'idea è semplice: occorre stampare in un file a formato fisso delle linee di valori. Si noti bene che il formato fisso si presta bene all'uso della printf, e sicuramente all'uso dei formati Perl, anche se con campi molto lunghi questi diventano scomodi e francamente poco leggibili.

Ma l'ignoranza e l'inesperienza facevano da padroni nei primi anni della programmazione, così seguendo il fantastico principio del reinventare la ruota ecco che si implementava una sorta di sprintf del poveraccio:


my $INIZIO_CAMPO = "|";
my $FINE_CAMPO   = "|";

sub formatta($$$){
    my ($stringa, $lunghezza, $fineRiga) = @_;

    $stringa =~ s/,/./g;

    if( length($stringa) > $lunghezza ){
 $stringa = substr($stringa, 0, $lunghezza);
    }


    if( $fineRiga != 1 ){
 return $INIZIO_CAMPO . $stringa . $FINE_CAMPO . $SEPARATORE_CAMPO;
    } else {
 return $INIZIO_CAMPO . $stringa . $FINE_CAMPO . $FINE_LINEA;
    }


}

Piuttosto elementare:
  1. si sostituisce il carattere , con il ., e questo ha poco a che fare con la stampa stessa;
  2. se la stringa di partenza $stringa supera la lunghezza del campo (specificata in $lunghezza)
    si tronca la stringa (mentre non c'è un padding qualora la stringa sia piu' corta);
  3. si concatena la stringa con i delimitatori di campo e si aggiunge, eventualmente, un carattere di
    fine linea.

Come si potrebbe fare una versione compatta? O meglio, come affronterei il problema oggi?
Beh, come già detto, printf(3p) è la salvezza:


sub formatta{
    my ( $stringa, $lunghezza, $fine_riga ) = @_;

    my $format_string = sprintf "%%s%%%ds%%s%%s", $lunghezza;
    return sprintf $format_string, $INIZIO_CAMPO, $stringa, $FINE_CAMPO, ( $fine_riga ? "\n" : "" );
}

L'unica complicazione evidente è la gestione della lunghezza della stringa, che deve essere specificata nella stringa di formato.
Si supponga di chiamare la funzione formatta come segue:

say formatta 'foo', 5, 1;


Ora quello che succede è che:
  1. $format_string viene valorizzato come %s%5s%s%s ovvero sprintf "%%s%%%ds%%s%%s", $lunghezza; converte la stringa passata
    come argomento
    • %%s viene convertito come %s, il primo è il separatore di inizio campo, il penultimo di fine campo, l'ultimo è l'evetuale
      fine riga;
    • %%%ds viene convertito in %$lunghezzas ovvero %5s;
  2. la stringa composta in $format_string è ancora una stringa valida per la printf, che quindi viene riempita con
    i valori appositi.

Sicuramente questa versione è piu' compatta e piu' manutenibile, a patto di leggere correttamente il formato della pritnf e il "doppio formato"
costruito nel primo passaggio (es. %%s).

E' anche possibile compattare ancora di piu' cecando di evitare i doppi passaggi, o meglio di limitarli al massimo:


sub formatta{
    my ( $stringa, $lunghezza, $fine_riga ) = @_;

    my $format_string = sprintf "%1s%%%ds%1s%%1s", $INIZIO_CAMPO, $lunghezza, $FINE_CAMPO;
    return sprintf $format_string,  $stringa, ( $fine_riga ? "\n" : "" );
}

Il concetto rimane il medesimo, ma la $format_string in uscita dalla prima invocazione di sprintf vale qualcosa come |%5s|%1s
e quindi richiede solo due parametri (la stringa e il fine riga).

E' poi possibile allineare la stringa a sinistra (invece che a destra) semplicemente usando un padding negativo (es -5%s).

La lezione imparata è dunque: la printf è molto versatile, e nella maggior parte dei casi può risolvere parecchi grattacapi di formattazione!

sabato 29 aprile 2017

Another baby Perl program from a backup in the attic

This is a simple script that takes all arguments on the command line and returns a list of directories for each argument.
I don't remember at all what the purpose of this was, probably something to process a set of directories via a batch starting from
a set of filenames.
By the way, let's say how baby I was at that time…


1.1 Baby Code

Here it is, please note how long the code is…



#!/usr/bin/perl

# This script manipulates all its arguments returning a list of string which
# are the directory of all files. For example if the argument is
# /home/luca/file.txt only /home/luca/ is returned (note the last backslash).


# return array
@ret;

foreach $name (@ARGV){


    if( -f $name ){

 # check if the name contains a /, if no the directory must be the current one (./)
 if(not  $name =~ /\// ){
     $ret[++$#ret] = "./";
 }
 else{

     @parts;
     $dir;

     # split into the section with /
     @parts = split("/",$name);


     if( defined(@parts) ){

  for($i=0; $i < $#parts; $i++){
      $dir .= $parts[ $i ]."/";
  }
     }


     # put the result inot the array
     $ret[++$#ret] = $dir;
 }
    }
    elsif( -d $name ){


 # this is a directory, simply check if ends with the slash
 if( not $name =~ /\/$/ ){
     $name .= "/";
 }

 $ret[++$#ret] = $name;
    }
}


# all done, print the array
foreach $name (@ret){
    print $name."\n";

}

1.2 The teen-ager code

What if I have to write a similar service today?
That is the very first code that comes into my mind:



#!env perl

use v5.20;
use File::Spec;

my @dirs;
for ( @ARGV ){
    push @dirs, $_ if ( -d $_ );
    push @dirs, ( File::Spec->splitpath( $_ ) )[ 1 ] if ( -f $_ );
}

{
    local $" = "/\n";
    say "@dirs";
}

A lot less, uh?
It could be simpler, but so far I don't know any module to return the directory part of a path when a file is provided as argument, and
this is the reason I need to distinguish between the -f and -d cases.


The adoption of the list separator $" is specific to add the trailing backslash and to place every single directory on its own line. Of course this means, as $" suggests, that the array has to be printed via doubled quoted print. Here the adoption of say
or print is totally equivalent.


Let be honest here: the adoption of local and the surrounding block could be avoided, since the script exits implicitly right after
such couple of instructions, and this means the code could even be simpler, or better, shorter, but let's keep some good habits!

venerdì 14 aprile 2017

A baby Perl program from a backup in the attic!

…I was assigned one of my very first program to develop: a way to assure an user can run no more than a specific number of instances
of the same executable.


The real story was this: a company was using an Unix ncurses based ERP, and users were forced to connect via remote shell and
launch it automatically. The problem was that several users were opening more terminals (and therefore ERP clients) limiting
resources to other users.


I wanted to demonstrate my skills being able to implement the solution in a couple of hours, and instead of spending time
searching for a production-ready solution on the Internet, I decided to do it all on my own.


It was clear to me I was needing a kind of wrapper to control the execution of external programs. In fact, since users were
automatically switched from the remote shell into the ERP client, it did suffice to place the wrapper as the
user shell.


But how to implement it? At that time I knew Java, C++, C, Perl and some Bourne Shell. Making it in Java was too heavy, and
most notably required to install a JVM on the server (it was the time of the Red Hat 5 branch). C and C++ required too much time
to come with a working solution, and Perl was the most promising allowing me to do everything I was able to do with
other languages, overcoming the limitation of the shell (e.g., arithmetic).


But at that time I was not a fluent Perl developer.


A few days ago I found the above program out of an old backup, and so I spent five minutes to read it again. Not surprisingly, I found
it awful with respect to the code I write today, and moreover I see a lot of code uglyness due to baby steps. But hey, it was fun
to see how many things I've changed in my coding style, idioms, adoption of the language and of its operators, and most notably
about how I'm today toward compact code instead of long and blown code. At that time I was convinced that as long the code was, as much
it must be simpler to read, today I believe it is the opposite (with a very few exceptions I tend not to adopt until I
can remember very well).


In this article I will dissect a few parts of the above program to show you how I was writing code back in those days, and it was
a huge time ago (at least in computer timeline): 15+ years ago.


2 Baby Steps

Well, as you can imagine when I started doing a real job I was nothing more than a programmer-to-be, and my knowlegde
about Perl was really tiny. I mean, I read the Camel Book (of course!), and I was experimenting with Perl as much as I could,
but I was not an avid consumer of the Perl community (as well as other communities) and so I did not have a lot of chances
to learn from other people experience and code.


More than that, I just finished my university degree, and so my mind was literally full of theories about writing
correct and beautiful code, but that were just theories without any implementation! And last but not least, I was convinced
I could do everything by my own (that is, who needs modules?).


Today I recognize the following as baby steps in the Perl world.

2.1 Method Prototypes

Yes, I was using prototypes everywhere.


Why? I suspect they were comfortable to me, since I was used to languages where each method has a prototype (C, C++, Java), and
so I was trying to use a kind of common approach to every language, applying to Perl prototypes even when I was not needing
them at all!


Of course, by time and experience, I found that prototypes are usually not useful at all in my programs, and made refactoring
a lot harder.

2.2 Method instead of Operators

Perl allows operators to be used without braces, but that was something my eyes were not able to parse!
Again, coming from languages where methods and operators both need parentheses, I tried to bend Perl to my will
and use operators the very same way.

2.3 Untrusting the Thruth

Perl has the great ability to cast a variable depending on the context, but it was something too much complex for me.
So for instances, instead of testing a scalar against a not-true value, I was using the defined operator:


# if ( $scalar )
if ( defined $scalar ){ ... }

Worst: I was not using the ability of an array to be scalar-contextualized in tests:


#if ( ! @array )
if ( not defined @array || $#array <= 0 ){ ... }

2.4 Global Variables

my what?


I was not using scoped variables, and the reasons were:

  1. it was not clear to me the real difference between my and local, and I have to confess I thought local was what should be the
    name for scoped variables (maybe because of the way some shells declare local variables), but since local was usually a bad idea
    I decided not to use either;
  2. my scripts were quite small and self contained, so there was no risk at all about variable clash.

2.5 Backtick as a Rescue!

I knew pretty much well a kind of command line Unix tools (e.g., grep, awk, sed, find), and sometimes I needed
to do something in Perl without knowing how to do but with shell tools. So, how could I merge the both?


Easy pal: backtick the Unix tools and manage the result in Perl!

2.6 No Modules, please

I was not using modules, both by design and by fear.


With by design I mean that I was writing scripts for machine loosely connected to the Internet (just think I was working with server behind an ISDN router!),
and therefore even dowloading a module and install it could be quite a pain.


By fear means I was quite scared about importing other people's code. I was still learning about how to use correctly the CPAN, how to read
the documentation, and so on. And I did not want to install things in the wrong way on code that must run. After all, I was half-an-hour
away from implementing some kind of module functionality by my own (ah, the ego…).

2.7 Regexp Sometimes…

I tried to use regexp, but I was too less experienced. Therefore I usually did the substitution with friendly tools, like
split and alike.


I fear regexp nomore, and even if I'm not a master at all, I find interesting placing them in programs not only because
they allow me to write clear and compact code, but also because they still are some criptic stuff other developers
have hard time reading.


3 The Code

3.1 University Distortion

There are a couple of places where you can see evidence of the teachings at my university, most notably the
command line argument loop:


sub parseCommandLine()
{

    # The script must be at least two arguments.
    if ( $#ARGV < 1 or $#ARGV > 4 )
    {
        help();
        exit(0);
    }

    $POLICY_FILE = $DEFAULT_POLICY_FILE;

    foreach $argument (@ARGV)
    {
        if ( $argument =~  /(-program=)/ )
        {
            $argument =~ s/(-program=)//;
            $PROGRAM = $argument;
        }
        elsif ( $argument =~ /(-policy=)/ )
        {
            $argument =~ s/(-policy=)//;
            $POLICY_FILE = $argument;
        }
        elsif ( $argument =~ /(-username=)/ )
        {
            $argument =~ s/(-username=)//;
            $USERNAME = $argument;
        }
        elsif ( $argument =~ /(-message=)/ )
        {
            $argument =~ s/(-message=)//;
            $MESSAGE_FILE = $argument;
        }
    }

    # check main parameters
    if ( not defined $USERNAME or $USERNAME eq "")
    {
        warn("\nCannot find username !!\n\n");
        help();
        exit(1);
    }
    elsif ( not defined $PROGRAM or $PROGRAM eq "")
    {
        warn("\nCannot find the program name \n\n");
        help();
        exit(2);
    }
    elsif ( not defined $POLICY_FILE or $POLICY_FILE eq "")
    {
        warn("\nI need a policy file to run!\n\n");
        help();
        exit(3);
    }


}

As you can see I was hardwiring the arguments directly into the program, as well as I was not using any getopt-like module.
That was by culture: university never told me there was a getopt way of getting parameters!


Please note also that I was checking the argument numbers as well as exiting from the program with a different exit code for each branch.
The style reminds pretty much the C-style I was used to work with during my exams.

3.2 Ready? Go!

How can I execute another program from within the Perl wrapper?


Well, the simplest way that I was aware of is to call execute, in other words, to work as a low level C:


sub launch($)
{
    # take arguments
    my ($program) = @_;

    # execute the program
    sleep(2);
    exec($program);
}

3.3 How Many Instances can you Run?

How to define how many instances an user can run?


Here I decided to take inspiration from the sudo policy file, and so I invented my own policy file with a pretty
simple syntax:


username@executable=instances


where:

  • username was the Unix username;
  • executable was the name of the executable to run;
  • instances was the number of the maximum allowed instances of the executable for the specified username.

And to make it looking mor eprofessional, I allowed the policy file to include a star in any field
in order to mean anything or any instance.


Of course, the above was full crap. For instance, if you were able to create a link from the executable to another
with the right name you could change you allowance. But luckily, no user was able to do that, and to some
extent even the other sysadmins!


Having defined the policy file syntax, reading the file was as simple as:


sub getAllowedInstances($$$)
{
    # take params
    my ($policy_file, $username, $program) = @_;
    my $instances = -1;

    # try to open the policy file
    open (POLICY_FILE_HANDLER, "<".$policy_file) || die("\nCannot parse policy file <$policy_file> !\n");
    print "\nParsing configuration file $policy_file for program $program, username $username...";

    $instances = 0;           # by default do not allow a user to execute a program

    # get each line from the policy file, and then search for the username
    while ( $line = <POLICY_FILE_HANDLER>  )
    {

        print "\n\t Configuration line: $line ";


        # take only lines with the program name specified
        if( grep("$program", $line) ){

            @lineParts = split("@",$line);
            $configUsername = $lineParts[0];
            print "\ncontrollo se $username == $configUsername";

            if ( $username eq $configUsername )
            {
                # this is the right line
                # take the instances number
                @pieces = split("=" , $line);
                $instances = $pieces[1];
                # remove the '\n'
                chomp($instances);
                print "\n\t\t\tUser allowance: $instances";
                return $instances;
            }
            elsif ( $configUsername eq "*" )
            {
                # a valid entry for all users
                # take the instances number
                @pieces = split("=" , $line);
                $instances = $pieces[1];
                # remove the '\n'
                chomp($instances);
                print "\n\t\t\tGlobal allowance: $instances";
            }
        }
    }


    # no lines found, the user has no restrictions
    return $instances;
}

What an amazing piece of code, uh?


Instead of reading the policy file once (or seldom), I was reading it fully every time I needed to check an user; it was
a very non-optimzed code.
Moreover, I was reading and grepping it a line at time, a very keyboard effort.

3.4 How much are you Running?

How to get the number of runnable instances an user was running?


Piece of cake: let's do it in Unix, backtick in Perl and increase by one:



sub getRunningInstancesCount($$)
{
    # get parameters
    my ( $program, $username ) = @_;

    # get all processes for this program and the username
    @processes = `ps -u $username | grep $program | grep -v "grep"`;


    # get all lines count
    $running_instances = 0;
    if ( $#processes >= 0 )
    {
        $running_instances = $#processes + 1;
    }
    else
    {
        return 0;
    }

    return $running_instances;
}

Please note also the adoption of literals instead of variables: for example return 0; instead of return $running_instances where
the latter has been already initialized to zero.

3.5 All Pieces Together

Now, putting the places together made the main loop as simple as:


$RUNNING_INSTANCES = getRunningInstancesCount($BASE_NAME, $USERNAME);
print "\nYou're running $RUNNING_INSTANCES $BASE_NAME\n";

# if the user can, launch the program
if ( $RUNNING_INSTANCES < $ALLOWED_INSTANCES )
{
    print "\nExecuting $PROGRAM...";
    launch($PROGRAM);
    print "\nBye!\n";
}
else
{
    print "\nYou can't run no more instances of $PROGRAM";
    print "\nBye\n";
    displayMessage();
}


4 Lesson Learned

There is no lesson to learn here, but a lot of lessons learned in the between.


The only thing I could say is that you should never, never, throw away your code. Keep it, it is cheap, and someday you could
see how you progressed from a green programmer to the very guru developer you probably are today.

domenica 2 aprile 2017

Assegnamento e binding (in Perl)

Un articolo molto interessante e ben fruibile sulla definizione di variabili (e chiusure) e del loro livello "intermedio".
Effettivamente non mi ero mai posto il problema della differenza fra assegnamento e binding a livello di run-time.

domenica 19 marzo 2017

DBIx (DBIC) in 10 minuti

Per chi proviene dal mondo "classico" della programmazione ORM (Object Relational Mapping), il componente DBIX può risultare un po' ostico. Il problema principale, a mio avviso, è nella terminologia e nella modalità di utilizzo. Se un ORM classico infatti richiede solitamente un livello intermedio di persistenza (tipicamente tramite una sessione, dao, ecc), DBIX tende a fornire oggetti (proxy-zzati) molto piu' autonomi.
In questo brevissimo articolo voglio mostrare come può essere usato DBIX agilmente nelle operazioni piu' comuni.

1 Creazione del database

Si supponga di creare uno schema SQLite3 molto semplice:
sqlite3 database.db
sqlite> CREATE TABLE events( pk integer primary key autoincrement,
ts timestamp default current_timestamp,
description varchar(200) );

2 Eseguire il dump dello schema

Il programma dbicdump permette il dump di uno schema database, ovvero la creazione degli oggetti result che rappresentano ciascuno una tabella singola del database/schema.
 dbicdump -o dump_directory=./lib -o components='["InflateColumn::DateTime"]' \
  Test::Schema
  dbi:SQLite:database.db
Dumping manual schema for Test::Schema to directory ./lib ...
Schema dump completed.
Dopo aver eseguito questo comando si avrà una directory lib che contiene un file Schema.pm (che dichiara il namespace) e il relativo albero di directory Schema/Result con un file pm per ogni DBIX result, ovvero un file per tabella. In particolare, per la singola tabella event rappresentata dalla classe nel file Event.pm si ha che:
__PACKAGE__->add_columns(
  "pk",
  { data_type => "integer", is_auto_increment => 1, is_nullable => 0 },
  "ts",
  {
    data_type     => "timestamp",
    default_value => \"current_timestamp",
    is_nullable   => 1,
  },
  "description",
  { data_type => "varchar", is_nullable => 1, size => 200 },
);
Si nota come il sistema di gestione dei result sia di tipo dichiarativo: ogni classe (Perl) indica in modo dichiarativo i propri membri, e ciascun membro corrisponde sostanzialmente ad una colonna del database.
L'utilizzo di DBIX risulta veramente veloce e semplice (dal punto di vista della quantità del codice). La classe schema eredita da DBIX::Schema e quindi dispone del metodo connect che consente la connessione al database. Ogni azione che si vuole fare su un database (istanza) deve avvenire attraverso lo schema. Lo schema raccoglie una serie di tuple raggruppate in un result set (inteso qui differentemente rispetto a JDBC, DBI, ecc). Ogni operazione che si vuole svolgere su una tupla deve passare attraverso un result set. In sostanza si potrebbe affermare che l'analogia fra DBI e DBIX è la seguente:
DBI - JDBC - similari DBIX Significato
database handler schema Connessione al database (istanza)
result set array di oggetti Risultati da una query
statement su tabella result set Interazione lettura/scrittura con una tabella

3 Un primo esempio

Ecco quindi un programma di esempio:
use Test::Schema;

my $schema_connection = Test::Schema->connect( 'dbi:SQLite:/home/luca/tmp/dbix/database.db' );


for ( 1..100 ){
    my $event = $schema_connection
 ->resultset( 'Event' )
 ->create( { description => "Evento $_" } );

    # update !
    $event->update();
}

# ricerca di eventi
my $result_set = $schema_connection->resultset( 'Event' )->search( { pk =>{ '>' => 50, '<' => 87 }  } );

while ( ( my $event = $result_set->next() ) ){
    say "Evento " . $event->pk . " = " . $event->description;
}
#+end-perl

La prima parte carica lo schema e gli oggetti creati appositamente da ~dbicdump~.
Successivamente si crea lo schema, ovvero ci si collega al database (istanza).
Poi si effettua un semplice ciclo per inserire 100 righe nella tabella /events/, corrispondente all'oggetto Perl ~Event~.
Si noti che tali oggetti sono creati con il metodo ~create~ sul result set, che a sua volta è agganciato alla tabella /events/.
In altre parole la riga

#+negin_src perl
my $event = $schema_connection
 ->resultset( 'Event' )
 ->create( { description => "Evento $_" } );
esegue:
  1. una connessione al database (istanza) usando lo Schema;
  2. decide di lavorare sul result set Event, ovvero sulla tabella corrispondente events;
  3. chiedendo di creare un oggetto che rappresenta una singola riga nella tabella.
Giunti a questo punto DBIX sa tutto quello che gli serve per memorizzare in modo permanente sul database l'oggetto, e quindi tradurlo in una riga di SQL. Da notare che l'oggetto creato tramite il metodo create è un oggetto Perl a tutti gli effetti, ovvero è possibile usare i metodi accessor per impostare i valori.
Fino a qui DBIX si è solo "preparato", ma non ha eseguito nulla di fatto. Nel momento in cui l'oggetto si aggiorna, ovvero si invoca il metodo update, questo viene inserito/aggiornato nella tabella.
Questo è un punto nodale che rappresenta una differenza fondamentale nell'approccio DBIX rispetto ad altri ORM (es. Hibernate): invece che creare degli oggetti slegati dal database e richiedere ad un servizio DAO di rendere persistente tali oggetti, DBIX crea oggetti collegati alla propria tabella e al proprio database, così che tali oggetti "sappiano" dove andare ad "inserirsi" o "aggiornarsi". Nessuna cosa, entità o servizio di persistenza esterno viene invocato.
Successivamente è possibile rileggere i dati inseriti, ancora una volta passando per il result set:
  1. si usa la connessione al database (istanza), ovvero lo Schema;
  2. si dichiara di voler lavorare sullo schema Event, ovvero la tabella fisica events;
  3. si effettua una ricerca specificando, per ogni colonna che si vuole cercare, i valori da mettere in and-logico. Nell'esempio di cui sopra si ha che si prendono tutte le tuple con pk compreso fra 51 e 86 inclusi. L'oggetto ritornato è un Result Set, da intendersi come collezione di oggetti del tipo Event.
Si può allora iterare sul result set per ottenere tutti gli oggetti di tipo Event richiesti. Da notare che è possibile specificare delle clausole where letterali, il metodo search può accettare diversi formati di parametri. Inoltre esiste un metodo find per la ricerca secca di un record per chiave primaria.

4 Update massivo

Ci sono due strade per effettuare un aggiornamento massivo di record:
  1. iterare su ogni oggetto collegato ad una tupla ed eseguire un update singolo;
  2. eseguire un update sul result set trovato da una query di ricerca.
Il primo metodo potrebbe riassumersi così:
my $result_set = $schema_connection->resultset( 'Event' )->search( { pk =>{ '>' => 50, '<' => 87 }  } );

while ( ( my $event = $result_set->next() ) ){
    $event->description( " AGGIORNATO " . $event->description() );
    $event->update();
}
L'idea è semplice: si effettua una ricerca, si prendono uno ad uno gli oggetti Event (ciascuno dei quali corrisponde ad una tupla) e lo si aggiorna tramite update. DBIX è sufficientemente intelligente per capire che deve eseguire una UPDATE verso il database, siccome la riga proveniva da una query.
Il secondo approccio, sicuramente piu' compatto e simile, come concetto, alla query SQL che si vorrebbe eseguire, è il seguente:
my $result_set = $schema_connection->resultset( 'Event' )->search( { pk =>{ '>' => 50, '<' => 87 }  } );
$result_set->update( { description => 'AGGIORNATO' } );
La differenza, ovvia, è che non si possono chiamare degli accessor nel caso di update di un intero result set, e quindi questa tecnica è effettivamente utile quando si devono impostare tutti i valori ad un letterale prestabilito.

5 Colonne modificate, annullare le modifiche

Un singolo oggetto collegato ad un result set è in grado di sapere quali colonne sono state modificate:
$event->description( " AGGIORNATO " . $event->description() );
    my %cols = $event->get_dirty_columns();
    for my $col ( keys %cols ){
 say "Evento " . $event->pk . " con colonna $col modificata " ;
    }
e quindi è anche possibile evitare di eseguire delle query qualora l'oggetto non sia stato modificato:
$event->update() if ( $event->get_dirty_columns() );

6 Cancellazione

Beh, come ci si puo' aspettare, delete esegue lo scopo:
$event->delete;

7 Insert o Update?

Inizialmente ho mentito: non è necessario chiamare update per eseguire una query INSERT o una query UPDATE. Come ci si può aspettare il metodo update esegue…eh.. UPDATE! Esiste infatti un metodo insert da richiamare su un oggetto risultato per eseguire l'inserimento nella tabella corrispondente. Il motivo per il quale nel primo esempio si è usato update è che lo schema ha creato l'oggetto con create, che inserisce di fatto una tupla nella tabella corrispondete. L'update successiva aggiorna tale tupla. E' possibile creare un oggetto senza inserirlo nel database usando il metodo new sul result set, che restituisce un oggetto sul quale occorre poi fare una insert esplicita:
my $event = $schema_connection
    ->resultset( 'Event' )
    ->new( { description => "!!Evento $_" } );

$event->insert;

8 Aggiungere foreign keys

Supponiamo di voler dotare ogni evento di un "tag":
sqlite> CREATE TABLE tags( pk integer primary key autoincrement, description varchar(20) );
sqlite> INSERT INTO tags( description) VALUES( 'Tag1' ), ( 'Tag2' );
sqlite> DROP TABLE events;
sqlite> CREATE TABLE events( pk integer primary key autoincrement,
   ...>    ts timestamp default current_timestamp,
   ...>    description varchar(200),
   ...>    tag_pk integer,
   ...>    FOREIGN KEY(tag_pk) REFERENCES tags(pk) );
Se si ricostruisce il modello Perl con dbicdump si ha che viene creata una classe Tag che contiene nella definizione il seguente blocco:
=head1 RELATIONS

=head2 events

Type: has_many

Related object: L

=cut

__PACKAGE__->has_many(
  "events",
  "Test::Schema::Result::Event",
  { "foreign.tag_pk" => "self.pk" },
  { cascade_copy => 0, cascade_delete => 0 },
);
che istruisce DBIX sul fatto che Event e Tag sono in relazione attraverso le chiavi esterne. Analogamente Event viene modificato rispetto a prima:
__PACKAGE__->belongs_to(
  "tag_pk",
  "Test::Schema::Result::Tag",
  { pk => "tag_pk" },
  {
    is_deferrable => 0,
    join_type     => "LEFT",
    on_delete     => "NO ACTION",
    on_update     => "NO ACTION",
  },
);
Vediamo ora come è possibile inserire delle tuple che agiscano su entrambe le tabelle:
use Test::Schema;

my $schema_connection = Test::Schema->connect( 'dbi:SQLite:/home/luca/tmp/dbix/database.db' );


for ( 1..100 ){
    my $tag = $schema_connection
 ->resultset( 'Tag' )
 ->find( ( $_ % 2 ) + 1 );

    my $event = $schema_connection
 ->resultset( 'Event' )
 ->new( { description => "Evento $_" } );

    $event->tag_pk( $tag );
    $event->insert;
}
Come si può notare si seleziona in modo "random" un tag dal resultset Tag, e poi lo si imposta nell'oggetto Event che viene poi inserito tramite insert. Da notare una bruttura: DBIX chiama il metodo accessor della relazione come la colonna stessa della tabella, in questo caso tag_pk. Ovviamente non è DBIX, quanto dbicdump, quindi questa cosa va tenuta presente e/o modificata a mano per rendere piu' leggibile il codice Perl (dopotutto tag_pk() agisce su un oggetto Tag e non su un oggetto integer). Se ad esempio si modifica Event.pm come segue:
__PACKAGE__->belongs_to(
  "tag",  # era tag_pk
  "Test::Schema::Result::Tag",
  { pk => "tag_pk" },
  {
    is_deferrable => 0,
    join_type     => "LEFT",
    on_delete     => "NO ACTION",
    on_update     => "NO ACTION",
  },
);
allora il seguente codice usa il metodo mnemonico tag che ricorda meglio l'oggetto risultato Tag:
for ( 1..100 ){
    my $tag = $schema_connection
 ->resultset( 'Tag' )
 ->find( ( $_ % 2 ) + 1 );

    my $event = $schema_connection
 ->resultset( 'Event' )
 ->new( { description => "Evento $_" } );


    $event->tag( $tag ); # era tag_pk
    $event->insert;
}
A questo punto si può procedere in maniera analoga alla ricerca dei dati, il metodo Event::tag fornirà un oggetto di tipo Tag mentre Tag::events fornirà una lista di oggetti Event. Ad esempio:
my $result_set = $schema_connection->resultset( 'Tag' )->find( 1 );

for my $event ( $result_set->events() ){
    say "Evento trovato " . $event->description;
}
da notare che sul result set non si deve effettuare nessuna operazione poiché il metodo find restituisce un solo valore Tag.

9 Riassunto

DBIX è un meccanismo molto flessibile e potente, che opera a livello semi-dichiarativo: come si è potuto notare ogni oggetto collegato ad una tupla database è espresso tramite invocazioni di metodi che ne definiscono struttura e relazioni (es. belongs_to). Il concetto chiave di DBIX è, a mio avviso, il fatto che il result set non rappresenta un set di risultati quanto una tabella fisica (o un join di tabelle), e che di conseguenza ogni singola tupla di tabella/e diventa un oggetto capace di agire autonomamente sulla propria persistenza. Ne consegue che ogni volta che si vuole interagire con una tabella si deve passare per un result set, sia per aggiungere, aggiornare, cancellare o selezionare tuple, che a loro volta diventano oggetti, che includono la logica dao al proprio interno.