---

---

---

---

---

• Manipulation de dates
• Chargement dynamique de modules
• Analyse d'emails
• Factorisation d'une plage de numéros de téléphone
• SMTP
• RegExp: "Greedy" et "ungreedy"?
• RegExp: Détecter des séquences
• RegExp: Les éléments détectés
• Gestion des signaux
• Un script pour renommer des fichiers en masse
• Informations sur le fichier courant
• Informations le lien symbolique exécuté

Lorsque vous travaillez sur une plateforme informatique, il est courant de manipuler des données dont la date appartient à un interval donné. Par exemple :

• Un incident s'est produit. Pendant toute la durée de l'incident, certains traitements n'ont pas été effectués. Vous devez rattraper les traitements sur la plage temporelle qui correspond à l'incident.
• Chaque jour, à 3 heures du matin, vous devez traiter les informations de la vieille.

Le module ci-dessous permet d'exprimer des dates de façon absolue (relativement au calendrier en vigueur), ou de façon relative (relativement à une date donnée).

• Exemple d'expression absolue : Le 21 janvier 2010, à minuit.
• Exemples d'expressions relatives :
  • Hier.
  • Il y a deux jours.
  • Hier, à midi.
  • Trois jours avec le 1er mars 2009.
  • Deux jours et 3 heures, avant le 1er mars 2010.

# Author: Denis BEURIVE # # This package provides functionalities used to transform textual representations of date (including time) into DateTime objects. # The textual representation is: # # (+|-)${date}((+|-)${duration})? # Where: # - ${date}: Represents the date and time. # - ${duration}: Represents the duration added or subtracted from the date. # The duration is optional. If no duration is specified, then the date is converted "as is". # # The first add/substract sign defines inclusion or exclusion. # The second add/substract sign defines wether we should add or substract the duration from the date. # # --- ${date} specification --- # # "NOW" or ${YYYY}[${MM}[${DD}[${HH}[${MM}[${SS}]]]]] # # "NOW" means the current date and time. # ${YYYY} "year" or the absolute year (ex: 1998). # "year" means the current year. # ${MM}: "month" or the absolute month (ex: 04 for April). # "month" means the current month. # Default value is 01 (for January). # ${DD}: "day" or the absolute day (from 1 to 31). # "day" means the current day. # Default value is 01. # ${HH}: "hour" or the absolute hour (from 0 to 23). # "hour" means the current hour. # Default value is 00. # ${MM}: "minute" or the absolute minute (from 0 to 59). # "minute" means the current minute. # Default value is 00. # ${SS}: "second" or the absolute second (from 0 to 59). # "second" means the current second. # Default value is 00. # # --- ${duration} specification --- # # (\d+\s*years?:)?(\d+\s*months?:)?(\d+\s*weeks?:)?(\d+\s*days?:)?(\d+\s*hours?:)?(\d+\s*minutes?:)?(\d+\s*seconds?)? # # For exeaple: # "2 years". # "2 years:1 month". # "1 year:3 weeks". # "1 month:2 days". # "2 days:1 hour" # # --- Examples --- # # +NOW => Thursday 30 July 2009 - 11:49:32 (included) # -NOW => Thursday 30 July 2009 - 11:49:32 (excluded) # +2000 => Saturday 01 January 2000 - 00:00:00 (included) # +2000:month => Saturday 01 July 2000 - 00:00:00 (included) # +2000:02 => Tuesday 01 February 2000 - 00:00:00 (included) # +year:02 => Sunday 01 February 2009 - 00:00:00 (included) # -year:02 => Sunday 01 February 2009 - 00:00:00 (excluded) # +year:month:day => Thursday 30 July 2009 - 00:00:00 (included) # +year:month:day:hour => Thursday 30 July 2009 - 11:00:00 (included) # +year:month-1year => Tuesday 01 July 2008 - 00:00:00 (included) # +year:month-2months => Friday 01 May 2009 - 00:00:00 (included) # -year:month-2months => Friday 01 May 2009 - 00:00:00 (excluded) # +year:month-1day => Tuesday 30 June 2009 - 00:00:00 (included) # +year:month-2days => Monday 29 June 2009 - 00:00:00 (included) # +NOW-3seconds => Thursday 30 July 2009 - 11:49:29 (included) # -2009:01:01:02:02:02 => Thursday 01 January 2009 - 02:02:02 (excluded) use strict; use Exporter; use DateTime; package dateParse; use vars qw (@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(&parseDateAndDuration &printDate); # [PRIVATE] # Local time zone. my $tz = DateTime::TimeZone::Local->TimeZone(); # [PUBLIC] # This function parses a date along with a duration. The syntax used to define the date is: # (+|-)${date}((+|-)${duration})? # With: ${date} : "NOW" or YYYY[MM[DD[HH[SS[MM]]]]]. See the decription of the function parseDate(). # ${duration} : See description of the function parseDuration(). The duration part is optional. # @param string String that represents the date, in "Date/Duration" notation. # @return Upon successful completion, the function returns a hash. This hash contains 2 entries: # - inclusion: The value could be 0 or 1, depending if the date is included or not. # - datetime: The date, as an object of class DateTime that represents the date. # Otherwize, the function returns an empty hash. sub parseDateAndDuration { my ($string) = @_; my %result = (); if ($string =~ m/^(\+|\-)([^\-\+]+)((\+|\-)([^\-\+]+))?$/) { my $inclusion = $1; my $date = $2; my $gap = $3; my $direction = $4; my $duration = $5; my $dateObj = undef; my $durationObj = undef; if ($date =~ m/^NOW$/i) { $dateObj = DateTime->now(); $dateObj->set_time_zone($tz); } else { $dateObj = parseDate($date); } unless(defined($dateObj)) { return undef; } $result{'inclusion'} = ($inclusion eq '+')? 1 : 0; if (defined($gap)) { $durationObj = parseDuration($duration); unless(defined($durationObj)) { return undef; } if ($direction eq '+') { $result{'datetime'} = $dateObj->add($durationObj); return %result; } else { $result{'datetime'} = $dateObj->subtract($durationObj); return %result; } } $result{'datetime'} = $dateObj; return %result; } return (); } # [PUBLIC] # This function returns a string that represents the date, interpreted from the "Date/Duration" notation. # @param $expr String that represents the date in "Date/Duration" notation. # @return Upon successfull completion, the function will return a pretty textual representation of the date. # Otherwize, the function returns the value undef. sub printDate { my ($expr) = @_; my %date = parseDateAndDuration($expr); unless(exists($date{'datetime'})) { return undef; } return $date{'datetime'}->strftime('%A %d %B %Y - %H:%M:%S') . ' ' . ($date{'inclusion'} ? '(included)' : '(excluded)'); } # [PRIVATE] # This function parses a string that represents a duration. # The syntax use to define a duration is: # (\d+\s*years?:)? \ # (\d+\s*months?:)? \ # (\d+\s*weeks?:)? \ # (\d+\s*days?:)? \ # (\d+\s*hours?:)? \ # (\d+\s*minutes?:)? \ # (\d+\s*seconds?)? # @param $string string that represents the duration. # @return Upon successful completion, the function returns an object of the class DateTime::Duration. # Otherwize, the function returns the value undef. sub parseDuration { my ($string) = @_; my $lastIdx = 0; my @tab = (); my %order = ('years' => 1, 'months' => 2, 'weeks' => 3, 'days' => 4, 'hours' => 5, 'minutes' => 6, 'seconds' => 7); my %duration = ('years' => 0, 'months' => 0, 'weeks' => 0, 'days' => 0, 'hours' => 0, 'minutes' => 0, 'seconds' => 0); @tab = split(/:/, $string); if ((int @tab) == 0) { return undef; } for (my $i=0; $i<(int @tab); $i++) { ## Remove leading and traling spaces. $tab[$i] =~ s/^\s*//; $tab[$i] =~ s/\s*$//; if ($tab[$i] =~ m/^(\d+)\s*(\w+)$/) { my $value = $1; my $unit = lc($2); $unit =~ s/s?$/s/; # print "value=[$value], unit=[$unit]\n"; unless(exists($duration{$unit})) { return undef; } ## The unit is unknown. if ($order{$unit} <= $lastIdx) { return undef; } ## The unit has already been found $duration{$unit} = $value; $lastIdx = $order{$unit}; } else { return undef; } } # foreach my $k (%duration) { print "o $k => " . $duration{$k} . "\n"; } return DateTime::Duration->new(%duration); } # [PRIVATE] # This function parses a date. The syntax used to define the date is: # $year[:$month[:$day[:$hour[:$minute[:$second]]]]] # With: $year = year|\d+ # $month = month|\d+ # $day = day|\d+ # $hour = hour|\d+ # $minute = minute|\d+ # $second = second|\d+ # @param $string String that represents the date. # @return Upon successful completion, the function returns an object of the class DateTime. # Otherwize, the function returns the value undef. sub parseDate { my ($string) = @_; my $res = undef; my @tab = (); my %date = ('year' => undef, 'month' => 1, 'day' => 1, 'hour' => 0, 'minute' => 0, 'second' => 0); my %parsers = ('year' => \&getYear, 'month' => \&getMonth, 'day' => \&getDay, 'hour' => \&getHour, 'minute' => \&getMinute, 'second' => \&getSecond); my @position = ('year', 'month', 'day', 'hour', 'minute', 'second'); @tab = split(/:/, $string); for (my $i=0; $i<(int @tab); $i++) { if ($tab[$i] =~ m/^(([a-z]+)|(\d+))$/i) { my $tag = $2; my $value = $3; if (defined($tag)) { my $function = undef; $tag = lc($tag); unless ($tag eq $position[$i]) { return undef; } $function = $parsers{$tag}; $date{$tag} = &{$function}('NOW'); } else { $date{$position[$i]} = $value; } } else { return undef; } } $res = DateTime->new(%date); $res->set_time_zone($tz); return $res; } # [PRIVATE] # This function returns the year's value, interpreted from the date's syntax. # NOW means "the current year". # @param $y The string that represents the year (in absolute or relative notation). # @return The function returns a value the represents the correct year's value. sub getYear { my ($y) = @_; if ($y =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->year(); } if ($y =~ /^[0-9]+$/) { return $y; } return undef; } # [PRIVATE] # This function returns the month's value, interpreted from the date's syntax. # NOW means "the current month". # @param $m The string that represents the month (in absolute or relative notation). # @return The function returns a value the represents the correct month's value. sub getMonth { my ($m) = @_; if ($m =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->month(); } if ($m =~ /^[0-9]+$/) { return $m; } return undef; } # [PRIVATE] # This function returns the day's value, interpreted from the date's syntax. # NOW means "the current day". # @param $d The string that represents the day (in absolute or relative notation). # @return The function returns a value the represents the correct day's value. sub getDay { my ($d) = @_; if ($d =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->day(); } if ($d =~ /^[0-9]+$/) { return $d; } return undef; } # [PRIVATE] # This function returns the hour's value, interpreted from the date's syntax. # NOW means "the current hour". # @param $h The string that represents the hour (in absolute or relative notation). # @return The function returns a value the represents the correct hour's value. sub getHour { my ($h) = @_; if ($h =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->hour(); } if ($h =~ /^[0-9]+$/) { return $h; } return undef; } # [PRIVATE] # This function returns the minute's value, interpreted from the date's syntax. # NOW means "the current minute". # NOW-N means "N minutes before the current minute". # @param $m The string that represents the minute (in absolute or relative notation). # @return The function returns a value the represents the correct minute's value. sub getMinute { my ($m) = @_; if ($m =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->minute(); } if ($m =~ /^[0-9]+$/) { return $m; } return undef; } # [PRIVATE] # This function returns the second's value, interpreted from the date's syntax. # NOW means "the current second". # @param $s The string that represents the second (in absolute or relative notation). # @return The function returns a value the represents the correct second's value. sub getSecond { my ($s) = @_; if ($s =~ /^NOW$/i) { my $now = DateTime->now(); $now->set_time_zone($tz); return $now->second(); } if ($s =~ /^[0-9]+$/) { return $s; } return undef; } # [TEST] # This function should be used to test this module. sub test_parseDate { my $date = $ARGV[0]; my $dateObject = parseDate($date); unless(defined($dateObject)) { print "[$date] is not correct!\n"; exit 1; } print "Date <$date>: " . $dateObject->datetime . "\n"; exit 0; } # [TEST] # This function should be used to test this module. sub test_parseDuration { my $duration = $ARGV[0]; my $durationObject = parseDuration($duration); unless(defined($durationObject)) { print "[$duration] is not correct!\n"; exit 1; } exit 0; } # [TEST] # This function should be used to test this module. sub printExamples { my @dates = qw ( +NOW -NOW +2000 +2000:month +2000:02 +year:02 -year:02 +year:month:day +year:month:day:hour +year:month-1year +year:month-2months -year:month-2months +year:month-1day +year:month-2days +NOW-3seconds -2009:01:01:02:02:02 +year-1second +year-1day +year-1month +year-1week +year:12:25+10days ); foreach my $date (@dates) { print $date . ' => ' . printDate($date) . "\n"; } } # printExamples(); # print printDate($ARGV[0]) . "\n"; 1;

Exemple d'utilisation du module :

#!/usr/bin/perl # Author: Denis BEURIVE # This script is used to generate a list of commands that should be replayed. # # Examples: # # $ perl createCommandes.pl --dateFrom=+2009:10:01:09:00:00 --dateTo=-2009:10:01:14:00:00 --period=1 --unit=hour # perl myCommand.pl --dateFrom=+2009:10:01:09:00:00 --dateTo=-2009:10:01:10:00:00 # perl myCommand.pl --dateFrom=+2009:10:01:10:00:00 --dateTo=-2009:10:01:11:00:00 # perl myCommand.pl --dateFrom=+2009:10:01:11:00:00 --dateTo=-2009:10:01:12:00:00 # perl myCommand.pl --dateFrom=+2009:10:01:12:00:00 --dateTo=-2009:10:01:13:00:00 # perl myCommand.pl --dateFrom=+2009:10:01:13:00:00 --dateTo=-2009:10:01:14:00:00 # # $ perl createCommandes.pl --dateFrom=+year:month:day:hour --dateTo=-year:month:day:hour+3hours --period=15 --unit=minute # perl myCommand.pl --dateFrom=+2011:09:05:15:00:00 --dateTo=-2011:09:05:15:15:00 # perl myCommand.pl --dateFrom=+2011:09:05:15:15:00 --dateTo=-2011:09:05:15:30:00 # perl myCommand.pl --dateFrom=+2011:09:05:15:30:00 --dateTo=-2011:09:05:15:45:00 # perl myCommand.pl --dateFrom=+2011:09:05:15:45:00 --dateTo=-2011:09:05:16:00:00 # perl myCommand.pl --dateFrom=+2011:09:05:16:00:00 --dateTo=-2011:09:05:16:15:00 # perl myCommand.pl --dateFrom=+2011:09:05:16:15:00 --dateTo=-2011:09:05:16:30:00 # perl myCommand.pl --dateFrom=+2011:09:05:16:30:00 --dateTo=-2011:09:05:16:45:00 # perl myCommand.pl --dateFrom=+2011:09:05:16:45:00 --dateTo=-2011:09:05:17:00:00 # perl myCommand.pl --dateFrom=+2011:09:05:17:00:00 --dateTo=-2011:09:05:17:15:00 # perl myCommand.pl --dateFrom=+2011:09:05:17:15:00 --dateTo=-2011:09:05:17:30:00 # perl myCommand.pl --dateFrom=+2011:09:05:17:30:00 --dateTo=-2011:09:05:17:45:00 # perl myCommand.pl --dateFrom=+2011:09:05:17:45:00 --dateTo=-2011:09:05:18:00:00 use lib '/home/services/perl-common'; use strict; use logger; use Getopt::Long; use DateTime; use dateParse; # ---------------------------------------------------------------------- # Variables # ---------------------------------------------------------------------- my $help = 0; # Help command flag. my $dateFrom = undef; # Starting date from the command line (string). my $dateTo = undef; # Ending date from the command line (string). my %cliFrom = (); # Internal representation of the starting date. my %cliTo = (); # Internal representation of the ending date. my $period = undef; # Period, from the command line. my $unit = undef; # Period's unit. my $cliDateFrom = undef; # Starting date for the current loop. my $cliDateTo = undef; # End date for the current loop. my $decal = undef; # Total cumulated duration; # ---------------------------------------------------------------------- # Parse the command line # ---------------------------------------------------------------------- unless ( GetOptions ( 'help' => \$help, 'dateFrom=s' => \$dateFrom, 'dateTo=s' => \$dateTo, 'period=s' => \$period, 'unit=s' => \$unit ) ) { print STDERR "ERROR: Invalid command line.\n"; exit 1; } if ($help) { help(); exit 0; } unless (defined($dateFrom)) { print STDERR "ERROR: Missing command line argument <dateFrom>!\n"; exit 1; } unless (defined($dateTo)) { print STDERR "ERROR: Missing command line argument <dateTo>!\n"; exit 1; } unless (defined($period)) { print STDERR "ERROR: Missing command line argument <period>!\n"; exit 1; } unless (defined($unit)) { print STDERR "ERROR: Missing command line argument <unit>!\n"; exit 1; } # ------------------------------------------------------------------------------ # Check dates # ------------------------------------------------------------------------------ %cliFrom = parseDateAndDuration($dateFrom); %cliTo = parseDateAndDuration($dateTo); unless (exists($cliFrom{'datetime'})) { my $mess = "Invalid date specification for start date ($dateFrom)"; print STDERR "$mess\n"; exit 1; } unless (exists($cliTo{'datetime'})) { my $mess = "Invalid date specification for stop date ($dateTo)"; print STDERR "$mess\n"; exit 1; } # ---------------------------------------------------------------------- # Calculate data day per day # ---------------------------------------------------------------------- $cliDateFrom = $dateFrom; $cliDateTo = $dateTo; $decal = 0; while (1) { my %from = undef; # Starting date. my %to = (); # Ending date. my $decalTo = undef; my $tagFrom = undef; my $tagTo = undef; $decalTo = $decal + $period; $dateFrom = "${cliDateFrom}+${decal}${unit}"; $dateTo = "${cliDateFrom}+${decalTo}${unit}"; %from = parseDateAndDuration($dateFrom); %to = parseDateAndDuration($dateTo); $decal += $period; if (DateTime->compare($to{'datetime'}, $cliTo{'datetime'}) > 0) { last; } ## ------------------------------- ## Lines to adapt. ## ------------------------------- $tagFrom = $from{'datetime'}->strftime('+%Y:%m:%d:%H:%M:%S'); $tagTo = $to{'datetime'}->strftime('-%Y:%m:%d:%H:%M:%S'); print "perl myCommand.pl --dateFrom=$tagFrom --dateTo=$tagTo\n"; } exit 0; # ---------------------------------------------------------------------- # End of script - functions. # ---------------------------------------------------------------------- sub help() { print STDOUT "perl createDates.pl [--help] --dateFrom=... --dateTo=... --period=... --unit=...\n\n"; print STDOUT "\t--dateFrom: This date defines the beginning of the period upon which we calculate statistics.\n"; print STDOUT "\t Ex: +2010:10:01 or +2010:10:01:21:55:00\n\n"; print STDOUT "\t--dateTo: This date defines the end of the period upon which we calculate statistics.\n"; print STDOUT "\t Ex: -2010:10:02\n\n"; print STDOUT "\t--period: This value represents the duration between two dates.\n\n"; print STDOUT "\t--unit: This value represents the period's unit.\n\n"; print STDOUT "Example: perl createCommandes.pl --dateFrom=+2010:11:01 --dateTo=+2011:01:01 --period=1 --unit=day\n"; }

Le chargement dynamique de modules permet d'implémenter aisément une architecture à base de greffons (plugins).

Le code ci-dessous charge un ensemble de modules.

• Tous les modules à charger sont stockés sous le même répertoire (dont le chemin est déterminé par la valeur de $MODULES_DIR).
• Chaque module exporte la liste des fonctions qu'il exporte.

use strict; use Data::Dumper; # Path to the directory used to store all the modules to load. my $MODULES_DIR = './modules'; my $err = undef; my $string = undef; my $resultat = undef; my @tab = (); my %hash = (); my @modules = (); # ----------------------------------------------------------------------- # We load all modules that should be loaded. # ----------------------------------------------------------------------- @modules = listModules($MODULES_DIR, \$err); if (defined($err)) { print STDERR "ERROR: Could not load modules in \"$MODULES_DIR\" - $err!\n"; exit 1; } # ----------------------------------------------------------------------- # Load all modules. # ----------------------------------------------------------------------- foreach my $module (@modules) { my $functions = eval { require "$MODULES_DIR/$module"; }; print STDOUT "Module \"$module\" loaded.\n"; foreach my $f (keys %{$functions}) { print "\t$f\n"; } } # ----------------------------------------------------------------------- # Call some functions. # With "eval", you can only pass scalars. References are scalars. # ----------------------------------------------------------------------- $string = 'chaine de test'; eval "\$resultat = m1::function1(\$string)"; ## NOTE: Do not replace $string by its value print "resultat = [$resultat]\n"; $string = 'chaine de test'; eval '$resultat = m1::function1($string)'; ## NOTE: Single quotes instead of double quotes print "resultat = [$resultat]\n"; $string = 'chaine de test'; eval "\$resultat = m1::function2(\$string)"; ## NOTE: Do not replace $string by its value print "resultat = [$resultat]\n"; @tab = (10, 20, 30); eval '$resultat = m2::function3(\@tab)'; eval "\$resultat = m2::function3(\\\@tab)"; %hash = ('a' => 10, 'b' => 20); eval '$resultat = m2::function4(\%hash)'; %hash = ('a' => 10, 'b' => 20); eval '$resultat = m2::function5(\%hash)'; foreach my $e (@{$resultat}) { print STDOUT "\tres($e)\n"; } sub listModules { my ($inPath, $outErr) = @_; my @files = (); my @modules = (); $$outErr = undef; unless (opendir (dir, "$inPath")) { $$outErr = $!; return undef; } @files = readdir(dir); closedir (dir); foreach my $file (@files) { if ($file =~ m/^(.+)\.pm$/) { push (@modules, $file); } } return @modules; }

# First module to load (modules/m2.pm). package m1; use strict; my %functions = ( 'function1' => { 'argsNumber' => 1, 'args' => 'string', 'retour' => 'res' }, 'function2' => { 'argsNumber' => 1, 'args' => 'string', 'retour' => 'res' } ); sub function1 { my ($st) = @_; print STDOUT "Calling m1::function1()\n"; return "OK 1: $st"; }; sub function2 { my ($st) = @_; print STDOUT "Calling m2::function2()\n"; return "OK 2: $st"; }; \%functions;

# Second module to load (modules/m2.pm). package m2; use strict; my %functions = ( 'function3' => { 'argsNumber' => 1, 'args' => 'array', 'retour' => undef }, 'function4' => { 'argsNumber' => 1, 'args' => 'hash', 'retour' => undef }, 'function5' => { 'argsNumber' => 1, 'args' => 'hash', 'retour' => 'array' } ); sub function3 { my ($tab) = @_; print STDOUT "Calling m2::function3()\n"; foreach my $e (@{$tab}) { print STDOUT "\t=> $e\n"; } }; sub function4 { my ($hash) = @_; print STDOUT "Calling m2::function4()\n"; foreach my $e (keys %{$hash}) { print STDOUT "\t=> $e\n"; } }; sub function5 { my ($hash) = @_; my @ret = (); print STDOUT "Calling m2::function5()\n"; foreach my $e (keys %{$hash}) { print STDOUT "\t=> $e\n"; push (@ret, 2*$hash->{$e}); } return \@ret; }; \%functions;

L'analyse d'emails n'est pas une tâche triviale. Ce module permet d'extraire tous les fichiers joints à un email, ainsi que les adresses de l'envoyeur et du destinataire.

# Author: Denis BEURIVE # This module deals with attached files within emails. # It analyzes emails passed through the standard input. # And it dumps attached files on the file system (under temporary directory pathes). # In addition, it retrieves email addresses from the email's header ("To" and "From"). #!/usr/bin/perl package mail; use strict; use MIME::Parser; use MIME::Body; use Data::Dumper; use vars qw (@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(&analyseEmail &retrieveAttachedFiles); # [PUBLIC] # This function reads email from STDIN. Then it analyzes it. # @param $outMailData Refrence to hash used to store information about the email. # The following keys will be added to the hash: # - 'To': Reference to an array used to store the list of destination emails. # - 'From': Reference to an array used to store the list of senders' email addressses. # - 'File': Reference to an array used to store the pathes to the attached files. # @param $inConfig Refrence to hash used to store the global configuration. # @param $outStatus Reference to a hash used to store the status of the operation. # @return The function always returns the value undef. # @warning Please note that this function creates temporary files. # It is your responsibility to remove them from the file system. sub analyseEmail { my ($outMailData, $inConfig, $outStatus) = @_; my $emailParser = undef; # Parser for the email. my $emailEntity = undef; # Email entities. my $emailParserResult = undef; # Error message for the parsing. my @fromEmails = undef; # List of sender's email. my @toEmails = (); # List of destinations' emails. my @attachedFiles = (); # List of attached files. %{$outStatus} = (); %{$outMailData} = (); $outStatus->{'err'} = 0; $outStatus->{'mess'} = undef; # ------------------------------------------------------------- # Parse the email # Please, see documentation for: # - MIME::Parser # - MIME::Entity # - MIME::Head # - MIME::Body # Usefull code: # - Dumper($emailParserResult) # ------------------------------------------------------------- $emailParser = new MIME::Parser; $emailParser->output_under($inConfig->{'tmpDirectory'}); $emailEntity = eval { $emailParser->parse(\*STDIN) }; $emailParserResult = $emailParser->results; if ($emailParserResult->errors) { $outStatus->{'err'} = 1; $outStatus->{'mess'} = "An error occured while parsing the email: " . $emailParserResult->errors; return undef; } @toEmails = $emailEntity->head->get_all('To'); cleanEmails(\@toEmails); @fromEmails = $emailEntity->head->get_all('From'); cleanEmails(\@fromEmails); walkThroughEmail($emailEntity, \@attachedFiles); $outMailData->{'To'} = \@toEmails; $outMailData->{'From'} = \@fromEmails; $outMailData->{'File'} = \@attachedFiles; return undef; } # [PRIVATE] # This function removes EOL characters at the end of emails. # @param $inOutList Reference to an array that contains the emails to clean. # @return The function always returns the value unidef. sub cleanEmails { my ($inOutList) = @_; foreach my $e (@{$inOutList}) { chomp($e); if ($e =~ m/<([^<>]+)>/) { my $m = $1; $e = $m; } } } # [PRIVATE] # The recursive function walk through the email structure. # @param $entity Current entity. # @param $outFiles Reference to an array that will be used to store pathes to attached files. # Each element of the array is a reference to a hash. # Each referenced hash contains to keys: # - 'handler': Handler to the mail entity that points to the attached file. # - 'path': Full path to the attached file. # @return The function always returns the value unidef. sub walkThroughEmail { my ($entity, $outFiles) = @_; my @parts = (); # ----------------------------------------------------------- # Walk through the body # ----------------------------------------------------------- @parts = $entity->parts; if (@parts) { foreach my $part (@parts) { walkThroughEmail($part, $outFiles); } } else { # ------------------------------------------------------- # single part... # ------------------------------------------------------- my ($type, $subtype) = split('/', $entity->head->mime_type); my $body = $entity->bodyhandle; unless ($type =~ /^(text|message)$/) { my $path = $body->path; if (defined($path)) { push (@{$outFiles}, {'handler' => $body, 'path' => $path}); } } } return undef; } # [PUBLIC] # Among all attached files, this function retrieves all files which names verify a given regular expression. # @param $inList $inMailData Reference to the data structure generated by the function analyseEmail(). # The data structure contains the list of attached files extracted from the email. # @param $inRegExp Regular expression that identifies the attached file to keep. # @return The function returns an array which contains the attached files that match the regular expression. sub retrieveAttachedFiles { my ($inList, $inRegExp) = @_; my @list = (); foreach my $file (@{$inList->{'File'}}) { my $path = $file->{'path'}; my $handler = $file->{'handler'}; if ($path =~ m/${inRegExp}/i) { push (@list, { 'handler' => $handler, 'path' => $path }); } } return @list; } 1;

Exemple d'utilisation.

use strict; use mail; ... # ------------------------------------------------------------- # Some variables # ------------------------------------------------------------- my %mailData = (); my %config = (); my %status = (); ... # ------------------------------------------------------------------------------ # Set the termination handler # ------------------------------------------------------------------------------ END { if (exists($mailData{'File'})) { if (int @{$mailData{'File'}} > 0) { my $path = dirname($mailData{'File'}->[0]->{'path'}); unless ($path =~ m/^\/*$/) { my @command = ('/bin/rm', '-rf', $path); system (@command); } } } } # ------------------------------------------------------------- # Parse the email # ------------------------------------------------------------- analyseEmail(\%mailData, \%config, \%status); ...

Dans le secteur des télécommunications, il est courant de devoir factoriser des plages de numéros de téléphone. Cette opération est nécessaire pour la configuration de certains équipements téléphoniques. Le module ci-dessous effectue cette opération de factorisation.

Exemple : On considère l'ensemble de 15 numéros présentés ci-dessous.

Dans cet exemple, pour des raisons de clarté, les numéros sont triés par ordre croissant. Cela dit, il n'est pas nécessaire de classer les numéros pour utiliser le module.

Le principe est le suivant :

• On détecte les suites de numéros qui comportent une puissance de 10 éléments: 10, 100, 1000, ... On crée ainsi des suites de numéros.
• Le plus petit numéro de chaque suite ainsi constitué doit se terminer par un zéro (ex: 0147300600).
• Chaque suite ainsi constituée fait l'objet d'une factorisation.

1. 0147300600
2. 0147300601
3. 0147300602
4. 0147300603
5. 0147300604
6. 0147300605
7. 0147300606
8. 0147300607
9. 0147300608
10. 0147300609
11. 0147300610
12. 0147300611
13. 0147300612
14. 0147300613
15. 0147300614

Dans l'exemple ci-dessous, les numéros en rouge constituent une suite de 10 numéros. Cette suite sera factorisée de la façon suivante : "014730060".

# Author: Denis BEURIVE # Ce module regroupe des fonctions utilisées pour manipuler le fichier de configuration du TS (trunck Selector). # @warning Certaines des fonctions présentes dans ce module supposent que les données qui leur sont passées en argument sont valides. # Autrement dit, la validation du format des données doit se faire en amont de leur utilisation dans ces fonctions. # Veuillez lire attentivement les commentaires qui précèdent chaque fonction. # @remark Dans ce document, les termes "numéros" et "plage de numéros" sont confondus. # Il faut considérer qu'un numéro est une "plage de numéro" qui ne contient qu'un seul élément. use strict; use Exporter; package ts; use vars qw (@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(&buildRange &explodeRange); # [PUBLIC] # Cette fonction regroupe les numéros de téléphone (ou de fax) en plage de numéros. # Une plage de numéros contient un nombre de numéros "puissance de 10" (1, 10, 100, 1000,...). # o La plage "147300512" contient un seul numéro: 0147300512 # o La plage "14730051" contient 10 numéros: de 0147300510 à 0147300519 # Il faut lire "014730051x", avec x=0,1,...,9 # o La plage "1473005" contient 100 numéros: de 0147300500 à 0147300599 # Il faut lire "014730051xy" avec x=0,1,...,9 et y=0,1,...,9 # Et ainsi de suite. # # On désire "factoriser en plage" la liste des numéros suivants : # # 1. 0147300600 # 2. 0147300601 # 3. 0147300602 # 4. 0147300603 # 5. 0147300604 # 6. 0147300605 # 7. 0147300606 # 8. 0147300607 # 9. 0147300608 # 10. 0147300609 # 11. 0147300610 # 12. 0147300611 # 13. 0147300612 # 14. 0147300613 # 15. 0147300614 # # On envoie au TS les numéros suivants : # 14730060 # 147300610 # 147300611 # 147300612 # 147300613 # 147300614 # # @param inNumbers Liste des numéros de téléphone à factoriser. # @return La fonction retourne un tableau qui contient la "factorisation". # Chaque élément de la liste retournée est un numéro, ou une plage de numéros. # Remarque : Un numéro est une plage de numéro qui ne contient qu'un seul élément. # @remark Conformément aux spécifications, le zéro présent au début de chaque numéro retourné est éliminé. sub buildRange { my ($inNumbers) = @_; my @sortedNumbers = (); my @result = (); # Classement des numéros par ordre croissant. @sortedNumbers = sortNumbers($inNumbers); # Détection des plages. @result = factorizeNumbers(\@sortedNumbers); # Tri des plages. @result = sortAll(\@result); # Formatage des plages. return formatNumbersToTS(\@result); } # [PUBLIC] # Cette fonction calcule tous les numéros d'une plage de numéros. # @param inRange Plage à étendre. # La fonction s'attend à recevoir une plage "au format TS". C'est-à-dire, une chaîne de caractères qui ne commence pas par un zéro. # @return La fonction renvoie un tableau contenant tous les numéros de la plage. # Les numéros renvoyés sont exprimés au format "standard". C'est-à-dire, une chaîne de caractères qui commence par un zéro. sub explodeRange { my ($inRange) = @_; my $l = undef; my $m = undef; my @res = (); $inRange = "0${inRange}"; $l = length($inRange); if ($l == 10) { return ($inRange); } $m = 10 ** (10 - $l); for (my $i=0; $i<$m; $i++) { push (@res, "$inRange" . leftPadValue($i, 10 - $l)); } return @res; } # [PRIVATE] # Cette fonction permet de justifier une valeur avec des zéros à gauche. # @param inValue Valeur à justifier. # @param inLength Taille totale de la chaîne retournée. # @return La fonction retourne une chaîne de caractères qui représente la valeur justifiée. sub leftPadValue { my ($inValue, $inLength) = @_; my $res = ''; for (my $i=0; $i<$inLength - length("$inValue"); $i++) { $res .= '0'; } return "${res}${inValue}"; } # [PRIVATE] # Cette fonction "factorise" une liste de numéros en plages de numéros. # @note CF description de la fonction buildRange() pour connaître la définition d'une plage de numéros. # @note Dans cette fonction, le terme "séquence" désigne une plage de 10 numéros consécutifs. # @param inNumbers Référence vers un tableau qui contient la liste des numéros à "factoriser". # @return La fonction retourne la liste "factorisée" de numéros. # @warning La liste des numéros doit être triée au préalable! # Le tri doit être effectué grâce à la fonction sortNumbers(). sub factorizeNumbers { my ($inNumbers) = @_; my @input = (); my @result = (); @input = @{$inNumbers}; while (1) { my @sequencesIndexes = (); my @sequences = (); # On détecte les séquences de 10 numéros consécutifs, et dont le premier élément (de la séquence) se termine par 0 (ex: "014530045_0_"). @sequencesIndexes = scanNumbersForSequences(\@input); # On extrait les séquences de la liste des numéros. foreach my $s (@sequencesIndexes) { # On injecte la séquence détectée dans la liste des séquences. push (@sequences, substr($input[$s], 0, length($input[$s])-1)); # On "élimine" les séquences détectées de la liste des numéros. for (my $i=0; $i<10; $i++) { $input[$s+$i] = undef; } } # On injecte les numéros "isolés" (hors plage) dans la liste des numéros. foreach my $n (@input) { if (defined($n)) { push(@result, $n); } }; if (int @sequencesIndexes == 0) { last; } @input = @sequences; } return @result; } # [PRIVATE] # Cette fonction parcourt une liste de numéros afin de détecter d'éventuelles plages de 10 numéros. # @param inNumbers Référence vers un tableau qui contient la liste des numéros à parcourir. # @return La fonction renvoie un tableau qui contient les indices des (débuts des) séquences dans la liste de numéros. # Ce tableau peut être vide, si aucune séquence n'est détectée. # @warning La liste des numéros doit être triée au préalable! # Le tri doit être effectué grâce à la fonction sortNumbers(). sub scanNumbersForSequences { my ($inNumbers) = @_; my $pool = undef; my $find = 0; my @sequences = (); # On construit une chaîne de caractères constituée uniquement des derniers caractères de la liste des numéros. $pool = lastDigitToString($inNumbers); # Condition de sortie de la boucle: ($find == 0) # Cela signifie qu'aucune suite de 10 numéros consécutifs n'a été détectée. while (1) { my $position = findSuccessionFromList(\$pool, $inNumbers, \$find); if ($find == 0) { last; } if ($position != -1) { push (@sequences, $position); } } return @sequences; } # [PRIVATE] # Cette fonction extrait les derniers nombres de chaque numéro et les aligne sur une ligne. # Ex: @inNumbers = ("014730060_3_", "014730060_6_", "014730060_9_") => "369". # @param inNumbers Référence vers un tableau qui contient la liste des numéros manipuler. # @return La fonction retourne une chaîne de caractères. sub lastDigitToString { my ($inNumbers) = @_; my $line = ''; foreach my $n (@{$inNumbers}) { $line .= substr("$n", -1); } return $line; } # [PRIVATE] # Cette fonction recherche la séquence de caractères "0123456789" dans une chaîne. # @param inList Référence vers une chaîne de caractères à analyser. # @param inNumbers Référence vers un tableau qui contient la liste des numéros à parcourir. # @param outFound Référence vers un indicateur utilisé pour signaler la détection d'une plage. # o 0: Aucune plage n'a été trouvée. # o 1: Une plage a été trouvée. # @return Si la fonction détecte la séquence recherchée, alors elle retourne la position de la séquence dans la chaîne sur laquelle s'effectue la recherche. # La position retournée est représentée par la position du début de la séquence (ici le "0"), dans la chaîne analysée (la position commence à 0). # Puis la fonction remplace la séquence "0123456789" par la séquence "##########". # => De cette façon la même séquence ne sera pas détectée une seconde fois. # Sinon, la fonction retourne la valeur -1. sub findSuccessionFromList { my ($inList, $inNumbers, $outFound) = @_; my $numbers = $$inList; $$outFound = 0; if ($$inList =~ m/0123456789/) { my $startIndex = undef; ## Index, dans le tableau de numéros (référencé par $inNumbers), du numéro dont le dernier caractère est "0". my $startRoot = undef; ## Chaîne constante dans la plage de numéros. $$outFound = 1; $startIndex = $-[0]; $startRoot = $inNumbers->[$startIndex]; chop($startRoot); # On remplace la plage par des caractères "#", de telle façon qu'elle ne sera pas détectée une seconde fois. $$inList =~ s/0123456789/##########/; # On vérifie bien que tous les numéros de la plage "potentielle" comportent la même racine! for (my $i=$startIndex+1; $i<$startIndex+10; $i++) { my $currentNumber = undef; $currentNumber = $inNumbers->[$i]; chop($currentNumber); if ("$currentNumber" ne "$startRoot") { return -1; } } return $startIndex; } return -1; } # [PRIVATE] # Cette fonction formate un numéro en vue de son injection dans le TS. # @param inNumber Numero à formater. # @return La fonction renvoie le numéro formater. sub formatNumberToTS { my ($inNumber) = @_; $inNumber =~ s/^0//; return $inNumber; } # [PRIVATE] # Cette fonction formate une liste de numéros en vue de son injection dans le TS. # @param inNumbers Référence vers un tableau qui contient la liste de numéros à formater. # @return La fonction retourne un tableau qui contient la liste des numéros formatés. sub formatNumbersToTS { my ($inNumbers) = @_; my @result = (); foreach my $n (@{$inNumbers}) { push(@result, formatNumberToTS($n)); } return @result; } # [PRIVATE] # Cette fonction classe une liste de numéros par ordre croissant. # @param inNumbers Référence vers la liste des numéros de téléphone à classer. # @return La fonction renvoie un tableau qui contient les numéros, classés par ordre croissant. sub sortNumbers { my ($inNumbers) = @_; return sort { cmpNumbers($a, $b); } @{$inNumbers}; } # [PRIVATE] # Cette fonction classe une liste de numéros et de plages par ordre croissant. # @param inNumbers Référence vers la liste des numéros et des plages à classer. # @return La fonction renvoie un tableau qui contient les numéros et les plages, classés par ordre croissant. sub sortAll { my ($inNumbers) = @_; return sort { cmpNumbers($a, $b, 1); } @{$inNumbers}; } # [PRIVATE] # Cette fonction compare deux "plages" de numéros. # @note Les plages de numéros peuvent éventuellement ne contenir qu'un seul numéro. # Si la plage "014730254" est renseignée, alors elle sera considérée comme égale à "0147302549". # Si la plage "01473025" est renseignée, alors elle sera considérée comme égale à "0147302599". # @param inNumber1 Première plage de numéro. # @param inNumber2 Deixième plage de numéro. # @param inPlage Cet indicateur permet de configurer le comportement de la fonction. # Si ce paramètre est défini, alors le comparateur suppose que les valeurs renseignées sont des plages de plusieurs numéros. # Sinon, le comparateur suppose que les valeurs renseignées sont des plages qui ne contiennent qu'un seul numéro (autrement dit, des numéros). # @return Si $inNumber1 < $inNumber2, alors la fonction renvoie la valeur -1. # Si $inNumber1 > $inNumber2, alors la fonction renvoie la valeur +1. # Si $inNumber1 == $inNumber2, alors la fonction renvoie la valeur 0. # @warning Cette fonction ne fait aucun test sur le format des plages qui lui sont passées en argument! sub cmpNumbers { my ($inNumber1, $inNumber2, $inPlage) = @_; my @c1 = (); my @c2 = (); $inNumber1 =~ s/^0+//; $inNumber2 =~ s/^0+//; @c1 = split(//, $inNumber1); @c2 = split(//, $inNumber2); if (! defined($inPlage)) { if (int @c1 > int @c2) { return 1; } if (int @c1 < int @c2) { return -1; } } else { my $l = undef; $l = int @c1; for (my $i=0; $i<10 - $l; $i++) { push (@c1, '9'); } $l = int @c2; for (my $i=0; $i<10 - $l; $i++) { push (@c2, '9'); } } for (my $i=0; $i<int @c1; $i++) { if ($c1[$i] > $c2[$i]) { return 1; } if ($c1[$i] < $c2[$i]) { return -1; } } return 0; } # ------------------------------------------------------------------------------------- # Petites fonction de debug. # Les fonctions suivantes peuvent être utilisées pour afficher les contenus des # certaine structures de données. # ------------------------------------------------------------------------------------- sub dumpNumbers { my ($inList) = @_; my $i = 0; foreach my $n (@{$inList}) { printf ("\t- %5d NUMBER %s\n", $i, $n); $i++; }; } sub dumpSequence { my ($inList) = @_; my $i = 0; foreach my $n (@{$inList}) { printf ("\t- %4d SEQ@ %s\n", $i, $n); $i++; }; } sub shuffle { my (@inArray) = @_; my $v = undef; my $size = int @inArray; for (my $i=0; $i<$size; $i++) { my $a = int(rand($size)); my $b = int(rand($size)); $v = $inArray[$a]; $inArray[$a] = $inArray[$b]; $inArray[$b] = $v; } return @inArray; } # ------------------------------------------------------------------------------------- # Fonctions de tests unitaires. # Les fonctions suivantes peuvent être utilisées pour tester, de façon interactive, # chaque fonction de ce module. Les données de test sont renseignées via la ligne de # commande ou via un fichier de test. # ------------------------------------------------------------------------------------- # Cette fonction lit les paramètres du test depuis l'entrée standard. # Ex: perl ts.pm < test1.txt # L'utilisation de cette fonction permet de générer des jeux de test dont les données sont "mélangées" (non classées). sub shuffleInputList { my @numbers = (); my @result = (); while (<STDIN>) { chomp $_; $_ =~ s/^\s+//; $_ =~ s/\s+$//; if ($_ =~ m/^$/) { next; } push (@numbers, $_); } @result = shuffle(@numbers); foreach my $n (@result) { print "$n\n"; } } # Cette fonction lit les paramètres du test depuis la ligne de commande. # Ex: perl ts.pm 0147300614 0147300615 sub TESTcmpNumbers { my ($plage) = @_; my $n1 = $ARGV[0]; my $n2 = $ARGV[1]; my $c = cmpNumbers($n1, $n2, $plage); if ($c == +1) { print "$n1 > $n2\n"; } if ($c == -1) { print "$n1 < $n2\n"; } if ($c == 0) { print "$n1 == $n2\n"; } } # Cette fonction lit les paramètres du test depuis l'entrée standard. # Ex: perl ts.pm < test1.txt sub TESTsortNumbers { my @numbers = (); my @result = (); while (<STDIN>) { chomp $_; $_ =~ s/^\s+//; $_ =~ s/\s+$//; if ($_ =~ m/^$/) { next; } push (@numbers, $_); } print "INPUT:\n"; foreach my $n (@numbers) { print "\t- $n\n"; } @result = sortNumbers(\@numbers); print "OUTPUT:\n"; foreach my $number (@result) { print "\t- $number\n"; } } # Cette fonction lit les paramètres du test depuis l'entrée standard. # Ex: perl ts.pm < test1.txt sub TESTlastDigitToString { my @numbers = (); while (<STDIN>) { chomp $_; $_ =~ s/^\s+//; $_ =~ s/\s+$//; if ($_ =~ m/^$/) { next; } push (@numbers, $_); } print "INPUT:\n"; foreach my $n (@numbers) { print "\t- $n\n"; } print lastDigitToString(\@numbers) . "\n"; } # Cette fonction lit les paramètres du test depuis la ligne de commande. # Ex: perl ts.pm 01473006142123456789001234567890998 sub TESTfindSuccessionFromList { my $input = $ARGV[0]; print "=> " . findSuccessionFromList(\$input) . "\n"; } # Cette fonction lit les paramètres du test depuis l'entrée standard. # Ex: perl ts.pm < test1.txt sub TESTscanNumbersForSequences { my @tab = (); my @numbers = (); my @sorted = (); my $i = 0; while (<STDIN>) { chomp $_; $_ =~ s/^\s+//; $_ =~ s/\s+$//; if ($_ =~ m/^$/) { next; } push (@numbers, $_); } @sorted = sortNumbers(\@numbers), print "INPUT:\n"; foreach my $n (@sorted) { print "\t- $i $n\n"; $i++; } @tab = scanNumbersForSequences(\@sorted); foreach my $n (@tab) { print "=> $n\n"; } } # Cette fonction lit les paramètres du test depuis l'entrée standard. # Ex: perl ts.pm < test1.txt sub TESTbuildRange { my @numbers = (); my @result = (); while (<STDIN>) { chomp $_; $_ =~ s/^\s+//; $_ =~ s/\s+$//; if ($_ =~ m/^$/) { next; } push (@numbers, $_); } @result = buildRange(\@numbers); foreach my $n (@result) { print "=> $n\n"; } } # Cette fonction lit les paramètres du test depuis la ligne de commande. # Ex: perl ts.pm 0147300614 sub TESTexplodeRange { my $plage = $ARGV[0]; my @res = (); if ($plage =~ m/^0/) { print STDERR "Le format de la plage doit correspondre aux spécifications du TS!\n"; print STDERR "Il ne faut pas mettre de caractère 0 au début de la plage.\n"; exit 1; } @res = explodeRange($plage); dumpNumbers(\@res); } 1;

Le texte ci-dessous illustre la procédure à suivre pour envoyer un fichier en pièce jointe par SMTP.

Connectez-vous au serveur SMTP et entrez les commandes suivantes :

telnet smtp.tiscali.fr 25
Trying 213.36.80.74...
Connected to mail-tiscali.libertysurf.net.
Escape character is '^]'.
220 mail.libertysurf.net ESMTP Service (6.5.026) ready
EHLO fr.tiscali.com
250-mail.libertysurf.net
250-DSN
250-8BITMIME
250-PIPELINING
250-HELP
250-AUTH
250-DELIVERBY 300
250 SIZE 5120000
MAIL FROM:<denis.beurive@fr.tiscali.com>
250 MAIL FROM:<denis.beurive@fr.tiscali.com> OK
RCPT TO:<denis_beurive@yahoo.com>
250 RCPT TO:<denis_beurive@yahoo.com> OK
DATA
354 Start mail input; end with <CRLF>.<CRLF>

Ensuite, envoyer la «partie de donnée» (data part). Le fichier à envoyer est encodé en base 64. Le nom du fichier envoyé est "to_send".

• Le texte en noir représentent l'entête de la "partie de donnée".
• Le texte en bleu représente le corps du fichier.

Message-ID: <3F3377BA.9A669F60@yahoo.com>
Date: Fri, 08 Aug 2003 12:13:14 +0200
From: Tiscali user <denis.beurive@fr.tiscali.com>
Reply-To: denis_beurive@yahoo.com
To: denis_beurive@yahoo.com
Subject: attached file
Content-Type: multipart/mixed; boundary="====1060343816====";


--====1060343816====
Content-Type: text/plain; charset="iso-8859-1"
Content-Transfer-Encoding: quoted-printable

This is the attached file
--====1060343816====
Content-Type: application/octet-stream; name="to_send"
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="to_send"

dXNlIGxpYiAiL2V4cG9ydC9jb21tb24tcGVybC1saWIvbXlfcGFja2FnZXMvIjsKdXNlIHN0cmlj
dDsKdXNlIGZpbGVyOwoKCm15ICRyYzsKbXkgJGVycjsKbXkgJGhvc3Q7Cm15ICRwb3J0OwpteSAk
bG9naW47Cm15ICRwYXNzOwpteSAkcGF0aDsKbXkgJG5hbWU7Cm15ICRjaGVja19wZXJpb2Q7Cm15
ICR2YWxpZF9hZ2U7Cm15ICRtYXhfcmVjb25uZWN0OwpteSAkd2FpdF9yZWNvbm5lY3Q7CgojIC0t
LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLQojIENoZWNr
IGNvbW1hbmQgbGluZQojIC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0t
LS0tLS0tLS0tLQoKaWYgKGludCBAQVJHViAhPSAxMCkKewogIHByaW50ICJVc2FnZTogcGVybCBm
dHAucGwgPGhvc3Q+IDxwb3J0PiA8bG9naW4+IDxwYXNzd29yZD4gPGZpbGUgcGF0aD4gPGZpbGUg
bmFtZT4gIiAuCiAgICAgICAgIjxjaGVjayBwZXJpb2Q+IDx2YWxpZCBhZ2U+IDxtYXggcmVjb25u
ZWN0PiA8d2FpdCByZWNvbm5lY3Q+XG5cbiI7CiAgZXhpdCAxOwp9CgokaG9zdCAgICAgICAgICAg
PSAkQVJHVlswXTsKJHBvcnQgICAgICAgICAgID0gJEFSR1ZbMV07CiRsb2dpbiAgICAgICAgICA9
ICRBUkdWWzJdOwokcGFzcyAgICAgICAgICAgPSAkQVJHVlszXTsKJHBhdGggICAgICAgICAgID0g
JEFSR1ZbNF07CiRuYW1lICAgICAgICAgICA9ICRBUkdWWzVdOwokY2hlY2tfcGVyaW9kICAgPSAk
QVJHVls2XTsKJHZhbGlkX2FnZSAgICAgID0gJEFSR1ZbN107CiRtYXhfcmVjb25uZWN0ICA9ICRB
UkdWWzhdOwokd2FpdF9yZWNvbm5lY3QgPSAkQVJHVls5XTsKCiMgLS0tLS0tLS0tLS0tLS0tLS0t
LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tCiMgV2FpdCBmb3IgdGhlIGZpbGUgdG8g
YmVjb21lIGF2YWlsYWJsZQojIC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0t
LS0tLS0tLS0tLS0tLQoKJHJjID0gd2FpdF9mb3JfZmlsZV9mdHAgKAogICAgICAgICAgICAgICAg
ICAgICAgICAgICRob3N0LAogICAgICAgICAgICAgICAgICAgICAgICAgICRwb3J0LAogICAgICAg
ICAgICAgICAgICAgICAgICAgICRsb2dpbiwKICAgICAgICAgICAgICAgICAgICAgICAgICAkcGFz
cywgCiAgICAgICAgICAgICAgICAgICAgICAgICAgJHBhdGgsCiAgICAgICAgICAgICAgICAgICAg
ICAgICAgJG5hbWUsCiAgICAgICAgICAgICAgICAgICAgICAgICAgJGNoZWNrX3BlcmlvZCwKICAg
ICAgICAgICAgICAgICAgICAgICAgICAkdmFsaWRfYWdlLAogICAgICAgICAgICAgICAgICAgICAg
ICAgICRtYXhfcmVjb25uZWN0LAogICAgICAgICAgICAgICAgICAgICAgICAgICR3YWl0X3JlY29u
bmVjdCwKICAgICAgICAgICAgICAgICAgICAgICAgICBcJGVyciwgCiAgICAgICAgICAgICAgICAg
ICAgICAgICAgMQogICAgICAgICAgICAgICAgICAgICAgICApOwoKaWYgKCRyYyA9PSAtMSkKewog
IHByaW50ICJFcnJvciB3aGlsZSB3YWl0aW5nIGZvciBmaWxlICckcGF0aCcgLT4gJyRuYW1lJyB0
byBiZSBhdmFpbGFibGU6ICRlcnJcblxuIjsKICBleGl0IDE7Cn0KCnByaW50ICJGaWxlICckcGF0
aCcgLT4gJyRuYW1lJyBpcyBhdmFpbGFibGVcblxuIjsKCgoKZXhpdCAwOwo=

--====1060343816====--

Enfin, envoyer la séquence suivante : .

Le script ci-dessous génère le texte qui correspond au contenu di fichier envoyé (partie en bleu, dans l’exemple précédent).

use strict; use MIME::Base64; use MIME::QuotedPrint; my $file; my $boundary; my $message; my $mail_from; my $mail_to; my $mail_subject; my $mail_body; my $content_type; $file = "to_send"; $boundary = "====" . time() . "===="; $message = encode_qp( "This is the attached file" ); $mail_from = 'denis_beurive@yahoo.com'; $mail_to = 'denis_beurive@yahoo.com'; $mail_subject = 'test attached file'; $content_type = "multipart/mixed; boundary=\"$boundary\""; unless (open (ATTACHEMENT, "<$file")) { print STDERR "[FATAL] Can not open attachement file '$file' - $!\n"; exit 1; } binmode ATTACHEMENT; undef $/; $mail_body = encode_base64(<ATTACHEMENT>); close ATTACHEMENT; $boundary = '--'.$boundary; $mail_body = <<END_OF_BODY; $boundary Content-Type: text/plain; charset="iso-8859-1" Content-Transfer-Encoding: quoted-printable $message $boundary Content-Type: application/octet-stream; name="$file" Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename="$file" $mail_body $boundary-- END_OF_BODY print "To send as mail body:\n\n"; print "[" . $mail_body . "]"; print "\n\n";

Par défaut, Perl détecte la chaîne la plus longue qui vérifie l’expression régulière. Ce comportement est appelé «greedy match».

use strict; my $string = "__TOTO__TITI__TATA__"; my $delimitor = "__"; my $match; if ($string =~ m/(${delimitor}[_a-zA-Z0-9]+${delimitor})/) { $match = $1; print STDOUT "Greedy match = [$match]\n"; } if ($string =~ m/(${delimitor}[_a-zA-Z0-9]+?${delimitor})/) { $match = $1; print STDOUT "Ungreedy match = [$match]\n"; }

use strict; my $string; my $res1; my $res2; my $res3; my $res4; my $res5; if (int @ARGV != 1) { print "Usage: perl test.pl <string>\n"; exit 1; } $string = $ARGV[0]; $res1 = $string; $res2 = $string; $res3 = $string; $res4 = $string; $res5 = $string; $res1 =~ s/(.)\1/$1/g; print 's/(.)\1/$1/g ' . " => $res1\n\n"; $res2 =~ s/(.)\1\1/$1/g; print 's/(.)\1\1/$1/g ' . " => $res2\n\n"; $res3 =~ s/(.)\1+/$1/g; print 's/(.)\1+/$1/g ' . " => $res3\n\n"; $res4 =~ s/(.)\1([ABC])\2/$1$2/g; print 's/(.)\1([ABC])\2/$1$2/g ' . " => $res4\n\n"; $res5 =~ s/(.)\1+([ABC])\2+/$1$2/g; print 's/(.)\1+([ABC])\2+/$1$2/g ' . " => $res4\n\n"; exit 0;

use strict; ## the expression '\1' represents the first pattern (between '(' ')'). ## the expression '\2' represents the second pattern (between '(' ')'). ## ... ## '\1' means: the first pattern 1 times (not 3 times) ## '\1{1}' means: the first pattern 2 times (not 1 times) ## '\1{2}' means: the first pattern 3 times (not 2 times) ## '\1{3}' means: the first pattern 4 times (not 3 times) my $tel = $ARGV[0]; my $type = 'unknown'; while (1) { #### #### derniers chiffres egaux (0xxxxx1111) #### if ($tel =~ m/^0[0-9]{5}([0-9])\1{3}$/) { $type = '0xxxxx1111'; last; } #### #### Double quadruplette (xx10241024) #### if ($tel =~ m/^[0-9]{2}([0-9]{4})\1{1}$/) { $type = 'xx10241024'; last; } #### #### 2 centaines en fin de numéro (xxxx100200) #### if ($tel =~ m/^[0-9]{4}[1-9]00[1-9]00$/) { $type = 'xxxx100200'; last; } #### #### 2 paires (xxxxxx1212) #### if ($tel =~ m/^[0-9]{6}([0-9]{2})\1{1}$/) { $type = 'xxxxxx1212'; last; } #### #### Double triplette finale (xxxx720720) #### if ($tel =~ m/^[0-9]{4}([0-9]{3})\1{1}$/) { $type = 'xxxx720720'; last; } #### #### 3 derniers chiffres égaux (xxxxxxx111) #### if ($tel =~ m/^[0-9]{7}([1-9])\1{2}$/) { $type = 'xxxxxxx111'; last; } #### #### 2 doubles (xxxxxx1122) #### if ($tel =~ m/^[0-9]{6}([0-9])\1{1}([0-9])\2{1}$/) { $type = 'xxxxxx1122'; last; } #### #### Les 4 remiers chiffres sont égaux aux 4 derniers (0154xx0154) #### if ($tel =~ m/^([0-9]{4})[0-9]{2}\1$/) { $type = '0154xx0154'; last; } #### #### Les années 2000 (xxxxx2002) #### if ($tel =~ m/^0[0-9]{5}200[0-9]{1}$/) { $type = '0xxxxx2002'; last; } #### #### 3 derniers chiffres égal a zéro (0xxxxx9000) #### if ($tel =~ m/^0[0-9]{5}[1-9]000$/) { $type = '0xxxxx9000'; last; } #### #### Les années 1995 à 1999 (0xxxxx1995) #### if ($tel =~ m/^0[0-9]{5}199[5-9]{1}$/) { $type = '0xxxxx1995'; last; } last; } print "Type = $tel est de type <$type>\n";

use strict; my $text = 'Before the match "cat" and after the match. Before the match "dog" and after.'; print 'm/"cat"/:' . "\n"; if ($text =~ m/"cat"/) { print "\t\$` = [$`]\n"; print "\t\$& = [$&]\n"; print "\t\$' = [$']\n"; } print "\n\n"; print 'm/("cat").*("dog")/:' . "\n"; if ($text =~ m/("cat").*("dog")/) { print "\t\$` = [$`]\n"; print "\t\$& = [$&]\n"; print "\t\$' = [$']\n"; print "\tStart of \$& = " . $-[0] . "\n"; print "\tEnd of \$& = " . $+[0] . "\n"; print "\n"; print "\t\$1 = [$1]\n"; print "\tStart of \$2 = " . $-[1] . "\n"; print "\tEnd of \$2 = " . $+[1] . "\n"; print "\n"; print "\t\$2 = [$2]\n"; print "\tStart of \$2 = " . $-[2] . "\n"; print "\tEnd of \$2 = " . $+[2] . "\n"; } print "\n\n";

use strict; use POSIX qw(:signal_h); use IO::Handle; STDOUT->autoflush(1); my $STOP = 0; my $SIGNAL = 'no signal'; my $sigset; my $old_sigset; # ------------------------------------------------------- # Signal handler executed when a signal is received # ------------------------------------------------------- sub signal_handler { my ($sig) = @_; $STOP = 1; $SIGNAL = "Received signal $sig"; } # ------------------------------------------------------- # Bind signal hadler to signals # ------------------------------------------------------- $SIG{'INT'} = 'signal_handler'; $SIG{'TERM'} = 'signal_handler'; $SIG{'HUP'} = 'signal_handler'; # ------------------------------------------------------- # Sleep 5 seconds # ------------------------------------------------------- print STDOUT "\n\n"; print STDOUT "=&dt; You have 5 seconds to press [CTRL]-[C] (signals activated)\n\n"; sleep 5; # ------------------------------------------------------- # Block signals and restore signals, so we can look at # variable STOP # ------------------------------------------------------- $sigset = POSIX::SigSet-&dt;new(SIGINT, SIGHUP, SIGTERM); $old_sigset = POSIX::SigSet-&dt;new; unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset)) { die "Could not block signal"; } print STDOUT "Signals blocked\n"; print STDOUT "\tmain(): STOP = $STOP\n"; $STOP = 0; $SIGNAL = 'no signal'; print STDOUT "\nUnblock signals now\n\n"; unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) { die "Could not unblock signal"; } # ------------------------------------------------------- # Block signals and wait 5 seconds # ------------------------------------------------------- $sigset = POSIX::SigSet-&dt;new(SIGINT, SIGHUP, SIGTERM); $old_sigset = POSIX::SigSet-&dt;new; unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset)) { die "Could not block signal"; } print STDOUT "Signals blocked\n"; print STDOUT "\t=&dt; You have 5 seconds to press [CTRL]-[C] (signals ignored)\n"; sleep 5; print STDOUT "Unblock signals now\n\n"; unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) { die "Could not unblock signal"; } # ------------------------------------------------------- # Block signals and restore signals, so we can look at # variable STOP # ------------------------------------------------------- $sigset = POSIX::SigSet-&dt;new(SIGINT, SIGHUP, SIGTERM); $old_sigset = POSIX::SigSet-&dt;new; unless (defined sigprocmask(SIG_BLOCK, $sigset, $old_sigset)) { die "Could not block signal"; } print STDOUT "Signals blocked\n"; print STDOUT "\tmain(): STOP = $STOP\n"; $STOP = 0; $SIGNAL = 'no signal'; print STDOUT "Unblock signals now\n"; unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) { die "Could not unblock signal"; } print STDOUT "\n\n";

#!/usr/bin/perl # DESCRIPTION # # Ce script permet d'effectuer de renommer des fichiers "en masse". # La recherche des fichiers à renommer est effectuér à travers toute l'arborescence à partir du répertoire courant. # # USAGE # # renamer.pm [--simul] # # NOTE # # Pour définir les masques des noms de fichiers à renommer, veuillez éditer la variable suivante: @PATTERNS # Par exemple: my @PATTERNS = ('_([A-Z]{2})([0-9]{2})\.pm$', '_([A-Z]{2})([0-9]{2})\.html$', '_([A-Z]{2})([0-9]{2})\.js$'); # # Pour définir les nouveaux noms des fichiers, veuillez éditer la fonction transform(). use strict; use File::Find; use File::Basename; use Getopt::Long; use Cwd; # ---------------------------------------------------------------- # Configuration # ---------------------------------------------------------------- my @PATTERNS = ('_([A-Z]{2})([0-9]{2})\.pm$', '_([A-Z]{2})([0-9]{2})\.html$', '_([A-Z]{2})([0-9]{2})\.js$'); # ---------------------------------------------------------------- # Variables # ---------------------------------------------------------------- my @files = (); my $base = getcwd; my $verbose = 0; my %result = (); my $simul = undef; my %options = { 'simul' => \$simul }; unless (GetOptions(%options)) { print STDERR "Error while parsing the command line.\n"; exit 1; } # ---------------------------------------------------------------- # Get the list of files # ---------------------------------------------------------------- print "Searching in \"$base\".\n"; find(\&wanted, ($base)); # ---------------------------------------------------------------- # Look for the given patterns # ---------------------------------------------------------------- foreach my $fullname (@files) { my $basename = basename($fullname); my $path = dirname($fullname); print "Looking for $fullname\n"; foreach my $pattern (@PATTERNS) { if ($basename =~ m/$pattern/) { my $new_name = transform($basename); my $new_path = "${path}/${new_name}"; print " - Renaming $fullname\n"; print " $new_path.\n"; unless(defined($simul)) { unless (rename $fullname, $new_path) { die("Can not rename $fullname into $new_path: $!\n"); } } } } } exit 0; # ---------------------------------------------------------------- # Fonctions # ---------------------------------------------------------------- sub wanted { my $basename = $_; my $full_path = $File::Find::name; foreach my $p (@PATTERNS) { if ($basename =~ m/${p}/) { push(@files, $full_path); last; } } } sub transform { my ($in_name) = @_; $in_name =~ s/_([A-Z]{2})([0-9]{2})\.(.+)*$/_${1}0${2}.${3}/; return $in_name; }

use File::Basename; use Cwd; my $full_path_to_the_current_file = Cwd::realpath(__FILE__); my $full_path_to_the_current_file_directory = dirname(Cwd::realpath(__FILE__)); print "Absolute path to the current file: $full_path_to_the_current_file\n"; print "Absolute path to the current directory: $full_path_to_the_current_file_directory\n"; print "Script being executed: " . Cwd::realpath($0) . "\n"; # Is the file being executed is the current one ? if (Cwd::realpath($0) eq Cwd::realpath(__FILE__)) { # The current file is the one being executed. }

ls -l projet/symlink.pl 
lrwxr-xr-x  1 denisbeurive  staff  12  8 nov 12:46 projet/symlink.pl -> test/test.pl	

use File::Basename; use Cwd; print "Absolute path to the symbolink link directory: " . Cwd::realpath(dirname($0)) . "\n"; print "Absolute path to the symbolink link: " . Cwd::realpath(dirname($0)) . '/' . basename($0) . "\n"; print "Absolute path to the symbolink link target: " . Cwd::realpath(__FILE__) . "\n";

Résultat :

Absolute path to the symbolink link directory: /Users/denisbeurive/Desktop/projet Absolute path to the symbolink link: /Users/denisbeurive/Desktop/projet/symlink.pl Absolute path to the symbolink link target: /Users/denisbeurive/Desktop/projet/test/test.pl

---

---

---

---

---