Vv2l.pl est un script Perl qui vérifie les
liens de votre dossier de publication (votre site, blog, page-perso
avant publication) et répare ce qu'il peut réparer.
Il vérifie donc et réparre les paths absolues
(c'est trés souvent le cas), les erreurs d'extentions (c'est
aussi trés souvent le cas .htm au lieu de .html),
non
concordance
du lien (soit à cause d'une erreur de fichier,
soit carrement une faute d'orthographe), lien au fichiers ayant disparus
ou renommer (et quand il ne sait pas il demande
à l'utilisateur par l'intermédiaire d'une liste de
possibilités (fichier et/ou ancre) vers ou pointer, qui sont
numérotés.
Exemple:
Liens obsoléte => dans fichiers : config.html |
lien brut : commun.htm#avantiges | rootfile: commun | extention :
htm | ancre: aventiges
Possibilités : entrez le [Num] de votre choix ou directement le
lien ou passez votre tour [Entrer] ou q pour quitter
[0]
commandes_lx.html
[1]
comcombre_masqué#la_revanche
[2]
commun.html#aventages
[3]
cri2joie.html#cetait_celui_avant
[4] LaCjusto.html#dessus
votre reponse:
Et bien sûr, vous deviez entrer 2
ou carrement commun.html#avantages ou Enter pour
passer sans rien modifier soit q pour quitter, parcque vous
vous souvenez qu'on vous attend pour la soupe...
Enfin voilà, je l'ai écris pour réparer les liens
cassés de mon site, c'était pas du luxe plus de 300 pages
et quelque chose comme 28000 liens à contrôler.
Il fonctionne bien et laisse le dossier original intact (il ne fait que
le lire) stocke toutes les ancres et nom_de_fichier susceptible d'etre
des liens et les comparres au copies de vos fichiers qu'il
créé dans un répertoire ./newsite . Il fait aussi
des comptes rendu de modif dans des fichiers log. Ca fait 3 ans
que je travailler dessus...
Il est bien, spartiate mais il fonctionne.
Alain Adelmar
Pour pas avoir de surprises regarder sur vv2l.pl (le script)
#!/usr/bin/perl
# remd: vv2l comme Vaillant Verificateur De Liens - par alain
*
# remd: Répare les liens locaux de votre espace de
publication *
# (rep de pages perso, site) en les testant pour chaque
fichier. *
# Il répare les erreurs d'afféctation, de path (absolu ou
relatif) *
# UNIX/M$/LX, les fautes d'extentions, doublons, ortografe, etc... *
# Vérif des encres et ré-attribution du 1er flag ou
création (-c) *
# d'une encre #_top (si page existe sans flag). Corrige les fautes *
# d'orthographes et les path
erronés.
*
# Vers:4.3 => 6.6 | 08.2010 alain Adelmar Pessac
aadelmar@free.fr *
#
-------------------------------------------------------
*
# (v: Version Vérif De Luxe (Unix-Like - Windows) Alain
Adelmar ) *
# remd: autonome n'utilise que les modules standards (facultatif)
*
#------------------------------------------------------------------*
# usage: vv2l.pl [-cu] [rep_source]
[sous-rep(image)]
*
#-----------------------------------
*
#
options:
*
# -c (complet) effectuera des tests, logs et
pré-réparation style *
#
marquer
d'un tag "top" les pages html pas marquées *
# -g (gros site) pour les site dépassant les 50 pages ou 1000
liens*
#
cette
option adapte la sortie formaté pour le choix *
# -u (update) insére la date de mise à jour, en gardant
l'original *
#
en
commantaire, répare les
liens.
*
# -l (light) essai de reparer par lui meme et tri avant de proposer*
# a
l'utilisateur. (peu simplifier le
travail) *
# -s (silencieux) reparre les liens sans intervention de user, fait*
#
un
rapport pour ce qu'il n'a pas
réparrer.
*
#------------------------------------------------------------------*
# (script Perl pour environement M$ et
UNIX-LIKE)
*
# créé par alain Adelmar (2008.11) à
Pessac 6 rue de Tunis 33600 *
#*******************************************************************
# $ID$:
# - Excellent conçu pour les gros site (>1000
pages)
*
# la meilleur version car elle fonctionne- enormisime - Alain A
# version utf8- encore beaucoup de controle. Il fonctionne
# AAAA-pour Alain Adelmar Alias Asynchrone - AhAhAhAh!
my $script = "vv2l.pl";
my $vers = "6.6";
#$Author: alain $:"Adelmar Alain";
my $moi = 'Adelmar Alain <aadelmar@numericable.fr';
#use strict;
use File::Copy;
#use warnings;
use Cwd;
my $dir = cwd;
print "dir vaut :$dir\n";
use locale;
(my $sec,my $min,my $heure,my $mjour,my $mois,my $annee,my $sjour,my
$ajour,my $isdst) = localtime(time);
my @lssjour = qw( Dim Lun Mar Mer Jeu Ven Sam);
my @lssmois = qw ( Janvier Fevrier Mars Avril Mai Juin Juillet Aout
Septembre Octobre Novembre Decembre );
my $french_date_now = "$lssjour[$sjour] $mjour $lssmois[$mois] " .
($annee+=1900) . " - $heure:$min:$sec";
my $fr_date_now = $french_date_now;
my $datenum = 0;
my $fr_dt_file = my $fr_date_file = "";
my @tmpstat = "";
my $mode = 8;
my $format_d = 0;
print "date/heure: $fr_date_now\n";
my $lx = "*-" x 25;
my $file = $0;
print "file vaut $file\n";
$fr_date_file = datefinefile($file, $mode, $format_d);
$file = "";
my $head_lbl= "script $0\nécris par $moi\nle
$fr_dt_file\nexecuter le $french_date_now\n";
my $head_lbl_console = "$lx\nscript:
$0\nle $fr_dt_file\nécris par: $moi\nexecuter le:
$french_date_now\n$lx\n";my $fr_num_file = my $nwligne = "";
my $gnus = 0;
my %pf = my %h_tencre = my %h_tag = my %h_rootf = my %h_lnkhttp = my
%h_lnkftp = my %h_fst = "";
my $f = my $fout = my $resp = my $rootfile = my $e = my $tout = my
$contenu = my $l = "";
my $d = my $srep = my $flg = my $rootfile_file = my $newsite = my
$path_tmp = "";
my @contenu = my @pathf = my @ligne = my @nwcopim = my @nwcontenu
= my @val = ();
my $value = my $key = my $ext = my $hdl_file = my $troncfile = my $line
= my $email = "";
my $recap_lbl= "$0 écris par $moi \nle $fr_date_file\nexecuter
$fr_date_now\n";
my @cop = my @nwcop = ();
my @ls_other_file = my @ls_file_meta = my @files = my @ls_tencre = ();
my $kf = my $err = my $ef = my $j = my $ere = my $ht = my $q = my $body
= 0;
my $u = my $i = my $ouvert = my $tronquage = my $index = my $tz = my $k
= my $v = 0;
my $b = my $hf = my $pa = my $repu = "";
my $slx = "\n\n\n\n\n\n\n\n\n\n$lx"; # pour eviter le clear
ou autre system nettoyage ecran
my $argv = "noting";
my @vh = values(%pf);
# pour l'adressage/les systeme UNIX, Linux, cygwin ou autre (/) et ceux
de M$ (\)
my @gnul = ( "\\", "\/"); #pas mal because $slash sera
toujours bon, je suis trop fort
my $cong= "this is a real gnu OS, congratulation\n";
if ($dir =~ /^\//) {
$gnus++;
}
my $slash = $gnul[$gnus];
# -----------traitement argument - dossier a traiter et verification $d
valide------ debut
if (@ARGV) {
if ($ARGV[0] =~ /^-/) {
$ARGV[0] =~ s/-()/($1)/;
($argv = "c") if ($ARGV[0]=~ /^c/); #
pour complet
($argv = "g") if ($ARGV[0]=~ /^g/); #
pour gros site ou paquets de feuilles
($argv = "u") if ($ARGV[0]=~ /^u/); #
pour update
($argv = "l") if ($ARGV[0]=~ /^l/); #
pour light
($argv = "o") if ($ARGV[0]=~ /^o/); #
pour ortographe
if ($ARGV[1] ne "") {
$d = $ARGV[1];
$srep = $ARGV[2];
&verifd;
}
}
else {
$d = $ARGV[0];
$srep = $ARGV[1];
&verifd;
}
}
else {
print "usage: $script [-cou] [dossier_a_traiter]
[sous-dossier_image]\n(made by $moi\n";
#---------demander quel repertoire traiter et verifier si il
existe
print "$lx$lx\n";
print "Indiquez le dossier a traiter:\n";
chomp($d =<STDIN>);
&verifd;
}
#-----------------------------------------------------------------------------
fin
#--------------- initialisation des variables -------------------------
debut
my @copim = my @lines = my @nwlines = ();
my @nieme = ("zorro", "premier", "deuxieme", "troisieme", "quatrieme");
my $userx = "";
my $e_mailp = 'aadelmar@numericable.fr';
my $etlencre = my $fp = my $ff = my $fe = 0;
my $fileo = my $fileso = "";
my $encre = my $lnknet = my $lnkbrut = my $lnkbrt = my $lnkt = "";
my $cnta = my $cntlnkhttp = my $cnttl = my $encre_vue = my $cntlnkftp =
0;
my $z = my $eb = my $fr = my $ea = 0;
my $firstline = "Editer par le script $script vers:$vers ce jour
$fr_date_now :\n";
my $psr = "Veuillez ré-entrer le nom simple du sous
répertoire: expl: image\nil aura comme path $d\/image ou passer
en tapant Enter\n";
my $psr1 = "avez vous un sous-repertoire (pour les photos, icones,
etc)\nsi oui lequel: (expl: images)\n";
my $x_down = " " x 47;
# $x_down = ("*-" x 24) .
"||";
#
fioritures qui soulignes
my $y = "__-__*" x
15;
#
idem pour différencier
my $al = "\t| === A_l_a_i_n -\/\/-
A_d_e_l_m_a_r === ||";
# pub perso
#--- explication pour l'utilisateur
my $lblo = "\n\tCe script $script va controler et réparer les
liens locaux de chaque page HTML\n\tSans pour cela toucher à
votre dossier de page-perso\n\til placera l integralite de son travail
dans le repertoire courant\n\tdans un dossier nommer:\.\/newsite\n";
#----------------- sortie formatée pour l'affichage
fichiers/tags --------- ok
format STDOUT_TOP =
Page @<<
$%
n
lien
n
lien
===
===============================
===
==============================
.
$rootfile_file = "vrl";
$hdl_file = "VRL";
my $o_ext = "log";
&ouvre_file($rootfile_file, $hdl_file, $o_ext);
#création et ouverture d'un rep temporaire pour placer le
nouveau site -------------- debut
$newsite = "$dir$slash" . "newsite";
print "le newsite sera adresser comme : $newsite\n";
&faitmoitmp; #johnny, johnny
# $path_tmp = "$tmp" . "$slash"; # cette ligne existe deja dans
&faitmoitmp
print "$lx$lx\n";
#vrl est ouvert pour un log de constat d'encre possible en local
&traite_d;
&recup_all_tags;
#-------------------------------(1 à partir de là on
à tous les liens possible
# stocké dans les hashages %h_tencre, %h_fst, %h_tag et %h_rootf
&onyva;
sub onyva {
# passe en revue page/page, ligne/ligne, $lien/lien les copie
crées dans $path_tmp
opendir RC, "$path_tmp" or die "Ouverture de $path_tmp
impossible $!";
@files = (sort readdir RC);
foreach $file(@files) {
next if ($file =~ /\.log$/g);
$fr_date_file = datefinefile($file, $mode,
$format_d);
#($troncfile, $ext)=split(/\./, $file);
#$rootfile_file = "rap_$troncfile";
#$hdl_file = "RAP";
#my $o_ext = "log";
#&ouvre_file($rootfile_file, hdl_file, $o_ext);
print "$firstline$lx\n";
#----------------------------------------------a
là
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
$kf++;
print "$lx\nCe fichier est le $kf eme
que vous traité\n";
# faire ici le passage en pause
($troncfile, $ext)=split(/\./, $file);
$rootfile_file = "rap_$troncfile";
$hdl_file = "RAP";
my $o_ext = "log";
&ouvre_file($rootfile_file,
$hdl_file, $o_ext);
# attention de pas confondre rootfile
ext et encre avec celle des liens
$rootfile = $ext = $encre = "";
$countpfl = $countpl = 0;
print "$lx\n";
&controle_file($file);
&reparation($file);
&compte_rendu;
#close FSR || die "Fermeture de fsr
impossible $!";
push @rep, $file;
}
}
close RAP || die "far toi encouler granda connassa rap $!";
closedir RC || die "Fermeture de $path_tmp impossible (putain de
merde) $!";
#-------------------------------------------------------------------fin
}
sub controle_file {
my ($file) = @_;
#initialisation des variables
my @contenu= "";
$filesrc = "$path_tmp" . "$file";
$fr_date_file = &datefinefile($file, $mode, $format_d);
print RAP "\t$lx\n$file du $fr_date_file\n";
#----------------------------------
open FI, "$filesrc" or die "Ouverture du fichier $file
impossible $!";
@contenu = <FI>;
close FI || die "Fermeture impossible $!";
$countpl = 0;
#--------------------------- voila regler ca et fermer les
fichier ouverts
foreach $line(@contenu) {
$countpl++; #compteur de
ligne par file
$fl = "file: $file \|ligne:$countpl ";
#ok preindication file origine ligne (pour RAP_a)
$flplus = "$fl :lnknet:$lnknet encre:$encre
rootfile:$rootfile ext:$ext\n"; # ceci n'est pas
initialisé a deplacer
$countpfl = 0; # ok
initialise compteur par lien de la ligne
@ls_m = ($line =~ /href=\"(.*?)\"\>/ig);
foreach (@ls_m) {
$j++; # que fait ce $j?
$corrompu = $etlencre = 0;
$encre = "";
$lnkbrut = $_;
# ok compteur par liens dans la ligne (3
max)
$countpfl++;
# a degager quand tout tourne ca c'est
du bla bla
$oldlb = $lnkbrut;
$q++; #numero
unique du lien
print RAP "$lx\n$fl lien brut: $lnkbrut
c\'est le $nieme[$countpfl]\n";
$err = "err $fl lkb:$lnkbrut l: $countpl
n: $countpfl\n";
print "$lnkbrut\t$countpl\n";
if ($lnkbrut=~ /^mailto/) {
($kk, $email) = split(/:/,
$lnkbrut);
($login, $fai) = split(/\@/,
$email);
$cnta++;
$eb++;
$v++;
print RAP "login = $login et
fai = $fai\n";
#------------------------modification perso
if ($email =~
/^a.?adelmar\@numericable\.fr/) {
$e_mailp =
"aadelmar\@free\.fr";
print RAP
"erreur adresse corrigé $email deviens $e_mailp\n";
$ea++;
$line =~
s/()\Q$email\E()/$1$e_mailp$2/;
$v++;
# a saquer
because c'est line qu'il faut modifier
$nwline = $line;
print "line:
$nwline\n";
#$nwmot =
s/()$email()/($1)$e_mailp($2)/;
print "modif
d'adresse mail effectué sur $file fraction de ligne $mot
$countpl\n";
}
push @adressemail,
"$login\@$fai";
&chklnk;
$v++;
}
#--------lien vers news-groupes
trouvé
elsif ($lnkbrut=~ /^news/) {
($kk, $nws) =split(/:/,
$lnkbrut);
print RAP "news-groupes
trouvé $nws\n";
$eb++; #pas sur
&chklnk;
$v++;
}
#--------------------http
elsif ($lnkbrut=~ /^http:\/\//i) {
$encre ="";
($lnkhttp, $encre) =
split(/\#/, $lnkbrut);
$cntlnkhttp++;
$prlnkhttp = "$file
ligne:$countpl\t$lnkhttp\t$encre";
push @lnk_http, $prlnkhttp;
# ou en hashage
$h_lnkhttp{"$lnkhttp" .
"_$cntlnkhttp"} = $encre;
$eb++; #pas sur
$encre= "";
&chklnk;
$v++;
}
#------------------ftp
elsif ($lnkbrut=~ /^ftp:\/\//i) {
$encre= "";
($lnkftp, $encre) =
split(/\#/, $lnkbrut);
$cntlnkftp++;
$prlnkftp = "$file
ligne:$countpl\t$lnkftp\t$encre";
push @lnk_ftp,
$prlnkftp;
#-------------- ou en hashage
$h_lnkftp{"$lnkftp" .
"_$cntlnkftp"} = $encre;
$eb++; #pas sur
$encre= "";
&chklnk;
$v++;
}
#-------------------local (ce qui nous
interresse)
#-----------------------------------------------------------------ici
else {
SCONTROL:if (exists ${{reverse
%h_tencre}} {$lnkbrut}) {
# *CB1 tout bon
print RAP " *CB1 good tb $lnkbrut n\:$q
nc\:$v\n";
$v++;
$eb++;
}
# *CB2
elsif (exists ${{reverse
%h_fst}} {$lnkbrut}) {
print RAP " *CB2
good vfile $lnkbrut n\:$q nc\:$v\n";
$v++;
$eb++;
}
# *CB3(2/2) peut etre le
lien ne pointe que sur encre
elsif (exists ${{reverse
%h_tag}} {$lnkbrut}) {
# *CB3(1) si le nom de la page + le lien
colle-------------------------pass 3 ok--v
if(exists
${{reverse %h_tencre}} {"$file" . "$lnkbrut"}) {
print RAP " *CB3(1) good sf $lnkbrut nlien\:$q nc\:$v\n";
$v++;
$eb++;
}
#------------------------------------------------------------------------------°
# sinon
else {
# *CB3(2)
print "ceci est fortement
improbable mais votre lien $lnkbrut doit etre reparrer\nufull:\n";
print RAP " *CB3(2) good sf
$lnkbrut nlien\:$q nc\:$v\n";
&utilisateur_full;
}
}
# *CB4 --apres la moulinette a bon liens on entre
dans le vif------
elsif ($lnkbrut =~ /[\/]|[\\]/) {
# if ($lnknet =~ /[\/]|[\\]/) {
$ef++;
$v++;
print RAP " *CB4a part a dp $lnkbrut
nlien\:$q nc\:$v\n";
°age_path;
}
else {
# assignation des valeurs lnknet et encre et
stockage des parametres existants
$ere++;
&decortique_file;
$fl = "file: $file \|ligne:$countpl ";
$flplus = "$fl :lnknet:$lnknet encre:$encre
rootfile: $rootfile ext:$ext\n";
print RAP " *CB4 $flplus\n";
#
*CB4b(2/2)------------------------------------------------------------|
pass 2 ok --v
if ($lnkbrut=~ /^\#/) {
$lnkbrut = "$file" . "$lnkbrut";
print RAP "*CB4b $lnkbrut
nlien\:$q nc\:$v\n";
#---------------------------------------------------------------------------°
# *CB4b1
if (exists ${{reverse %h_tencre}}
{$lnkbrut}) {
print RAP "$flplus
fff encre seule a reparrer $lnknet deviens $lnkbrut\n";
&utilisateur_full;
$v++;
print RAP "*CB4b1
$lnkbrut nlien\:$q nc\:$v\n";
goto SCONTROL;
}
else {
#---------------------------------------------------------------------|pass
2
ok --v
# *CB4b2
print RAP "*CB4b2
$flplus commence par dieze mais encre pas bonne $lnkbrut\n";
$etlencre= 1;
$lnknet = $file;
($rootfile,
$ext)=split(/\./, $lnknet);
&utilisateur_fe;
$v++;
goto SCONTROL;
}
#--------------------------------------------------------------------------------------°
}
# *CB4c ici on ce rend compte que file est
bon mais y a autre chose qui pourri le lien
elsif (exists ${{reverse %h_fst}} {$lnknet}) {
my $q = 0;
@val= ();
@tr_encre_pf= ();
@val = (values (%h_tencre));
foreach (@val) {
($lknet_tmp,
$encre_tmp)= split(/\#/, $_);
if ("$lnknet" eq
"$lknet_tmp") {
if($encre_tmp eq "") {
$rl = "$lknet_tmp";
}
else {
$rl = "$lknet_tmp" . "\#" .
"$encre_tmp";
}
push @tr_encre_pf, $rl;
$q++
}
}
print "$lx\n$flplus Pas bon\t
$lnknet\t $encre :\n *CB4c \n";
$y = 0;
$a = $b = "";
$na = $nb = 0;
@tr_encre_pf = sort @tr_encre_pf;
for (0 .. (@tr_encre_pf/2)) {
for $i(0..1) {
$u = $y + $i;
#$pf{$i} = "$tr_file[$u]";
$pf{$i} = $tr_encre_pf[$u];
}
$a = $pf{0};
$na = $u - 1;
$b = $pf{1};
$nb = $u;
write;
#print "\t$_\t$y\n";
$y += 2;
}
print "[enter] suprimera l encre
mais pas le liens\n";
chomp($encru = <STDIN>);
# *CB4c1 passe
if ($encru eq "") {
print "rien ne sera
fait\n";
$lnkbrut = "$lnknet";
print RAP " *CB4c1
$lnkbrut nlien\:$q nc\:$v\n";
$v++;
}
# *CB4c2 chiffre entrer
-------------------------------------------- |pass 1 ok-----v
elsif($encru =~/^\d/) {
print RAP "votre
choix num qui vaut $tr_encre_pf[$encru]\n";
print "votre choix
num qui vaut $tr_encre_pf[$encru]\n";
$lnkbrut =
$tr_encre_pf[$encru];
print RAP " *CB4c2
$lnkbrut nlien\:$q nc\:$v\n";
$v++;
&chklnk;
goto SCONTROL;
}
#-----------------------------------------------------------------------------------°
# *CB4c3 encre entrer a la main
elsif($encru=~ /^\w/) {
print RAP "vous avez
entrer la chaine $encru\n";
print "vous avez
entrer la chaine $encru\n";
$lnkbrut = "$encru";
print RAP " *CB4c3
$lnkbrut nlien\:$q nc\:$v\n";
&chklnk;
$v++;
goto SCONTROL;
}
print "ici la fin du buzz
encre\n";
}
# *CB4d ici on se rend compte que c'est
l'extention qui daille
elsif (exists ${{reverse %h_tencre}}
{"$rootfile\.html\#$encre"}) {
print RAP "ok c'etait l'extention
qui daillait, donc ext=html\n";
print RAP "gagne lien vers encre
du meme fichier $lnkbrut nlien\:$q nc\:$v\n";
$lnkbrut =
"$rootfile\.html\#$encre";
print RAP " *CB4d $lnkbrut
nlien\:$q nc\:$v\n";
&chklnk;
$v++;
}
# *CB4e ici on se rend compte que c'est
l'extention qui daille
elsif (exists ${{reverse %h_fst}}
{"$rootfile\.html"}) {
print RAP "*CB4e $fl : ici c'est
rootfile qui est ok\n";
#
*CB4e1-----------------------------------------------------| pass 5 ok
---v
if($encre == 0) {
$lnkbrut =
"$rootfile\.html";
print RAP " *CB4e1
$lnkbrut nlien\:$q nc\:$v\n";
print RAP "gagne lien
vers $lnkbrut nlien\:$q nc\:$v\n";
&chklnk;
$v++;
}
#---------------------------------------------------------------------------°
# *CB4e2
else {
# si cette
construction est infructueuse faire lnknet=rootfile.html =>ufe
$lnkbrut =
"$rootfile\.html\#$encre";
print RAP " *CB4e2
$lnkbrut nlien\:$q nc\:$v\n";
print RAP "aurai du
etre traiter en CB4d look that $lnkbrut gagné $v\n";
&chklnk;
$v++;
goto SCONTROLE;
}
}
# *CB4f ici il n'y a que rootfile qui matche
elsif (exists ${{reverse %h_rootf}}
{$rootfile}) {
print "quel lien match,
choisissez:\n";
$i = 0;
while ( ($key, $value) = each
%h_rootf) {
if($value eq
$rootfile) {
$ch_ext = $key;
($kk, $ext_tmp)= split(/:/,
$ch_ext);
push @ls_ext, $ext_tmp;
print "pour $rootfile\.$ext_tmp
taper $i\n";
}
$i++;
}
$resp= <STDIN>;
chomp $resp;
$lnkbrut = "$rootfile\." .
$ls_ext[$resp];
print "vous avez valider
$lnkbrut\n";
print RAP " *CB4f $lnkbrut
nlien\:$q nc\:$v\n";
&chklnk;
$v++;
goto SCONTROL;
}
# *CB4g
else {
# si il y a une encre
(reparrer)et aussi un faux nom de fichier creer un if
# $p++;
#
*CB4g1----------------------------------------------------------------------Pass
4
ok --v
if ($encre eq "") {
# Dernier else | sans
encre ce liens part a uf: code erreur "desauf"
print "$lx
desauf\n$flplus\n";
print RAP " *CB4g1
(mais pas sorti) $lx desauf\n$flplus\n";
&utilisateur_f;
}
#--------------------------------------------------------------------------------°
# *CB4g2
--------------------------------------------------------------------Pass
6
ok--v
else {
# choisir un fichier
puis une encre
# Dernier else num:
$p| avec encre ce liens part a ufull: code erreur deaafull
print "$lx
deaafull\n$flplus\n";
print RAP "*CB4g2 $lx
deaafull\n$flplus\n";
&utilisateur_full;
#-----------------------------------------------------------------------------------°
}
}
}
}
}
# $j = 1; # $j est le compteur de liens total
push @nwcontenu, $line;
}
}
#-----------------------------Recup_all_tags----------------------------
debut
sub recup_all_tags {
# --le handle est pour RAP
foreach $likef(@nwlsfile) {
$cf++; #compteur de fichiers
next if ($likef=~ /^\./);
$file = $likef;
$encre_vue = 0;
# re-ajouter le path au nom de fichier
$ftagsrc = "$path_tmp$slash$file";
# vérif mode (html, tml, htm, xml, etc..)
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
$fr_date_file = datefinefile($file,
$mode, $format_d);
(push @ls_h_fst, $file) unless (
scalar(grep(/$file/, @ls_h_fst)) );
(push @ls_tencre, $file) unless (
scalar(grep(/$file/, @ls_tencre)) );
@lines = @nwlines = "";
open FT, "$ftagsrc" or die "Ouverture du
fichier $file impossible $!";
binmode(FT);
$lpp = 0;
@lines = <FT>;
close FT || die "Fermeture impossible
$!";
# reconstruit les balises
tronquées et sort sur @nwlines
@nwlines =
&reconstruire_ligne(@lines);
foreach $line(@nwlines) {
print "line\n";
if ($line =~
/<body\>/i) {
$body = $lpp;
# discutable si &cherche_encre pas $tz++
et vice versa
&cherche_encre($line);
$tz++;
push @copim,
$line;
$lpp++;
}
else {
print "je vais passer a cherche_encre\n";
&cherche_encre($line);
push @copim,
$line;
$lpp++;
}
}
# tout ce qui suit est faut jusqu'a
&faitdcopies, mais pas grave car ne peut etre utiliser - a saquer
if ($encre_vue == 0) {
if ($argv eq "c") {
#
$copim[$body].= "<a name=\"_top\"\>\n"; # je ne comprend pas
cette ligne surement une erreur
$copim[$body] = "<a name=\"_top\"\>\n";
print VRL "pour
voir body trouvé\n$copim[$body]\n";
}
else {
# ce else est
à degagez quand testé
print VRL "pour
voir body trouvé\n$copim[$body]\n";
}
}
if ($argv eq "u") {
$copim[$body] .= "\n<--
mise à jour du document par $script le $fr_date_now
\ninitialement daté du " . $fr_date_file . "\n";
print VRL "pour voir body
trouvé\n$copim[$body]\n";
}
&faitdcopies;
@copim = "";
@nwlines = "";
# detail des encres trouvées par
fichiers
print VRL "\npour $file $encre_vue encre
trouvé\/s\nDétail:\n";
#while ($une_encre =
shift(@ls_encre_pf)) {
# print VRL ("\t$une_encre\n");
#}
}
else {
# on ne sait jamais peut etre un lien
fait reference à un script donc
# attention
(push @ls_h_fst, $file) unless (
scalar(grep(/$file/, @ls_h_fst)) );
(push @ls_tencre, $file) unless (
scalar(grep(/$file/, @ls_tencre)) );
}
}
#---passage de la liste contenant tous les liens @ls_tencre au
tableau de hashage %h_tencre
# ote les doublons
my $i = 0;
foreach $el (@ls_tencre) {
$tmp{$el} = $i++;
}
@ls_tencre = keys %tmp;
@ls_tencre = sort(@ls_tencre);
foreach (@ls_tencre) {
$h_tencre{$i_h_tencre} = $_;
$i_h_tencre++;
}
#--- idem pour les encres seules
@ls_encre_pf = sort(@ls_encre_pf);
foreach (@ls_encre_pf) {
$h_tag{$i_h_tag} = $_;
$i_h_tag++;
}
#--- idem pour les fichiers seul
@ls_h_fst = sort(@ls_h_fst);
foreach (@ls_h_fst) {
$h_fst{$i_h_fst} = $_;
$i_h_fst++;
}
#----------a degager quand pris en compte---voici les trois
hachage
print VRL "\n$lx\nvoici les trois hachage:\n$lx\nh_tencre\n";
foreach $key (sort keys %h_tencre) {
$val = $h_tencre{$key};
print VRL "\t$val\n";
}
print VRL "\n$lx\nh_fst\n";
my $i= 0;
while (($zo, $ht) = each %h_fst) {
($rootf, $ext)= split(/\./, $ht);
$h_rootf{"$i:$ext"}= $rootf;
print VRL "\t$zo:$ht\n";
}
print VRL "\n$lx\nh_tag\n";
while (($zo, $htag) = each %h_tag) {
print VRL "\t$zo:$htag\n";
}
print VRL "\n$lx\n$moi vous remercie d\'utiliser $script
vers:$vers \n- $fr_date_now\n";
#-----------------------------------
close VRL || die "double dremmer closure of $flg not
possibilé $!";
}
#---------------------------------------------------------------------------------
fin
sub cherche_encre {
my ($line)= @_;
if ($line=~ /<a\sname=\"(.*?)\"/i) {
$tag = $1;
$encre_vue++;
$fz = "$file#$tag";
push @ls_tencre, $fz;
push @ls_encre_pf, "#$tag";
$tz++;
print "encre tttrouvée ||| $tag|\n";
}
# si aucune encre trouvé peut etre interessant...
}
#---------------------------------------------------------- debut
sub reparation {
my ($file)= @_;
$fcible = "$path_newsite" . "$file";
open FR, ">$fcible" or die "Ouverture de $fcible impossible
$!";
print FR @nwcontenu;
#réinitialisation des listes par fichiers
@nwcontenu = ""; # ou @nwcontenu = @nwl = "";
close FR || die "Fermeture de $fcible impossible $!";
}
sub utilisateur_f {
$userx = "f";
@val =();
$a = $b = "";
# @valalpha = ""; #en prevision du tri des concordances
(voir 5 lignes plus bas)
print RAP "uf:Ce liens n a pas de corresp $lnkbrut il par a
user\n";
# print "Choisissez un fichier vers lequel $lnkbrut pointera\n";
print "$lx\nChanger fielname: $lnkbrut [num]|[Enter]|[q]
quitter\n";
@val = (values (%h_fst));
@val = (sort @val);
# # trier par ordre alphabétique par concordance, si
option -l activé--------
# if ($argv eq "l") {
# $deb_lkbrut = substr($lnkbrut, 0, 1);
# foreach $element(@val) {
# my $deb_ancre = substr($element, 0, 1);
# (push @valalpha, $element) if
($deb_ancre eq $deb_lkbrut);
# }
# }
# if (@valalpha ne "") {
# @val = @valalpha;
# }
#
#----------------------------------------------------------------------------
$i = 0;
$pair = 0;
$ff++;
foreach (@val) {
$lknet_tmp = $_;
$max = 40;
DEBF:if($pair == $max) {
®arder($userx);
}
else {
if($pair%2 == 0) {
$na = $i;
$a = $lknet_tmp;
if($lknet_tmp eq
"$val[$#val]") {
$b = "n\/a";
write;
}
$i++;
$pair++;
}
else {
$nb = $i;
$b = $lknet_tmp;
write;
$pair++;
$i++;
}
}
}
®arder($userx);
}
sub utilisateur_fe {
$userx = "fe";
@val =();
$a = $b = "";
# @valalpha = ""; #en prevision du tri des concordances
(voir 5 lignes plus bas)
# ligne dessous a saquer quand bon
print RAP "fe:pas de corresp pour $lnkbrut il par a user\n";
# print "Choisissez une encre vers lequel $lnkbrut pointera\n";
print "$lx\nChanger ancre: $lnkbrut [num]|[Enter]|[q] quitter\n";
@val = (values (%h_tencre));
@val = (sort @val);
# # trier par ordre alphabétique par concordance, si
option -l activé---------
# if ($argv eq "l") {
# $deb_lkbrut = substr($lnkbrut, 0, 1);
# foreach $element(@val) {
# my $deb_ancre = substr($element, 0, 1);
# (push @valalpha, $element) if
($deb_ancre eq $deb_lkbrut);
# }
# }
# if (@valalpha ne "") {
# @val = @valalpha;
# }
#
#-----------------------------------------------------------------------------
$pair = 0;
$i = 0;
foreach (@val) {
#---pour limiter a lnknet
$value = $_;
($lknet_tmp, $encre_tmp)= split(/\#/, $_);
if($lknet_tmp eq $lnknet) {
$max = 40;
DEBFE:if($pair == $max) {
®arder($userx);
}
else {
if($pair%2 == 0) {
$na = $i;
$a = $value;
if($value eq
"$val[$#val]") {
$b = "n\/a";
write;
}
$i++;
$pair++;
}
else {
$nb = $i;
$b = $value;
write;
$pair++;
$i++;
}
}
}
}
®arder($userx);
}
sub utilisateur_full {
$userx = "full";
@val = ();
$a = $b = "";
# @valalpha = ""; #en prevision du tri des concordances
(voir 5 lignes plus bas)
print RAP "ufull:Ce liens n a pas de corresp $lnkbrut il par a
user\n";
print "$lx\nChanger lien: $lnkbrut [num]|[Enter]|[q] quitter\n";
@val = (values (%h_tencre));
@val = (sort @val);
# # trier par ordre alphabétique par concordance, si
option -l activé---
# if ($argv eq "l") {
# $deb_lkbrut = substr($lnkbrut, 0, 1);
# foreach $element(@val) {
# my $deb_ancre = substr($element, 0, 1);
# (push @valalpha, $element) if
($deb_ancre eq $deb_lkbrut);
# }
# }
# if (@valalpha ne "") {
# @val = @valalpha;
# }
#
#----------------------------------------------------------------------
$i = 0;
$pair = 0;
foreach (@val) {
$value = $_;
$max = 40;
DEBFULL:if($pair == $max) {
®arder($userx);
}
# ceci affiche les valeurs $values et les chiffres
represantant les valeur indexés sur $i
else {
if($pair%2 == 0) {
$na = $i;
$a = $value;
if($value eq "$val[$#val]") {
$b = "n\/a";
write;
}
$pair++;
$i++;
}
else {
$nb = $i;
$b = $value;
write;
$pair++;
$i++;
}
}
}
®arder($userx);
}
sub faitdcopies {
# les copies de fichier en meta langage doivent etre copier dans
/newsite_x/tmp
$copie = "$path_tmp" . "$file";
#&reconstruire_ligne;
print VRL "fichier $file,de $j lignes dont $k ligne href
couper\n";
open FC, ">$copie" or die "Ouverture de $copie impossible $!";
print FC "@nwlines";
#print FC "@copim";
#---
if ($argv eq "u") {
print FC '<!-- fichier initial ' . "$file
daté du $fr_date_file" . ' -->';
}
close FC || die "Fermeture de $copie impossible $!";
@copim = "";
@nwlines = @lines = "";
$z++;
}
#------------------------------------------------------------------------verifd
sub verifd {
unless (-e $d) {
print "Veuillez ré-entrer le chemin complet
du dossier à traiter, expl:" . '/home/pub/monsite ou
//perl//pub//toto' . "\n";
chomp($d = <STDIN>);
}
}
sub traite_d {
#-----------ouverture lecture, assignation @lsfile, controle
srep != sous_rep
opendir R, "$d" or die "Ouverture de $d impossible $!";
my @lsfile = (sort readdir R);
closedir R or die "Fermeture du repertoire R impossible $!";
foreach $file(@lsfile) {
if ($file =~ /^\./) {
print "voulez vous traiter ce fichier
[o,n](n): $file\n";
$point = <STDIN>;
chomp $point;
if($point =~ /^o/i) {
push @ls_other_file, $fichiercible;
}
}
# vérifier si un rep est $srep (donc juste
rep_rootname ou plus bas) et le traiter à la place de
&faitmoitmp
if (-d "$d$slash$file") {
my $sous_rep = $file;
# vérifier si un rep est $srep
(donc sous la forme /home/pub/foo/bar)et le traiter à la place
de &faitmoitmp
#demander a user si on traite $sous-rep
}
else {
my $fichiersource = "$d$slash$file";
#print "$lx\navant copy fichiersource
vaut $fichiersource\n";
my $fichiercible = "$path_tmp$file";
#print "$lx\napres copy fichiercible
vaut $fichiercible\n";
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
push @h_fst, $file;
push @ls_file_meta, $fichiercible;
copy($fichiersource, $fichiercible) or die
"impossibilité de copier $fichiersource sur $fichiercible $!";
}
else {
push @h_fst, $file;
my $fichiercible = "$path_newsite$file";
push @ls_other_file, $fichiercible;
copy($fichiersource, $fichiercible) or die
"impossibilité de copier $fichiersource sur $fichiercible $!";
}
#copy($fichiersource, $fichiercible) or
die "impossibilité de copier $fichiersource sur $fichiercible
$!";
# exec dos2unix "$d$slash$file"; # voir
si ca marche
push @nwlsfile, $file;
}
}
# rend compte sur VRL
print VRL "\n$lx\nliste des fichiers meta que recup_all
recopiera dans $path_tmp\n";
foreach (@ls_file_meta) {
print VRL "$_\n";
}
print VRL "\n$lx\nliste des autre fichiers que recopier dans
$path_newsite\n";
foreach (@ls_other_file) {
print VRL "$_\n";
}
print VRL "\n$lx\n";
}
#---------- choix du repertoire temporaire-------------\
sub faitmoitmp {
my $q = 0;
if (-e $newsite) {
while (-e $newsite) {
$q++;
$newsite = "$dir$slash" . "newsite" .
"_$q";
}
mkdir $newsite or die "ouverture de $newsite
impossible $!";
}
else {
mkdir $newsite or die "ouverture de $newsite
impossible $!";
}
$tmp = "$newsite$slash" . "tmp";
mkdir $tmp or die "création de $tmp impossible $!";
$path_tmp = "$tmp$slash";
$path_newsite = "$newsite$slash";
# ca ne veut rien dire si $srep est du style /home/pub/image ca
marchera pas
if (defined $srep) {
if ($srep =~ /\w$/i) {
$srep = "$path_newsite" . "$srep";
mkdir $srep or die "ouverture de $srep
impossible $!";
}
}
print "Un dossier newsite contiendra vos pages
corrigées\net $slash" . "newsite$slash" . "tmp contiendra les
logs de synthése\n";
}
#--------------------------sous procedure qui modifie les portions de
ligne
sub chklnk {
if($corrompu == 0) {
$line =~ s/()\Q$oldlb\E()/$1$lnkbrut$2/;
$oldlb = $lnkbrut;
$corrompu++;
}
else {
$line =~ s/()\Q$oldlb\E()/$1$lnkbrut$2/;
$oldlb = $lnkbrut;
}
# $line =~ s/$oldlb/$lnkbrut/xmg;
# $line =~ s/()\Q$oldlb\E()/$1$lnkbrut$2/;
}
#---------------------------------------------------------------degage_path
sub degage_path {
print RAP "DP: path trop long $err\n";
&decortique_file;
while ($lnknet =~ /$slash/) {
@pathl = split(/$slash/, $lnknet);
$fpointe = pop @pathl;
# $presquesrep = pop @path1;
# ($fpointe = $presquesrep) if ($presquesrep=~
/$srep$/); # laisse srep dans le nom si il exsiste
if ($encre gt "") {
$lnknet = $fpointe;
$lnkbrut = "$lnknet" . "\#$encre";
print RAP "Correction faite $lnkbrut par
dp\n";
print "Correction faite $lnkbrut par
dp\n";
}
#
#------------------------------------------------pass 4 ok -------v
else {
$lnkbrut = $lnknet = $fpointe;
print RAP "Corriger: $lnkbrut par dp\n";
print "Correction faite $lnkbrut par
dp\n";
}
#-----------------------------------------------------------------°
}
$v++;
$fr++;
&chklnk;
goto SCONTROL;
}
# lknet2lnkbrut-----------------debut (ne sert qu'a controler au
debuggage)
sub lknet2lnkbrut {
print RAP "LKNET2LB: etat des liens en entrer:\nln: $lnknet\nlb:
$lnkbrut\n";
if($encre eq "") {
$lnkbrut = "$lnknet";
}
else {
$lnkbrut = "$lnknet" . "\#" . "$encre";
}
&chklnk;
print RAP "LKNET2LB: etat des liens en sortie:\nln: $lnknet\nlb:
$lnkbrut\n$lx\n";
goto SCONTROL;
}
#--------------------------------- fin
#----------------------------------------Compte rendu
---------------------------debut
sub compte_rendu {
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
$file_cr= "$path_tmp" . "frap_" . "$ir.log";
open FRAP, ">$file_cr" or die "Ouverture de
$file_cr impossible $!";
print "$firstline$lx\n";
print FRAP "Liens http de $file trouvé avec
liste:\n";
foreach $lk(@lnk_http) {
print FRAP "adresse Web: $lk\n";
}
print FRAP "\n$lx\navec le hashage maintenant\n";
while ( ($key, $value) = each %h_lnkhttp) {
print FRAP "$key = $value\n";
}
print FRAP "\n$lx\n";
print FRAP "liens ftp de $file trouvé:\n";
foreach $lk(@lnk_ftp) {
print FRAP "adresse ftp: $lk\n";
}
print FRAP "\n$lx\navec hashage now:\n";
while ( ($key, $value) = each %h_lnkftp) {
print FRAP "$key " . "=" . "$value\n";
}
print FRAP "$lx\n$lx\navec le nouveau hashage
h_tencre\n";
while ( ($key, $value) = each %h_tencre) {
print FRAP "$key = $value\n";
}
#-----------login now----
print FRAP "$lx\n\tlogin trouvé:\n";
$login = join("\n", @adressemail);
print FRAP "$login\n";
if($ea >= 1) {
print FRAP "$ea erreurs reparés
par $e_mailp\n";
}
#------------stat
print FRAP "$lx\n";
print FRAP "Sur un total de $cnttl lignes
controler\npour un total de $j liens controler :\n";
print FRAP "$cntlnkhttp liens http: " . "\nnon
controler\n" . "\n$cntlnkftp liens ftp:\nnon controler pour le
moment\n";
print FRAP "Les lnknet maintenant\n";
print FRAP "$j liens controler sur $file\n";
print FRAP "recap total de $j liens:\n$eb bon
adressage\n$ef erreur adressage\n$fr erreur adressage fichier
réparer\n$eb bonne encre\n$ere erreur encre\n$err encre
reparrer\nerreur adresse web $ea\n";
$filos = join("\n", @rep);
print FRAP "effectuer sur les fichiers:\n" .
"\n$filos\n$lx\n"; #ca marche
print FRAP "fait le $fr_date_now\n";
close FRAP || die "dreumer ca bloque $!";
}
# --------------------------------remise a zero de nwlines et
incremente index rapport
@nwcontenu = "";
$ir++;
}
#-------------------------------------------------------------------------------------
fin
#-------------------------------------ouvre_log-- géant
sub ouvre_file {
my ($rootfile_file, $hdl_file, $ext)= @_;
print "dans ouvre_file mon rootfile_file vaut $rootfile_file\n";
my $i = 0;
if ($rootfile_file eq "var_2vvl") {
$flg = "$dir$slash$rootfile_file.$ext";
while (-e $flg) {
$flg = "$dir$slash$rootfile_file" .
"_$i" . ".$ext";
$i++;
}
}
if ($path_tmp eq "") {
$path_tmp = $dir;
}
$flg = "$path_tmp$slash$rootfile_file.$ext";
while (-e $flg) {
$flg = "$path_tmp$slash$rootfile_file" . "_$i" .
".$ext";
$i++;
}
open $hdl_file, ">$flg" or die "Ouverture de $flg impossible
$!";
print $hdl_file "script: $script (V: $vers) - date:
$fr_date_now\n$lx\n";
}
sub regarder {
my $userx = @_;
# print "$lx\nChanger lien: $lnkbrut [num]|[Enter]|[q]
quitter\n";
chomp($repu = <STDIN>);
# si l'user ne veux pas ce prononcer| ou n'est pas dans les 40
propositions pour uf et uef
if($repu eq "") {
#$max = $max + 40;
$pair = 0;
(goto DEBF and undef $repu) if ($userx eq "f");
(goto DEBFE and undef $repu) if ($userx eq "fe");
(goto DEBFULL and undef $repu) if ($userx eq "full");
# if ($userx eq "f") {
# undef $repu;
# goto DEBF;
# }
# elsif ($userx eq "fe") {
# undef $repu;
# goto DEBFE;
# }
# elsif ($userx eq "full") {
# undef $repu;
# goto DEBFULL;
# }
}
elsif($repu =~ /^\d/) {
$lnkbrut = $val[$repu];
print RAP "\n $userx important\n$lnkbrut\n";
$lnkbrt = $lnkbrut;
($lnknet, $encre)= split(/\#/, $lnkbrt);
print "Votre choix valider:\t $lnkbrut\n";
$userx = "";
$v++;
&chklnk;
undef $repu;
goto SCONTROL;
}
elsif($repu =~ /^q$/i) {
$userx = "";
$v++;
print "Ce programme va se fermer, retrouver les log
dans /newsite/tmp \n";
print RAP "Programme $script vers:$vers d\'
$moi\nfermer par utilisateur à $fr_date_now,\nbonne
journée\n";
close RAP || die "far toi encouler granda connassa
rap $!";
closedir RC || die "Fermeture de $path_tmp
impossible (putain de merde) $!";
}
else {
print "Vous avez entrer $repu ca remplacera
$lnkbrut\n";
$lnkbrut = $repu;
$lnkbrt = $lnkbrut;
($lnknet, $encre)= split(/\#/, $lnkbrt);
&chklnk;
undef $repu;
$userx = "";
$v++;
goto SCONTROL;
}
}
sub reconstruire_ligne {
my ($lines) = @_;
# on split tout ca a plat
$tout = "@lines";
@cop = split(//, $tout);
# balise $ouvert = 1 ==> vrai; 0 ==> faux
$ouvert = $tronquage = 0;
@ligne = @nwcop = "";
foreach $e(@cop) {
if ($ouvert == 0) {
$i++;
if($e eq "<") {
# signale qu'une balise est ouverte et
pousse la ligne
$ouvert = 1;
push @ligne, $e;
}
elsif ($e eq "\n") {
# pousse \n dans @ligne puis @ligne dans
@nwcop et réinitialise @ligne
push @ligne, $e;
push @nwcop, @ligne;
@ligne ="";
$i = 0;
}
else {
# pousse le caractère dans la
ligne
push @ligne, $e;
}
}
# un balise à été ouverte donc passage en
ouvert
else {
$i++;
if ($e eq "\n") {
# balise tronquées
$tronquage = 1;
$k++;
}
elsif ($e eq ">") {
$ouvert = 0;
if ($tronquage == 1) {
# si tronqué pousser le caractère dans
ligne et lui ajouter une fin de ligne
# puis remettre à zero $ligne, $tronquage et
ouvert
push @ligne, "$e\n";
push @nwcop, @ligne;
$i = 0;
@ligne = "";
$tronquage = 0;
}
elsif ($tronquage == 0) {
# si il n'y a pas eu de tronquage pousser dans ligne
push @ligne, $e;
}
}
else {
# print "je passe en ouvert quelconque
$i:$e:\n";
# si c'est un caractere quelconque, le
pousser dans ligne
push @ligne, $e;
}
}
}
$contenu = join('', @nwcop);
@nwlines = $contenu;
}
sub decortique_file {
# decortique le nom complet($lnkbrut) en lnknet, encre, rootfile
et ext, sans toucher a lnkbrut et lnknet
$lnkbrt = $lnkbrut;
($lnknet, $encre) = split(/\#/, $lnkbrt);
$lnkt = $lnknet;
($rootfile, $ext) = split(/\./, $lnkt);
}
sub datefinefile {
my ($file, $m_acces, $format_d)= @_;
$datenum = ((stat($file))[$mode]);
(my $sec,my $min,my $heure,my $mjour,my $mois,my $annee,my
$sjour,my $ajour,my $isdst) = localtime($datenum);
if ($mois <= 9) {
$mois= "0" . ($mois+1);
}
if ($mjour <= 9) {
$mjour = "0" . "$mjour";
}
if ($heure <= 9) {
$heure = "0" . "$heure";
}
if ($min <= 9) {
$min = "0" . "$min";
}
if ($sec <= 9) {
$sec = "0" . "$sec";
}
my $cj = $lssjour[$sjour];
my $pj = substr($cj, 0, 2);
my $pm = substr("$lssmois[$mois]", 0 , 3);
if ($annee < 100) {
$pa = $annee;
}
elsif ($annee <=109) {
$pa = "0" . ($annee-100);
}
else {
$pa = ($annee-100);
}
if ($format_d == 1) {
# format differants 1: 20100131-203001
$fr_date_file = ($annee+=1900) .
"$mois$mjour-$heure$min$sec";
}
elsif ($format_d == 2) {
# format differants 2: 31/01/2010-20:30
$fr_date_file = "$mjour\/$mois\/" . ($annee+=1900) .
"-$heure:$min";
}
elsif ($format_d == 3) {
# format differants 2: $fr_datenum_file =
Di-31/01/2010-20:30:02
$fr_date_file = "$pj-$mjour\/$mois\/" .
($annee+=1900) . "-$heure:$min:$sec";
}
elsif ($format_d == 4) {
# format differants: $fr_dt_file = 31Jan10-20h
$fr_date_file = "$mjour$pm" . "$pa" . "-$heure" .
"h";
}
elsif ($format_d == 5) {
# format differants: $fr_dt_file = Di 31 Jan 10 -
20h30
$fr_date_file = "$pj $mjour $pm" . " $pa" . "-
$heure" . "h$min";
}
else {
# format differants: $fr_date_file = Dim 31 Janvier
2010 - 20:30:02
$fr_date_file = "$lssjour[$sjour] $mjour
$lssmois[$mois] " . ($annee+=1900) . " - $heure:$min:$sec";
}
return $fr_date_file;
}
format STDOUT =
@<<<
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
@<<<
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$na, $a, $nb, $b
.
# script Perl écrit par alain Adelmar alias alCoolfort
# ce script repare plus de 9 liens sur 10
END;