Exemples d'implémentation¶

Ce chapitre présente deux projets complets et fonctionnels en Perl moderne. Le premier est une API REST CRUD avec Mojolicious et SQLite illustrant les patterns web courants. Le second est un moteur de parsing et transformation de texte multi-format exploitant la puissance des expressions régulières Perl.

Projet 1 : API REST CRUD avec Mojolicious¶

Architecture¶

L'API géré une ressource Item avec les opérations CRUD complètes sur une base SQLite. Elle répond en JSON et inclut une validation des entrees.

GET    /api/items        -> liste tous les items
GET    /api/items/:id    -> recupere un item
POST   /api/items        -> cree un item
PUT    /api/items/:id    -> met a jour un item
DELETE /api/items/:id    -> supprime un item

Modèle : lib/MojoCRUD/Model/Item.pm¶

package MojoCRUD::Model::Item;
use v5.36;
use DBI;

# Constructeur : recoit un handle DBI
sub new ($class, $dbh) {
    # Creation de la table si elle n'existe pas
    $dbh->do(q{
        CREATE TABLE IF NOT EXISTS items (
            id          INTEGER PRIMARY KEY AUTOINCREMENT,
            nom         TEXT    NOT NULL,
            description TEXT,
            quantite    INTEGER NOT NULL DEFAULT 0,
            cree_le     DATETIME DEFAULT CURRENT_TIMESTAMP
        )
    });
    return bless { dbh => $dbh }, $class;
}

# Liste tous les items
sub liste ($self) {
    my $sth = $self->{dbh}->prepare(
        'SELECT id, nom, description, quantite, cree_le FROM items ORDER BY id'
    );
    $sth->execute;
    return $sth->fetchall_arrayref({});  # hashrefs
}

# Recupere un item par son id
sub par_id ($self, $id) {
    my $sth = $self->{dbh}->prepare(
        'SELECT id, nom, description, quantite, cree_le FROM items WHERE id = ?'
    );
    $sth->execute($id);
    return $sth->fetchrow_hashref;
}

# Cree un item, retourne son nouvel id
sub creer ($self, $data) {
    my $sth = $self->{dbh}->prepare(
        'INSERT INTO items (nom, description, quantite) VALUES (?, ?, ?)'
    );
    $sth->execute($data->{nom}, $data->{description} // '', $data->{quantite} // 0);
    return $self->{dbh}->last_insert_id;
}

# Met a jour un item, retourne le nombre de lignes modifiees
sub mettre_a_jour ($self, $id, $data) {
    my $sth = $self->{dbh}->prepare(
        'UPDATE items SET nom = ?, description = ?, quantite = ? WHERE id = ?'
    );
    return $sth->execute($data->{nom}, $data->{description} // '', $data->{quantite} // 0, $id);
}

# Supprime un item, retourne le nombre de lignes supprimees
sub supprimer ($self, $id) {
    my $sth = $self->{dbh}->prepare('DELETE FROM items WHERE id = ?');
    return $sth->execute($id);
}

1;

Application : app.pl¶

#!/usr/bin/perl
use v5.36;
use Mojolicious::Lite -signatures;
use DBI;
use MojoCRUD::Model::Item;

# Connexion a la base de donnees SQLite
helper db => sub {
    state $dbh = DBI->connect(
        'dbi:SQLite:dbname=items.db',
        undef, undef,
        { RaiseError => 1, AutoCommit => 1 }
    );
    return $dbh;
};

# Modele partage
helper item_model => sub ($c) {
    state $model = MojoCRUD::Model::Item->new($c->db);
    return $model;
};

# Sous-routine de validation
sub valider_item ($data) {
    my @erreurs;
    push @erreurs, 'Le champ nom est requis'       unless $data->{nom};
    push @erreurs, 'La quantite doit etre positive' if defined $data->{quantite} && $data->{quantite} < 0;
    return @erreurs;
}

# GET /api/items — liste
get '/api/items' => sub ($c) {
    my $items = $c->item_model->liste;
    $c->render(json => $items);
};

# GET /api/items/:id — detail
get '/api/items/:id' => sub ($c) {
    my $id   = $c->param('id');
    my $item = $c->item_model->par_id($id);

    return $c->render(status => 404, json => { erreur => 'Item non trouve' })
        unless $item;

    $c->render(json => $item);
};

# POST /api/items — creation
post '/api/items' => sub ($c) {
    my $data = $c->req->json // {};
    my @erreurs = valider_item($data);

    return $c->render(status => 400, json => { erreurs => \@erreurs })
        if @erreurs;

    my $id   = $c->item_model->creer($data);
    my $item = $c->item_model->par_id($id);
    $c->render(status => 201, json => $item);
};

# PUT /api/items/:id — mise a jour
put '/api/items/:id' => sub ($c) {
    my $id   = $c->param('id');
    my $data = $c->req->json // {};

    return $c->render(status => 404, json => { erreur => 'Item non trouve' })
        unless $c->item_model->par_id($id);

    my @erreurs = valider_item($data);
    return $c->render(status => 400, json => { erreurs => \@erreurs })
        if @erreurs;

    $c->item_model->mettre_a_jour($id, $data);
    $c->render(json => $c->item_model->par_id($id));
};

# DELETE /api/items/:id — suppression
del '/api/items/:id' => sub ($c) {
    my $id = $c->param('id');

    return $c->render(status => 404, json => { erreur => 'Item non trouve' })
        unless $c->item_model->par_id($id);

    $c->item_model->supprimer($id);
    $c->render(status => 204, data => '');
};

app->start;

Lancement

perl app.pl daemon -l http://*:3000
# ou en mode developpement avec rechargement auto
morbo app.pl

Projet 2 : Moteur de parsing et transformation de texte¶

Ce script lit des fichiers CSV, de logs Apache et XML, applique des transformations via un pipeline et produit une sortie JSON structurée.

Pipeline de transformation : transform.pl¶

#!/usr/bin/perl
use v5.36;
use File::Slurper qw(read_text);
use JSON::PP;

# --- Parsers ---

# Parse un fichier CSV simple (sans guillemets imbriques)
sub parse_csv ($texte) {
    my @lignes  = split /\n/, $texte;
    my @entetes = split /,/, shift @lignes;
    chomp @entetes;

    my @enregistrements;
    for my $ligne (@lignes) {
        next unless $ligne =~ /\S/;  # ignore lignes vides
        chomp $ligne;
        my @champs = split /,/, $ligne;
        my %enreg;
        @enreg{@entetes} = @champs;
        push @enregistrements, \%enreg;
    }
    return @enregistrements;
}

# Parse les logs au format Combined Log Format d'Apache/Nginx
# Exemple : 127.0.0.1 - frank [10/Oct/2000:13:55:36 -0700] "GET /apache_pb.gif HTTP/1.0" 200 2326
sub parse_log_apache ($texte) {
    my @entrees;
    my $patron = qr{
        ^(\S+)          # IP client
        \s+\S+          # ident (souvent -)
        \s+(\S+)        # utilisateur auth
        \s+\[([^\]]+)\] # horodatage
        \s+"(\S+)       # methode HTTP
        \s+(\S+)        # chemin
        \s+\S+"         # protocole
        \s+(\d+)        # code HTTP
        \s+(\d+|-)      # taille reponse
    }x;

    for my $ligne (split /\n/, $texte) {
        next unless $ligne =~ $patron;
        push @entrees, {
            ip         => $1,
            utilisateur => $2,
            horodatage => $3,
            methode    => $4,
            chemin     => $5,
            code_http  => int($6),
            taille     => $7 eq '-' ? 0 : int($7),
        };
    }
    return @entrees;
}

# Parse un XML simple (balises de premier niveau uniquement)
sub parse_xml_simple ($texte) {
    my @elements;
    # Capture les blocs <item ...>...</item>
    while ($texte =~ m{<item\b([^>]*)>(.*?)</item>}gsi) {
        my ($attrs_texte, $contenu) = ($1, $2);

        # Extraction des attributs id="valeur"
        my %attrs;
        while ($attrs_texte =~ /(\w+)="([^"]+)"/g) {
            $attrs{$1} = $2;
        }

        # Extraction des sous-elements <nom>valeur</nom>
        my %champs = %attrs;
        while ($contenu =~ m{<(\w+)>([^<]*)</\1>}g) {
            $champs{$1} = $2;
        }
        push @elements, \%champs;
    }
    return @elements;
}

# --- Transformations ---

# Normalise les cles d'un hashref en minuscules sans espaces
sub normaliser_cles ($enreg) {
    my %sortie;
    for my $cle (keys %$enreg) {
        (my $cle_norm = lc $cle) =~ s/\s+/_/g;
        $sortie{$cle_norm} = $enreg->{$cle};
    }
    return \%sortie;
}

# Filtre les enregistrements selon un critere
sub filtrer ($enregistrements, $critere) {
    return [ grep { $critere->($_) } @$enregistrements ];
}

# Projette les enregistrements sur un sous-ensemble de champs
sub projeter ($enregistrements, @champs) {
    return [
        map {
            my $src = $_;
            +{ map { $_ => $src->{$_} } @champs }
        } @$enregistrements
    ];
}

# Enrichit chaque enregistrement avec des champs calcules
sub enrichir ($enregistrements, $fn) {
    return [ map { $fn->($_) } @$enregistrements ];
}

# --- Pipeline principal ---

sub pipeline ($source, @etapes) {
    my $donnees = $source;
    for my $etape (@etapes) {
        $donnees = $etape->($donnees);
    }
    return $donnees;
}

# --- Programme principal ---

# Exemple 1 : traitement CSV
my $csv_texte = <<'CSV';
nom,ville,age,score
Alice,Paris,28,92
Bob,Lyon,34,75
Charlie,Paris,22,88
Diana,Marseille,29,95
CSV

my @csv_data = parse_csv($csv_texte);
my $resultat_csv = pipeline(
    [ map { normaliser_cles($_) } @csv_data ],
    sub { filtrer($_[0], sub { $_[0]->{ville} eq 'Paris' }) },
    sub { projeter($_[0], 'nom', 'age', 'score') },
    sub { enrichir($_[0], sub {
        my $e = { %{$_[0]} };
        $e->{niveau} = $e->{score} >= 90 ? 'excellent' : 'bien';
        return $e;
    })},
);

say "=== Resultat CSV (Parisiens) ===";
say JSON::PP->new->pretty->encode($resultat_csv);

# Exemple 2 : analyse de logs Apache
my $log_texte = <<'LOG';
192.168.1.1 - alice [01/Apr/2025:10:00:01 +0200] "GET /api/items HTTP/1.1" 200 1234
192.168.1.2 - bob [01/Apr/2025:10:00:05 +0200] "POST /api/items HTTP/1.1" 201 89
192.168.1.3 - - [01/Apr/2025:10:00:09 +0200] "GET /secret HTTP/1.1" 403 0
192.168.1.1 - alice [01/Apr/2025:10:01:00 +0200] "DELETE /api/items/5 HTTP/1.1" 404 45
LOG

my @logs = parse_log_apache($log_texte);
my $erreurs = filtrer(\@logs, sub { $_[0]->{code_http} >= 400 });

say "\n=== Erreurs HTTP ===";
for my $e (@$erreurs) {
    printf "  %s %s -> %d\n", $e->{methode}, $e->{chemin}, $e->{code_http};
}

# Exemple 3 : parsing XML
my $xml = <<'XML';
<catalogue>
  <item id="1"><nom>Clavier</nom><prix>49.99</prix><stock>15</stock></item>
  <item id="2"><nom>Souris</nom><prix>29.99</prix><stock>0</stock></item>
  <item id="3"><nom>Ecran</nom><prix>299.00</prix><stock>5</stock></item>
</catalogue>
XML

my @produits = parse_xml_simple($xml);
my $dispo = filtrer(\@produits, sub { ($_[0]->{stock} // 0) > 0 });

say "\n=== Produits disponibles ===";
say JSON::PP->new->pretty->encode($dispo);

Parsing XML en production

Pour des fichiers XML complexes ou en production, utilisez XML::LibXML ou XML::Twig plutôt qu'un parser maison. Les parsers a base de regex ne gèrent pas les cas limites (CDATA, namespaces, attributs avec guillemets simples).