Publicité
Discussion fermée
Page 2 sur 6 PremièrePremière 123456 DernièreDernière
Affichage des résultats 21 à 40 sur 113
  1. #21
    Membre confirmé
    Inscrit en
    février 2005
    Messages
    167
    Détails du profil
    Informations forums :
    Inscription : février 2005
    Messages : 167
    Points : 200
    Points
    200

    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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
    Expert Confirmé
    Avatar de 2Eurocents
    Inscrit en
    septembre 2004
    Messages
    2 177
    Détails du profil
    Informations personnelles :
    Âge : 44

    Informations forums :
    Inscription : septembre 2004
    Messages : 2 177
    Points : 3 099
    Points
    3 099

    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 :
    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 :
    $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
    Invité de passage
    Inscrit en
    octobre 2004
    Messages
    10
    Détails du profil
    Informations forums :
    Inscription : octobre 2004
    Messages : 10
    Points : 4
    Points
    4

    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 :
    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 ( $fichierabo = <stdin> ) ;
    open ( FICHIER , $fichierabo ) ;
    chomp ( @fichier = <FICHIER> ) ;
    close ( FICHIER ) ;
     
    $nbligne = $#fichier + 1 ;
    print " ce fichier comporte $nbligne \n" ;
     
    $ligne = 1 ;
    foreach ( @fichier )
    {
        @travail = split( // , $_ ) ;
        $caractere = $#travail + 1 ;
        print " la ligne $ligne comporte $caractere \n" ;
        @travail = () ;
        $ligne += 1 ;
    }
      0  0

  4. #24
    Expert Confirmé Sénior
    Avatar de Jedai
    Homme Profil pro
    Enseignant
    Inscrit en
    avril 2003
    Messages
    6 175
    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 175
    Points : 8 311
    Points
    8 311

    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
    Inscrit en
    janvier 2003
    Messages
    2 684
    Détails du profil
    Informations personnelles :
    Âge : 37

    Informations forums :
    Inscription : janvier 2003
    Messages : 2 684
    Points : 2 847
    Points
    2 847

    Par défaut

    Et voici un script plus complet par rapport à mon précédent qui fait iso-8859-1 <-> utf-8 :
    Code :
    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::Recode;
     
    sub to_iso {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while(<FICHIER>){
    		my($cd) = Locale::Recode->new(from => 'UTF-8',
    		to=>'ISO-8859-1');
    		die $cd->getError if $cd->getError;
    		$cd->recode($_) or die $cd->getError;
    		print FICHIER_DEST;			
    	}
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename($file_dest, $file) and unlink $file_dest;
    }
     
    sub to_utf {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while(<FICHIER>){
    		my($cd) = Locale::Recode->new(from => 'ISO-8859-1',
    		to=>'UTF-8');
    		die $cd->getError if $cd->getError;
    		$cd->recode($_) or die $cd->getError;
    		print FICHIER_DEST;			
    	}
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename($file_dest, $file) and unlink $file_dest;
    }
     
    sub recode_file {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	my($encode) = $_[1];
    	if($encode eq "1"){
    		&to_iso($file, $file_dest);
    	}
    	else {
    		&to_utf($file, $file_dest);
    	}
    }
     
    sub recode_repertory {
    	my($repertory) = $_[0];
    	my($pos) = rindex($repertory, '/');
    	if($pos != (length($repertory)-1)){
    		$repertory .= '/';
    	}
    	my($encode) = $_[1];
    	chdir $repertory;
    	my(@files) = `ls`;
    	my($file);
    	foreach $file (@files){
    		$file = $repertory.$file;
    		chomp $file;
    		if( -f $file){
    			&recode_file($file, $encode);
    		}
    		elsif ( -d $file){
    			&recode_repertory($file, $encode);
    		}
    	}
    }
     
     
    ###################MAIN######################
     
     
    if ($#ARGV > -1){
    	chomp $ARGV[0] and chomp $ARGV[1];
    	if ($ARGV[0] =~ /[A-Za-z]+/){
    		print "recode prend 2 arguments.\n";
    		print "Le premier argument doit être un nombre :\n";
    		print "1 : UTF-8 => ISO-8859-1\n";
    		print "2 : 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;
    	}
    	if ($ARGV[0] > 2 or $ARGV[0] < 1){
    		print "Le premier argument doit être un nombre valide :\n";
    		print "1 : UTF-8 => ISO-8859-1\n";
    		print "2 : ISO-8859-1 => UTF-8\n";
    		exit 0;
    	}
    	if ( -f $ARGV[1]){
    		&recode_file($ARGV[1], $ARGV[0]);	
    	}
    	elsif ( -d $ARGV[1]){
    		&recode_repertory($ARGV[1], $ARGV[0]);
    	}
    } 
    elsif ($#ARGV > 1) {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    elsif ($#ARGV == 0) {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    else {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    @++
    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 Confirmé Sénior
    Avatar de Jedai
    Homme Profil pro
    Enseignant
    Inscrit en
    avril 2003
    Messages
    6 175
    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 175
    Points : 8 311
    Points
    8 311

    Par défaut

    Avec encodage de départ et d'arrivée paramétrables :
    Code :
    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::Long;
    use Pod::Usage;
    $| = 1; # Autoflush on
     
    sub from_to_file ($);
    sub recode_dir ($);
     
    Getopt::Long::Configure ("bundling", "ignore_case");
    my ($verbose, $recursive, $all_files, $backup, $force, $from,        $to) = 
       (0,        0,          0,          2,       0,      "ISO-8859-1", "UTF-8");
     
    GetOptions( "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 )
        or pod2usage(-exitval => 2, -verbose => 1);;
    unless( @ARGV ) { pod2usage(-exitval => 2, -verbose => 1) }
     
    if( $backup == 2 ) {
      print "Do you want to backup your files ?(Y/n) ";
      if( <STDIN> =~ /^no?\s*/i ){
        $backup = 0;
      }
    }
     
     
    ## Main
     
    foreach my $file ( @ARGV ){
      if( -f $file ){
        from_to_file( $file );
      } elsif( -d $file ) {
        recode_dir( $file );
      }
    }
     
     
    ## Fonctions
     
    sub from_to_file ($) {
      my $file  = shift ;
      my $file_dest = $file.".new";
      my ($in, $out);
      while( -e $file_dest ) { $file_dest .= ".new" }
     
      open $in, "<:bytes", $file or die "$!\n";
      open $out, ">:bytes", $file_dest or die "$!\n";
     
      print "Encode $file from $from to $to.\n" if $verbose;
      while(<$in>){ 
        if ( $force ) {
     
          unless( defined Encode::from_to( $_, $from, $to, Encode::FB_PERLQQ ) ) {
            print "Error while encoding $file, are you sure that this file ",
              "is encoded in $from ?\n";
          }
     
        } else {
     
          eval { Encode::from_to( $_, $from, $to, 1 ) };
          if( $@ ){
            print "Error while encoding $file, are you sure that this file ",
              "is encoded in $from ?\nEncoding of $file aborted !\n";
            unlink $file_dest;
          }
     
        }
        print {$out} $_;
      }
     
      # backup if asked for
      if( $backup ){
        my $file_bak = $file.".bak";
        while( -e $file_bak ) { $file_bak .= ".bak" }
        rename( $file, $file_bak );
      }
     
      close $in and close $out;
      rename($file_dest, $file);
    }
     
    sub recode_dir ($) {
      my $dir = shift ;
      $dir .= "/" unless $dir =~ m</$>;
     
      opendir RECDIR, $dir or die "$!\n";
      my $file;
      while( defined ( $file = readdir RECDIR ) ) {
        unless( $file =~ /^\.{1,2}$/ ) {
          if( -d $dir.$file and $recursive ) {
            recode_dir( $dir.$file );
          } elsif (-f $dir.$file and ($file !~ /^\./ or $all_files) ){
            from_to_file( $dir.$file );
          }
        }
      }
    }
     
    __END__
     
    =head1 NAME
     
    Recode.pl
     
    =head1 SYNOPSIS
     
    Recode.pl [options] [file|directory ...]
     
     Options:
      -v or --verbose     Set the verbosity level of this program
      -f or --from        Encoding of the input files (default : ISO-8859-1)
      -t or --to          Target encoding (default : UTF-8)
      -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(s) and/or directory(ies)
    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 :
    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
    Invité de passage
    Inscrit en
    décembre 2005
    Messages
    1
    Détails du profil
    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 :
    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::Recode;
     
    sub to_iso {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while(<FICHIER>){
    		my($cd) = Locale::Recode->new(from => 'UTF-8',
    		to=>'ISO-8859-1');
    		die $cd->getError if $cd->getError;
    		$cd->recode($_) or die $cd->getError;
    		print FICHIER_DEST;			
    	}
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename($file_dest, $file) and unlink $file_dest;
    }
     
    sub to_utf {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	open FICHIER, "< $file" or die "$!\n";
    	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
    	while(<FICHIER>){
    		my($cd) = Locale::Recode->new(from => 'ISO-8859-1',
    		to=>'UTF-8');
    		die $cd->getError if $cd->getError;
    		$cd->recode($_) or die $cd->getError;
    		print FICHIER_DEST;			
    	}
    	close FICHIER and close FICHIER_DEST;
    	unlink $file and rename($file_dest, $file) and unlink $file_dest;
    }
     
    sub recode_file {
    	my($file) = $_[0];
    	my($file_dest) = $file.".new";
    	my($encode) = $_[1];
    	if($encode eq "1"){
    		&to_iso($file, $file_dest);
    	}
    	else {
    		&to_utf($file, $file_dest);
    	}
    }
     
    sub recode_repertory {
    	my($repertory) = $_[0];
    	my($pos) = rindex($repertory, '/');
    	if($pos != (length($repertory)-1)){
    		$repertory .= '/';
    	}
    	my($encode) = $_[1];
    	chdir $repertory;
    	my(@files) = `ls`;
    	my($file);
    	foreach $file (@files){
    		$file = $repertory.$file;
    		chomp $file;
    		if( -f $file){
    			&recode_file($file, $encode);
    		}
    		elsif ( -d $file){
    			&recode_repertory($file, $encode);
    		}
    	}
    }
     
     
    ###################MAIN######################
     
     
    if ($#ARGV > -1){
    	chomp $ARGV[0] and chomp $ARGV[1];
    	if ($ARGV[0] =~ /[A-Za-z]+/){
    		print "recode prend 2 arguments.\n";
    		print "Le premier argument doit être un nombre :\n";
    		print "1 : UTF-8 => ISO-8859-1\n";
    		print "2 : 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;
    	}
    	if ($ARGV[0] > 2 or $ARGV[0] < 1){
    		print "Le premier argument doit être un nombre valide :\n";
    		print "1 : UTF-8 => ISO-8859-1\n";
    		print "2 : ISO-8859-1 => UTF-8\n";
    		exit 0;
    	}
    	if ( -f $ARGV[1]){
    		&recode_file($ARGV[1], $ARGV[0]);	
    	}
    	elsif ( -d $ARGV[1]){
    		&recode_repertory($ARGV[1], $ARGV[0]);
    	}
    } 
    elsif ($#ARGV > 1) {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    elsif ($#ARGV == 0) {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    else {
    	print "recode prend 2 arguments.\n";
    	print "Le premier argument doit être un nombre :\n";
    	print "1 : UTF-8 => ISO-8859-1\n";
    	print "2 : 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;
    }
    @++

    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 actif Avatar de spirit_epock
    Inscrit en
    mars 2006
    Messages
    153
    Détails du profil
    Informations forums :
    Inscription : mars 2006
    Messages : 153
    Points : 159
    Points
    159

    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 :
    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:\Perl\bin\perl -w 
     
    use time::localtime;
    use strict;
    use Net::SMTP;
     
    my $smtp;
    my $date = localtime;
    my $serveur_connexion = machin chose; #indiquer le serveur qui donne acces
     
    	$smtp = Net::SMTP->new('$serveur_connexion', Debug =>1 , Timeout => 30) 
    	or die "Connexion SMTP impossible\n : $!";
    	$smtp->mail('toto@titi.net') or die "mail SMTP impossible\n : $!";
    	$smtp->to('tata@tutu.net') or die "destinataire SMTP impossible\n : $!";
    	$smtp->data() or die "data SMTP impossible\n : $!";
    	$smtp->datasend("From: toto <toto\@titi.net\n");   	#destinataire
      $smtp->datasend("To: tata <tata\@tutu.net\n");   		#expeditaire
    	$smtp->datasend("Date: $date\n");										#date
      $smtp->datasend("Subject  : Salut\n") or warn "Subject SMTP impossible\n : $!";	#sujet
      $smtp->datasend("\n");															# separateur
      $smtp->datasend("Tu mets.\n") or warn "Body SMTP impossible\n : $!";	# corps du message
      $smtp->datasend("ton texte.\n");	# corps du message
      $smtp->dataend() or die "Dataend SMTP impossible\n : $!";
    	$smtp->quit or die "Quit SMTP impossible\n : $!";
    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+
      0  0

  9. #29
    Membre actif
    Inscrit en
    juin 2004
    Messages
    254
    Détails du profil
    Informations forums :
    Inscription : juin 2004
    Messages : 254
    Points : 196
    Points
    196

    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 confirmé
    Inscrit en
    avril 2005
    Messages
    801
    Détails du profil
    Informations forums :
    Inscription : avril 2005
    Messages : 801
    Points : 276
    Points
    276

    Par défaut

    Résoudre un nom de PC en addresse IP:

    Code :
    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
    Invité régulier
    Inscrit en
    février 2004
    Messages
    14
    Détails du profil
    Informations forums :
    Inscription : février 2004
    Messages : 14
    Points : 7
    Points
    7

    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 :
    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
    16 755
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 755
    Points : 490 691
    Points
    490 691

    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 :
    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 :
    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.

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  13. #33
    Membre éprouvé
    Inscrit en
    juin 2006
    Messages
    427
    Détails du profil
    Informations forums :
    Inscription : juin 2006
    Messages : 427
    Points : 474
    Points
    474

    Par défaut

    on peut faire plus court avec grep:

    recuperer les doublons:
    Code :
    1
    2
    my %seen;
    my @doublons = grep {++$seen{$_}==2} @liste
    recupere les elements uniques (liste sans doublons):
    Code :
    1
    2
    my %seen;
    my @unique = grep {++$seen{$_}==1} @liste
      0  0

  14. #34
    Membre habitué
    Profil pro Michaël Hooreman
    Inscrit en
    octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Nom : Michaël Hooreman
    Âge : 34
    Localisation : Belgique

    Informations forums :
    Inscription : octobre 2005
    Messages : 111
    Points : 139
    Points
    139

    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 :
    1
    2
    3
     
    perl -e 'use Cwd; print Cwd::abs_path("./bashrc"); print $/'
    /data01/samba/users/mhoo/bashrc
    Sous windows:
    Code :
    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 Michaël Hooreman
    Inscrit en
    octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Nom : Michaël Hooreman
    Âge : 34
    Localisation : Belgique

    Informations forums :
    Inscription : octobre 2005
    Messages : 111
    Points : 139
    Points
    139

    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 :
    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 Michaël Hooreman
    Inscrit en
    octobre 2005
    Messages
    111
    Détails du profil
    Informations personnelles :
    Nom : Michaël Hooreman
    Âge : 34
    Localisation : Belgique

    Informations forums :
    Inscription : octobre 2005
    Messages : 111
    Points : 139
    Points
    139

    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 :
    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 :
    open FILE, '>', 'truc.txt' or die ...
    Michaël Hooreman
      0  0

  17. #37
    Membre habitué Avatar de rcageot
    Inscrit en
    septembre 2006
    Messages
    127
    Détails du profil
    Informations forums :
    Inscription : septembre 2006
    Messages : 127
    Points : 143
    Points
    143

    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 );
    }
      0  0

  18. #38
    Membre actif Avatar de mobscene
    Inscrit en
    avril 2005
    Messages
    331
    Détails du profil
    Informations forums :
    Inscription : avril 2005
    Messages : 331
    Points : 199
    Points
    199

    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 :
    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
    32
    Détails du profil
    Informations personnelles :
    Âge : 51

    Informations forums :
    Inscription : février 2007
    Messages : 32
    Points : 41
    Points
    41

    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 :
    1
    2
    3
    4
    5
    6
     
    sub fnLog
    {
    	my $strMessage = shift @_;  
    	print STDERR "[" . (caller(1))[3] . "]" . $strMessage."\n";		
    }
      0  0

  20. #40
    Membre éprouvé
    Inscrit en
    juin 2006
    Messages
    427
    Détails du profil
    Informations forums :
    Inscription : juin 2006
    Messages : 427
    Points : 474
    Points
    474

    Par défaut

    en fait ca equivaut à utiliser carp:
    Code :
    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 :
    1
    2
    3
    4
    sub bla {
      my $arg = shift;
      croak "expected an integer argument" unless $arg =~ /^\d+$/;
    }
      0  0

Liens sociaux

Règles de messages

  • Vous ne pouvez pas créer de nouvelles discussions
  • Vous ne pouvez pas envoyer des réponses
  • Vous ne pouvez pas envoyer des pièces jointes
  • Vous ne pouvez pas modifier vos messages
  •