IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Langage Perl Discussion :

Scripts ou codes gratuits et disponibles pour tous en Perl [Sources]


Sujet :

Langage Perl

  1. #21
    Membre actif
    Inscrit en
    Février 2005
    Messages
    167
    Détails du profil
    Informations forums :
    Inscription : Février 2005
    Messages : 167
    Points : 203
    Points
    203
    Par défaut Comment compter le nombre d'occurrences dans une chaîne ?
    Si on sait avant de la lancer le programme, on peut le coder en dur et utiliser l'opérateur tr/// de transliteration, qui est simple et très efficace :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
     
    my $nr_a = ($str =~ tr/a/a/);
    Comment ça marche ? tr/// remplace un caractère par un autre (on peut aussi faire tr/aeiou/uieao/ pour changer plusieurs différents caractères). Donc on va se contenter de remplacer le caractère qu'on cherche 'a', par la même chose (pour ne pas bousiller la chaîne). Ensuite, à la fin de l'opération, tr// renvoie le nombre de transliterations qu'il a fait. Et voila comment on compte les caractères.

    Par contre, si on ne sait pas quelle caractère on veut compter au départ, on ne pas le stocker dans une variable :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    $car = 'x';
    my $nr_a = ($str =~ tr/$car/$car/); # ne marche pas
    L'explication est que tr ne fait pas de l'interpolation des chaînes. Surtout, ne soyez pas tenté de faire eval "\$str =~ tr/$car/$car/" (je ne mets pas les balises code pour ne pas attirer l'attention dessus...) C'est trop dangereux.

    Aussi, tr ne marchera pas si ce qu'on veut compter est plus long qu'un caractère. Pour s'en sortir, on utilise un match en contexte de liste:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    my $ch = 'n';
    my $nr = () = ($str =~ m/$ch/g);
    Comment ça marche ? Quand on ajoute /g à un match, cela indique au moteur de regexps de repartir faire la recherche là où ça a terminé la dernière fois (au lieu de commencer au début de la chaine). On le voit plus souvent comme ceci :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
     
    while( $_ =~ /truc/g ) {
        print "encore un truc\n";
    }
    Mais rien n'empeche de choper toutes les matches d'un seul coup, et les stocker dans un array :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
     
    my @truc = ($_ =~ /truc/g); # tous les trucs
    Ensuite, ce qu'il faut savoir, c'est que lorsqu'on on essaie d'interpreter un array en contexte scalaire, cela renvoie le nombre d'éléments de l'array (ce qui est fort, fort utile à bien des égards, et la raison principale qui explique l'absence d'un operateur du style my $nbre = length(@array), c'est tout bêtement trop simple à faire une fois qu'on a compris comment jouer avec le contexte). Par exemple :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    my $nr = @ARGV;
    print "lancé avec $nr arguments\n";
    Revenons à notre m/$ch/g. En fait, on se fiche un peu de stocker les éléments matché dans la chaîne, on veut juste leur nombre. Donc, on les capture mais on ne les garde pas avec () et on force le contexte scalaire derrière pour obtenir le fameux nombre. L'autre chose à retenir est qu'avec cette approche, rien ne limite $ch à un caractère : on peut mettre ce qu'on veut.
      0  0

  2. #22
    Membre expert
    Avatar de 2Eurocents
    Profil pro
    Inscrit en
    Septembre 2004
    Messages
    2 177
    Détails du profil
    Informations personnelles :
    Âge : 54
    Localisation : France

    Informations forums :
    Inscription : Septembre 2004
    Messages : 2 177
    Points : 3 166
    Points
    3 166
    Par défaut Formatage de nombres
    Suite au sujet "espace dans un nombre pour une meilleure lisibilité", je rajoute ce petit bout de code de formatage d'un nombre.

    C'est un peu plus complet que ce qui est dans le sujet ...

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    my $separateur=" ";
    my $groupage=3;
    my $point_decimal=",";
     
    my ($p_entiere, $p_decimale)=split (/\./, $nombre);
    1 while ($p_entiere =~ s/(\d)(\d{$groupage}($|$separateur))/$1$separateur$2/);
    1 while ($p_decimale =~ s/(\d{$groupage})(\d)/$1$separateur$2/);
    $nombre = join ($point_decimal, $p_entiere, $p_decimale);
    Il vous suffit donc de mettre la valeur à formater dans $nombre.

    La valeur peut être positive ou négative. Elle doit être exprimée sous en notation décimale (la notation scientifique n'est pas supportée).

    Elle peut être conditionnée au préalable pour ne conserver qu'une partie des décimales :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    $nombre = sprintf ("%0.2f", $nombre);
    Le scalaire $separateur indique le caractère qui sera utilisé pour séparer les groupes de chiffres.

    Le scalaire $groupage indique le nombre de chiffres par groupe.

    Le scalaire $point_decimal indique le caractère utilisé pour représenter la virgule.

    Avec les valeurs ci dessus, "-15648.15657" sera formatté en "-15 648,156 57" par exemple

    Libre à vous d'en faire une fonction ou autre ...
    La FAQ Perl est par ici
    : La fonction "Rechercher", on aurait dû la nommer "Retrouver" - essayez et vous verrez pourquoi !
      0  0

  3. #23
    Futur Membre du Club
    Profil pro
    Inscrit en
    Octobre 2004
    Messages
    10
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Octobre 2004
    Messages : 10
    Points : 6
    Points
    6
    Par défaut
    voicic un script qui permet de connaitre le nombre de lignes d un fichier texte
    ainsi que le nombre de caractere par lignes
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
     
    #! C:\Perl\bin\perl -w
     
    print " entrez le nom du fichier a evaluez ( marque l extention ) ? \n " ;
    chomp &#40; $fichierabo = <stdin> &#41; ;
    open &#40; FICHIER , $fichierabo &#41; ;
    chomp &#40; @fichier = <FICHIER> &#41; ;
    close &#40; FICHIER &#41; ;
     
    $nbligne = $#fichier + 1 ;
    print " ce fichier comporte $nbligne \n" ;
     
    $ligne = 1 ;
    foreach &#40; @fichier &#41;
    &#123;
        @travail = split&#40; // , $_ &#41; ;
        $caractere = $#travail + 1 ;
        print " la ligne $ligne comporte $caractere \n" ;
        @travail = &#40;&#41; ;
        $ligne += 1 ;
    &#125;
      0  0

  4. #24
    Expert éminent
    Avatar de Jedai
    Homme Profil pro
    Enseignant
    Inscrit en
    Avril 2003
    Messages
    6 245
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Côte d'Or (Bourgogne)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : Avril 2003
    Messages : 6 245
    Points : 8 586
    Points
    8 586
    Par défaut
    S'il s'agit seulement de compter le nombre de lignes, il est préférable de slurper le fichier puis d'utiliser l'opérateur tr// pour compter le nombre de fin de ligne, c'est plus rapide parce que perl n'a pas besoin d'effectuer le découpage. On peut même utiliser sysread pour aller encore plus vite ou pour fragmenter la tâche sur de très gros fichier.
    Bien sûr tout ceci n'est valable que si l'on a vraiment besoin de faire ça très souvent... Et qu'on a pas besoin de faire d'opération qui exige de découper le fichier en lignes.

    --
    Jedaï
      0  0

  5. #25
    Expert confirmé
    Avatar de GLDavid
    Homme Profil pro
    Service Delivery Manager
    Inscrit en
    Janvier 2003
    Messages
    2 851
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France, Seine Saint Denis (Île de France)

    Informations professionnelles :
    Activité : Service Delivery Manager
    Secteur : Industrie Pharmaceutique

    Informations forums :
    Inscription : Janvier 2003
    Messages : 2 851
    Points : 4 743
    Points
    4 743
    Par défaut
    Et voici un script plus complet par rapport à mon précédent qui fait iso-8859-1 <-> utf-8 :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
     
    #!/usr/bin/perl -w
     
    use strict;
    use Locale&#58;&#58;Recode;
     
    sub to_iso &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while&#40;<FICHIER>&#41;&#123;
    		my&#40;$cd&#41; = Locale&#58;&#58;Recode->new&#40;from => 'UTF-8',
    		to=>'ISO-8859-1'&#41;;
    		die $cd->getError if $cd->getError;
    		$cd->recode&#40;$_&#41; or die $cd->getError;
    		print FICHIER_DEST;			
    	&#125;
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename&#40;$file_dest, $file&#41; and unlink $file_dest;
    &#125;
     
    sub to_utf &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while&#40;<FICHIER>&#41;&#123;
    		my&#40;$cd&#41; = Locale&#58;&#58;Recode->new&#40;from => 'ISO-8859-1',
    		to=>'UTF-8'&#41;;
    		die $cd->getError if $cd->getError;
    		$cd->recode&#40;$_&#41; or die $cd->getError;
    		print FICHIER_DEST;			
    	&#125;
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename&#40;$file_dest, $file&#41; and unlink $file_dest;
    &#125;
     
    sub recode_file &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	my&#40;$encode&#41; = $_&#91;1&#93;;
    	if&#40;$encode eq "1"&#41;&#123;
    		&to_iso&#40;$file, $file_dest&#41;;
    	&#125;
    	else &#123;
    		&to_utf&#40;$file, $file_dest&#41;;
    	&#125;
    &#125;
     
    sub recode_repertory &#123;
    	my&#40;$repertory&#41; = $_&#91;0&#93;;
    	my&#40;$pos&#41; = rindex&#40;$repertory, '/'&#41;;
    	if&#40;$pos != &#40;length&#40;$repertory&#41;-1&#41;&#41;&#123;
    		$repertory .= '/';
    	&#125;
    	my&#40;$encode&#41; = $_&#91;1&#93;;
    	chdir $repertory;
    	my&#40;@files&#41; = `ls`;
    	my&#40;$file&#41;;
    	foreach $file &#40;@files&#41;&#123;
    		$file = $repertory.$file;
    		chomp $file;
    		if&#40; -f $file&#41;&#123;
    			&recode_file&#40;$file, $encode&#41;;
    		&#125;
    		elsif &#40; -d $file&#41;&#123;
    			&recode_repertory&#40;$file, $encode&#41;;
    		&#125;
    	&#125;
    &#125;
     
     
    ###################MAIN######################
     
     
    if &#40;$#ARGV > -1&#41;&#123;
    	chomp $ARGV&#91;0&#93; and chomp $ARGV&#91;1&#93;;
    	if &#40;$ARGV&#91;0&#93; =~ /&#91;A-Za-z&#93;+/&#41;&#123;
    		print "recode prend 2 arguments.\n";
    		print "Le premier argument doit être un nombre &#58;\n";
    		print "1 &#58; UTF-8 => ISO-8859-1\n";
    		print "2 &#58; ISO-8859-1 => UTF-8\n";
    		print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    		exit 0;
    	&#125;
    	if &#40;$ARGV&#91;0&#93; > 2 or $ARGV&#91;0&#93; < 1&#41;&#123;
    		print "Le premier argument doit être un nombre valide &#58;\n";
    		print "1 &#58; UTF-8 => ISO-8859-1\n";
    		print "2 &#58; ISO-8859-1 => UTF-8\n";
    		exit 0;
    	&#125;
    	if &#40; -f $ARGV&#91;1&#93;&#41;&#123;
    		&recode_file&#40;$ARGV&#91;1&#93;, $ARGV&#91;0&#93;&#41;;	
    	&#125;
    	elsif &#40; -d $ARGV&#91;1&#93;&#41;&#123;
    		&recode_repertory&#40;$ARGV&#91;1&#93;, $ARGV&#91;0&#93;&#41;;
    	&#125;
    &#125; 
    elsif &#40;$#ARGV > 1&#41; &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    elsif &#40;$#ARGV == 0&#41; &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    else &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    @++
    GLDavid
    Consultez la FAQ Perl ainsi que mes cours de Perl.
    N'oubliez pas les balises code ni le tag

    Je ne répond à aucune question technique par MP.
      0  0

  6. #26
    Expert éminent
    Avatar de Jedai
    Homme Profil pro
    Enseignant
    Inscrit en
    Avril 2003
    Messages
    6 245
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Côte d'Or (Bourgogne)

    Informations professionnelles :
    Activité : Enseignant

    Informations forums :
    Inscription : Avril 2003
    Messages : 6 245
    Points : 8 586
    Points
    8 586
    Par défaut
    Avec encodage de départ et d'arrivée paramétrables :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
     
    #! /usr/bin/perl
    use strict;
    use warnings;
     
     
    ## Initialisations
     
    use Encode;
    use Getopt&#58;&#58;Long;
    use Pod&#58;&#58;Usage;
    $| = 1; # Autoflush on
     
    sub from_to_file &#40;$&#41;;
    sub recode_dir &#40;$&#41;;
     
    Getopt&#58;&#58;Long&#58;&#58;Configure &#40;"bundling", "ignore_case"&#41;;
    my &#40;$verbose, $recursive, $all_files, $backup, $force, $from,        $to&#41; = 
       &#40;0,        0,          0,          2,       0,      "ISO-8859-1", "UTF-8"&#41;;
     
    GetOptions&#40; "verbose|v" => \$verbose, "recursive|r" => \$recursive, 
      "backup|b!" => \$backup, "all-files|a" => \$all_files, 
      "force|F" => \$force, "from|f=s" => \$from, "to|t=s" => \$to &#41;
        or pod2usage&#40;-exitval => 2, -verbose => 1&#41;;;
    unless&#40; @ARGV &#41; &#123; pod2usage&#40;-exitval => 2, -verbose => 1&#41; &#125;
     
    if&#40; $backup == 2 &#41; &#123;
      print "Do you want to backup your files ?&#40;Y/n&#41; ";
      if&#40; <STDIN> =~ /^no?\s*/i &#41;&#123;
        $backup = 0;
      &#125;
    &#125;
     
     
    ## Main
     
    foreach my $file &#40; @ARGV &#41;&#123;
      if&#40; -f $file &#41;&#123;
        from_to_file&#40; $file &#41;;
      &#125; elsif&#40; -d $file &#41; &#123;
        recode_dir&#40; $file &#41;;
      &#125;
    &#125;
     
     
    ## Fonctions
     
    sub from_to_file &#40;$&#41; &#123;
      my $file  = shift ;
      my $file_dest = $file.".new";
      my &#40;$in, $out&#41;;
      while&#40; -e $file_dest &#41; &#123; $file_dest .= ".new" &#125;
     
      open $in, "<&#58;bytes", $file or die "$!\n";
      open $out, ">&#58;bytes", $file_dest or die "$!\n";
     
      print "Encode $file from $from to $to.\n" if $verbose;
      while&#40;<$in>&#41;&#123; 
        if &#40; $force &#41; &#123;
     
          unless&#40; defined Encode&#58;&#58;from_to&#40; $_, $from, $to, Encode&#58;&#58;FB_PERLQQ &#41; &#41; &#123;
            print "Error while encoding $file, are you sure that this file ",
              "is encoded in $from ?\n";
          &#125;
     
        &#125; else &#123;
     
          eval &#123; Encode&#58;&#58;from_to&#40; $_, $from, $to, 1 &#41; &#125;;
          if&#40; $@ &#41;&#123;
            print "Error while encoding $file, are you sure that this file ",
              "is encoded in $from ?\nEncoding of $file aborted !\n";
            unlink $file_dest;
          &#125;
     
        &#125;
        print &#123;$out&#125; $_;
      &#125;
     
      # backup if asked for
      if&#40; $backup &#41;&#123;
        my $file_bak = $file.".bak";
        while&#40; -e $file_bak &#41; &#123; $file_bak .= ".bak" &#125;
        rename&#40; $file, $file_bak &#41;;
      &#125;
     
      close $in and close $out;
      rename&#40;$file_dest, $file&#41;;
    &#125;
     
    sub recode_dir &#40;$&#41; &#123;
      my $dir = shift ;
      $dir .= "/" unless $dir =~ m</$>;
     
      opendir RECDIR, $dir or die "$!\n";
      my $file;
      while&#40; defined &#40; $file = readdir RECDIR &#41; &#41; &#123;
        unless&#40; $file =~ /^\.&#123;1,2&#125;$/ &#41; &#123;
          if&#40; -d $dir.$file and $recursive &#41; &#123;
            recode_dir&#40; $dir.$file &#41;;
          &#125; elsif &#40;-f $dir.$file and &#40;$file !~ /^\./ or $all_files&#41; &#41;&#123;
            from_to_file&#40; $dir.$file &#41;;
          &#125;
        &#125;
      &#125;
    &#125;
     
    __END__
     
    =head1 NAME
     
    Recode.pl
     
    =head1 SYNOPSIS
     
    Recode.pl &#91;options&#93; &#91;file|directory ...&#93;
     
     Options&#58;
      -v or --verbose     Set the verbosity level of this program
      -f or --from        Encoding of the input files &#40;default &#58; ISO-8859-1&#41;
      -t or --to          Target encoding &#40;default &#58; UTF-8&#41;
      -r or --recursive   Process directories recursively
      -a or --all-files   Process hidden files too
      -b or --backup      Backup the files to *.bak
      --nob or --nobackup To avoid the backup of the files
      -F or --force       The program try to convert all parts of a file
                            that seems to have the good encoding
     
    B<This program> will read the given input file&#40;s&#41; and/or directory&#40;ies&#41;
    and encode them with the encoding specified by --to. Be careful since 
    this program does B<not> check if the content of a file is really text !
     
    =cut
    Par exemple :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    ./Recode.pl --from koi8-u --backup --recursive /MonRepertoireAvecLesFichiersEnKoi8-u
    ./Recode.pl -f koi8-u -rb /MonRepertoireAvecLesFichiersEnKoi8-u
    TIMTOWDI

    [ EDIT :
    #1 Quelques corrections pour rendre le script plus robuste et plus fiable, les effets de ce script sont maintenant toujours inversibles car il annule le réencodage en cas de problème
    #2 Introduction d'une option "--force" pour obliger le script à réencoder même lorsque des problèmes se présentent ]
    --
    Jedaï
      0  0

  7. #27
    Nouveau Candidat au Club
    Profil pro
    Inscrit en
    Décembre 2005
    Messages
    1
    Détails du profil
    Informations personnelles :
    Localisation : Suisse

    Informations forums :
    Inscription : Décembre 2005
    Messages : 1
    Points : 1
    Points
    1
    Par défaut Conversion iso-8859-1 <-> utf-8 sous windows XP
    Citation Envoyé par GLDavid
    Et voici un script plus complet par rapport à mon précédent qui fait iso-8859-1 <-> utf-8 :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
     
    #!/usr/bin/perl -w
     
    use strict;
    use Locale&#58;&#58;Recode;
     
    sub to_iso &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while&#40;<FICHIER>&#41;&#123;
    		my&#40;$cd&#41; = Locale&#58;&#58;Recode->new&#40;from => 'UTF-8',
    		to=>'ISO-8859-1'&#41;;
    		die $cd->getError if $cd->getError;
    		$cd->recode&#40;$_&#41; or die $cd->getError;
    		print FICHIER_DEST;			
    	&#125;
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename&#40;$file_dest, $file&#41; and unlink $file_dest;
    &#125;
     
    sub to_utf &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while&#40;<FICHIER>&#41;&#123;
    		my&#40;$cd&#41; = Locale&#58;&#58;Recode->new&#40;from => 'ISO-8859-1',
    		to=>'UTF-8'&#41;;
    		die $cd->getError if $cd->getError;
    		$cd->recode&#40;$_&#41; or die $cd->getError;
    		print FICHIER_DEST;			
    	&#125;
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename&#40;$file_dest, $file&#41; and unlink $file_dest;
    &#125;
     
    sub recode_file &#123;
    	my&#40;$file&#41; = $_&#91;0&#93;;
    	my&#40;$file_dest&#41; = $file.".new";
    	my&#40;$encode&#41; = $_&#91;1&#93;;
    	if&#40;$encode eq "1"&#41;&#123;
    		&to_iso&#40;$file, $file_dest&#41;;
    	&#125;
    	else &#123;
    		&to_utf&#40;$file, $file_dest&#41;;
    	&#125;
    &#125;
     
    sub recode_repertory &#123;
    	my&#40;$repertory&#41; = $_&#91;0&#93;;
    	my&#40;$pos&#41; = rindex&#40;$repertory, '/'&#41;;
    	if&#40;$pos != &#40;length&#40;$repertory&#41;-1&#41;&#41;&#123;
    		$repertory .= '/';
    	&#125;
    	my&#40;$encode&#41; = $_&#91;1&#93;;
    	chdir $repertory;
    	my&#40;@files&#41; = `ls`;
    	my&#40;$file&#41;;
    	foreach $file &#40;@files&#41;&#123;
    		$file = $repertory.$file;
    		chomp $file;
    		if&#40; -f $file&#41;&#123;
    			&recode_file&#40;$file, $encode&#41;;
    		&#125;
    		elsif &#40; -d $file&#41;&#123;
    			&recode_repertory&#40;$file, $encode&#41;;
    		&#125;
    	&#125;
    &#125;
     
     
    ###################MAIN######################
     
     
    if &#40;$#ARGV > -1&#41;&#123;
    	chomp $ARGV&#91;0&#93; and chomp $ARGV&#91;1&#93;;
    	if &#40;$ARGV&#91;0&#93; =~ /&#91;A-Za-z&#93;+/&#41;&#123;
    		print "recode prend 2 arguments.\n";
    		print "Le premier argument doit être un nombre &#58;\n";
    		print "1 &#58; UTF-8 => ISO-8859-1\n";
    		print "2 &#58; ISO-8859-1 => UTF-8\n";
    		print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    		exit 0;
    	&#125;
    	if &#40;$ARGV&#91;0&#93; > 2 or $ARGV&#91;0&#93; < 1&#41;&#123;
    		print "Le premier argument doit être un nombre valide &#58;\n";
    		print "1 &#58; UTF-8 => ISO-8859-1\n";
    		print "2 &#58; ISO-8859-1 => UTF-8\n";
    		exit 0;
    	&#125;
    	if &#40; -f $ARGV&#91;1&#93;&#41;&#123;
    		&recode_file&#40;$ARGV&#91;1&#93;, $ARGV&#91;0&#93;&#41;;	
    	&#125;
    	elsif &#40; -d $ARGV&#91;1&#93;&#41;&#123;
    		&recode_repertory&#40;$ARGV&#91;1&#93;, $ARGV&#91;0&#93;&#41;;
    	&#125;
    &#125; 
    elsif &#40;$#ARGV > 1&#41; &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    elsif &#40;$#ARGV == 0&#41; &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    else &#123;
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre &#58;\n";
    	print "1 &#58; UTF-8 => ISO-8859-1\n";
    	print "2 &#58; ISO-8859-1 => UTF-8\n";
    	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
    	exit 0;
    &#125;
    @++

    Merci pour ces informations, mais je suis devant un problème un peu différent :

    Je travaille avec perl 5.8.7 et j'aimerais convertir un flux ISO-8859-1 en UTF-8 (et inversément) SANS passer par la création de fichiers, est-ce possible :
    Windows utilise pas défaut un flux UTF-16, est-il possible d'utilisé un autre format de flux ( ISO-8859-1,UTF-8...)? comment savoir le format du flux courant ? Y a-t-il des posibilité ? peux-tu m'aider ? Ou pis-je trouver l'information ou un exemple de code ?
    D'avance merci.
    A bientôt
    Gorry
      0  0

  8. #28
    Membre habitué Avatar de spirit_epock
    Profil pro
    Inscrit en
    Mars 2006
    Messages
    153
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Mars 2006
    Messages : 153
    Points : 173
    Points
    173
    Par défaut
    Voici un script pour envoyer un mail par Net::SMTP.

    Il permet d'indiquer de renseigner l'expediteur, le destinataire,la date d'envoi (ce qui est pratique elle apparait bien dans les gestionnaires de mails), le sujet et le corp du message.


    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
     
    #! C&#58;\Perl\bin\perl -w 
     
    use time&#58;&#58;localtime;
    use strict;
    use Net&#58;&#58;SMTP;
     
    my $smtp;
    my $date = localtime;
    my $serveur_connexion = machin chose; #indiquer le serveur qui donne acces
     
    	$smtp = Net&#58;&#58;SMTP->new&#40;'$serveur_connexion', Debug =>1 , Timeout => 30&#41; 
    	or die "Connexion SMTP impossible\n &#58; $!";
    	$smtp->mail&#40;'toto@titi.net'&#41; or die "mail SMTP impossible\n &#58; $!";
    	$smtp->to&#40;'tata@tutu.net'&#41; or die "destinataire SMTP impossible\n &#58; $!";
    	$smtp->data&#40;&#41; or die "data SMTP impossible\n &#58; $!";
    	$smtp->datasend&#40;"From&#58; toto <toto\@titi.net\n"&#41;;   	#destinataire
      $smtp->datasend&#40;"To&#58; tata <tata\@tutu.net\n"&#41;;   		#expeditaire
    	$smtp->datasend&#40;"Date&#58; $date\n"&#41;;										#date
      $smtp->datasend&#40;"Subject  &#58; Salut\n"&#41; or warn "Subject SMTP impossible\n &#58; $!";	#sujet
      $smtp->datasend&#40;"\n"&#41;;															# separateur
      $smtp->datasend&#40;"Tu mets.\n"&#41; or warn "Body SMTP impossible\n &#58; $!";	# corps du message
      $smtp->datasend&#40;"ton texte.\n"&#41;;	# corps du message
      $smtp->dataend&#40;&#41; or die "Dataend SMTP impossible\n &#58; $!";
    	$smtp->quit or die "Quit SMTP impossible\n &#58; $!";
    Il est tout aussi possible de mettre dans des variables : l'expediteur, le destinataire, le sujet et le corps du message, selon la convenance.

    a+
    L'opposé du jeu n'est pas le sérieux mais la réalité.
    Sigmund Freud
      0  0

  9. #29
    Membre extrêmement actif
    Avatar de Madmac
    Homme Profil pro
    Ingénieur développement logiciels
    Inscrit en
    Juin 2004
    Messages
    1 685
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Canada

    Informations professionnelles :
    Activité : Ingénieur développement logiciels
    Secteur : Alimentation

    Informations forums :
    Inscription : Juin 2004
    Messages : 1 685
    Points : 1 376
    Points
    1 376
    Billets dans le blog
    7
    Par défaut
    J'ai trouvé ce site qui en contient pas mal:

    http://pleac.sourceforge.net/pleac_perl/index.html
      0  0

  10. #30
    Membre averti
    Profil pro
    Inscrit en
    Avril 2005
    Messages
    801
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Avril 2005
    Messages : 801
    Points : 314
    Points
    314
    Par défaut
    Résoudre un nom de PC en addresse IP:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
     
    sub Domain2IP {
    # le domaine est attendu en paramètre
    my ($domaine)=@_;
    # Déclaration des variables utilisées :
    my (@bytes,$name,$altnames,$addrtype,$len,$packaddr);
    my ($ip);
      # on supprime des espaces éventuels en début et fin du domaine
      $domaine =~ s/^\s+|\s+$//g;
     
      # on lance la résolution du domaine -> ip #
      if (!(($name, $altnames, $addrtype, $len, @addrlist) =gethostbyname ($domaine))) {
        # Echec...
        return (0);
      }else{
        # on extrait l'adresse IP, et on la renvoie
        $ip=join('.',(unpack("C4",$addrlist[0])));
        return ($ip);
      }
    }
    tout le monde est d'accord pour critiquer la pensée unique
      0  0

  11. #31
    Membre à l'essai
    Inscrit en
    Février 2004
    Messages
    14
    Détails du profil
    Informations forums :
    Inscription : Février 2004
    Messages : 14
    Points : 11
    Points
    11
    Par défaut
    Pas super parfait comme script mais avec un peu de volonté je vais le pauffiner (je dis souvent ça ).

    En gros, ça liste les dependances entre les modules maison que j'ai créé dans le repertoire dans lequel s'execute le script.

    La sortie produite est prête à génerer un beau graphviz

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
     
    my $some_dir = '.';
     
    opendir (DIR, $some_dir) || die $!;
     
    my %pm;
    my @dep;
     
    foreach (readdir(DIR)) {
        $pm{$1} = 1 if /^(.*)\.pm/;
    }
    closedir DIR;
     
    foreach my $pm (keys %pm) {
        open (FHPM, "$some_dir/$pm.pm") || die $!;
        while (<FHPM>) {
            if (/^use (.*);/) {
                if (defined($pm{$1})) {
                    push @dep, "$pm -> $1";
                }
            }
        }
        close (FHPM);
    }
     
    # generation graphviz
    my $graphviz = "digraph G {node [color=lightblue2, style=filled];\n";
    $graphviz .= join ";\n", @dep;
    $graphviz .= "\n}\n";
     
    print $graphviz;
      0  0

  12. #32
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    Avril 2004
    Messages
    19 818
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Avril 2004
    Messages : 19 818
    Points : 499 183
    Points
    499 183
    Par défaut doublons dans un tableau
    Comment récuperer les doublons d'un tableau?

    voici une fonction qui liste les doublons d'un tableau. pour l'utiliser :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
     
    my @tableau = (1,2,3,4,2,"toto","titi","titi");
    my @les_doublon = &liste_doublons(\@tableau);
    print "@les_doublon"; #=> 2 titi
    sub liste_doublons {
      my $reference_tableau = shift;
      my %temp;
      my @doublons;
      foreach my $case (@$reference_tableau){
      	if ($temp{$case}++ == 1){ 	#$temp{$case}++ met la valeur associé à $case à i+1 
      		push (@doublons, $case);#et renvoie i, sachant que l'on considère que i est 
      	}				#à 0 lorsqu'il n'a pas encore été initialisé. Donc 
      #la première fois que tu rencontres un élément a dans la liste @$reference_tableau, $temp{a} est mis à 1 
      #et le push n'est pas exécuté (car 0 != 1), la deuxième fois qu'on rencontre a, le push est exécuté. 
      #Les fois suivantes il ne l'est plus. Donc au final on a tous les doublons en un exemplaire dans @doublons.
      }
      return @doublons;
    }
    Comment supprimer les doublons d'un tableau ?


    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
     
    my @tableau = (1,2,3,4,2,"toto","titi","titi");
    my @tableau_sans_doublon = &supprime_doublon(\@tableau);
    print "@tableau_sans_doublon"; #=> 1 2 3 4 titi toto
     
    sub supprime_doublon {	#fonction qui supprime les doublons dans un tableau.
      my $self=shift;	#recupere la reference du tableau	
      my %saw;		#declaration d'un hash
      my @result = @$self;	#dereference le tableau, donc on le recupere et le copie dans @result
      			#pour eviter de travailler sur le tableau d'origine et le modifier.
      undef %saw;
      @saw{@result} = ();	#chaque case de @result est mis en clef dans %saw avec une valeur nulle. et comme un 
      @result = sort keys %saw; #hash n'a pas deux clef identique, redondance supprimée.
      return(@result);
    }
    voilà, vu le nombre de topics dans le forum à ce sujet, je pense que ces deux fonctions aideront plus d'une personnes.
      0  0

  13. #33
    Membre confirmé
    Profil pro
    Inscrit en
    Juin 2006
    Messages
    427
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Juin 2006
    Messages : 427
    Points : 459
    Points
    459
    Par défaut
    on peut faire plus court avec grep:

    recuperer les doublons:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    my %seen;
    my @doublons = grep {++$seen{$_}==2} @liste
    recupere les elements uniques (liste sans doublons):
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    my %seen;
    my @unique = grep {++$seen{$_}==1} @liste
    Recherche staigiaire(s) motivé(s) sur projet perl/reseau a grande echelle. Me contacter par mp.
      0  0

  14. #34
    Membre habitué
    Profil pro
    Inscrit en
    Octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Âge : 43
    Localisation : Belgique

    Informations forums :
    Inscription : Octobre 2005
    Messages : 111
    Points : 142
    Points
    142
    Par défaut Il existe un module qui le fait
    Citation Envoyé par GLDavid
    Obtenir un chemin relatif à partir d'un chemin absolu :
    Le module Cwd permet de le faire.

    Sous linux:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    perl -e 'use Cwd; print Cwd::abs_path("./bashrc"); print $/'
    /data01/samba/users/mhoo/bashrc
    Sous windows:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
     
    perl -e "use Cwd; print Cwd::abs_path('perl.exe') . $/;"
    C:\Perl\bin\perl.exe
    Michaël Hooreman
      0  0

  15. #35
    Membre habitué
    Profil pro
    Inscrit en
    Octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Âge : 43
    Localisation : Belgique

    Informations forums :
    Inscription : Octobre 2005
    Messages : 111
    Points : 142
    Points
    142
    Par défaut Tri d'un fichier avec clé dans les lignes et filtrage
    Je veux récupérer les lignes d'un fichier qui commencent par TDR, et trier avec comme clé les 10 caractères à partir du 32eme.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    cat file | perl -nle 'push @r,$_;}{print foreach (sort {substr($a,32,10) cmp substr($b,32,10)} @r)' > file.filtered_and_sorted
    Remarque: le }{ apres le push correspond à l'opérateur "secret" "baiser eskimo":
    est équivalent à
    Michaël Hooreman
      0  0

  16. #36
    Membre habitué
    Profil pro
    Inscrit en
    Octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Âge : 43
    Localisation : Belgique

    Informations forums :
    Inscription : Octobre 2005
    Messages : 111
    Points : 142
    Points
    142
    Par défaut
    Citation Envoyé par GLDavid
    Un truc tout simple car j'ai encore vu un post à ce sujet : comment écrire dans un fichier :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
     
    open FILE, '>truc.txt' or die "truc.txt : $!\n";
    print FILE "Bla bla bla !!!!";
    close FILE;
    Les redirections dans la close open sont identiques à celles d'Unix :
    > je crée un fichier s'il n'existe pas sinon j'écrase le précédent s'il existe
    >> je crée un fichier s'il n'existe pas sinon j'écris à la suite du précédent.
    Ajout de 2Eurocent toujours utile : EN AUCUN CAS mettre de virgule entre le FILE et la chaine dans l'instruction print !

    @ ++
    Pour les redirections, petite remarque: il est plus fiable d'utiliser un 'open' à 3 arguments (cfr camel book entres autres). On préfèrera donc:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    open FILE, '>', 'truc.txt' or die ...
    Michaël Hooreman
      0  0

  17. #37
    Membre habitué Avatar de rcageot
    Profil pro
    rien
    Inscrit en
    Septembre 2006
    Messages
    128
    Détails du profil
    Informations personnelles :
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : rien

    Informations forums :
    Inscription : Septembre 2006
    Messages : 128
    Points : 170
    Points
    170
    Par défaut
    salut,
    je me suis fait il y a longtemps un librairie de fonction que j'utilise souvent
    je n'ai pas remis le nez dans le code donc il peut y avoir des optimisations mais ça marche très bien depuis des années :-)
    ############################################################################
    # Sub : right_adjust (justify a droite)
    # Usage : &right_adjust("#caractere","chaine");
    # retour: la chaine ajuste a droite au nombre de caracteres
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
     
    sub right_adjust {
        local($sp,$str) = @_;
        $long = length($str);
        for ($r=$long;$r<=$sp;$r++) {
           $str = $str." ";
        }
        return $str;
    }
    ############################################################################
    # Sub : which (emulation du which Unix)
    # Usage : &which("file");
    # retour: le path complet du fichier .
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
     
    sub which {
       local ($file) = @_;
       my($file) = shift;
       foreach (split(/:/, $ENV{PATH})) {
        return "$_/$file" if (-x "$_/$file");
       }
       return undef;
    }
    ############################################################################
    # Sub : isnum (test si la chaine de caractere est numerique)
    # Usage : if (&isnum("chaine") ) {;
    # retour: 1 ou vrai si la chaine est numerique .
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
     
    sub isnum {
       local ($test) = @_;
       $test2 = $test;
       $cnt = $test2 =~ tr/0-9//;
       if ($cnt != length($test)) {
          return (0);
       } else {
          return (1);
       }
    }

    ############################################################################
    # sub : select _jour, _mois, _annee, _heure, _minutes
    # usage : &select
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
     
    sub select_jour {
       local ($first,$last,$sel,$js_add,$name) = @_;
       if ($first eq "") {$first = 1;}
       if ($last eq "") {$last =31;}
       if (defined $name) {
          print "   <SELECT name=\"$name\" $js_add>";
       } else {
          print "   <SELECT name=\"jour\" $js_add>";
       }
       print "    <OPTION>";
       for ($z=$first;$z<=$last;$z++) {
          if ($sel == $z) {
             print "    <OPTION SELECTED VALUE=\"$z\">$z";
          } else {
             print "    <OPTION VALUE=\"$z\">$z";
          }
       }
       print "   </SELECT>";
    }
    sub select_mois {
       local ($first,$last,$sel,$js_add,$name) = @_;
       if ($first eq "") {$first = 1;}
       if ($last eq "") {$last =12;}
       if (defined $name) {
          print "   <SELECT name=\"$name\" $js_add>";
       } else {
          print "   <SELECT name=\"mois\" $js_add>";
       }
       print "    <OPTION>\n";
       for ($z=$first;$z<=$last;$z++) {
          if ($sel == $z) {
             print "    <OPTION SELECTED VALUE=\"$z\">$z\n";
          } else {
             print "    <OPTION VALUE=\"$z\">$z\n";
          }
       }
       print "   </SELECT>\n";
    }
     
    sub select_annee {
       local ($first,$last,$sel,$js_add,$name) = @_;
       if ($first eq "") {$first = $annee;}
       if ($last eq "") {$last = $first + 20;}
       if (defined $name) {
          print "   <SELECT name=\"$name\" $js_add>";
       } else {
          print "   <SELECT name=\"annee\" $js_add>";
       }
       print "    <OPTION>\n";
       for ($z=$first;$z<=$last;$z++) {
          if ($sel == $z) {
             print "    <OPTION SELECTED VALUE=\"$z\">$z\n";
          } else {
             print "    <OPTION VALUE=\"$z\">$z\n";
          }
       }
       print "   </SELECT>\n";
    }
     
    sub select_heure {
       local ($first,$last,$sel,$js_add) = @_;
       if ($first eq "") {$first = 0;}
       if ($last eq "") {$last = 23;}
       print "   <SELECT name=\"heure\" $js_add>\n";
       print "    <OPTION>\n";
       for ($z=$first;$z<=$last;$z++) {
          if ($sel == $z) {
             print "    <OPTION SELECTED VALUE=\"$z\">$z\n";
          } else {
             print "    <OPTION VALUE=\"$z\">$z\n";
          }
       }
       print "   </SELECT>\n";
    }
     
    sub select_minute {
       local ($first,$last,$sel,$js_add) = @_;
       if ($first eq "") {$first = 0;}
       if ($last eq "") {$last = 59;}
       print "   <SELECT name=\"minute\" $js_add>\n";
       print "    <OPTION>\n";
       for ($z=$first;$z<=$last;$z+=5) {
          if ($sel == $z) {
             print "    <OPTION SELECTED VALUE=\"$z\">$z\n";
          } else {
             print "    <OPTION VALUE=\"$z\">$z\n";
          }
       }
       print "   </SELECT>\n";
    }
    ############################################################################
    # Sub : commify (Converti chiffre en chaine 1000 => 1,000)
    # Usage : print "debut " . &commify($chiffre) ." suite";
    # retour: chaine modifie
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
     
    sub commify {
        local($_) = shift;
        1 while s/^(-?\d+)(\d{3})/$1,$2/;
        return $_;
    }
    ############################################################################
    # Sub : compress (elimine tous les espaces dans une chaine de caractères)
    # Usage : &compress($chaine);
    # retour: chaine modifie
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
     
    sub compress {
       local ($chaine_a_compresser) = @_;
       while ( index($chaine_a_compresser," ") != -1) { $chaine_a_compresser =~ s/ //g;}
       return $chaine_a_compresser;
    }
    ############################################################################
    # Sub : trim_space (elimine tous les caractères choisis en début et à la fin dans une chaine de caractères)
    # Usage : &trim_space($chaine);
    # retour: chaine modifie
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
     
    sub trim_space {
       local ($chaine_a_traiter,$car2del) = @_;
       if ($car2del eq "") {$car2del = " ";}
       while (substr($chaine_a_traiter,0,1) eq "$car2del") {
          $chaine_a_traiter = substr($chaine_a_traiter,1);
       }
       while (substr($chaine_a_traiter,length($chaine_a_traiter)-1,1) eq "$car2del") {
          $chaine_a_traiter = substr($chaine_a_traiter,0,length($chaine_a_traiter)-1);
       }
       return $chaine_a_traiter;
    }
    ############################################################################
    # Sub : br_to_lf et lf_to_br (remplace les retours chariot/line feed par des code <BR>
    # et vice versa dans une chaine)
    # Usage : &br_to_lf($chaine);
    # retour: chaine modifie
    #---------------------------------------------------------------------------
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
     
     
    sub br_to_lf {
       local($ch_mod) = @_;
       $ch_mod =~ s/<BR>/\n/g;
       return $ch_mod;
    }
     
    sub lf_to_br {
       local($ch_mod) = @_;
       $ch_mod =~ s/\r//g;
       while (index($ch_mod, "\n\n") != -1) {$ch_mod  =~ s/\n\n/\n/g;}
       if (substr($ch_mod,length($ch_mod)-1) eq "\n") {
          $ch_mod = substr($ch_mod,0,length($ch_mod)-1);
       }
       $ch_mod =~ s/\n/<BR>/g;
       return $ch_mod;
    }
    ############################################################################
    # Obtenir le jour de la semaine d'un jour donné
    # Usage: $week_day = &get_week_day($jour,$mois,$annee)
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
     
     
    sub get_week_day {
            local($d,$m,$y) = @_;
            local($ya,$c);
     
            $y = (localtime(time))[5] + 1900  if ($y eq '');
     
            if ($m > 2) {
                    $m -= 3;
            } else {
                    $m += 9;
                    --$y;
            }
            $c = int($y/100);
            $ya = $y - (100 * $c);
            $jd =  int((146097 * $c) / 4) +
                       int((1461 * $ya) / 4) +
                       int((153 * $m + 2) / 5) +
                       $d + 1721119;
            $sem_jour = ($jd + 1) % 7;
            return($sem_jour);
    }
    ############################################################################
    # Copy d'un répertoire avec ses sous répertoires dans un autre répertoire
    # Usage: &copy_dir ( source, destination)

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
     
     
    sub copy_dir {
       local ($path_from,$path_to) = @_;
       $path_from =~ s$//$/$g;
       $path_to   =~ s$//$/$g;
       local (*DIR);
       opendir( DIR, "$path_from" ) || &web_error("Impossible d'ouvrir le répertoire $path_from<BR>Erreur: $!","$cgiurl");
     
       while ( $entry = readdir( DIR ) ) {
          $type = ( -d "$path_from/$entry" ) ? "dir" : "file"; 
          if ( ($type eq "dir") && ($entry ne "..") && ($entry ne ".") ) {
             if (!-d "$path_to/$entry") { 
                &web_error("Impossible de se placer sur le répertoire $path_to  <BR>Erreur: $!\n","$cgiurl") unless chdir ("$path_to");
                &web_error("Impossible de créer le sous répertoire $entry dans $path_to  <BR>Erreur: $!\n","$cgiurl") unless mkdir "$entry" , 0755;
                #print "<BR>Création de $path_to/$entry\n";
             }
             &copy_dir("$path_from/$entry","$path_to/$entry");
          }
          if ( ( $type eq "file" ) && ($entry ne "..") ) {
             #print "<BR>Copy $path_from/<b>$entry</b> \n";
             &copy_file("$path_from/$entry","$path_to/$entry");
          }
       }
     
       closedir( DIR );
       return;
    }
    ############################################################################
    # backup de dossier avec test si le fichier cible a été modifié
    # Usage: backup_dir (origine , destination, mo)
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
     
    sub backup_dir {
       local ($path_from,$path_to,$mode) = @_;
       $path_from =~ s$//$/$g;
       $path_to   =~ s$//$/$g;
       local (*DIR);
       if ($mode ne "test") {
          print "<UL><LI>backup de $path_from";
       }
       opendir( DIR, "$path_from" ) || &web_error("Impossible d'ouvrir le répertoire $path_from<BR>Erreur: $!","$cgiurl");
     
       while ( $entry = readdir( DIR ) ) {
          $type = ( -d "$path_from/$entry" ) ? "dir" : "file"; 
          if ( ($type eq "dir") && ($entry ne "..") && ($entry ne ".") ) {
             if (!-d "$path_to/$entry") {
                if ($mode ne "test") {
                   &web_error("Impossible de se placer sur le répertoire $path_to  <BR>Erreur: $!\n","$cgiurl") unless chdir ("$path_to");
                   &web_error("Impossible de créer le sous répertoire $entry dans $path_to  <BR>Erreur: $!\n","$cgiurl") unless mkdir "$entry" , 0777;
                   print "<BR><b>Création de $path_to/$entry</b>\n";
                }
             }
             &backup_dir("$path_from/$entry","$path_to/$entry","$mode");
          }
          if ( ( $type eq "file" ) && ($entry ne "..") && (compress($entry) ne "") ) {
             ($dev_source,
              $ino_source,
              $mode_source,
              $nlink_source,
              $uid_source,
              $gid_source,
              $rdev_source,
              $size_source,
              $atime_source,
              $mtime_source,
              $ctime_source,
              $blksize_source,
              $blocks_source) = stat("$path_from/$entry");
             ($dev_dest,
              $ino_dest,
              $mode_dest,
              $nlink_dest,
              $uid_dest,
              $gid_dest,
              $rdev_dest,
              $size_dest,
              $atime_dest,
              $mtime_dest,
              $ctime_dest,
              $blksize_dest,$blocks_dest) = stat("$path_to/$entry");
             if ( ($atime_source != $atime_dest) && ($mtime_source != $mtime_dest) ) {
                if ($mode ne "test") {
                   $perms1 = $mode_source & 07777;
                   $oct_perms1 = sprintf "%lo", $perms1;
                   print "<table border><tr><td colspan=5>$entry ($size_source bytes)</td></tr>\n";
                   print "<tr><td></td><td>A</td><td>M</td><td>C</td><td>Mode</td></tr>\n";
                   print "<tr><td>source</td><td>$atime_source</td><td>$mtime_source</td><td>$ctime_source</td><td>$mode_source : $oct_perms1</td></tr>\n";
                   if (-e "$path_to/$entry") {
                      $perms2 = $mode_dest & 07777;
                      $oct_perms2 = sprintf "%lo", $perms2;
                      print "<tr><td>destination</td><td>$atime_dest</td><td>$mtime_dest</td><td>$ctime_dest</td><td>$mode_dest : $oct_perms2</td></tr>\n";
                   } else {
                      print "<tr><td>destination</td><td colspan=4><font color=red>Création</font></td></tr>\n";
                   }
                   print "</table>\n";
                   &copy_file("$path_from/$entry","$path_to/$entry");
                   $perm = "0"."$oct_perms1";
                   chmod  0666 , "$path_to/$entry";
                   print "<br><font color=blue><b>Copie ok</b></font>";
                   ($atime, $mtime) = (stat("$path_from/$entry"))[8,9];
                   utime $atime, $mtime, "$path_to/$entry";
                }
                $nbfilebck +=1;
             } 
          }
       }
       if ($mode ne "test") {
          print "</LI></UL>";
       }
       closedir( DIR );
       return;
    }
    ############################################################################
    # Copie de fichier en mode binaire
    # Usage: copy_file(origine , destination)
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
     
    sub copy_file {
        local ($infile,$outfile) = @_;
     
        open( INFILE, "<$infile" );
        open( OUTFILE, ">$outfile" );
     
        binmode( INFILE ); binmode( OUTFILE ); # crucial for binary files!
     
        while ( read( INFILE, $buffer, 1024 ) ) {
          print OUTFILE $buffer;
        }
     
        close( INFILE ); close( OUTFILE );
    }
    Si un ricard vaut un steak, j'ai bien bouffé une vache hier soir !
    L'art de poser les bonnes questions dans les forums afin de ne pas passer pour un
      0  0

  18. #38
    Membre actif Avatar de mobscene
    Profil pro
    Inscrit en
    Avril 2005
    Messages
    331
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Avril 2005
    Messages : 331
    Points : 234
    Points
    234
    Par défaut
    Normalisé une chaine utf8 , j'ai écrit cette fonction pour rendre une chaine utf8 strict donc en UTF-8

    voila la bebete

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    sub utf8_strictify
    {
        my $data = shift;
        if (Encode::is_utf8($data) && !Encode::is_utf8($data,1)) 
        {
            Encode::_utf8_off($data);
            Encode::from_to($data, 'utf8', 'UTF-8');
            Encode::_utf8_on($data);
        }
        return $data;
    }
    Everybody have in their the potential to be their own god : Marilyn Manson
      0  0

  19. #39
    Membre du Club
    Inscrit en
    Février 2007
    Messages
    34
    Détails du profil
    Informations personnelles :
    Âge : 61

    Informations forums :
    Inscription : Février 2007
    Messages : 34
    Points : 44
    Points
    44
    Par défaut Logging
    Bonjour,

    Un petit truc utile pour déboguer, ça écrit dans STDERR la fonction dans laquelle se trouve l'appel à fnLog suivi du message.

    On peut bien sur écrire ailleurs... le truc pratique c'est 'caller'.

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
     
    sub fnLog
    {
    	my $strMessage = shift @_;  
    	print STDERR "[" . (caller(1))[3] . "]" . $strMessage."\n";		
    }
      0  0

  20. #40
    Membre confirmé
    Profil pro
    Inscrit en
    Juin 2006
    Messages
    427
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Juin 2006
    Messages : 427
    Points : 459
    Points
    459
    Par défaut
    en fait ca equivaut à utiliser carp:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
     
    use Carp;
     
    sub fnLog
    {
    	my $strMessage = shift @_;  
    	carp $strMessage;
    }
    carp est un warn qui signal la ligne de l'appelant et non la ligne ou il est, et de meme croak est un die qui signal la ligne de l'appelant.

    croak est tres utilise pour signaler un mauvais argument passé à une fonction, car l'erreur est alors bien au niveau de l'appel à cette fonction et non dans al fonction elle meme:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    sub bla {
      my $arg = shift;
      croak "expected an integer argument" unless $arg =~ /^\d+$/;
    }
    Recherche staigiaire(s) motivé(s) sur projet perl/reseau a grande echelle. Me contacter par mp.
      0  0

Discussions similaires

  1. Réponses: 2
    Dernier message: 04/11/2009, 11h17
  2. Réponses: 5
    Dernier message: 15/09/2009, 13h00
  3. Réponses: 12
    Dernier message: 29/07/2009, 17h26
  4. Réponses: 0
    Dernier message: 23/07/2009, 16h21
  5. Réponses: 0
    Dernier message: 23/07/2009, 16h21

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo