Grosse quiche en perl cherche petite aide

Fermé
tipsi - 11 nov. 2004 à 00:17
 tipsi - 11 nov. 2004 à 11:05
Hello

Voila j'ai fait mon serveur Web et j'ai trouver sur un site un script en Perl permettant d'uploader des fichiers sur le serveur.
Je l'ai installé, ca fonctionne bien.

Le seul truc c'est que sur ma première page html, j'ai mis ce code la :

<form ACTION="/cgi-bin/save_fichier.cgi" method=POST ENCTYPE=multipart/form-data>
<p>
<input type=file name=file>
<input type=submit name=download value=Envoyer>
</p>
</form>

Il me crée donc un formulaire avec parcourir et envoyer, et quand je clique sur envoyer il me renvoie sur une autre page avec la même chose.
Comment supprimer cette seconde page?

Je mets aussi mon fichier save_fichier.cgi car je pense que ca vient de la mais comme je connais rien au perl....

Merci de votre aide

Fichier save_fichier.cgi

#!/usr/bin/perl -Tw
# Chemin a adapter sous Unix

=head1 NAME

Script permettant d'uploader un fichier sur le serveur
à l'aide la librairie CGI.pm. On passe par un formulaire
HTML de type <FORM METHOD=POST ENCTYPE=multipart/form-data>
et a l'aide de la balise <INPUT TYPE=file NAME=file>

Le fichier est enregistre dans le repertoire $upload_dir,

Modifier les variables necessaires dans la configuration
ci-dessous. Pour générer la doc de ce fichier, faire
"pod2html save_fichier.txt".

=head1 VERSION

$Revision: 0.3 $

=head1 DESCRIPTION

=cut

# v0.3 Utilisation de CGI.pm
# v0.2 Correction controle parametres
# --> uniquement chaines de caracteres acceptes
# --> execution avec use Strict, elimination de la plupart des erreurs
# Reste a corriger certains (pb de cgi-lib.pl)
# v0.1 Initialisation

use CGI qw(:standard);
use CGI::Carp qw/fatalsToBrowser/;
use strict;
use diagnostics;
use File::Copy;

## Repertoire ou sont deposes les fichiers
my $upload_dir = "/tmp/";

# Cettte variable est utilise dans le cas ou qqn
# essaie de telecharger un fichier deja existant
# dans le repertoire concerne
# Si $boolEcrase=0 un message d'erreur apparait
# Si $boolEcrase=1 le fichier est Ecrase
my $boolEcrase=0;

&main($boolEcrase);


=head2 main($boolEcrase)

Bon vieux main
--> Appel ecran de formulaire
--> Si fichier soumis, traitement du fichier et enregistrement
sur le serveur

=cut

sub main()
{
my($boolEcrase)=@_;
# Ecran formulaire
&ecran();
# Traitement du formulaire si nom de
# fichier passe en parametre
if (my $file = param('filename'))
{
my $tmpfile=tmpFileName($file);
&traiter_fichier($file,$tmpfile,$boolEcrase);
}
}


#--------------------------------------------------------
# Formulaire HTML de depot
#--------------------------------------------------------
sub ecran
{
print header();
print start_html("Exemple de telechargement de fichiers");
print h1("Exemple de telechargement de fichiers"),
'Cet exemple montre comment deposer un fichier via un formulaire et
un CGI Perl. Cet exemple fonctionne avec Netscape 2.0 minimum ou
IE 4.0 minimum.',
start_multipart_form(),
"Choisissez votre fichier a déposer:",
filefield(-name=>'filename',-size=>45),
submit('download','Telechargez'),
endform,
end_html;
if (!(-w $upload_dir))
{
print "Attention le repertoire $upload_dir est protege en ecriture<br>";
print "Aucune depot ne pourra se faire ...";
}
}

#--------------------------------------------------------
# Enregistrement du fichier
# temporaire dans le repertoire final
#--------------------------------------------------------
sub traiter_fichier
{
my($file,$tmpfile,$boolFile)=@_;
my($nom);
if ($file=~/.*\\(.*)$/) {$nom=$1;}
else {$nom=$file;}

my %stats;
my($fileFinal) = $upload_dir.$nom;
if ((-e $fileFinal) && ($boolFile==0)) {&Aff_e_fichier_existant();}

print hr();
if (-e $tmpfile)
{
use File::Copy;
copy($tmpfile,$fileFinal) || die "Impossible de creer $fileFinal avec $tmpfile:$!\n<br>";
&Aff_succes_ecriture ($fileFinal,$file);
}
}

#--------------------------------------------------------
# Message d'erreur pour l'ecriture sur fichier existant
#--------------------------------------------------------
sub Aff_e_fichier_existant
{
my($url)=$ENV{'SRIPT_NAME'};
my($buf) = "
Vous tentez d'écraser un fichier sur le serveur .<BR>
Le nom que vous avez donnez a votre fichier est deja occupé .<BR>
Veuillez rentrer un autre nom .<BR>";
print h1("Fichier existant"),$buf;
exit;
}

#--------------------------------------------------------
# Message apres un depot reussi
#--------------------------------------------------------
sub Aff_succes_ecriture
{
my($uploaded_file,$filename) = @_;
my(@status) = stat($uploaded_file);
my($buf)="
<H2>Document transferré avec succès</H2>
<PRE>
Nom du document local : <FONT COLOR=\#FF0000> $filename </FONT>
Taille du fichier : $status[7]
</PRE>";
print $buf;
exit;
}

2 réponses

jisisv Messages postés 3645 Date d'inscription dimanche 18 mars 2001 Statut Modérateur Dernière intervention 15 janvier 2017 955
11 nov. 2004 à 00:54
Euh, chez moi celà fonctionne
(ii apache 1.3.31-7 ) sous Debian.
(J'ai utilisé save_file.cgi de manière consistante)

Pointe ton navigateur sur
http://tonserveur/cgi-bin/save_file.cgi
et effectue ton upload , ici il sera dans /tmp

Quel est ton OS, quel est ton serveur http
Si serveur Apache,
le répertoire cgi-bin est-il correctement renseigné dans ton httpd.conf ?
(il semble que oui)
<troll>
Perl, pouah quelle horreur quelle manque de lisibilité
</troll>
Gates gave you the windows.
GNU gave us the whole house.(Alexandrin)
0
J'ai téléchargé un autre code scripts.
Je l'ai mis en place, il me plait plus que le premier.

Merci de ta réponse en tout cas.
0