给你一个 Tfinger 单元,调用即可!^_^
unit Finger;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, WinSock, FingConst;
type
ESocketError = class(Exception);
EFingerError = class(Exception);
TFingerErrorEvent = procedure(Sender : TObject; var Msg : string) of Object;
TFinger = class(TComponent)
private
{ Private declarations }
FTimeOut : Integer;
FQuery : string;
FTerminal : TMemo;
FOnConnecting : TNotifyEvent;
FOnSending : TNotifyEvent;
FOnReceiving : TNotifyEvent;
FOnClosed : TNotifyEvent;
FOnCanceled : TNotifyEvent;
FOnError : TFingerErrorEvent;
InvWnd : THandle;
procedure SetQuery(Value : string);
procedure DoConnecting(Sender : TObject);
procedure DoSending(Sender : TObject);
procedure DoReceiving(Sender : TObject);
procedure DoClosed(Sender : TObject);
procedure DoCanceled(Sender : TObject);
procedure DoError(Sender : TObject; var Msg : string);
protected
{ Protected declarations }
ErrorStr : string;
Timer : TTimer;
CurTick : Integer;
TimedOut : boolean;
MyWSAData : TWSADATA;
AsyncHandle : THandle;
FingerSocket : TSocket;
FingerPort : Cardinal;
WsInitCount : Integer;
ServerInAddr : u_long;
ServerIPAddr : string;
ServerName : string;
AddInfo : string;
Canceled : boolean;
HostFound : boolean;
ServiceFound : boolean;
Error : boolean;
ErrorNo : Cardinal;
Connected : boolean;
DataHasArrived : boolean;
ReadyToSend : boolean;
ConnectionClosed : boolean;
procedure ProcessError;
procedure TimerOnTimer(Sender : TObject);
procedure TimerOn;
procedure TimerOff;
procedure OpenSocket;
procedure CloseSocket;
function SocketErrorStr(Errno : Cardinal) : string;
procedure ResolveRemoteHost;
procedure FindFingerService;
procedure Open;
procedure Connect;
procedure Close;
procedure SendQuery;
procedure RecvData;
procedure ReInit;
procedure WndProc(var Msg : TMessage);
public
{ Public declarations }
OutStream : TStream;
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Execute;
procedure Cancel;
published
{ Published declarations }
property Terminal : TMemo read FTerminal write FTerminal;
property TimeOut : Integer read FTimeOut write FTimeOut
default 60;
property Query : string read FQuery write SetQuery;
property OnConnecting : TNotifyEvent read FOnConnecting write FOnConnecting;
property OnSending : TNotifyEvent read FOnSending write FOnSending;
property OnReceiving : TNotifyEvent read FOnReceiving write FOnReceiving;
property OnClosed : TNotifyEvent read FOnClosed write FOnClosed;
property OnCanceled : TNotifyEvent read FOnCanceled write FOnCanceled;
property OnError : TFingerErrorEvent read FOnError write FOnError;
end;
procedure Register;
implementation
const
Finger_Port = 79;
WM_HOSTFOUND = WM_USER+1;
WM_SERVICEFOUND = WM_USER+2;
WM_SOCKETACTIVITY = WM_USER+3;
procedure Register;
begin
RegisterComponents('Internet', [TFinger]);
end;
constructor TFinger.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
if not (csDesigning in ComponentState) then
begin
if WSAStartUp($0101,MyWSADATA)<>0 then
begin
ErrorStr:=feInvalidVersion;
ProcessError;
end;
InvWnd:=AllocateHWnd(WndProc);
Inc(WsInitCount);
end;
FTimeOut:=60;
Timer:=TTimer.Create(Self);
Timer.Enabled:=false;
Timer.OnTimer:=TimerOnTimer;
OutStream:=TMemoryStream.Create;
ReInit;
end;
destructor TFinger.Destroy;
var
i : Integer;
begin
OutStream.Free;
Timer.Free;
if not (csDesigning in ComponentState) then
begin
for i:=1 to WsInitCount do
WSACleanUp;
DeallocateHWnd(InvWnd);
end;
inherited Destroy;
end;
procedure TFinger.ProcessError;
begin
DoError(Self,ErrorStr);
raise EFingerError.Create(ErrorStr);
end;
procedure TFinger.SetQuery(Value : string);
var
i : byte;
begin
i:=Pos('@',Value);
if i=0 then
begin
ErrorStr:=feInvalidQuery;
ProcessError;
end;
AddInfo:=Copy(Value,1,i-1);
ServerName:=Copy(Value,i+1,Length(Value)-i);
FQuery:=Value;
end;
function TFinger.SocketErrorStr(ErrNo : Cardinal) : string;
begin
Result:=Format(feWinsockError,[ErrNo]);
end;
procedure TFinger.WndProc(var Msg : TMessage);
begin
with Msg do
if Msg=WM_HOSTFOUND then
begin
HostFound:=true;
ErrorNo:=WSAGetAsyncError(lParam);
Error:=ErrorNo<>0;
Result:=0;
end
else
if Msg=WM_SERVICEFOUND then
begin
ServiceFound:=true;
ErrorNo:=WSAGetAsyncError(lParam);
Error:=ErrorNo<>0;
Result:=0;
end
else
if Msg=WM_SOCKETACTIVITY then
begin
ErrorNo:=WSAGetAsyncError(lParam);
Error:=ErrorNo<>0;
if not Error then
begin
case WSAGetSelectEvent(lParam) of
FD_CONNECT :
begin
Connected:=true;
end;
FD_READ :
DataHasArrived:=true;
FD_WRITE :
ReadyToSend:=true;
FD_CLOSE :
ConnectionClosed:=true;
end;
end;
Result:=0;
end
else
Result:=DefWindowProc(InvWnd,Msg,lParam,wParam);
end;
procedure TFinger.DoConnecting(Sender : TObject);
begin
if Assigned(FOnConnecting) then
FOnConnecting(Sender);
end;
procedure TFinger.DoSending(Sender : TObject);
begin
if Assigned(FOnSending) then
FOnSending(Sender);
end;
procedure TFinger.DoReceiving(Sender : TObject);
begin
if Assigned(FOnReceiving) then
FOnReceiving(Sender);
end;
procedure TFinger.DoClosed(Sender : TObject);
begin
if Assigned(FOnClosed) then
FOnClosed(Sender);
end;
procedure TFinger.DoCanceled(Sender : TObject);
begin
if Assigned(FOnCanceled) then
FOnCanceled(Sender);
end;
procedure TFinger.DoError(Sender : TObject; var Msg : string);
begin
if Assigned(FOnError) then
FOnError(Sender,Msg);
end;
procedure TFinger.TimerOnTimer(Sender : TObject);
begin
Dec(CurTick);
if CurTick=0 then
begin
if AsyncHandle<>0 then
begin
WSACancelAsyncRequest(AsyncHandle);
AsyncHandle:=0;
end;
if WSAIsBlocking then
WSACancelBlockingCall;
TimerOff;
TimedOut:=true;
end;
end;
procedure TFinger.TimerOn;
begin
Timer.Enabled:=true;
CurTick:=FTimeOut;
end;
procedure TFinger.TimerOff;
begin
Timer.Enabled:=false;
end;
procedure TFinger.ReInit;
begin
AsyncHandle:=0;
HostFound:=false;
ServiceFound:=false;
Connected:=false;
DataHasArrived:=false;
ReadyToSend:=false;
Canceled:=false;
ConnectionClosed:=false;
TimedOut:=false;
end;
procedure TFinger.ResolveRemoteHost;
var
Buf : array[0..MAXGETHOSTSTRUCT] of char;
RemoteHost : PHostEnt;
a : array[0..3] of byte;
i : byte;
begin
ServerInAddr:=Inet_Addr(PChar(ServerName));
if ServerInAddr=SOCKET_ERROR then
begin
AsyncHandle:=WSAAsyncGetHostByName(InvWnd,WM_HOSTFOUND,PChar(ServerName),
@Buf,MAXGETHOSTSTRUCT);
if AsyncHandle=0 then
begin
ErrorStr:=SocketErrorStr(ErrorNo);
ProcessError;
end;
TimerOn;
repeat
Application.ProcessMessages;
until HostFound or TimedOut or Canceled;
TimerOff;
AsyncHandle:=0;
if Error then
begin
ErrorStr:=SocketErrorStr(ErrorNo);
ProcessError;
end
else
if TimedOut then
begin
ErrorStr:=feTimedOut;
ProcessError;
end
else
if Canceled then
begin
raise EFingerError.Create(feCanceled);
end;
RemoteHost:=PHostEnt(@Buf);
for i:=0 to 3 do
a:=byte(RemoteHost^.h_addr_list^);
ServerIPAddr:=IntToStr(a[0])+'.'+IntToStr(a[1])+
'.'+IntToStr(a[2])+'.'+IntToStr(a[3]);
ServerInAddr:=Inet_Addr(PChar(ServerIPAddr));
if ServerInAddr=SOCKET_ERROR then
begin
ErrorStr:=feResolving;
ProcessError;
end;
end;
end;
procedure TFinger.FindFingerService;
var
Buf : array[0..MAXGETHOSTSTRUCT] of char;
PSE : PServEnt;
begin
AsyncHandle:=WSAAsyncGetServByName(InvWnd,WM_SERVICEFOUND,'finger','tcp',
@Buf,MAXGETHOSTSTRUCT);
if AsyncHandle=0 then
begin
FingerPort:=Finger_Port;
end
else
begin
TimerOn;
repeat
Application.ProcessMessages
until ServiceFound or Canceled or TimedOut;
TimerOff;
AsyncHandle:=0;
if Error or TimedOut then
begin
FingerPort:=Finger_Port;
end
else
if Canceled then
raise EFingerError.Create(feCanceled)
else
begin
PSE:=PServEnt(@Buf);
FingerPort:=htons(PSE^.s_port);
end;
end;
end;
procedure TFinger.OpenSocket;
begin
FingerSocket:=Socket(PF_INET,SOCK_STREAM,IPPROTO_IP);
if FingerSocket=TSocket(INVALID_SOCKET) then
begin
ErrorStr:=SocketErrorStr(WSAGetLastError);
ProcessError;
end;
end;
procedure TFinger.Connect;
var
RemoteAddress : TSockAddr;
LastError : Cardinal;
begin
with RemoteAddress do
begin
Sin_Family:=PF_INET;
Sin_Port:=htons(FingerPort);
Sin_addr:=TInAddr(ServerInAddr);
end;
AsyncHandle:=WSAAsyncSelect(FingerSocket,InvWnd,WM_SOCKETACTIVITY,
FD_CONNECT or FD_READ or FD_WRITE or FD_CLOSE);
if AsyncHandle=SOCKET_ERROR then
begin
ErrorStr:=SocketErrorStr(WSAGetLastError);
ProcessError;
end;
TimerOn;
if WinSock.Connect(FingerSocket,RemoteAddress,
SizeOf(RemoteAddress))=SOCKET_ERROR then
begin
LastError:=WSAGetLastError;
if LastError<>WSAEWOULDBLOCK then
begin
ErrorStr:=SocketErrorStr(LastError);
ProcessError;
end;
end;
repeat
Application.ProcessMessages
until Connected or Canceled or TimedOut;
TimerOff;
if Canceled then
raise EFingerError.Create(feCanceled)
else
if TimedOut then
begin
ErrorStr:=feTimedOut;
ProcessError;
end;
end;
procedure TFinger.Open;
begin
DoConnecting(Self);
ReInit;
ResolveRemoteHost;
FindFingerService;
OpenSocket;
Connect;
end;
procedure TFinger.CloseSocket;
begin
if FingerSocket<>INVALID_SOCKET then
begin
if WinSock.CloseSocket(FingerSocket)=0 then
begin
FingerSocket:=INVALID_SOCKET;
end
else
begin
ErrorStr:=SocketErrorStr(WSAGetLastError);
ProcessError;
end;
end;
end;
procedure TFinger.Close;
begin
CloseSocket;
end;
procedure TFinger.SendQuery;
var
Buf : string;
sd,i : Integer;
LastError : Integer;
Finished : boolean;
begin
DoSending(Self);
Buf:=Concat(AddInfo,^M^J);
TimerOn;
i:=1;
repeat
Application.ProcessMessages;
sd:=Winsock.Send(FingerSocket,Buf,Length(Buf)-i+1,0);
if sd=SOCKET_ERROR then
begin
LastError:=WSAGetLastError;
if LastError<>WSAEWOULDBLOCK then
begin
Error:=true;
ErrorStr:=SocketErrorStr(LastError);
ProcessError;
end;
end
else
Inc(i,sd);
Finished:=i>Length(Buf);
Application.ProcessMessages;
until Finished or TimedOut or Canceled;
TimerOff;
if TimedOut then
begin
ErrorStr:=feTimedOut;
ProcessError;
end
else
if Canceled then
raise EFingerError.Create(feCanceled);
end;
procedure TFinger.RecvData;
var
Ch : Char;
Finished : boolean;
LastError : Integer;
rc : Integer;
SaveTerminalReadOnly : boolean;
begin
DoReceiving(Self);
TimerOn;
repeat
Application.ProcessMessages;
until DataHasArrived or Canceled or TimedOut or Error;
TimerOff;
if Canceled then
raise EFingerError.Create(feCanceled)
else
if TimedOut then
begin
ErrorStr:=feTimedOut;
ProcessError;
end
else
if Error then
begin
ErrorStr:=SocketErrorStr(ErrorNo);
ProcessError;
end;
DataHasArrived:=false;
if Assigned(FTerminal) then
begin
SaveTerminalReadOnly:=FTerminal.ReadOnly;
FTerminal.ReadOnly:=false;
end;
repeat
TimerOn;
Application.ProcessMessages;
rc:=recv(FingerSocket,Ch,1,0);
if rc=SOCKET_ERROR then
begin
LastError:=WSAGetLastError;
if LastError<>WSAEWOULDBLOCK then
begin
ErrorStr:=SocketErrorStr(LastError);
ProcessError;
end;
end
else
begin
if Assigned(FTerminal) and (Ch<>^M) then
SendMessage(FTerminal.Handle,WM_CHAR,word(Ch),0);
OutStream.Write(Ch,1);
end;
Application.ProcessMessages;
Finished:=ConnectionClosed;
TimerOff;
until Finished or Canceled or TimedOut;
OutStream.Position:=0;
if Assigned(FTerminal) then
FTerminal.ReadOnly:=SaveTerminalReadOnly;
if Finished then
DoClosed(Self)
else
if Canceled then
raise EFingerError.Create(feCanceled)
else
if TimedOut then
begin
ErrorStr:=feTimedOut;
ProcessError;
end;
end;
procedure TFinger.Cancel;
begin
Canceled:=true;
DoCanceled(Self);
if AsyncHandle<>0 then
begin
WSACancelAsyncRequest(AsyncHandle);
AsyncHandle:=0;
end;
if WSAIsBlocking then
WSACancelBlockingCall;
end;
procedure TFinger.Execute;
begin
Open;
try
SendQuery;
RecvData;
finally
Close;
end;
end;
end.