转载的例子:
{------------------- uSocketCommon.PAS -------------------}
{ 下面是客户端和服务器端都要用到的公共单元uSocketCommon.PAS。}
{ 该单元是客户端应用程序和服务器端应用程序的核心部分,应用 }
{ 程序中的常量、类型、过程、函数等都在本单元中声明。 }
unit uSocketCommon;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, StdCtrls, ScktComp, ComCtrls;
const
{ 下面是一组应用程序中用到的字符串常量 }
sConnectedOK = '建立连接';
sConnecting = '正在连接...';
sDisconnectedOK = '断开连接';
sSaving = '正在发送...';
sLoading = '正在接收...';
sConnectError = '连接失败!请检查相关设置';
sMessageBoxCaption = '消息';
sPercentFmt = '已经完成 %D%%';{ 用于显示数据传输完成的百分比 }
{ 下面是动词列表:
前缀是vc的动词表由客户端发出;前缀是vs的动词由服务器端发出。 }
vcNone = 8000;{ 无效的动词 }
vsNone = 8000;{ 无效的动词 }
vcCancel = 9001;{ 取消操作 }
vsEchoCancel = 9002;{ 响应取消 }
vcFail = 9003;{ 操作失败 }
vsEchoFail = 9004;{ 响应失败 }
vsFail = 9005;{ 操作失败 }
vcSave = 1001;{ 请求发送,即保存到服务器中 }
vsReadyToSave = 1002;{ 接收和保存文件准备就绪 }
vcSaveInfo = 1003;{ 要保存文件的信息 }
vsSaveInfoOK = 1004;{ 正确收到保存文件的信息 }
vcFirstBuf = 1005;{ 发送第一个包 }
vsFirstBufOK = 1006;{ 正确收到第一个包 }
vcCommonBuf = 1007;{ 发送中间的包 }
vsCommonBufOK = 1008;{ 正确收到中间的包 }
vcLastBuf = 1009;{ 发送最后一个包 }
vsSaveOK = 1010;{ 正确接收完毕即保存成功 }
vcLoad = 2001;{ 请求接收,即从服务器装入 }
vsReadyToLoad = 2002;{ 向客户端发送文件准备就绪 }
vcLoadInfo = 2003;{ 需要接收文件的信息-文件名 }
vsLoadInfoOK = 2004;{ 正确收到并返回文件大小 }
vcReadyToLoad = 2005;{ 接收文件准备就绪 }
vsFirstBuf = 2006;{ 发送第一个包 }
vcFirstBufOK = 2007;{ 正确收到第一个包 }
vsCommonBuf = 2008;{ 发送中间的包 }
vcCommonBufOK = 2009;{ 正确收到中间的包 }
vsLastBuf = 2010;{ 发送最后一个包 }
vcLoadOK = 2011;{ 正确接收完毕即接收成功 }
vsLoadOK = 2012;{ 接收成功 }
ServerSocketPort = $ABCD;{ 端口号,可任意设置,尽可能不要与其它端口号重复 }
DataLen = 4096; { 数据包的最大尺寸是4K字节 }
LeadLen = 20; { 引导包的固定尺寸是20字节 }
{ 引导包中包括 16 个字节的身份识别代码和 4 个字节动词代码 }
SendLen = LeadLen + DataLen; { 发送包或接收包的最到尺寸是 (4096 + 20) 字节 }
type
TDataBuf = array [0..DataLen - 1] of Char; { 数据包缓存 }
TLeadBuf = array [0..LeadLen - 1] of Char; { 引导包缓存 }
TSendBuf = array [0..SendLen - 1] of Char; { 发送包或接收包缓存 }
TFileOfChar = file of Char; { 字符文件,用于接收方保存文件 }
TSocketMode = (smSave, smLoad, smNone); { 用于表示Socket当前的状态 }
TSocketData = record { 用于保存与当前Socket相关的信息 }
OnLine: Boolean; { 连接状态 }
Mode: TSocketMode; { 工作状态 }
SrcFileName: string; { 源文件名 }
DstFileName: string; { 目标文件名 }
FS: TFileStream; { 文件流 }
FSEnabled: Boolean; { 文件流状态 }
F: TFileOfChar; { 文件 }
FEnabled: Boolean; { 文件状态 }
FileSize: Integer; { 文件尺寸 }
LeftSize: Integer; { 剩余尺寸 }
ProgressBar: TProgressBar; { 进度条 }
ALabel: TLabel; { 进度标签 }
end;
PSocketData = ^TSocketData; { 类型指针,类型为TSocketData类型 }
TSocketVerb = Integer; { 动词类型 }
{ 判定动词是否含有终止意图 }
function IsTerminateVerb(AVerb: TSocketVerb): Boolean;
{ 报告错误 }
procedure ShowError(AHandle: THandle; S: string);
{ 传输日志 }
procedure Log(S: string; AMemo: TMemo);
{ 重置相关数据 }
procedure ResetSocketData(var P: PSocketData);
{ 新建Socket的相关数据,返回指针 }
function NewSocketData: PSocketData;
{ 将得到的包分解成为引导包和数据包 }
procedure ExtractBuf(Buf: TSendBuf; BufSize: Integer;
var LBuf: TLeadBuf; var DBuf: TDataBuf);
{ 分解引导包得到引导包中包含的动词 }
function ExtractVerb(LBuf: TLeadBuf): TSocketVerb;
{ 根据指定的动词初始化需要发送的包 }
procedure MakeVerbBuf(AVerb: TSocketVerb; var Buf: TSendBuf;
var SendSize: Integer);
{ 将数据包写入要发送的包中 }
procedure MakeSendBuf(DataBuf: TDataBuf; Count: Integer;
var SendBuf: TSendBuf; var SendSize: Integer);
{ 服务器端响应和处理客户端动词,这里的处理是服务器端程序的核心部分 }
procedure ServerEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AServerSocket: TCustomWinSocket);
{ 客户端响应和处理服务器端动词,这里的处理是客户端程序的核心部分 }
procedure ClientEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AClientSocket: TClientSocket);
implementation
const
IDString = 'SOCKET_TEST_DEMO'; { 引导包中的身份识别串,16个字符 }
LogTimeFormat = 'YYYY-MM-DD HH:MM:SS ';{ 用于登记传输日志的时间格式 }
DataSubDir = 'Data';{ 服务器端接收文件保存到应用程序所在目录的子目录Data中 }
TempSubDir = 'Temp';{ 客户端接收文件保存到应用程序所在目录的子目录Temp中 }
var
DataDir: string;{ 服务器端保存文件的路径 }
TempDir: string;{ 客户端保存文件的路径 }
{ 判定动词是否含有终止操作的意图 }
function IsTerminateVerb(AVerb: TSocketVerb): Boolean;
begin
Result := (AVerb = vcNone) or
(AVerb = vsNone) or
(AVerb = vcCancel) or
(AVerb = vsEchoCancel) or
(AVerb = vcFail) or
(AVerb = vsEchoFail) or
(AVerb = vsFail) or
(AVerb = vsSaveOK) or
(AVerb = vcLoadOK) or
(AVerb = vsLoadOK);
end;
{ 报告错误 }
procedure ShowError(AHandle: THandle; S: string);
begin
MessageBox(AHandle, PChar(S),
sMessageBoxCaption, MB_OK + MB_ICONEXCLAMATION);
end;
{ 服务器端登记数据传输日志 }
procedure Log(S: string; AMemo: TMemo);
begin
AMemo.Lines.Append(FormatDateTime(LogTimeFormat, Now) + S);
end;
{ 重置与Socket相关的数据 }
procedure ResetSocketData(var P: PSocketData);
begin
with P^ do try
Mode := smNone;
SrcFileName := '';
DstFileName := '';
if FSEnabled then try FS.Free; except end;
FSEnabled := False;
if FEnabled then try CloseFile(F); except end;
FEnabled := False;
FileSize := 0;
LeftSize := 0;
except
end;
end;
{ 新建一个数据结构,用于存放相关Socket的有关信息 }
function NewSocketData: PSocketData;
var
P: PSocketData;
begin
New(P);
with P^ do begin
Mode := smNone;
SrcFileName := '';
DstFileName := '';
FSEnabled := False;
FEnabled := False;
FileSize := 0;
LeftSize := 0;
P^.OnLine := False;
end;
Result := P;
end;
{ 分解收到的包,得到引导包和数据包 }
procedure ExtractBuf(Buf: TSendBuf; BufSize: Integer;
var LBuf: TLeadBuf; var DBuf: TDataBuf);
var
X: Integer;
begin
for X := 0 to LeadLen - 1 do LBuf[X] := Buf[X];
for X := LeadLen to BufSize - 1 do DBuf[X - LeadLen] := Buf[X];
end;
{ 分解引导包,得到动词 }
function ExtractVerb(LBuf: TLeadBuf): TSocketVerb;
var
HeadS: string[16];
VerbS: string[4];
X: Integer;
AVerb: TSocketVerb;
begin
HeadS := '';
for X := 0 to 15 do HeadS := HeadS + LBuf[X];
VerbS := '';
for X := 16 to LeadLen - 1 do VerbS := VerbS + LBuf[X];
if HeadS = IDString then try{ 身份识别串合法时才检查动词 }
AVerb := StrToInt(VerbS);
except
AVerb := vcNone;{ 解析动词失败,则认为是无效动词 }
end else begin
AVerb := vcNone;{ 身份非法则认为是无效动词 }
end;
Result := AVerb;
end;
{ 根据动词对将发送的包进行引导包部分的初始化 }
procedure MakeVerbBuf(AVerb: TSocketVerb; var Buf: TSendBuf;
var SendSize: Integer);
var
S: string;
X: Integer;
begin
S := IDString + IntToStr(AVerb);
if Length(S) = LeadLen then begin
for X := 1 to LeadLen do
Buf[X - 1] := S[X];
end;
SendSize := LeadLen;
end;
{ 将数据包写入将发送的包 }
procedure MakeSendBuf(DataBuf: TDataBuf; Count: Integer;
var SendBuf: TSendBuf; var SendSize: Integer);
var
X: Integer;
begin
for X := 0 to Count - 1 do
SendBuf[LeadLen + X] := DataBuf[X];
SendSize := LeadLen + Count;
end;
{ 根据Socket相关的信息建立保存文件信息的数据包 }
procedure MakeSaveInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vcSaveInfo, SendBuf, SendSize);
S := P^.SrcFileName + '|' +
P^.DstFileName + '|' +
IntToStr(P^.FileSize) + '|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;
{ 根据客户端Socket的相关信息建立下载文件信息的数据包,该包不含文件大小信息 }
procedure MakeClientLoadInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vcLoadInfo, SendBuf, SendSize);
S := P^.SrcFileName + '|' + P^.DstFileName + '|0|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;
{ 根据服务器端Socket的相关信息建立将送出文件信息的数据包,包括文件大小信息 }
procedure MakeServerLoadInfoBuf(P: PSocketData; var SendBuf: TSendBuf;
var SendSize: Integer);
var
S: string;
X, Len: Integer;
begin
MakeVerbBuf(vsLoadInfoOK, SendBuf, SendSize);
S := P^.SrcFileName + '|' +
P^.DstFileName + '|' +
IntToStr(P^.FileSize) + '|';
Len := Length(S);
for X := 1 to Len do
SendBuf[LeadLen + X - 1] := S[X];
SendSize := LeadLen + Len;
end;
{ 分解数据包,得到将保存的文件的信息,存入向相关的Socket的数据中 }
procedure ExtractSaveInfo(DataBuf: TDataBuf; var P: PSocketData);
var
S, ASrcFileName, ADstFileName, AFileSize: string;
ASize: Integer;
begin
S := DataBuf;
try
ASrcFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
ADstFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
AFileSize := Copy(S, 1, Pos('|', S) - 1);
ASize := StrToInt(AFileSize);
P^.SrcFileName := ASrcFileName;
P^.DstFileName := ADstFileName;
P^.FileSize := ASize;
except
end;
end;
{ 分解数据包,得到将要下载的文件信息,并存入相关的Socket数据中 }
procedure ExtractLoadInfo(DataBuf: TDataBuf; var P: PSocketData);
var
S, ASrcFileName, ADstFileName, AFileSize: string;
ASize: Integer;
begin
S := DataBuf;
try
ASrcFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
ADstFileName := Copy(S, 1, Pos('|', S) - 1); Delete(S, 1, Pos('|', S));
AFileSize := Copy(S, 1, Pos('|', S) - 1);
ASize := StrToInt(AFileSize);
P^.SrcFileName := ASrcFileName;
P^.DstFileName := ADstFileName;
P^.FileSize := ASize;
except
end;
end;
{ 根据传输的相关信息更新进度显示 }
procedure UpdateProgress(P: PSocketData);
var
R: Real;
N: Integer;
begin
if P^.ProgressBar.Max <= 0 then P^.ProgressBar.Max := 1;{ 防止 0 作除数 }
R := P^.ProgressBar.Position / P^.ProgressBar.Max;
R := R * 100;
N := Round(R);
P^.ALabel.Caption := Format(sPercentFmt, [N]);{ 进度百分比 }
end;
{ 服务器端响应和处理客户端动词}
procedure ServerEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AServerSocket: TCustomWinSocket);
{ 参数 AVerb 是根据客户端数据包解析得到的动词;
参数 DataBuf 是得到的客户端的数据包;
参数 DL 是数据包的尺寸;
变量参数 SendBuf 用于返回响应的包;
变量参数 SendSize 用于返回响应包的尺寸;
对象参数 AServerSocket 用于表明处理当前响应的Socket。
}
var
P: PSocketData; { 用于访问Socket中的相关数据 }
ResL, L: Integer;{ 局部变量 }
DBuf: TDataBuf; { 数据包 }
EchoVerb: TSocketVerb;{ 响应动词 }
begin
P := AServerSocket.Data;{ 指向Socket的数据 }
SendSize := 0;
if P <> nil then case AVerb of
{ 以下是异常情况下的动词响应 }
vcNone: SendSize := 0;{ 如果是无效动词,则不响应 }
vcCancel: MakeVerbBuf(vsEchoCancel, SendBuf, SendSize); { 响应取消操作 }
vcFail: MakeVerbBuf(vsEchoFail, SendBuf, SendSize); { 响应上传失败 }
{ 以下是服务器端接收文件时对客户端动词的响应 }
vcSave: MakeVerbBuf(vsReadyToSave, SendBuf, SendSize);{ 响应上传就绪 }
vcSaveInfo: begin{ 解析保存文件的信息,响应解析成功 }
ExtractSaveInfo(DataBuf, P);
MakeVerbBuf(vsSaveInfoOK, SendBuf, SendSize);
end;
vcFirstBuf,
vcCommonBuf: begin{ 响应收到包成功 }
EchoVerb := vsFail;
if ((AVerb = vcFirstBuf) and (not P^.FEnabled)) or
((AVerb = vcCommonBuf) and (P^.FEnabled)) then try
if AVerb = vcFirstBuf then begin
{ 如果是第一个包则用Rewrite方式打开文件 }
P^.DstFileName :=
DataDir + '/' + ExtractFileName(P^.DstFileName);
AssignFile(P^.F, P^.DstFileName);
Rewrite(P^.F);
P^.FEnabled := True;
EchoVerb := vsFirstBufOK; { 响应收到第一个包 }
end else begin
EchoVerb := vsCommonBufOK;{ 响应收到中间的包 }
end;
BlockWrite(P^.F, DataBuf, DL, ResL);{ 数据写入文件 }
if ResL <> DL then EchoVerb := vsFail;{ 写失败则响应失败 }
except
EchoVerb := vsFail;{ 操作引发异常则响应失败 }
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize);{ 构造响应包 }
end;
vcLastBuf: begin{ 收到最后一个包,成功处理后响应保存成功 }
EchoVerb := vsFail;
if P^.FEnabled then try
BlockWrite(P^.F, DataBuf, DL, ResL);
CloseFile(P^.F);{ 关闭文件 }
P^.FEnabled := False;
EchoVerb := vsSaveOK;
except
EchoVerb := vsFail;
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize);
end;
{ 以下是服务器端发送文件时对客户端动词的响应 }
vcLoad: MakeVerbBuf(vsReadyToLoad,
SendBuf, SendSize); { 向客户端发送就绪 }
vcLoadInfo: begin{ 解析文件名,创建文件流,响应文件大小 }
ExtractLoadInfo(DataBuf, P);
if FileExists(P^.SrcFileName) then try{ 检查文件是否存在 }
P^.SrcFileName :=
DataDir + '/' + ExtractFileName(P^.SrcFileName);
P^.FS := TFileStream.Create(P^.SrcFileName, fmOpenRead);
P^.FSEnabled := True;
P^.FileSize := P^.FS.Size;
P^.Mode := smLoad;
P^.LeftSize := P^.FS.Size;
MakeVerbBuf(vsLoadInfoOK, SendBuf, SendSize);
MakeServerLoadInfoBuf(P, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcReadyToLoad: begin{ 客户端就绪则发送第一个包 }
if P^.FSEnabled then try
case P^.LeftSize of
0: L := 0;
1..DataLen: L := P^.LeftSize;
else
L := DataLen;
end;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;{ 更新剩余的数据大小 }
MakeVerbBuf(vsFirstBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcFirstBufOK,
vcCommonBufOK: begin{ 客户端正确收到,则继续发送剩余的包 }
if P^.FSEnabled then try
if P^.LeftSize > DataLen then
L := DataLen
else
L := P^.LeftSize;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
if P^.LeftSize = 0 then
MakeVerbBuf(vsLastBuf, SendBuf, SendSize)
else
MakeVerbBuf(vsCommonBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
except
MakeVerbBuf(vsFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vsFail, SendBuf, SendSize);
end;
end;
vcLoadOK: MakeVerbBuf(vsLoadOK, SendBuf, SendSize);{ 发送成功 }
else
SendSize := 0;{ 除上述所有情况之外,则不响应 }
end;
end;
{ 客户端响应并处理服务器端的动词 }
procedure ClientEchoForVerb(AVerb: TSocketVerb; DataBuf: TDataBuf; DL: Integer;
var SendBuf: TSendBuf; var SendSize: Integer;
AClientSocket: TClientSocket);
{ 参数 AVerb 是根据服务器端数据包解析得到的动词;
参数 DataBuf 是得到的服务器端的数据包;
参数 DL 是数据包的尺寸;
变量参数 SendBuf 用于返回响应的包;
变量参数 SendSize 用于返回响应包的尺寸;
对象参数 AClientSocket 用于表明处理当前响应的Socket。
考虑到下面的响应处理与服务器端的响应处理比较相似,所以注释从简。
}
var
P: PSocketData;
DBuf: TDataBuf;
ResL, L: Integer;
EchoVerb: TSocketVerb;
begin
SendSize := 0;
P := AClientSocket.Socket.Data;
if (P <> nil) and (P^.OnLine) then case AVerb of
vsNone,
vsEchoCancel,
vsEchoFail,
vsFail: SendSize := 0;
vsReadyToSave: begin
P^.FS := TFileStream.Create(P^.SrcFileName, fmOpenRead);
P^.Mode := smSave;
P^.FSEnabled := True;
P^.FileSize := P^.FS.Size;
P^.LeftSize := P^.FS.Size;
P^.ProgressBar.Min := 0; { 初始化进度条数据 }
P^.ProgressBar.Max := P^.FS.Size;
P^.ProgressBar.Position := 0;
MakeSaveInfoBuf(P, SendBuf, SendSize);
end;
vsSaveInfoOK: begin
if P^.FSEnabled then try
case P^.LeftSize of
0: L := 0;
1..DataLen: L := P^.LeftSize;
else
L := DataLen;
end;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
MakeVerbBuf(vcFirstBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + L;
UpdateProgress(P);{ 更新进度显示 }
except
MakeVerbBuf(vcFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vcFail, SendBuf, SendSize);
end;
end;
vsFirstBufOK,
vsCommonBufOK: begin
if P^.FSEnabled then try
if P^.LeftSize > DataLen then
L := DataLen
else
L := P^.LeftSize;
if L > 0 then P^.FS.ReadBuffer(DBuf, L);
P^.LeftSize := P^.LeftSize - L;
if P^.LeftSize = 0 then
MakeVerbBuf(vcLastBuf, SendBuf, SendSize)
else
MakeVerbBuf(vcCommonBuf, SendBuf, SendSize);
MakeSendBuf(DBuf, L, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + L;
UpdateProgress(P);{ 更新进度显示 }
except
MakeVerbBuf(vcFail, SendBuf, SendSize);
end else begin
MakeVerbBuf(vcFail, SendBuf, SendSize);
end;
end;
vsSaveOK: SendSize := 0;
vsReadyToLoad: MakeClientLoadInfoBuf(P, SendBuf, SendSize);
vsLoadInfoOK: begin
ExtractSaveInfo(DataBuf, P);
MakeVerbBuf(vcReadyToLoad, SendBuf, SendSize);
end;
vsFirstBuf,
vsCommonBuf: begin
if ((AVerb = vsFirstBuf) and (not P^.FEnabled)) or
((AVerb = vsCommonBuf) and (P^.FEnabled)) then try
if AVerb = vsFirstBuf then begin
P^.DstFileName :=
TempDir + '/' + ExtractFileName(P^.DstFileName);
AssignFile(P^.F, P^.DstFileName);
Rewrite(P^.F);
P^.FEnabled := True;
P^.ProgressBar.Min := 0;
P^.ProgressBar.Max := P^.FileSize;
P^.ProgressBar.Position := 0;
EchoVerb := vcFirstBufOK;
end else begin
EchoVerb := vcCommonBufOK;
end;
BlockWrite(P^.F, DataBuf, DL, ResL);
if ResL <> DL then
MakeVerbBuf(vcFail, SendBuf, SendSize)
else
MakeVerbBuf(EchoVerb, SendBuf, SendSize);
P^.ProgressBar.Position := P^.ProgressBar.Position + DL;
UpdateProgress(P);
except
MakeVerbBuf(vcFail, SendBuf, SendSize)
end else begin
MakeVerbBuf(vcFail, SendBuf, SendSize)
end;
end;
vsLastBuf: begin
EchoVerb := vcFail;
if P^.FEnabled then try
BlockWrite(P^.F, DataBuf, DL, ResL);
CloseFile(P^.F);
P^.FEnabled := False;
EchoVerb := vcLoadOK;
P^.ProgressBar.Position := P^.ProgressBar.Position + DL;
UpdateProgress(P);
except
EchoVerb := vcFail;
end;
MakeVerbBuf(EchoVerb, SendBuf, SendSize)
end;
vsLoadOK: SendSize := 0;
else
SendSize := 0;
end;
end;
initialization
{ 检查相关目录是否存在,如果不存在则建立,以防止文件操作失败。}
DataDir := ExtractFilePath(Application.ExeName) + DataSubDir;
TempDir := ExtractFilePath(Application.ExeName) + TempSubDir;
if not DirectoryExists(DataDir) then ForceDirectories(DataDir);
if not DirectoryExists(TempDir) then ForceDirectories(TempDir);
end.
{------------------- uClient.PAS -------------------}
{ 下面是客户端用于接收和发送数据的窗体单元uClient.PAS。 }
{ 该工程中包括两个窗体。其中,作为主窗体的 FClientMain在 }
{ 工程文件中创建,作为客户端发送和接收数据的窗体类TFClient即 }
{ 用即创建,用完就销毁。 }
unit uClient;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, ComCtrls, StdCtrls, ExtCtrls, Registry;
type
TFClient = class(TForm)
ClientSocket1: TClientSocket;{ 不用在设计时初始化相关属性,在程序中设置 }
ProgressBar1: TProgressBar; { 用于显示数据传输进度 }
ButtonCancel: TButton; { 取消数据传输 }
Label1: TLabel; { 用于动态显示传输数据完成的百分比 }
procedure ButtonCancelClick(Sender: TObject); { 事件:按“取消”按钮 }
procedure ClientSocket1Connect(Sender: TObject; { 事件:建立连接 }
Socket: TCustomWinSocket);
procedure ClientSocket1Connecting(Sender: TObject;{ 事件:正在连接 }
Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;{ 事件:断开连接 }
Socket: TCustomWinSocket);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);{ 事件:读取数据 }
procedure FormDestroy(Sender: TObject);{ 事件:销毁窗体 }
private
procedure DoFirstVerb(AVerb: Integer); { 私有方法:发出第一个命令(动词) }
public
end;
{ 调用该函数用于向服务器端发送文件,若成功则返回True,否则返回False }
{ 入口参数LocalSrcFileName是本地需要发送的文件的完整文件名(含完整路径); }
{ 入口参数IP用于指定服务器端的IP地址; }
function ClientSendFile(LocalSrcFileName: string;
IP: string = '127.0.0.1'): Boolean;
{ 调用该函数用于从服务器端下载文件,若成功则返回True,否则返回False }
{ 入口参数RemoteSrcFileName是服务器端需要发送的文件的文件名(可以不含完整路径);}
{ 入口参数IP用于指定服务器端的IP地址; }
function ClientLoadFile(RemoteSrcFileName: string;
IP: string = '127.0.0.1'): Boolean;
implementation
uses
uSocketCommon;{ 引用公共的单元,该单元中包括Socket的一些例程 }
var
{ 用于存取端口号,等号右边的常量在单元uSocketCommon 中有声明 }
FPort: Integer = ServerSocketPort;
FirstVerb: Integer; { 用于存取数据传输任务的第一个动词命令 }
NeedFree: Boolean = False; { 用于存取是否需要将进度窗体销毁 }
{$R *.DFM}
function ClientSendFile(LocalSrcFileName: string;
IP: string = '127.0.0.1'): Boolean;{ 向服务器端发送 }
var
P: PSocketData; { 存取Socket的相关信息,
类型指针PSocketData在单元uSocketCommon中声明 }
begin
with TFClient.Create(Application) do try{ 即用即创建 }
NeedFree := False;{ 初始值,不用程序自动销毁 }
ClientSocket1.Address := IP;{ 设置服务器端的IP地址 }
ClientSocket1.Port := FPort;{ 设置端口号 }
P := NewSocketData; { 新建类型指针,函数NewSocketData在公共单元中 }
P^.ProgressBar := ProgressBar1;{ 为P指定进度条 }
P^.ALabel := Label1; { 为P指定标签 }
ClientSocket1.Socket.Data := P;{ 指定当前Socket的相关信息 }
try
ClientSocket1.Active := True;{ 试图建立连接 }
except
ShowError(Application.Handle, sConnectError);{ 连接失败,报告信息 }
NeedFree := True;{ 需要程序自动销毁进度窗体 }
end;
if not NeedFree then begin{ 连接成功则保存发送文件的相关信息 }
P := ClientSocket1.Socket.Data;
P^.SrcFileName := LocalSrcFileName;
P^.DstFileName := ExtractFileName(LocalSrcFileName);
FirstVerb := vcSave;{ 设置第一个动词是vcSave,动词声明在公共单元中 }
Result := ShowModal = mrOK;{ 显示数据传输进度窗体 }
end else begin{ 连接失败 }
Result := False;
end;
finally
Free;{ 用完即销毁 }
end;
end;
function ClientLoadFile(RemoteSrcFileName: string;
IP: string = '127.0.0.1'): Boolean;{ 从服务器端接收 }
var
P: PSocketData;
begin
with TFClient.Create(Application) do try{ 即用即创建 }
NeedFree := False;{ 缺省为不通过程序自动销毁 }
ClientSocket1.Address := IP;{设置服务器端IP地址 }
ClientSocket1.Port := FPort;{设置端口号 }
{下面是初始化Socket的相关信息 }
P := NewSocketData;
P^.ProgressBar := ProgressBar1;
P^.ALabel := Label1;
ClientSocket1.Socket.Data := P;
try
ClientSocket1.Active := True;{试图建立连接}
except{连接失败}
ShowError(Application.Handle, sConnectError);
NeedFree := True;
end;
if not NeedFree then begin{若连接成功则保存相关信息}
P := ClientSocket1.Socket.Data;
P^.SrcFileName := RemoteSrcFileName;
P^.DstFileName := ExtractFileName(RemoteSrcFileName);
FirstVerb := vcLoad;{设置第一个动词为vcLoad}
Result := ShowModal = mrOK;{显示进度窗体}
end else begin{连接失败}
Result := False;
end;
finally
Free;{用完即销毁}
end;
end;
procedure TFClient.FormDestroy(Sender: TObject);{ 销毁窗体时释放资源 }
var
P: PSocketData;
begin
P := ClientSocket1.Socket.Data;
ClientSocket1.Socket.Data := nil;
Dispose(P);
end;
procedure TFClient.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);{ 连接成功时即刻发出第一个动词 }
var
P: PSocketData;
begin
Label1.Caption := ''; { 标签设计时的文本是“连接失败,请[取消]” }
Label1.Font.Color := clBlack;{ 设计时字体颜色是红色,连接成功后置为黑色 }
Caption := sConnectedOK; { 连接成功 }
P := ClientSocket1.Socket.Data; { 获得数据地址 }
if P <> nil then begin
P^.OnLine := True; { 置连接状态为True }
DoFirstVerb(FirstVerb);{ 发出第一个动词 }
if FirstVerb = vcSave then{ 根据第一个动词确定窗体的标题 }
Caption := sSaving
else
Caption := sLoading;
end;
end;
procedure TFClient.ClientSocket1Connecting(Sender: TObject;
Socket: TCustomWinSocket);{ 正在连接时的处理 }
begin
Caption := sConnecting;{ 显示正在连接的信息 }
end;
procedure TFClient.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);{ 断开连接时的处理 }
var
P: PSocketData;
begin
Caption := sDisconnectedOK;{ 显示相关信息在标题 }
P := ClientSocket1.Socket.Data;{ 获取数据 }
ResetSocketData(P);{ 释放有关的资源,如关闭文件、流等 }
if P <> nil then P^.OnLine := False;{ 置连接状态为False }
end;
procedure TFClient.ButtonCancelClick(Sender: TObject);{ 取消传输 }
var
SendBuf: TSendBuf;
P: PSocketData;
AVerb: TSocketVerb;
L: Integer;
begin
P := ClientSocket1.Socket.Data;{ 获得当前数据 }
if (P <> nil) and P^.OnLine then begin { 根据合适的状态进行取消的动作 }
AVerb := vcCancel;{ 动词是客户端请求取消 }
MakeVerbBuf(AVerb, SendBuf, L);{根据动词生成发送的数据}
ClientSocket1.Socket.SendBuf(SendBuf, LeadLen);{发送请求取消数据包}
end else begin { 否则直接销毁窗口 }
ModalResult := mrCancel;
end;
end;
procedure TFClient.DoFirstVerb(AVerb: Integer);{私有方法}
var
SendBuf: TSendBuf;
L: Integer;
begin
MakeVerbBuf(AVerb, SendBuf, L);{生成第一个动词的数据包}
ClientSocket1.Socket.SendBuf(SendBuf, LeadLen);{发送该数据包}
end;
{ 下面对事件OnRead的处理是客户端应用程序的关键所在,该事件与服务器程序中的相应
事件互相接收和发送,并且严格遵循“你一句我一句”的原则,这样的循环控制才使得
数据传输能够快速有序地进行。应答序列的开始是客户端应用程序在ClientSocket连接
成功时发出的第一个动词引起的。 }
procedure TFClient.ClientSocket1Read(Sender: TObject;{客户端读取数据}
Socket: TCustomWinSocket);
var
LeadBuf: TLeadBuf;{具有固定长度的引导包,引导包的作用是正确识别合法用户}
DataBuf: TDataBuf;{数据包}
GetBuf, SendBuf: TSendBuf;{接收包和发送包}
Len, SendSize, Verb: Integer;
P: PSocketData;
begin
Len := ClientSocket1.Socket.ReceiveBuf(GetBuf, SendLen); { 将接收到的包读到
GetBuf中,并将实际读取的字节数存入Len中,这里的参数SendLen
用于指定最多读取的字节数,在公共单元中声明 }
Verb := vsNone;{初始得到的动词值}
if Len >= LeadLen then begin{如果实际字节数大于等于引导包的字节数,则初步认定
可以对该数据包进行分析}
ExtractBuf(GetBuf, Len, LeadBuf, DataBuf);{将得到的包分离出引导包和数据包}
Verb := ExtractVerb(LeadBuf);{根据引导包分析出包的动词}
ClientEchoForVerb(Verb, DataBuf, Len - LeadLen,
SendBuf, SendSize, ClientSocket1);{对服务器端动词的响应,
最后生成一个响应的包,即应答包}
case Verb of
vsEchoCancel: ModalResult := mrCancel;{如果动词是响应取消,则释放窗体}
vsFail,
vsEchoFail,
vsNone: ModalResult := mrAbort;{如果动词非法,则释放窗体}
vsSaveOK,
vsLoadOK: ModalResult := mrOK;{如果动词是成功结束,则释放窗体}
else
end;
end else begin{如果得到的包的字节数小于引导包指定的字节数,则认为是非法包}
SendSize := 0;{不需要响应}
end;
if SendSize > 0 then
ClientSocket1.Socket.SendBuf(SendBuf, SendSize);{发送应答包}
if IsTerminateVerb(Verb) then begin{如果是需要终止的动词,那么重置相关数据}
P := Socket.Data;
ResetSocketData(P);
end;
end;
end.
{ ------------------- Client.DPR -------------------}
{ 下面是客户端的工程文件Client.DPR。 }
{ 该工程中包括两个窗体。其中,作为主窗体的 FClientMain在 }
{ 工程文件中创建,作为客户端发送和接收数据的窗体类TFClient即 }
{ 用即创建,用完就销毁。 }
program Client;
uses
Forms,
uSocketCommon in 'uSocketCommon.pas',
uClientMain in 'uClientMain.pas' {FClientMain},
uClient in 'uClient.pas' {FClient};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TFClientMain, FClientMain);
Application.Run;
end.
{------------------- uClientMain.PAS -------------------}
{ 下面是客户端用于调用接收和发送数据的窗体单元uClientMain.PAS。}
{ 该单元是工程主窗体所在的单元。 }
unit uClientMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, StdCtrls;
type
TFClientMain = class(TForm)
DriveComboBox1: TDriveComboBox; { 选择驱动器 }
DirectoryListBox1: TDirectoryListBox;{ 选择目录 }
FilterComboBox1: TFilterComboBox; { 文件类型过滤器 }
FileListBox1: TFileListBox; { 选择文件 }
BtnSend: TButton; { 向服务器端发送文件 }
BtnLoad: TButton; { 从服务器端接收文件 }
BtnClose: TButton;{ 关闭窗口,结束程序 }
IPEdit: TEdit; { 输入IP地址 }
Label1: TLabel; { 提示输入IP地址 }
procedure FileListBox1Change(Sender: TObject);{ 选中的文件改变 }
procedure BtnSendClick(Sender: TObject); { 发送 }
procedure BtnLoadClick(Sender: TObject); { 接收 }
procedure BtnCloseClick(Sender: TObject); { 关闭 }
private
public
end;
var
FClientMain: TFClientMain;
implementation
uses
uClient;{ 引用发送和接收文件的单元,即ClientSocket所在的窗体单元 }
{$R *.DFM}
procedure TFClientMain.FileListBox1Change(Sender: TObject);{ 控制按钮是否有效 }
begin
BtnSend.Enabled := FileListBox1.FileName <> '';
BtnLoad.Enabled := BtnSend.Enabled;
end;
procedure TFClientMain.BtnSendClick(Sender: TObject);{ 上传文件 }
begin
if ClientSendFile(FileListBox1.FileName) then
Caption := '上传成功'
else
Caption := '上传失败';
end;
procedure TFClientMain.BtnLoadClick(Sender: TObject);{ 下载文件 }
begin
if ClientLoadFile(FileListBox1.FileName) then
Caption := '接收成功'
else
Caption := '接收失败';
end;
procedure TFClientMain.BtnCloseClick(Sender: TObject);{ 关闭客户端应用程序 }
begin
Close;
end;
end.
{------------------- Server.DPR -------------------}
{ 服务器端应用程序的工程文件Server.DPR。}
{ 这是一个极普通的工程文件,不必注释。 }
program Server;
uses
Forms,
uServer in 'uServer.pas' {FServer},
uSocketCommon in 'uSocketCommon.pas';
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TFServer, FServer);
Application.Run;
end.
{------------------- uServer.PAS -------------------}
{ 这是应用程序主窗体所在的单元uServer.PAS }
{ 该单元中的ServerSocket1 用于与客户端通信。}
unit uServer;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ScktComp, ExtCtrls;
type
TFServer = class(TForm)
Memo1: TMemo; { 记录连接、断开、传输等信息作为日志 }
BtnClear: TButton;{ 清除日志 }
BtnClose: TButton;{ 关闭窗口,结束程序 }
ServerSocket1: TServerSocket; { 服务程序的核心组件 }
procedure FormCreate(Sender: TObject); { 事件:窗体创建 }
procedure FormDestroy(Sender: TObject); { 事件:销毁窗体 }
procedure BtnClearClick(Sender: TObject);{ 事件:“清除”按钮 }
procedure BtnCloseClick(Sender: TObject);{ 事件:“关闭”按钮 }
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket); { 事件:客户端连接 }
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket); { 事件:客户端断开连接 }
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket); { 事件:服务器端读取收到的数据 }
private
public
end;
var
FServer: TFServer;
implementation
uses uSocketCommon;
{$R *.DFM}
procedure TFServer.FormCreate(Sender: TObject);
begin
ServerSocket1.Port := ServerSocketPort; { 设置端口号 }
ServerSocket1.Active := True; { 打开服务 }
Log('启动服务', Memo1); { 登记日志 }
end;
procedure TFServer.FormDestroy(Sender: TObject);
begin
ServerSocket1.Close; { 销毁窗体时关闭服务 }
end;
procedure TFServer.BtnCloseClick(Sender: TObject);
begin
Close; { 关闭窗体,结束程序 }
end;
procedure TFServer.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
var
P: PSocketData;
begin
P := NewSocketData; { 有新的客户端建立连接,则为其分配内存用于保存相关信息 }
Socket.Data := P;
Log('建立连接 [' + Socket.RemoteAddress + ']', Memo1);
end;
procedure TFServer.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
var
P: PSocketData;
begin
P := Socket.Data; { 断开一个客户端连接时,需要将相应服务器Socket的数据清除 }
Socket.Data := nil;
ResetSocketData(P);
Dispose(P);
Log('断开连接 [' + Socket.RemoteAddress + ']', Memo1);
end;
{ 根据动词确定相应的文本用于登记日志 }
function VerbToString(AVerb: TSocketVerb): string;
var
S: string;
begin
case AVerb of
vcSave: S := '开始接收';
vcLastBuf: S := '接收成功';
vcLoad: S := '开始发送';
vcLoadOK: S := '发送成功';
vcCancel: S := '取消操作';
vcFail: S := '操作失败';
vcNone: S := '收到非法数据';
else
S := '';
end;
Result := S;
end;
{ 服务器端相应客户端动词的处理,与客户端响应服务器端动词的处理相似。 }
procedure TFServer.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
DataBuf: TDataBuf;
LeadBuf: TLeadBuf;
GetBuf, SendBuf: TSendBuf;
Len, SendSize, Verb: Integer;
P: PSocketData;
S: string;
begin
Verb := vcNone;
Len := Socket.ReceiveBuf(GetBuf, SendLen);
if Len >= LeadLen then begin
ExtractBuf(GetBuf, Len, LeadBuf, DataBuf);
Verb := ExtractVerb(LeadBuf);
ServerEchoForVerb(Verb, DataBuf, Len - LeadLen , SendBuf, SendSize, Socket);
end else begin
SendSize := 0;
end;
if SendSize > 0 then
Socket.SendBuf(SendBuf, SendSize);
S := VerbToString(Verb);
if S <> '' then begin
S := S + ' [' + Socket.RemoteAddress + ']';
Log(S, Memo1);
end;
if IsTerminateVerb(Verb) then begin
P := Socket.Data;
ResetSocketData(P);
end;
end;
procedure TFServer.BtnClearClick(Sender: TObject);
begin
Memo1.Lines.Clear;{ 清除日志 }
end;
end.