Warning: main(./../../../common/menutop.html) [function.main]: failed to open stream: No such file or directory in /mnt/129/sdb/8/f/gadille/doc/scripting/perl/perl.php on line 16

Warning: main() [function.include]: Failed opening './../../../common/menutop.html' for inclusion (include_path='/mnt/129/sdb/8/f/gadille/include:.:/usr/php4/lib/php') in /mnt/129/sdb/8/f/gadille/doc/scripting/perl/perl.php on line 16
Tutoriel PERL

Documentation extern
intro link
-pe :lit en boucle le fichier passer en argument
-i : ecrit la sortie stdr dedans

Effectue un remplacement du debut de ligne(^) et la sort sous stdr
place replace into a chaque debut de ligne du fichier listcsv)
perl -pe 's/^/REPLACE INTO/' list.csv

Idem en plus complexe et sort le resultat dans le fichier d'entrée
Noter les escapage de quote (') et on doit aussi escaper les parenthése \( et autre element de language
perl -i -pe 's/^/REPLACE INTO \`brochure\`.\`NOTEENLIGNE\` ' list.csv

Pour repérer les fichiers n'ayant pas la bonne extension (jpg) en form Script perl
perl -e 'foreach my $file (glob("*")){if(!( $file=~ m/.+.jpg/)){$file=~ m/.+\.(.+)/;$h{$1}++;}}foreach my $k (keys(%h)) {print "$k\n";}'

A pour but de renomer les fichier JPG en jpg en form Script perl
perl -e 'foreach my $file (glob("*\.JPG")){ print $file; if($file=~ m/(.+)\.JPG/){ `mv $1.JPG $1.jpg`}}'


Exemple de base:
use strict;
use warnings;

my $name="toto";
print "Hello, $name\n"; #\n retour a la ligne  
print 'Hello, $name\n'; #lexico
print ("\nHello");
print 42;
perl test-1.pl
Hello, toto
Hello, $name\n

Unic ligne perl


option e

perl -e 'print "Hello, world!\n"'
Hello, world!
perl -e '$A = 12; print ++$A'

option n

while (<>) {
        ...    # votre programme ici
perl -ne 'print if /Hello/' test-1.pl
print "Hello, $name\n"; #\n retour a la ligne
print 'Hello, $name\n'; #lexico
print ("\nHello,");

option p

while (<>) {
     ...    # votre programme ici
} continue {
     print or die "-p destination: $!\n";
La partie code est excuter avant l'evalution dans while (ici avant de lire une ligne)
Ici effectue un print de la ligne

Print les 10ere ligne

perl -pe 'exit if $. > 10' fichier

Comptage de ligne:

perl -pe 'print "$.:"' test-1.pl

option i

perl -i -pe s/#// test-2.pl
remplace le 1er # par rient
le permet de réecrire dans le fichier source
perl -i -pe s/" "/""/ test-2.pl

Petit Code

perl -e 'my $to = scalar(time());print "timestamp:$to";my $ta = localtime($to);print "\tdate:$ta\n"'


my $excludetmp="toto,tata,titi";
my @exclude=split(/,/, $excludetmp);
for my $tmp (@exclude){
perl -MLWP::Simple -le 'print getprint "http://gadille.free.fr"'
-M charge la lib LWP::Simple

Variable type

Scalars = Single value

my $animal = "chat"; # my only if strict
my $answer = 2;
print "il y'a ", $answer * $answer, "chat\n";
il y'a 4 chat

$_ is the default variable use by many function
print; # print the default variable


$#arayname= last element
my @animals = ("camel", "llama", "owl");
my @numbers = (23, 42, 69);
my @mixed = ("camel", 42, 1.23);
print animal[0];
if (@animals < 5) { print "less than 5 animals";}
print $mixed[$#mixed];  # print 1.23
print @animals[0,1]; # gives ("camel", "llama");
print @animals[0..2]; # gives ("camel", "llama", "owl");
print @animals[1..$#animals]; # gives all except the first element
exemple code:
for (;$epochstart<=$epochend;$epochstart+=86400){
		my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday)=gmtime($epochstart);
		push @dates, sprintf("%04d-%02d-%02d", $year + 1900, $mon + 1, $mday);		
for my $date (@dates){
 print "date:$date"



my %fruit_color = ("apple", "red", "banana", "yellow");
You can also declare like that
my %fruit_color = {
	apple => "red",
	banana => "yellow",

print $fruit_color{"apple"};  #give red
my @fruits = keys %fruit_colors;    # get list of fruits
my @colors = values %fruit_colors;  # get list of colors


my %fruit=("apple", "red", "banana", "yellow","raisin","blanc");
print "$fruit{\"apple\"} \n";
my @tblfruit= keys %fruit;
print ("$tblfruit[0] $tblfruit[-1]");
$ red
banana orange
noter le -1 qui permet d'axcéder au dernier element du tableaux


Le propos du code est de faire une action lorsque un comid à plusieur cp_oid
if(!($dbh = DBI->connect( "dbi:DB2:$mebo", $mebouser, $mebopasswd ))){
		fatalerror("Check your parameter (MEBO dtb is still up? Perl catalog ok?)",$nagiosService,"MEBO dtb connection error");
$req="select  comid,cp_oid from ME.COMIDS order by cp_oid";	
$sth = $dbh->prepare($req);
my %cpcom;
my %cpcom2;
while ( my @row = $sth->fetchrow_array ) {
	$cpcom{$row[0]}=$row[1]; #comid en clef  -> cp_oid
	$cpcom2{$row[1]}++; #compte le nbr de comid par cp_oid	
for (@rows) {
	my comid = $1;
	# $cpcom{$comid}:done le cp_oid pour un comid  --> $cpcom2{$cp_oid}donne le nombre de comid pour ce cp_oid 
	if ($cpcom2{$cpcom{$comid}}>1){ 

%Env est codé sous forme de has

A hash of hash
my $variables = {
	scalar => {
		description => "single item",
		sigil => '$',
   array => {
   	description => "ordered list of items",
   	sigil => '@',
  	hash => {
  		description => "key/value pairs",
  		sigil => '%',
print "Scalars begin with a $variables->{'scalar'}->{'sigil'}\n";


Usual syntax
if ( condition ) {
} elsif ( other condition ) {
} else {
if ( /(\d{4}-\d{2}-\d{2}\.+/ ){
if (! defined $cols[3]){{
	print "! col[3] undef\n";
Dans le 1er if on fais la regex sur $_; Revers syntax
unless (condition){
Post-condition way
print "Yow!" if $zippy;
print "We have no bananas" unless $bananas



== equality
!= inequality
< less than
> greater than
<= less than or equal
>= greater than or equal


eq equality
ne inequality
gt greater than
le less than or equal
ge greater than or equal


&& and
|| or
! not


= assignment
. string concatenation
x string multiplication
.. range operator (creates a list of numbers)

$a -= 1; # same as $a = $a - 1
$a .= "\n"; # same as $a = $a . "\n";


File Test Symbol
-rFile is readable by effective uid/gid.-RFile is readable by real uid/gid.
-wFile is writable by effective uid/gid.-WFile is writable by real uid/gid.
-xFile is executable by effective uid/gid.-XFile is executable by real uid/gid.
-oFile is owned by effective uid.-OFile is owned by real uid/gid.
-eFile exists
-zFile has zero size (is empty).-sFile has nonzero size (returns size in bytes)
-fFile is a plain file.
-dFile is a directory.-lFile is a symbolic link
-pFile is a named pipe (FIFO), or Filehandle is a pipe.-SFile is a socket.
-bFile is a block special file.-cFile is a character special file.
-tFilehandle is opened to a tty.
-uFile has setuid bit set.-gFile has setgid bit set.
-kFile has sticky bit set.
-TFile is an ASCII text file (heuristic guess).-BFile is a "binary" file (opposite of -T).
-MScript start time minus file modification time, in days.-ASame for access time.
-CSame for inode change time (Unix, may differ for other platforms)

my $modTime = -M $file;
-M Script start time minus file modification time, in days.
si scrip lancer le 5 --> fichier modifier le 3 ==> 5-3 = 2

use File::Path;
if (! -e $diretl){
 	mkpath ($diretl)or die("Fail to create $diretl");
si le repertoir n'exite pas le créer



if (/foo/) { ... } # true if $_ contains "foo"
if ($a =~ /foo/) { ... } # true if $a contains "foo"


open(my $in, "<", "input.txt") or die "Can't open input.txt: $!";
while (<$in>) {         # assigns each line in turn to $_
	if (/shopbot/) {     # true if shopbot is in $_ 
		$shopbot +=1;

Complet Regex

Regex Symbol
RegexRevert Regex
.single character
\sa whitespace character (space, tab, newline, ...)\Snon-whitespace character
\da digit (0-9)\Da non-digit
\w a word character (a-z, A-Z, 0-9, _)\Wa non-word character
[aeiou] matches a single character in the given set[^aeiou] matches a single character outside the given set
(foo|bar|baz) matches any of the alternatives specified
^ start of string
$ end of string

Regex number
*zero or more of the previous thing
+one or more of the previous thing
?zero or one of the previous thing
{3}matches exactly 3 of the previous thing
{3,6}matches between 3 and 6 of the previous thing
{3,}matches 3 or more of the previous thing


This loop reads from STDIN, and prints non-blank lines:
while (<>) {
	next if /^$/;
Cute mail:
if ($email =~ /([^@]+)@(.+)/) {
	print "Username is $1\n";
	print "Hostname is $2\n";


s/foo/bar/; # replaces foo with bar in $_
$a =~ s/foo/bar/; # replaces foo with bar in $a
$a =~ s/foo/bar/g; # replaces ALL INSTANCES of foo with bar in $a

Loop Boucle


while ( condition ) {

Utilisation de "complement"
while ( condition ) {
	next if ($toto);
	last if ($end);
next permet de revenir en debut de la boucle
last sort de la boucle

Negative condition
until ( condition ) {

Post condition
print "LA LA LA\n" while (condition);  


for ($i = 0; $i <= $max; $i++) {


foreach (@array) {
        print "This element is $_\n";
print $list[$_] foreach 0 .. $max;

# you don't have to use the default $_ either...
foreach my $key (keys %hash) {
		print "The value of $key is $hash{$key}\n";

Files and I/O


open(my $in, "<", "input.txt") or die "Can't open input.txt: $!";
my $line = <$in>; #lit une ligne
my @lines = <$in>; #lit toute les ligne dans un tableaux
while (<$in>) { # assigns each line in turn to $_
	print "line: $_";
close $in or die "$in: $!";
Ouvre un fichier gunzipé sans y toucher et place le contenue dans $_ (man gzip)
open( FIN, "gzip -d -c $file |" ) or die "could not open file $file";
while(  ) {
		print "line: $_";


open(my $out, ">", "output.txt") or die "Can't open output.txt: $!";
open(my $log, ">>", "my.log") or die "Can't open my.log: $!";
print STDERR "This is your final warning.\n";   #stdr error
print $out "hello"; #output.txt
print $log "we write: $out"; #my.log
close $out;
close $logs;
Ecriture + complex
if (!(open( FOUT, "| gzip -9 > $subworkdir/country.tsv.gz" ))){
	print FOUT "hello";
if (!(open( FOUT, " >  :encoding(utf8)" ,"$subworkdir/${name}.tsv" ))){
	print FOUT "éééèèè";
on ne peux pas combiner le mode utf8 plus le mode gzip

Read Write Complex

Le propos est de choisir le fichier de sortie en fonction d'une partie de la ligne du fichier d'entré
open( FIN, "gzip -d -c $file |" ) or die "could not open file $file";
while(  ) {
	if ( /(\d{4}-\d{2}-\d{2}\.+/ ){
	if ( $dateS ne $lastDate ) 
		#if date is not in the hashtable
		$fh = new FileHandle;						
		$fh->open("| gzip -9 > $dateS.gz") or die "could not open $dateS.gz";
		$fileHandles{$dateS} = $fh;
	} else {
		#if in hastable use the correct fileHandles
		$fh = $fileHandles{$dateS};
	$lastDate = $dateS;


sub logger {
  my $logmessage = shift;
  open my $logfile, ">>", "my.log" or die "Could not open my.log: $!";
  print $logfile $logmessage;
  return "ok";
$pass=logger("We have a logger subroutine!");
Shift --> lits le tableaux par defaul @_ + le reduit d'une case


perl -e " print '-' x 8;"
effectue 8 fois le print '-'


Class 1: Prenom.pm

il faut rendre ce ficheir axcésible
export PERL5LIB=/opt/stats/lib:/opt/tomcat-8081/webapps/free/doc/scripting/perl/lib

package Person;
use strict;

## Constructeur                         ##
sub new {
my $self = {};
$self->{NOM} = undef;
$self->{AGE} = undef;
$self->{PRENOMS} = [];
bless($self, $class);
return $self;

## methods to access per-object data        ##
##                                          ##
## With args, they set the value. Without   ##
## any, they only retrieve it/them.         ##

sub name {
my $self = shift;
if (@_) { $self->{NAME} = shift }
return $self->{NAME};

sub age {
my $self = shift;
if (@_) { $self->{AGE} = shift }
return $self->{AGE};

sub prenom {
my $self = shift;
if (@_) { @{ $self->{PRENOMS} } = @_ }
return @{ $self->{PRENOMS} };


#!/usr/bin/perl #use strict; #use warnings; use Person; $him = Person->new(); $him->name("gadille"); $him->age(35); $him->prenom("lionel","claude","renée"); push @All_Recs, $him; # save object in array for later printf "%s à %d.\n", $him->name, $him->age; print "Prenoms: ", join(", ", $him->prenom), "\n"; printf "Last rec's name is %s\n", $All_Recs[-1]->name;
gadille à 35.
Prenoms: lionel, claude, renée
Last rec's name is gadille


use Mail::Sendmail;
sub sendamail{
my ($pass, $msg) = @_;
my $smtp=$config->{'GENERAL'}->{'MAIL'}->{'SMTP'};
my $to=$config->{'GENERAL'}->{'MAIL'}->{'TO'};
my $from=$config->{'GENERAL'}->{'MAIL'}->{'FROM'}; 
my %mail = (
		To => $to,
	    From => $from,
		subject => "kog_tar-sftp type:$type runfor:${yyyymmdd} status:".$pass,
		Smtp => $smtp,
	    body => "".$msg, 
$mail{'Content-type'} = 'text/html; charset=us-ascii';


Par les exemples
Ici je place le contenue de 2 colonne dans une hash pour usage ultérieure
my $db =DBI->connect("DBI:mysql:database=MADATABASE;host=${dtbhost}","$user","$password") or die "connection error";
my %hashTerm;
my $sql ="select * from FINANCIAL_TERM_TYPE";
my $sth = $db -> prepare($sql);
$sth->execute() or die "$sql FAILLURE";
while ( my @cols = $sth->fetchrow_array ) {
  $hashTerm{$cols[0]} =$cols[1];
pour utliser la hash
print "result".$hashTerm{"toto"}."\n";
Recupérer 1 seul tuple
my $sql ="select SUPPLIER_ID from SUPPLIER_CONTRACT where CONTRACT_ID=$cid";
my $sth = $db -> prepare($sql);
$sth->execute() or die "$sql FAILLURE";
my @cols1 = $sth->fetchrow_array ;
my $sid=$cols1[0];


Simple Thread

Ce premier exemple lance tous les thread en concurence
On utilise un tableaux pour contenir les threads @thr
On effectue une boucle pour lancer les thread
ceci tourne en concurence de notre programme principal
Puis on passe dans un boucle pour attendre la fin des thread et renvoyer le resulta du trvaille
use strict;
use threads;
use Math::Complex ':pi'; 

my @rayon =(28,32,45,78);
my @thr;
for (my $i=0;$i<@rayon;$i++){
	print "lance thread $i\n";
	$thr[$i] = threads->new(\&travaille,$rayon[$i],$i);
for (my $i=0;$i<@rayon;$i++){
	#join attend que le thread ce termine et recupe le return
 print "end thread num:".$thr[$i]->join."\n";

sub travaille {
	my ($rayon,$i)=@_;
	my $nbr;
	#just to use cpu	
	for (my $j=0;$j<10;$j++){
		for (my $i=0;$i<1000000;$i++){ #1ee6	
			$nbr = 2*pi*$rayon;	
	#sleep (5);
	print "Le thread $i  à fini sont boullot $rayon ==> $nbr\n";	
	return $i;
Il est interessant de noter que les threads ce termine de facons non ordoné (normal)
En effet mem si le calcul est simillaire
Il suffit que l'utilisateur bouge sa sourie en concurence du programme pour influencer les ressources dispos et ralentire un thread
Deplus je lance 4 thread sur un bi core + le main + eclipse + l'os + ....
Il n'ya aucune rasions que sa se temine une seul fois de la meme facons
lance thread 0
lance thread 1
lance thread 2
lance thread 3
Le thread 2  à fini sont boullot 45 ==> 282.743338823081
Le thread 1  à fini sont boullot 32 ==> 201.061929829747
Le thread 3  à fini sont boullot 78 ==> 490.088453960008
Le thread 0  à fini sont boullot 28 ==> 175.929188601028
end thread num:0
end thread num:1
end thread num:2
end thread num:3

Mecanisme de gestion

Le but du programme si dessous et de lancer un nombre limité configurable thread
Lorsque un thread et fini dans relancer un jusqu'a epuisement du boullots
use strict;
use threads;
use Math::Complex ':pi'; 

my @rayon =(101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122);
#nombre maximum de thread concurrent
my $max=10;

my @thr;
my $current=0; 
my @finish;
# init finish to false (0)
for (my $i=0;$i<@rayon;$i++){

for (my $i=0;$i<@rayon;$i++){
	print "main -> start of thread $i\n"; 
	$thr[$i] = threads->new(\&travaille,10,$rayon[$i],$i);
	while ($current==$max){		
		print "main ->  nbr of thread $current , max thread reach\n";
		sleep 5;
		for (my $j=0;$j<=$i;$j++){
			if (!$finish[$j]){ # if not finish
				if (! $thr[$j]->is_running()){ #if not running							
					#free ressource + get return
					print "main -> end thread num:".$thr[$j]->join."\n";
					$finish[$j]=1; # finish = true

## libére les ressource des threads de la pile en cours (et attend leur fin)
for (my $i=0;$i<@rayon;$i++){ #list des thread
	while (!$finish[$i]){ 
		sleep 5;
		print "#";
		if (! $thr[$i]->is_running()){							
			#libérer la resssource
			print "\nmain -> end thread num:$i  surface:".$thr[$i]->join."\n";

sub travaille {
	my ($rayon,$i)=@_;
	my $nbr;
	#just to use cpu
	for (my $j=0;$j<10;$j++){
		for (my $i=0;$i<1000000;$i++){ #1ee6	
			$nbr = 2*pi*$rayon;	
	#sleep 10;#+$i*4;	
	print "travaille -->  end of thread:$i   $rayon ==> $nbr \n";	
	return "$nbr";
$ max = nombre thread concurrent utilisable
Un point interressant est que l'on sature les deux core du cpu à 100 (la jusqu'a 10 core)



yum install perl-devel
yum install perl-CPAN
yum install perl-PadWalker
Rajouter use PadWalker; dans les fichiers perl

Pour eclipse installer epic plugin
help install new software

compiller des programme

perl Makefile.PL
make test make install

Debug en ligne

perl -d monscript.pl
Ensuite h pour l'aide en ligne
Les cmds de base
s step/next avec sous routine
n step/next sans sous routine
v 50 montre le code autour de la ligne 50
b 55 place un breack point sur la ligne 55
L list les breack point
c go .... s'arrete au break point suivant
c 60 s'arrete a la ligne 60
x $toto montre le contenue de la var toto
q quit

attention petit piege a con le debuger montre la ligne qu'il va excuter au prochain next pas celel qu'il a exécuté


perl -MCPAN -e shell
i /DBD/
m /DBD::DB2/
install DBD::DB2
  • getHelp
  • Dans une fichier perl vous tomber sur une commande inconnue pas de panique
    Dans ma ligne je ne comprent pas le mots glob
    perl -f glob
    perldoc File::Glob



    Unable to recognise encoding of this document at /usr/lib/perl5/vendor_perl/5.8.8/XML/SAX/PurePerl/EncodingDetect.pm line 96.
    Pour ma parts ce probleme est arrivé car j'ai introduit une ligne vide en tête de mon xml ce qui empéche le parsing de l'encodage
    Faite attention au contenue du fichier parssé


    yum search DBI
    yum search XML
    yum search perl|grep sax

    yum install perl-DBI.x86_64
    yum install perl-XML-Simple perl-XML-SAX.noarch perl-XML-SAX-Writer.noarch perl-XML-Parser

    Fermer rouvrir le projet perl

    mail pour des questions ou de l'aide