Perl et la programmation orientée objet

my $_private_method = sub {
  my $this = shift;

  my @argument = @_;
  # ...
};

# Appel de la méthode privée
sub public_method {
  # ...
  $this->$_private_method(...);  # ou $this->$_private_method->(...);
  # ...
}

# Destructeur
sub DESTROY {
  my $this = shift;
  
  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  # Diminuer le nombre de personnes créées.
  $NbrPersonnes--;
  
  return;
}

#!/usr/bin/perl
use warnings;
use strict;
use Carp;

use Personne;

my $Objet_Personne1 = Personne->new(
  { nom           => 'Dupont',
    prenom        => 'Jean',
    age           => 45,
    sexe          => 'M',
    nombre_enfant => 3,
  }
);

print "Bonjour\n";
$Objet_Personne1 = undef;
print "Bye bye";

Bonjour
===================================================
L'objet de la classe Personne va mourir
===================================================
Bye bye

package Personne;    # Nom du package, de notre classe
use warnings;        # Avertissement des messages d'erreurs
use strict;          # Vérification des déclarations
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.00';

# Comptage du nombre de personnes créées
my $NbrPersonnes = 0;     # champ statique privé

# Constructeur de la classe Personne
sub new {
  my ( $classe, $ref_arguments ) = @_;

  # Vérifions la classe
  $classe = ref($classe) || $classe;

  # Création de la référence anonyme à un hachage vide (futur objet)
  my $this = {};

  # Liaison de l'objet à la classe
  bless( $this, $classe );

  # Vérification des champs nom, prenom et sexe
  foreach my $attribut (qw/ nom prenom sexe /) {
    unless ( defined $ref_arguments->{$attribut} ) {
      croak("[Attention] Attribut $attribut manquant\n");
    }
  }
  unless ( $ref_arguments->{sexe} =~ m{^M|F$}i ) {
    croak(
      "[Attention] Mauvais attribut sexe : $ref_arguments->{sexe}, F ou M\n");
  }

  $this->{_NOM}          = $ref_arguments->{nom};
  $this->{_PRENOM}       = $ref_arguments->{prenom};
  $this->{AGE}           = $ref_arguments->{age};
  $this->{_SEXE}         = $ref_arguments->{sexe};
  $this->{NOMBRE_ENFANT} = $ref_arguments->{nombre_enfant} || 0;

  # Nombre de personnes créées.
  $NbrPersonnes++;

  return $this;
}

# accesseur obtenir_nom
sub obtenir_nom {
  my $this = shift;
  return $this->{_NOM};
}

# accesseur obtenir_prenom
sub obtenir_prenom {
  my $this = shift;
  return $this->{_PRENOM};
}

# accesseur obtenir_sexe
sub obtenir_sexe {
  my $this = shift;
  return $this->{_SEXE};
}

# accesseur obtenir_age
sub obtenir_age {
  my $this = shift;
  return $this->{AGE};
}

# mutateur modifier_age
sub modifier_age {
  my ( $this, $age ) = @_;

  if ( defined $age ) {
    unless ( $age =~ m{^\d+$} ) {
      croak "Mauvais argument : $age\n";
      return;
    }
    $this->{AGE} = $age;
  }

  return;
}

# accesseur obtenir_nombre_enfant
sub obtenir_nombre_enfant {
  my $this = shift;

  return $this->{NOMBRE_ENFANT};
}

# mutateur modifier_nombre_enfant
sub modifier_nombre_enfant {
  my ( $this, $nombre_enfant ) = @_;

  if ( defined $nombre_enfant ) {
    unless ( $nombre_enfant =~ m{^\d+$} ) {
      croak "Mauvais argument : $nombre_enfant\n";
      return;
    }
    $this->{NOMBRE_ENFANT} = $nombre_enfant;
  }

  return;
}

# Méthode marcher - ne prend aucun argument
sub marcher {
  my $this = shift;

  print "[$this->{_NOM} $this->{_PRENOM}] Marche\n";

  return;
}

# Méthode parler - un argument
sub parler {
  my ( $this, $message ) = @_;

  unless ( defined $message ) {
    $message = 'Ne sais pas quoi dire';
  }

  # Le premier caractère de la phrase est mis en majuscule
  $message = ucfirst($message);
  print "[$this->{_NOM} $this->{_PRENOM}] $message\n";

  return 1;
}

# méthode de classe Obtenir_nbr_personnes
sub Obtenir_nbr_personnes {
  my $classe = shift;

  return $NbrPersonnes;
}

# Destructeur
sub DESTROY {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  # Diminuer le nombre de personnes créées.
  $NbrPersonnes--;

  return;
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Homme;    # Nom du package, de notre classe
use warnings;     # Avertissement des messages d'erreurs
use strict;       # Vérification des déclarations
use Carp;         # Utile pour émettre certains avertissements

use base qw ( Personne Activite );   # hérite de la classe Personne et Activite
use vars qw($VERSION);               # Version de notre module
$VERSION = '1.00';

# Constructeur de la classe Personne
sub new {
  my ( $classe, $ref_arguments ) = @_;

  # Vérifions la classe
  $classe = ref($classe) || $classe;

  # Objet de notre classe héritée
  my $this = $classe->SUPER::new(
    { nom           => $ref_arguments->{nom},
      prenom        => $ref_arguments->{prenom},
      age           => $ref_arguments->{age},
      sexe          => 'M',
      nombre_enfant => $ref_arguments->{nombre_enfant},
    }
  );

  # Liaison de l'objet à la classe
  bless( $this, $classe );

  # Nouvel attribut
  $this->{BARBU} = $ref_arguments->{barbu};

  return $this;
}

# accesseur obtenir_barbu
sub obtenir_barbu {
  my $this = shift;

  return $this->{BARBU};
}

# mutateur modifier_barbu
sub modifier_barbu {
  my ( $this, $barbu ) = @_;

  if ( defined $barbu ) {
    unless ( $barbu =~ m{^\d+$} ) {
      croak "Mauvais argument : $barbu\n";
      return;
    }
    $this->{BARBU} = $barbu;
  }

  return $this->{BARBU};
}

# Méthode parler (un argument) qui va redéfinir la méthode parler
# de la classe mère
sub parler {
  my ( $this, $message ) = @_;

  unless ( defined $message ) {
    $message = 'je suis un homme et Ne sais pas quoi dire';
  }
  $this->SUPER::parler( $message . ' (je suis un homme)' );

  return 1;
}

# Destructeur
sub DESTROY {
  my $this = shift;

  # destructeur de la classe mère.
  print "=>Appel du destructeur de la classe mère\n\n";
  $this->SUPER::DESTROY();

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Femme;    # Nom du package, de notre classe
use warnings;     # Avertissement des messages d'erreurs
use strict;       # Vérification des déclarations
use Carp;         # Utile pour émettre certains avertissements

use base qw ( Personne Activite );   # hérite de la classe Personne et Activite
use vars qw($VERSION);               # Version de notre module
$VERSION = '1.00';

# Constructeur de la classe Personne
sub new {
  my ( $classe, $ref_arguments ) = @_;

  # Vérifions la classe
  $classe = ref($classe) || $classe;

  # Objet de notre classe héritée
  my $this = $classe->SUPER::new(
    { nom           => $ref_arguments->{nom},
      prenom        => $ref_arguments->{prenom},
      age           => $ref_arguments->{age},
      sexe          => 'F',
      nombre_enfant => $ref_arguments->{nombre_enfant},
    }
  );

  # Liaison de l'objet à la classe
  bless( $this, $classe );

  return $this;
}

# méthode accouche
sub accouche {
  my ( $this, $nombre_enfant ) = @_;

  if ( defined $nombre_enfant ) {
    unless ( $nombre_enfant =~ m{^\d+$} ) {
      croak "Mauvais argument : $nombre_enfant\n";
      return;
    }

    $this->parler("accouche de $nombre_enfant enfant(s)");
    my $NbrEnfant = $this->obtenir_nombre_enfant() + $nombre_enfant;
    $this->modifier_nombre_enfant($NbrEnfant);
  }

  return;
}

# Destructeur
sub DESTROY {
  my $this = shift;

  # destructeur de la classe mère.
  print "=>Appel du destructeur de la classe mère\n\n";
  $this->SUPER::DESTROY();

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}
1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Activite;    # Nom du package, de notre classe
use warnings;        # Avertissement des messages d'erreurs
use strict;          # Vérification des déclarations
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.00';

# Constructeur de la classe Personne
sub new {
  my ( $classe, $ref_arguments ) = @_;

  # Vérifions la classe
  $classe = ref($classe) || $classe;

  # Objet de notre classe héritée
  my $this = {};

  # Liaison de l'objet à la classe
  bless( $this, $classe );

  $this->{METIER}  = $ref_arguments->{metier};
  $this->{SALAIRE} = $ref_arguments->{salaire};

  return $this;
}

# accesseur obtenir_salaire
sub obtenir_salaire {
  my $this = shift;

  return $this->{SALAIRE};
}

# mutateur modifier_salaire
sub modifier_salaire {
  my ( $this, $salaire ) = @_;

  if ( defined $salaire ) {
    $this->{SALAIRE} = $salaire;
  }

  return;
}

# accesseur obtenir_metier
sub obtenir_metier {
  my $this = shift;

  return $this->{METIER};
}

# mutateur modifier_metier
sub modifier_metier {
  my ( $this, $metier ) = @_;

  if ( defined $metier ) {
    $this->{METIER} = $metier;
  }

  return;
}

# méthode impot_a_payer
sub impot_a_payer {
  my $this = shift;

  if ( exists $this->{SALAIRE} ) {
    return 0.6 * $this->{SALAIRE};
  }
  croak("[Attention] Difficile de calculer vos impôts sans salaire\n");
}

# Destructeur
sub DESTROY {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

#!/usr/bin/perl
use warnings;
use strict;
use Carp;

use Femme;
use Homme;
use utf8;    # On a des accents dans le script

# Nous sommes dans une boulangerie
print "[A la boulangerie]\n\n";

# 1ere personne = enfant
my $enfant = Homme->new(
  { nom    => 'Henry',
    prenom => 'Antoine',
    age    => 5,
  }
);

$enfant->parler("bonjour");

# 2eme personne = boulangere
my $boulangere = Femme->new(
  { nom    => 'Laplanche',
    prenom => 'Caroline',
    age    => 35,
  }
);

$boulangere->parler("bonjour");
$enfant->parler("comment tu t'appelles ?");
$boulangere->parler(
  " Je m'appelle " . $boulangere->obtenir_prenom() . " et toi ?" );
$enfant->parler( "Je m'appelle "
    . $enfant->obtenir_prenom()
    . $enfant->obtenir_nom() );
$enfant->parler("t'as quel âge ?");
$boulangere->parler( "J'ai " . $boulangere->obtenir_age() . " ans" );
$enfant->parler("pain mame s'il vous plait");

print "\n[Toujours dans la boulangerie, 2 vieux copains "
  . "d'école primaire se rencontrent]\n\n";

my $copain1 = Homme->new(
  { nom    => 'Henry',
    prenom => 'Guillaume',
    age    => 35,
  }
);

$copain1->parler("comment ça va ?");

my $copain2 = Homme->new(
  { nom    => 'Petit',
    prenom => 'Stephane',
    barbu  => 1,
  }
);

#

$copain2->parler("bien");

my $Copain2Barbu = $copain2->obtenir_barbu();
if ( defined $Copain2Barbu and $Copain2Barbu == 1 ) {
  $copain1->parler("et toi ? tu es barbu maintenant ?");
  $copain2->parler("moi ? barbu ? non juste fatigué...");
}

$copain2->parler("ma femme vient d'accoucher, alors les nuits sont courtes");
$copain2->parler("et toi ? tu as combien d'enfants ?");

$copain1->modifier_nombre_enfant(2);
$copain1->parler( "moi j'en ai " . $copain1->obtenir_nombre_enfant() );
$copain2->parler("quel âge ?");
$copain1->parler( "le dernier a 1 an et commence à marcher. le premier "
    . "commence à parler correctement. d'ailleurs "
    . "c'est lui qui demande du pain à la boulangerie" );

$copain2->parler("tu fais quoi comme métier ?");
$copain1->modifier_metier("ingénieur en informatique");
$copain1->parler( "je suis " . $copain1->obtenir_metier() );
$copain2->parler("Pardon, j'ai pas bien entendu");
$copain1->parler( $copain1->obtenir_metier() );

$enfant->parler("papa, pas de pièce pour le pain");
$copain1->parler("va demander à maman, elle est juste devant la porte");
$enfant->marcher();

print "\n[Mais maman se prend une prune par la police municipale] \n\n";
my $FemmeCopain1 = Femme->new(
  { nom    => 'Henry',
    prenom => 'Anne',
  }
);

$FemmeCopain1->parler( "Quoi ? une contravention pour 5 min de stationnement ? "
    . "Et vous êtes payé combien pour ça ?" );

my $contractuel = Homme->new(
  { nom    => 'Letellier',
    prenom => 'Carlos',
    barbu  => 1,
  }

);

$contractuel->parler(
  "1200 par mois, et ce n'est pas encore assez pour me faire insulter ! Vous payez combien d'impôts ?"
);

$FemmeCopain1->modifier_salaire(2000);
$FemmeCopain1->parler(
  "plus de " . $FemmeCopain1->impot_a_payer() . " euros par mois" );
$contractuel->parler(
  "Et bien vous pourrez mettre un visage sur le prochain chèque que vous aurez à régler!"
);

if ( $FemmeCopain1->obtenir_sexe() eq 'M' ) {
  $contractuel->parler("Bonne journée monsieur!");
}
else {
  $contractuel->parler("Bonne journée madame!");
}

$FemmeCopain1->parler( $enfant->obtenir_prenom() . ', '
    . $copain1->obtenir_prenom()
    . " : Allez on rentre à la maison!!" );

print "\n[Conversation terminée]\n";
print "Il y avait ", $boulangere->Obtenir_nbr_personnes(),
  " personne(s) dans la conversation\n\n";

package Personne;    # Nom du package, de notre classe
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '2.0';

use Moose;            # Il charge automatiquement strict et warnings

# Tout le code ici

1;
__END__

# Comptage du nombre de personnes créées
my $NbrPersonnes = 0;     # champ statique privé

# Création des attributs
has nom => (
  is       => 'ro',       # Attribut est lisible et non modifiable
  isa      => 'Str',      # Valeur de l'attribut de type chaîne de caractères
  required => 1,          # Attribut obligatoire
  reader => 'obtenir_nom',               # Nom de l'accesseur
  trigger => sub { $NbrPersonnes++; },   # Incrémente à chaque nouvelle personne
);

has prenom => (
  is       => 'ro',
  isa      => 'Str',
  required => 1,
  reader   => 'obtenir_prenom',
);

has sexe => (
  is       => 'ro',
  isa      => 'Str',
  required => 1,
  reader   => 'obtenir_sexe',
  trigger  => sub {
    my ( $this, $sexe ) = @_;
    unless ( $sexe eq 'M' or $sexe eq 'F' ) {
      die("[Attention] Mauvais attribut sexe $sexe : F ou M\n");
    }
  },
);

has age => (
  is       => 'rw',
  isa      => 'Int',
  required => 0,
  reader   => 'obtenir_age',
  writer   => 'modifier_age',
  trigger  => sub {
    my ( $this, $age ) = @_;
    unless ( $age > 0 ) {
      die("[Attention] Mauvais attribut age : $age\n");
    }
  },
);

has nombre_enfant => (
  is       => 'rw',
  isa      => 'Int',                       # Valeur de type entier
  required => 0,
  reader   => 'obtenir_nombre_enfant',
  writer   => 'modifier_nombre_enfant',    # Nom du mutateur
  default  => 0,                           # Valeur par défaut de l'attribut
  trigger  => sub {
    my ( $this, $nombre_enfant ) = @_;
    unless ( $nombre_enfant >= 0 ) {
      die("[Attention] Mauvais attribut nombre_enfant : $nombre_enfant\n");
    }
  },
);

# Méthode marcher - ne prend aucun argument
sub marcher {
  my $this = shift;
  my ($nom, $prenom) =( $this->obtenir_nom, $this->obtenir_prenom);
  print "[$nom $prenom] Marche\n";

  return;
}

# Méthode parler - un argument
sub parler {
  my ( $this, $message ) = @_;

  unless ( defined $message ) {
    $message = 'Ne sais pas quoi dire';
  }

  # Le premier caractère de la phrase est mis en majuscule
  $message = ucfirst($message);
  my ($nom, $prenom) =( $this->obtenir_nom, $this->obtenir_prenom);
  print "[$nom $prenom] $message\n";

  return 1;
}

# méthode de classe Obtenir_nbr_personnes
sub Obtenir_nbr_personnes {
  my $classe = shift;

  return $NbrPersonnes;
}

my ($nom, $prenom) =( $this->obtenir_nom, $this->obtenir_prenom);

my ($nom, $prenom) =( $this->{nom}, $this->{prenom} );

# Destructeur
sub DEMOLISH {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  # Diminuer le nombre de personnes créées.
  $NbrPersonnes--;

  return;
}

package Activite;    # Nom du package, de notre classe
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.30';

use Moose;            # Il charge automatiquement strict et warnings

has salaire => (
  is       => 'rw',
  isa      => 'Int',
  required => 0,
  reader   => 'obtenir_salaire',
  writer   => 'modifier_salaire',
);

has metier => (
  is       => 'rw',
  isa      => 'Str',
  required => 0,
  reader   => 'obtenir_metier',
  writer   => 'modifier_metier',
);

# méthode impot_a_payer
sub impot_a_payer {
  my $this = shift;

  if ( my $salaire = $this->obtenir_salaire ) {
    return 0.6 * $salaire;
  }
  croak("[Attention] Difficile de calculer vos impôts sans salaire\n");
}

# Destructeur
sub DEMOLISH {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

use Moose;
extends qw ( Personne Activite );    # hérite de la classe Personne et Activite

# modification de l'attribut sexe hérité
has '+sexe' => ( default => 'M');

# Méthode parler (un argument) qui va redéfinir la méthode parler
# de la classe mère
around 'parler' => sub {
  # Référence vers la méthode parler de la classe mère
  # objet et argument
  my ( $Ref_methode_parler_class, $this, $message ) = @_;

  unless ( defined $message ) {
    $message = 'je suis un homme et Ne sais pas quoi dire';
  }
  $this->$Ref_methode_parler_class( $message . ' (je suis un homme)' );

  return 1;
};

package Homme;    # Nom du package, de notre classe
use Carp;         # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.30';

use Moose;            # Il charge automatiquement strict et warnings
extends qw ( Personne Activite );    # hérite de la classe Personne et Activite

has barbu => (
  is       => 'rw',
  isa      => 'Int',
  required => 0,
  reader   => 'obtenir_barbu',
  writer   => 'modifier_barbu',
  trigger  => sub {
    my ( $this, $barbu ) = @_;
    unless ( $barbu =~ /^0|1$/ ) {
      die("[Attention] Mauvais attribut barbu : $barbu [0 ou 1]\n");
    }
  },
);

# modification de l'attribut sexe hérité
has '+sexe' => ( default => 'M');

# Méthode parler (un argument) qui va redéfinir la méthode parler
# de la classe mère
around 'parler' => sub {
  # Référence vers la méthode parler de la classe mère
  # objet et argument
  my ( $Ref_methode_parler_class, $this, $message ) = @_;

  unless ( defined $message ) {
    $message = 'je suis un homme et Ne sais pas quoi dire';
  }
  $this->$Ref_methode_parler_class( $message . ' (je suis un homme)' );

  return 1;
};

# Destructeur
sub DEMOLISH {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Femme;    # Nom du package, de notre classe
use Carp;         # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.30';

use Moose;            # Il charge automatiquement strict et warnings
extends qw ( Personne Activite );    # hérite de la classe Personne et Activite

# modification de l'attribut hérité
has '+sexe' => ( default => 'F');

# méthode accouche
sub accouche {
  my ( $this, $nombre_enfant ) = @_;

  if ( defined $nombre_enfant ) {
    unless ( $nombre_enfant =~ m{^\d+$} ) {
      croak "Mauvais argument : $nombre_enfant\n";
      return;
    }

    $this->parler("accouche de $nombre_enfant enfant(s)");
    my $NbrEnfant = $this->obtenir_nombre_enfant() + $nombre_enfant;
    $this->modifier_nombre_enfant($NbrEnfant);
  }

  return;
}

# Destructeur
sub DEMOLISH {
  my $this = shift;

  # Avertissement que l'objet va mourir
  print "===================================================\n";
  print "L'objet de la classe " . __PACKAGE__ . " va mourir\n";
  print "===================================================\n";

  return;
}
1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Personne;    # Nom du package, de notre classe
use warnings;        # Avertissement des messages d'erreurs
use strict;          # Vérification des déclarations
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.10';

use Class::Std::Utils;    # Permet la création d'objets inversés
{
  # Tout le code de notre classe
}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

my ( %nom, %prenom, %sexe, %age, %nombre_enfant );

# Constructeur de la classe Personne
  sub new {
    my ( $classe, $ref_arguments ) = @_;

    # Vérifions la classe
    $classe = ref($classe) || $classe;

    # Création d'un scalaire anonyme futur objet
    my $this = bless( anon_scalar(), $classe );

    # Vérification des champs nom, prénom et sexe
    foreach my $attribut (qw/ nom prenom sexe /) {
      unless ( defined $ref_arguments->{$attribut} ) {
        croak("[Attention] Attribut $attribut manquant\n");
      }
    }
    unless ( $ref_arguments->{sexe} =~ m{^M|F$}i ) {
      croak(
        "[Attention] Mauvais attribut sexe $ref_arguments->{sexe}, F ou M\n");
    }

    $nom{ ident $this}           = $ref_arguments->{nom};
    $prenom{ ident $this}        = $ref_arguments->{prenom};
    $sexe{ ident $this}          = $ref_arguments->{sexe};
    $age{ ident $this}           = $ref_arguments->{age};
    $nombre_enfant{ ident $this} = $ref_arguments->{nombre_enfant} || 0;

    # Nombre de personnes créées.
    $NbrPersonnes++;

    return $this;
  }

my $this = bless( anon_scalar(), $classe );

ident $this

#!/usr/bin/perl
use warnings;
use strict;
use Carp;

use Personne;
my $Personne = Personne->new(
  { nom    => 'Henry',
    prenom => 'Antoine',
    sexe   => 'M',
  }
);

use Data::Dumper;
print Dumper $Personne;

$VAR1 = bless( do{\(my $o = undef)}, 'Personne' );

# accesseur obtenir_nom
sub obtenir_nom {
  my $this = shift;
  return $nom{ ident $this};
}

# Destructeur
  sub DESTROY {
    my $this = shift;

    delete $nom{ ident $this};
    delete $prenom{ ident $this};
    delete $sexe{ ident $this};
    delete $age{ ident $this};
    delete $nombre_enfant{ ident $this};

    # Diminuer le nombre de personnes créées.
    $NbrPersonnes--;

    return;
  }

package Personne;    # Nom du package, de notre classe
use warnings;        # Avertissement des messages d'erreurs
use strict;          # Vérification des déclarations
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.20';

use Class::InsideOut qw/ :std /;
{
  # Tout le code ici
}
1;
__END__

use Class::InsideOut qw/ :std /;
{
  readonly nom    => my %nom;
  readonly prenom => my %prenom;
  readonly sexe   => my %sexe;
  public   age => my %age;
  public   nombre_enfant => my %nombre_enfant;

  # Comptage du nombre de personnes créées
  my $NbrPersonnes = 0;    # champ statique privé

  sub new {
    # ...
  }

sub new {
    my ( $classe, $ref_arguments ) = @_;

    # Vérifions la classe
    $classe = ref($classe) || $classe;

    # Création de notre objet
    my $this = register($classe);

    unless ( $ref_arguments->{sexe} =~ m{^M|F$}i ) {
      croak(
        "[Attention] Mauvais attribut sexe : $ref_arguments->{sexe}, F ou M\n");
    }

    $nom{ id $this}           = $ref_arguments->{nom};
    $prenom{ id $this}        = $ref_arguments->{prenom};
    $sexe{ id $this}          = $ref_arguments->{sexe};
    $age{ id $this}           = $ref_arguments->{age};
    $nombre_enfant{ id $this} = $ref_arguments->{nombre_enfant} || 0;

    # Nombre de personnes créées.
    $NbrPersonnes++;

    return $this;
  }

package Personne;    # Nom du package, de notre classe
use warnings;        # Avertissement des messages d'erreurs
use strict;          # Vérification des déclarations
use Carp;            # Utile pour émettre certains avertissements

use vars qw($VERSION);    # Version de notre module
$VERSION = '1.20';

use Class::InsideOut qw/ :std /;
{
  private nom           => my %nom;
  private prenom        => my %prenom;
  private sexe          => my %sexe;
  private age           => my %age;
  private nombre_enfant => my %nombre_enfant;

  # Comptage du nombre de personnes créées
  my $NbrPersonnes = 0;    # champ statique privé

  sub new {
    my ( $classe, $ref_arguments ) = @_;

    # Vérifions la classe
    $classe = ref($classe) || $classe;

    # Création de notre objet
    my $this = register($classe);

    unless ( $ref_arguments->{sexe} =~ m{^M|F$}i ) {
      croak(
        "[Attention] Mauvais attribut sexe : $ref_arguments->{sexe}, F ou M\n");
    }

    $nom{ id $this}           = $ref_arguments->{nom};
    $prenom{ id $this}        = $ref_arguments->{prenom};
    $sexe{ id $this}          = $ref_arguments->{sexe};
    $age{ id $this}           = $ref_arguments->{age};
    $nombre_enfant{ id $this} = $ref_arguments->{nombre_enfant} || 0;

    # Nombre de personnes créées.
    $NbrPersonnes++;

    return $this;
  }

  # accesseur obtenir_nom
  sub obtenir_nom {
    my $this = shift;
    return $nom{ id $this};
  }

  # accesseur obtenir_prenom
  sub obtenir_prenom {
    my $this = shift;
    return $prenom{ id $this};
  }

  # accesseur obtenir_sexe
  sub obtenir_sexe {
    my $this = shift;
    $sexe{ id $this};
  }

  # accesseur obtenir_age
  sub obtenir_age {
    my $this = shift;
    return $age{ id $this};
  }

  # mutateur modifier_age
  sub modifier_age {
    my ( $this, $age ) = @_;

    if ( defined $age ) {
      unless ( $age =~ m{^\d+$} ) {
        croak "Mauvais argument : $age\n";
        return;
      }
      $age{ id $this} = $age;
    }

    return;
  }

  # accesseur obtenir_nombre_enfant
  sub obtenir_nombre_enfant {
    my $this = shift;

    return $nombre_enfant{ id $this};
  }

  # mutateur modifier_nombre_enfant
  sub modifier_nombre_enfant {
    my ( $this, $nombre_enfant ) = @_;

    if ( defined $nombre_enfant ) {
      unless ( $nombre_enfant =~ m{^\d+$} ) {
        croak "Mauvais argument : $nombre_enfant\n";
        return;
      }
      $nombre_enfant{ id $this} = $nombre_enfant;
    }

    return;
  }

  # Méthode marcher - ne prend aucun argument
  sub marcher {
    my $this = shift;

    my ( $nom, $prenom ) = ( $nom{ id $this}, $prenom{ id $this} );
    print "[$nom $prenom] Marche\n";

    return;
  }

  # Méthode parler - un argument
  sub parler {
    my ( $this, $message ) = @_;

    unless ( defined $message ) {
      $message = 'Ne sais pas quoi dire';
    }

    # Le premier caractère de la phrase est mis en majuscule
    $message = ucfirst($message);
    my ( $nom, $prenom ) = ( $nom{ id $this}, $prenom{ id $this} );
    print "[$nom $prenom] $message\n";

    return 1;
  }

  # méthode de classe Obtenir_nbr_personnes
  sub Obtenir_nbr_personnes {
    my $classe = shift;

    return $NbrPersonnes;
  }

  # Destructeur bis
  sub DEMOLISH {
    my $this = shift; 
    #  print "Fin classe : ", __PACKAGE__,"\n";
  }

}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

package Personne;
{    # Nom du package, de notre classe

  use warnings;    # Avertissement des messages d'erreurs
  use strict;      # Vérification des déclarations
  use Carp;        # Utile pour émettre certains avertissements

  use vars qw($VERSION);    # Version de notre module
  $VERSION = '2.0';

  use Object::InsideOut;    # Module pour la création d'objets inversés

  # Tout notre code

}

1;                          # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

# Déclaration des attributs
  # Nom - attribut avec uniquement accesseur
  my @nom :Field 
          :Get(obtenir_nom)                          # Accesseur
          :Arg('Name' => 'nom', 'Mandatory' => 1)    # Attribut obligatoire
          :Type('scalar')                            # Type argument
          ;

  # Prenom - attribut avec uniquement accesseur
  my @prenom :Field 
             :Get(obtenir_prenom) 
             :Arg('Name' => 'prenom', 'Mandatory' => 1) 
             :Type('scalar')
             ;

  # Sexe - attribut avec uniquement accesseur
  my @sexe :Field 
           :Get(obtenir_sexe) 
           :Arg('Name' => 'sexe', 'Mandatory' => 1)
           :Type('scalar')
           ;
                     
  # nombre_enfant - avec accesseur et mutateur et valeur par défaut
  # on n'utilise pas Arg car on va faire une vérification
  my @nombre_enfant :Field 
                    :Get(obtenir_nombre_enfant) 
                    :Set(modifier_nombre_enfant)  # Mutateur
                    :Default(0)                   # Valeur par défaut
                    :Type(numeric);

  # Age - attribut avec accesseur et mutateur
  # on n'utilise pas Arg car on va faire une vérification
  my @age :Field 
          :Get(obtenir_age) 
          :Set(modifier_age) # Mutateur
          :Type(numeric)
          ;
  # Vérification sur l'age et le nombre d'enfants
  my %NosAttributs : InitArgs = ( 
    'nombre_enfant' => '', 
    'age' => '', 
  );

  sub _init : Init {
    my ( $self, $args ) = @_;
    
    foreach my $NomAttribut ( qw/ age nombre_enfant / ) {
      if ( exists $args->{$NomAttribut} ) {
        if ( ( $NomAttribut eq 'nombre_enfant') and $args->{$NomAttribut} >= 0 ) {
          # Déclaration de l'attribut
          $self->set( \@nombre_enfant, $args->{$NomAttribut} );
        }
        elsif ( ( $NomAttribut eq 'age') and $args->{$NomAttribut} > 0 ) {
          # Déclaration de l'attribut
          $self->set( \@age, $args->{$NomAttribut} )  if ( $NomAttribut eq 'age');
        }
        else {
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être >= 0\n") if ( $NomAttribut eq 'nombre_enfant');
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être > 0\n");
        }
      }
    }
  }

:Arg('Name' => 'NomAttribut')
# ou 
:Arg(NomAttribut)

:Arg('Name' => 'prenom', 'Mandatory' => 1)

my %NosAttributs : InitArgs = ( 
    'nombre_enfant' => '', 
    'age' => '', 
  );

sub _init : Init {
    my ( $self, $args ) = @_;
    
    foreach my $NomAttribut ( qw/ age nombre_enfant / ) {
      if ( exists $args->{$NomAttribut} ) {
        if ( ( $NomAttribut eq 'nombre_enfant') and $args->{$NomAttribut} >= 0 ) {
          # Déclaration de l'attribut
          $self->set( \@nombre_enfant, $args->{$NomAttribut} );
        }
        elsif ( ( $NomAttribut eq 'age') and $args->{$NomAttribut} > 0 ) {
          # Déclaration de l'attribut
          $self->set( \@age, $args->{$NomAttribut} )  if ( $NomAttribut eq 'age');
        }
        else {
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être >= 0\n") if ( $NomAttribut eq 'nombre_enfant');
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être > 0\n");
        }
      }
    }
  }

# Incrémentation du nombre de personnes créées.
  sub _AjouterPersonnes :PreInit {
         my ($self, $args) = @_;
         $NbrPersonnes ++;
  }

  # Méthode marcher - ne prend aucun argument
  sub marcher {
    my $this = shift;
    my ( $nom, $prenom ) = ( $this->obtenir_nom, $this->obtenir_prenom );
    print "[$nom $prenom] Marche\n";
  
    return;
  }
  
  # Méthode parler - un argument
  sub parler {
    my ( $this, $message ) = @_;
  
    unless ( defined $message ) {
      $message = 'Ne sais pas quoi dire';
    }
  
    # Le premier caractère de la phrase est mis en majuscule
    $message = ucfirst($message);
    my ( $nom, $prenom ) = ( $this->obtenir_nom, $this->obtenir_prenom );
    print "[$nom $prenom] $message\n";
  
    return 1;
  }
  
  # méthode de classe Obtenir_nbr_personnes
  sub Obtenir_nbr_personnes {
    my $classe = shift;
  
    return $NbrPersonnes;
  }

# Destructeur
  sub _destroy :Destroy {
    my $this = shift;
    print "Fin classe : ", __PACKAGE__,"\n";
    
    # Diminuer le nombre de personnes créées.
    $NbrPersonnes--;

  }

package Personne;
{    # Nom du package, de notre classe

  use warnings;    # Avertissement des messages d'erreurs
  use strict;      # Vérification des déclarations
  use Carp;        # Utile pour émettre certains avertissements

  use vars qw($VERSION);    # Version de notre module
  $VERSION = '2.0';

  use Object::InsideOut;    # Module pour la création d'objets inversés

  # Comptage du nombre de personnes créées
  my $NbrPersonnes = 0;     # champ statique privé

  # Déclaration des attributs
  # Nom - attribut avec uniquement accesseur
  my @nom :Field 
          :Get(obtenir_nom)                          # Accesseur
          :Arg('Name' => 'nom', 'Mandatory' => 1)    # Attribut obligatoire
          :Type('scalar')                            # Type argument
          ;

  # Prenom - attribut avec uniquement accesseur
  my @prenom :Field 
             :Get(obtenir_prenom) 
             :Arg('Name' => 'prenom', 'Mandatory' => 1) 
             :Type('scalar')
             ;

  # Sexe - attribut avec uniquement accesseur
  my @sexe :Field 
           :Get(obtenir_sexe) 
           :Arg('Name' => 'sexe', 'Mandatory' => 1)
           :Type('scalar')
           ;
                     
  # nombre_enfant - avec accesseur et mutateur et valeur par défaut
  # on n'utilise pas Arg car on va faire une vérification
  my @nombre_enfant :Field 
                    :Get(obtenir_nombre_enfant) 
                    :Set(modifier_nombre_enfant)  # Mutateur
                    :Default(0)                   # Valeur par défaut
                    :Type(numeric);

  # Age - attribut avec accesseur et mutateur
  # on n'utilise pas Arg car on va faire une vérification
  my @age :Field 
          :Get(obtenir_age) 
          :Set(modifier_age) # Mutateur
          :Type(numeric)
          ;
  # Vérification sur l'age et le nombre d'enfants
  my %NosAttributs : InitArgs = ( 
    'nombre_enfant' => '', 
    'age' => '', 
  );

  sub _init : Init {
    my ( $self, $args ) = @_;
    
    foreach my $NomAttribut ( qw/ age nombre_enfant / ) {
      if ( exists $args->{$NomAttribut} ) {
        if ( ( $NomAttribut eq 'nombre_enfant') and $args->{$NomAttribut} >= 0 ) {
          # Déclaration de l'attribut
          $self->set( \@nombre_enfant, $args->{$NomAttribut} );
        }
        elsif ( ( $NomAttribut eq 'age') and $args->{$NomAttribut} > 0 ) {
          # Déclaration de l'attribut
          $self->set( \@age, $args->{$NomAttribut} )  if ( $NomAttribut eq 'age');
        }
        else {
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être >= 0\n") if ( $NomAttribut eq 'nombre_enfant');
          die("Attribut $NomAttribut ($args->{$NomAttribut}) doit être > 0\n");
        }
      }
    }
  }
  
  # Incrémentation du nombre de personnes créées.
  sub _AjouterPersonnes :PreInit {
         my ($self, $args) = @_;
         $NbrPersonnes ++;
  }


  # Méthode marcher - ne prend aucun argument
  sub marcher {
    my $this = shift;
    my ( $nom, $prenom ) = ( $this->obtenir_nom, $this->obtenir_prenom );
    print "[$nom $prenom] Marche\n";
  
    return;
  }
  
  # Méthode parler - un argument
  sub parler {
    my ( $this, $message ) = @_;
  
    unless ( defined $message ) {
      $message = 'Ne sais pas quoi dire';
    }
  
    # Le premier caractère de la phrase est mis en majuscule
    $message = ucfirst($message);
    my ( $nom, $prenom ) = ( $this->obtenir_nom, $this->obtenir_prenom );
    print "[$nom $prenom] $message\n";
  
    return 1;
  }
  
  # méthode de classe Obtenir_nbr_personnes
  sub Obtenir_nbr_personnes {
    my $classe = shift;
  
    return $NbrPersonnes;
  }

  # Destructeur
  sub _destroy :Destroy {
    my $this = shift;
    print "Fin classe : ", __PACKAGE__,"\n";
  
    # Diminuer le nombre de personnes créées.
    $NbrPersonnes--;

  }


}

1;    # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes

use Object::InsideOut qw ( Personne Activite );

package Femme;    # Nom du package, de notre classe
{
  use warnings;     # Avertissement des messages d'erreurs
  use strict;       # Vérification des déclarations
  use Carp;         # Utile pour émettre certains avertissements
   
  use vars qw($VERSION);    # Version de notre module
  $VERSION = '2.0';

  use Object::InsideOut qw ( Personne Activite );   # hérite de la classe Personne et Activite

  # inialisation du sexe féminin chez la personne
  sub pre_init :PreInit {
       my ($self, $args) = @_;
       my $sexe = 'F';
       if ( exists $args->{sexe} and $args->{sexe} !~ m{^$sexe$}i ) {
         carp("[Attention] : mauvais sexe $args->{sexe}\n");
       }

       $args->{sexe} = $sexe;
  }

  # méthode accouche
  sub accouche {
    my ( $this, $nombre_enfant ) = @_;

    if ( defined $nombre_enfant ) {
      unless ( $nombre_enfant =~ m{^\d+$} ) {
        croak "Mauvais argument : $nombre_enfant\n";
        return;
      }

      $this->parler("accouche de $nombre_enfant enfant(s)");
      my $NbrEnfant = $this->nombre_enfant() + $nombre_enfant;
      $this->nombre_enfant($NbrEnfant);
    }

    return;
  }

  # Destructeur
  sub _destroy :Destroy {
    my $this = shift;
    print "Fin classe : ", __PACKAGE__,"\n";
  }

}
1;                                         # Important, à ne pas oublier
__END__           # Le compilateur ne lira pas les lignes suivantes