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épare les paths absolues
(c'est très souvent le cas), les erreurs d’extensions (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 carrément 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 | extension :
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]
concombre_masqué#la_revanche
[2]
commun.html#avantages
[3]
cri2joie.html#cetait_celui_avant
[4] LaCjusto.html#dessus
votre réponse:
Et bien sûr, vous deviez entrer 2
ou carrément commun.html#avantages ou Enter
pour
passer sans rien modifier soit q pour quitter, parce que 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’être
des liens et les compares au copies de vos fichiers qu'il
créé dans un répertoire ./newsite . Il fait aussi
des comptes rendu de modifs dans des fichiers log. Ça 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 - by asynchrone *
# 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 | 01.04 2009 alain Adelmar Pessac aadelmar@free.fr *
# ------------------------------------------------------- *
# (v: Vaillante De Luxe (Unix-Like - Windows) Alain Adelmar ) ** *
# remd: utilise mon module Datefr pour dater les logs (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.
# AAAA-pour Alain Adelmar Alias Asynchrone - AhAhAhAh!
my $script = "vv2l.pl";
my $vers = "4.3";
#$Author: alain $:"Adelmar Alain";
my $moi = "Adelmar Alain";
# use DateFrench donc installé FrDate.pm dans /Perl/lib ou /usr/lib/perl5x
# use File::Copy; #a voir car cda ne marche pas sur M$
# voir de toute façon la maniere de recopier (binmode et >:utf8 activé)
# use strict;
use File::Copy;
# use warnings;
use Cwd;
$dir = cwd;
print "dir vaut :$dir\n";
use DateFrench;
our $format_affichage = 2;
our $opt_date_file = 2;
our $fr_date_now = maintenant("$format_affichage");
print "$fr_date_now\n";
my $gnus = 0;
my $lx = "*-" x 25;
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 $gnul[$gnus] sera toujours bon, je suis trop fort
my $cong= "this is a real gnu OS, congratulation\n";
if ($0 =~ /[msys|cygwin|linux]$/) {
$gnus++;
print "$cong";
}
elsif ($dir =~ /\//) {
$gnus++;
print "$cong";
}
else {
print "Vous etes sur une machine Petite et Molle (MicroSoft), beuuurk...\n";
print "enfin quoi, sur un OS de merde\n";
print "gnus ne vaut que $gnus, et en plus, vos fichiers sont du style:\n";
print "C:" . "$gnul[$gnus]" . "caca" . "$gnul[$gnus]boudin au lieu de /super/extra\n os: $^O \n";
print "Mais $0 fonctionnera tout de meme sur cette grosse chiote de systeme\n";
}
# -----------traitement argument - dossier a traiter et verification $d valide------ debut
my $d = my $srep = "";
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 = "";
sub regarder($);
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 $ext = my $lnkbrt = my $lnkt = "";
$cnta = $cntlnkhttp = $cnttl = $encre_vue = $cntlnkftp = $z = $ef = $eb = $fr = $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_log = "vrl";
$hdl_log = "VRL";
&ouvre_log;
#création et ouverture d'un rep temporaire pour placer le nouveau site -------------- debut
$newsite = "$dir" . "$gnul[$gnus]" . "newsite";
print "le newsite sera adresser comme : $newsite\n";
&faitmoitmp; #johnny, johnny
# $path_tmp = "$tmp" . "$gnul[$gnus]"; # 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
# 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 ($files =~ /\.log$/g);
$opt_date_file = 1;
our $fr_date_file = datefichier($format_affichage, $opt_date_file, $file);
#($troncfile, $ext)=split(/\./, $file);
#$rootfile_log = "rap_$troncfile";
#$hdl_log = "RAP";
#&ouvre_log;
print "$firstline$lx\n";
#----------------------------------------------a là
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
($troncfile, $ext)=split(/\./, $file);
$rootfile_log = "rap_$troncfile";
$hdl_log = "RAP";
&ouvre_log;
# attention de pas confondre rootfile ext et encre avec celle des liens
$rootfile = $ext = $encre = "";
$countpfl = $countpl = 0;
print "$lx\n";
&controle_file;
&reparation;
&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 {
#initialisation des variables
my (@contenu)= "";
$filesrc = "$path_tmp" . "$file";
$format_affichage = 12;
$opt_date_file = 1;
our $fr_date_file = datefichier();
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
$mot = "href=\"(.*?)\"\>";
@ls_m = ($line =~ /$mot/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\@wanadoo\.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
&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") {
$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
if ($d =~ /"$gnul[$gnus]"$/) {
$ftagsrc = "$d" . "$file";
}
else {
$ftagsrc = "$d" . "$gnul[$gnus]" . "$file";
}
# vérif mode (html, tml, htm, xml, etc..)
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
$format_affichage = 12;
$opt_date_file = 1;
our $fr_date_file = datefichier($format_affichage, $opt_date_file, $file);
@lines = @nwlines =();
open FT, "$ftagsrc" or die "Ouverture du fichier $file impossible $!";
binmode(FT);
$lpp = 0;
@lines = <FT>;
close FT || die "Fermeture impossible $!";
#while (@lines) {
# (push @encref, $encre_t and $encre_t = $1) if (/<a name\=\"()\"\>/);
#}
&reconstruire_ligne;
foreach $line(@nwlines) {
if ($line =~ /<body\>/i) {
$body = $lpp;
&cherche_encre;
push @copim, $line;
$lpp++;
}
else {
&cherche_encre;
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 = ();
# 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 {
$fileo = "$d" . $gnul[$gnus] . "$file";
$fileso = "$path_newsite" . "$file";
# il faut recopier ce qui n'est pas html dans le rep cible et pas dans temporaire
open(LIRE, "$fileo") or die "Ouverture du script ou image $fileo impossible $!";
binmode(LIRE);
open(ECRIRE, ">$fileso") or die "Impossible de creer $fileso $!";
binmode(ECRIRE);
foreach (<LIRE>) {
print ECRIRE $_;
}
close LIRE || die "Fermeture du fichier script/image $fileo imposible $!";
close ECRIRE || die "Fermeture du script/image $fileso impossible $!";
# on ne sait jamais peut etre un lien fait reference à un script donc
$h_fst{$cf}= "$file";
# attention
push @ls_encre_pf, $file;
}
}
#----------a degager quand pris en compte---voici les trois hachage
print VRL "\n$lx\nvoici les trois hachage:\n$lx\nh_tencre\n";
while (($zo, $hf) = each %h_tencre) {
print VRL "\t$zo:$hf\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 {
if ($line=~ /<a\sname="(.*?)"/i) {
$tag = $1;
$encre_vue++;
$fz = "$file#$tag";
$kh = "$cf:$tz";
$h_tencre{$kh}= "$file" . '#' . "$tag";
$h_tag{$kh}= "#" . "$tag";
#push @lsctag, $fz;
push @ls_encre_pf, $tag;
push @ls_encre_pf, $fz;
$tz++;
}
}
#---------------------------------------------------------- debut
sub reparation {
$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 =();
# @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 =();
# @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 = ();
# @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 "@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 =();
$h_tencre{$z}= "$file";
$h_fst{$z}= "$file";
$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) {
# vérifier si un rep est $srep (donc juste rep_rootname ou plus bas) et le traiter à la place de &faitmoitmp
if (-d "$d$gnul[$gnus]$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 {
$fichiersource = "$d" . "$gnul[$gnus]" . "$file";
$fichiercible = "$path_tmp" . "$gnul[$gnus]" . "$file";
copy($fichiersource, $fichiercible) or die "impossibilité de copier $fichiersource sur $fichiercible $!";
# exec dos2unix "$d$gnul[$gnus]$file"; # voir si ca marche
push @nwlsfile, $file;
}
}
}
#---------- choix du repertoire temporaire-------------\
sub faitmoitmp {
my $q = 0;
if (-e $newsite) {
while (-e $newsite) {
$q++;
$newsite = "$dir" . "$gnul[$gnus]newsite" . "_$q";
}
mkdir $newsite or die "ouverture de $newsite impossible $!";
}
else {
mkdir $newsite or die "ouverture de $newsite impossible $!";
}
$tmp = "$newsite" . "$gnul[$gnus]" . "tmp";
mkdir $tmp or die "création de $tmp impossible $!";
$path_tmp = "$tmp" . "$gnul[$gnus]";
$path_newsite = "$newsite" . "$gnul[$gnus]";
# 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 $gnul[$gnus]newsite$gnul[$gnus]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 =~ /$gnul[$gnus]/) {
@pathl = split(/$gnul[$gnus]/, $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
#-------------------------------------ouvre_log-- géant
sub ouvre_log {
print "mon rootlog vaut $rootfile_log\n";
my $i = 0;
if ($path_tmp eq "") {
$path_tmp = $dir;
}
$flg = "$path_tmp" . "$gnul[$gnus]" . "$rootfile_log.log";
while (-e $flg) {
$flg = "$path_tmp" . "$gnul[$gnus]" . "$rootfile_log" . "_$i" . ".log";
$i++;
}
open $hdl_log, ">$flg" or die "Ouverture de $flg impossible $!";
print $hdl_log "script: $script (V: $vers) - date: $fr_date_now\n$lx\n";
}
#----------------------------------------Compte rendu ---------------------------debut
sub compte_rendu {
if ($file =~ /\.{1}s?h?x?t?m{1}l?$/i) {
$file_cr= "$path_tmp" . "rap_" . "$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\nN\/A 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
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 {
foreach $l(@lines) {
if ($l=~ /^\s/) {
$l=~ s/^\s{1}?//;
}
if ($l =~ /<a[^>]\n$/i) {
$l =~ s/\x0d\x0a$//;
$k++;
$j++;
}
# sinon ôter juste le \r (retour chariot)
else {
$l =~ s/\x0d$//;
$j++;
}
push @nwlines, $l;
}
print "fichier $file,de $j lignes dont $k ligne href couper\n";
}
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);
}
format STDOUT =
@<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$na, $a, $nb, $b
.
# script Perl écrit par alain Adelmar alias alCoolfort
# ce script repare plus de 9 liens sur 10
END;