|
PRÉSENTATION :
Exemple de transfert de fichier avec les composants TServerSocket et TClientSocket.
NOTES :
Le transfert de fichier n'est pas optimisé, mais ce n'était pas le but de cet exemple qui est en premier de montrer l'utilisation des composants.
Utilisation :
Sur le serveur il suffit d'appuyer sur le bouton ouvrir.
Sur un client il faut renseigner l'adresse ip du serveur et ensuite appuyer sur le bouton "Envoyer".
Le client se connecte au serveur, transfert le fichier par bloc et se déconnecte. Le serveur n'accepte qu'un seul fichier à la fois, ce n'est pas une limitation du TServerSocket mais de l'application.
CODE :
Unit Unit1;
Interface
Uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp, ExtCtrls;
Type
TForm1 = Class(TForm)
Client: TClientSocket;
Serveur: TServerSocket;
GroupBox1: TGroupBox;
btnOpen: TButton;
btnClose: TButton;
MemoServeur: TMemo;
GroupBox2: TGroupBox;
btnEnvoyer: TButton;
btnStop: TButton;
Edit1: TEdit;
Ouvrir: TOpenDialog;
MemoClient: TMemo;
RetardDebut: TTimer;
Procedure btnOpenClick(Sender: TObject);
Procedure btnCloseClick(Sender: TObject);
Procedure ServeurClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
Procedure ServeurClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
Procedure ServeurClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
Procedure ServeurClientRead(Sender: TObject; Socket: TCustomWinSocket);
Procedure ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
Procedure ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
Procedure ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
Procedure btnEnvoyerClick(Sender: TObject);
Procedure ClientRead(Sender: TObject; Socket: TCustomWinSocket);
Procedure btnStopClick(Sender: TObject);
Procedure RetardDebutTimer(Sender: TObject);
Private
{ Déclarations privées }
Public
{ Déclarations publiques }
End;
Var
Form1: TForm1;
Implementation
{$R *.dfm}
//**************************************************************************************
//
// Principe :
// le fichier envoyé en coupé en tranches de taille identiques et e transmises au serveur
// dans l'ordre du fichier.
//
// - Le client se connecte au serveur.
// - Si la connection est OK alors il envoie un trame du type ci-dessous avec ttType=1
// signalant qu'il s'agit du nom du fichier. ttNomFichier est alors le nom du fichier
// transféré.
// - Si le serveur accepte la demande, alors le fichier est envoyé par morceau avec le même
// type de trame. ttType = 2 pour signaler qu'il s'agit un morceau du fichier. ttDebut
// donne l'adresse du bloc dans le fichier et ttLong la taille du bloc.
// - Le client se deconnecte, ce qui ferme le fichier sur le serveur.
//
//**************************************************************************************
//**************************************************************************************
// Procédure d'affichage en clair des erreurs socket
// merci à djtexas
Function MessageErreurSocket( ErrorEvent: TErrorEvent; Var ErrorCode: Integer):String;
Var
ErrorMsg: String;
Begin
// définition du message d'erreur en fonction du code d'erreur
Case ErrorCode Of
10004 : ErrorMsg := 'Interrupted Function call.';
10013 : ErrorMsg := 'Permission Refusée.';
10014 : ErrorMsg := 'Mauvaise adresse.';
10022 : ErrorMsg := 'Arguments Invalides.';
10024 : ErrorMsg := 'Trop de fichiers ouverts.';
10035 : ErrorMsg := 'Resource temporarily unavailable.';
10036 : ErrorMsg := 'Operation en cours.';
10037 : ErrorMsg := 'Operation déjà en cours.';
10038 : ErrorMsg := 'Socket operation On non-socket.';
10039 : ErrorMsg := 'Destination address required.';
10040 : ErrorMsg := 'Message trop long.';
10041 : ErrorMsg := 'Protocol wrong Type For socket.';
10042 : ErrorMsg := 'Bad protocol option.';
10043 : ErrorMsg := 'Protocol Not supported.';
10044 : ErrorMsg := 'Socket Type Not supported.';
10045 : ErrorMsg := 'Operation Not supported.';
10046 : ErrorMsg := 'Protocol family Not supported.';
10047 : ErrorMsg := 'Address family Not supported by protocol family.';
10048 : ErrorMsg := 'Address already In use.';
10049 : ErrorMsg := 'Cannot assign requested address.';
10050 : ErrorMsg := 'Network Is down.';
10051 : ErrorMsg := 'Network Is unreachable.';
10052 : ErrorMsg := 'Network dropped connection On reset.';
10053 : ErrorMsg := 'Software caused connection abort.';
10054 : ErrorMsg := 'Connection reset by peer.';
10055 : ErrorMsg := 'No buffer space available.';
10056 : ErrorMsg := 'Socket Is already connected.';
10057 : ErrorMsg := 'Socket Is Not connected.';
10058 : ErrorMsg := 'Cannot send after socket shutdown.';
10060 : ErrorMsg := 'Connection timed Out.';
10061 : ErrorMsg := 'Connection refused.';
10064 : ErrorMsg := 'Host Is down.';
10065 : ErrorMsg := 'No route To host.';
10067 : ErrorMsg := 'Too many processes.';
10091 : ErrorMsg := 'Network subsystem Is unavailable.';
10092 : ErrorMsg := 'WINSOCK.DLL version Out Of range.';
10093 : ErrorMsg := 'Successful WSAStartup Not yet performed.';
10094 : ErrorMsg := 'Graceful shutdown In progress.';
11001 : ErrorMsg := 'Host Not found.';
11002 : ErrorMsg := 'Non-authoritative host Not found.';
11003 : ErrorMsg := 'This Is a non-recoverable error.';
11004 : ErrorMsg := 'Valid name, no data Record Of requested Type.';
Else
// erreur inconnue
ErrorMsg := 'Unknown socket error.';
End;
// mise en forme de la signification de l'erreur
ErrorMsg := 'Socket Error n°' + IntToStr(ErrorCode) + ' : ' + ErrorMsg;
// l'erreur est traitée
ErrorCode := 0;
// définition du type d'erreur
Case ErrorEvent Of
eeSend : ErrorMsg := 'Writing ' + ErrorMsg;
eeReceive : ErrorMsg := 'Reading ' + ErrorMsg;
eeConnect : ErrorMsg := 'Connecting ' + ErrorMsg;
eeDisconnect : ErrorMsg := 'Disconnecting ' + ErrorMsg;
eeAccept : ErrorMsg := 'Accepting ' + ErrorMsg;
Else
// erreur inconnue
ErrorMsg := 'Unknown ' + ErrorMsg;
End;
Result:=ErrorMsg;
End;
//
//**************************************************************************************
//**************************************************************************************
// Structure de la trame utilisée pour les échanges
//
Const
TailleBloc = 256;
Type
TIPTrame=Packed Record
Case ttType:Integer Of // ttType précise le type de la trame
// =1 quand c'est un nom de fichier
// =2 quand c'est un morceau du fichier
1:(
ttNomFichier:String[255]; // Nom du fichier
);
2:( ttDebut : Integer; // Adresse de début des données dans le fichier
ttLong : Integer; // Longueur des données envoyées
ttDatas : Array[0..TailleBloc-1] Of Byte ) // Données envoyées
End;
//
//**************************************************************************************
//**************************************************************************************
// SERVEUR
// Cette partie ne concerne que le serveur
Var
ServeurEnReception : Boolean = False; // =True quand une réception est en cours
ServeurAdresseClient : String = ''; // Adresse du client connecté
ServeurFichier : File; // Fichier utilisé pour la sauvegarde des morceaux
Procedure TForm1.btnOpenClick(Sender: TObject);
Begin
// Bouton de mise en écoute du serveur, c'est tout simple
Serveur.Open;
MemoServeur.Lines.Add('Serveur en écoute');
End;
Procedure TForm1.btnCloseClick(Sender: TObject);
Begin
// Bouton de fermeture du serveur, c'est aussi tout simple
If ServeurEnReception
And (MessageDlg('Un transfert est en cours, fermer le serveur ?',mtConfirmation,[mbYes,mbNo],0)=mrYes)
Then Begin
Serveur.Close;
MemoServeur.Lines.Add('Serveur desactivé');
End;
End;
//
// évènements du socket serveur
//
Procedure TForm1.ServeurClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
Begin
// C'est juste pour signaler
MemoServeur.Lines.Add('OnConnect:'+Socket.RemoteAddress);
End;
Procedure TForm1.ServeurClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
Begin
MemoServeur.Lines.Add('OnDisconnect:'+Socket.RemoteAddress);
// Le client se deconnecte => ou ferme le fichier en cours si besoin
If ServeurEnReception
Then Begin
CloseFile(ServeurFichier);
ServeurEnReception:=False;
End;
End;
Procedure TForm1.ServeurClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
Var ErrorCode: Integer);
Begin
// On ne fait que signaler l'erreur
MemoServeur.Lines.Add('OnClientError:'+Socket.RemoteAddress+#13+MessageErreurSocket(ErrorEvent,ErrorCode));
End;
Procedure TForm1.ServeurClientRead(Sender: TObject;
Socket: TCustomWinSocket);
Var Buffer:TIPTrame;
Erreur:Integer;
Recus :Integer;
Begin
// C'est ici la partie principale du serveur
// Cette procédure est appelée à chaque écriture d'un client
Erreur :=0;
Recus :=Socket.ReceiveLength; // Longueur reçue ( en octets )
MemoServeur.Lines.Add('OnRead'+Socket.RemoteAddress+' reçus '+IntToStr(Recus));
If Recus<= SizeOf(Buffer) // On vérifie que la longueur reçue tient dans la trame
// sinon attention au plantage !!!
Then With Buffer Do Begin
// Lecture de la trame reçue
Socket.ReceiveBuf(Buffer,Recus);
// En fonction du type de la trame on effectue les traitements
Case ttType Of
1:Begin
// C'est une nouvelle demande, on vérifie le nom du fichier
// La longueur de la trame doit être au minimumu de
// 4 ( taille de ttType ) + 1 ( longueur de la chaine ttNomFichier ) + Length(ttNomFichier)
If (Recus>=5)And(Recus>=(5+Length(ttNomFichier)))
Then Begin
// La longueur est bonne, on accepte la demande
MemoServeur.Lines.Add(ttNomFichier);
// On ferme le fichier précédent au cas ou
If ServeurEnReception Then CloseFile(ServeurFichier);
// On ouvre le fichier de réception en écriture
AssignFile(ServeurFichier,ExtractFilePath(ParamStr(0))+ttNomFichier);
Try
Rewrite(ServeurFichier,1);
ServeurEnReception:=True;
Erreur:=0;
Except
Erreur:=5; // Erreur de création du fichier
End;
End
Else Erreur:=2; // La longueur reçue est trop courte
End;
2:Begin
// On reçoit un morceau de fichier
// La longueur de la trame doit être au minimumu de
// 4 ( taille de ttType ) + 4 ( taille de ttDebut ) + 4 ( taille de ttLong )
// + ttLong ( nombre de données envoyées )
If (Recus>=12)And(Recus>=(12+ttLong))
Then Begin
// Le morceau n'est accepté que si une demande est en cours
If ServeurEnReception
Then Begin
// Le morceau n'est accepté que si le début du fichier à déjà été reçu
If (ttDebut>=0)And(ttDebut<=FileSize(ServeurFichier))
Then Begin
Try
// Si tout est bon on écrit le morceau dans le fichier
Seek(ServeurFichier,ttDebut);
BlockWrite(ServeurFichier,ttDatas,ttLong);
Erreur:=0; // C'est bon
Except
Erreur:=6; // Erreur d'écriture du fichier
End;
End
Else Erreur:=4; // La position 'début' n'est pas correcte
End
Else Erreur:=3; // On n'a pas reçue de demande
End
Else Erreur:=2; // La longueur reçue est trop courte
End;
End;// fin du case
End
Else Erreur:=1; // La longueur reçue est trop grande
// Dans tout les cas on envoie le code d'erreur au client
Socket.SendBuf(Erreur,4);
MemoServeur.Lines.Add(' Code de retour :'+IntToStr(Erreur));
End;
// fin de la partie serveur
//**************************************************************************************
//**************************************************************************************
// CLIENT
// Cette partie ne concerne que le client
Var
ClientFichier : File; // Fichier en cours d'envoi
ClientTrame : TIPTrame; // Copie de la dernière trame envoyée
Procedure TForm1.btnEnvoyerClick(Sender: TObject);
Begin
// Bouton envoyer, c'est le début
// On demande bien sur en premier le nom de fichier à transférer
If Not Ouvrir.Execute Then Exit;
AssignFile(ClientFichier,Ouvrir.FileName);
// On ouvre le fichier en lecture
Reset(ClientFichier,1);
// On essaye de se connecter au serveur
Client.Address:=Edit1.Text;
Client.Open;
End;
Procedure TForm1.ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
Begin
// La connection est réussie
MemoClient.Lines.Add('OnConnect:'+Socket.RemoteAddress);
// On demande alors l'envoi de la trame d'entête
ClientTrame.ttType:=1;
ClientTrame.ttNomFichier:=ExtractFileName(Ouvrir.FileName);
// La demande est différée par un petit timer car il est interdit
// d'écrire dans un OnConnect
btnEnvoyer.Enabled:=False;
RetardDebut.Enabled:=True;
End;
Procedure TForm1.RetardDebutTimer(Sender: TObject);
Begin
// Cette demande n'est faite qu'une fois par fichier
RetardDebut.Enabled:=False;
// On envoie au serveur la trame avec le nom du fichier
Client.Socket.SendBuf(ClientTrame,4+Length(ClientTrame.ttNomFichier)+1);
MemoClient.Lines.add('Envoi de l''entête');
End;
Procedure EnvoiBlocEnCours;
Begin
With ClientTrame Do
Begin
// Procédure d'envoi d'un morceau de fichier
// est appelée par ClientRead
// C'est une trame de type morceau de fichier
ttType:=2;
// Lecture dans le fichier
Seek(ClientFichier,ttDebut);
BlockRead(ClientFichier,ttDatas,TailleBloc,ttLong);
// Envoi du morceau
// La longueur envoyée est
// 4 ( taille de ttType ) + 4 ( taille de ttDebut ) + 4 ( taille de ttLong )
// + ttLong ( nombre de données envoyé )
Form1.Client.Socket.SendBuf(ClientTrame,ttLong+12);
Form1.MemoClient.Lines.add('Envoi du morceau '+IntToStr(ttDebut)+'['+IntToStr(ttLong)+']');
End;
End;
Procedure TForm1.ClientRead(Sender: TObject; Socket: TCustomWinSocket);
Var CodeRetour:Integer;
Begin
With ClientTrame Do
Begin
// On reçoit le code d'erreur du serveur, on le traite suivant les cas
MemoClient.Lines.Add('OnRead:'+Socket.RemoteAddress);
Socket.ReceiveBuf(CodeRetour,4);
Case ttType Of
1:Begin
// La dernière demande était un nom de fichier
// On teste le code de retour
If CodeRetour=0
Then Begin
// Par d'erreur, l'envoi réel peut donc commencer
ttDebut:=0;
EnvoiBlocEnCours;
End
Else Begin
// Le serveur refuse le fichier demandé => on arrète
MemoClient.Lines.Add('Erreur '+IntToStr(CodeRetour));
Client.Close;
End;
End;
2:Begin
// La dernière demande était un morceau de fichier
// On teste le code de retour
If CodeRetour=0
Then Begin
// Pas d'erreur on avance dans le fichier de la longueur envoyée précédemment
Inc(ttDebut,ttLong);
If ttDebut>=FileSize(ClientFichier)
Then Client.Close // C'est la fin du fichier, on ferme la connection
Else EnvoiBlocEnCours; // ce n'est pas la fin, on envoie le morceau
End
Else Begin
// Une erreur à eut lieu, on envoie le même morceau
MemoClient.Lines.Add('Erreur '+IntToStr(CodeRetour));
EnvoiBlocEnCours;
End;
End;
Else
// Normalement on ne doit pas passer ici.
// au cas ou, on ferme la connection
Client.Close;
End;
End;
End;
Procedure TForm1.ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
Begin
// à la déconnection on ferme le fichier est cours de lecture
MemoClient.Lines.Add('OnDisonnect:'+Socket.RemoteAddress);
btnEnvoyer.Enabled:=True;
CloseFile(ClientFichier);
End;
Procedure TForm1.ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; Var ErrorCode: Integer);
Begin
// On ne fait que signaler l'erreur
MemoServeur.Lines.Add('OnClientError:'+Socket.RemoteAddress+#13+MessageErreurSocket(ErrorEvent,ErrorCode));
End;
Procedure TForm1.btnStopClick(Sender: TObject);
Begin
// Arrêt du transfert en cours
RetardDebut.Enabled:=False;
Client.Close;
End;
// fin de la partie client
//**************************************************************************************
End.
|
| |
