blcksock.pas

delphi写的mib browser 源码,界面友好!

{==============================================================================|
| Project : Delphree - Synapse                                   | 002.001.001 |
|==============================================================================|
| Content: Library base                                                        |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| (the "License"); you may not use this file except in compliance with the     |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
|                                                                              |
| Software distributed under the License is distributed on an "AS IS" basis,   |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License.    |
|==============================================================================|
| The Original Code is Synapse Delphi Library.                                 |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)1999,2000,2001.           |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

unit blcksock;

interface

uses
  winsock, SysUtils, windows;

type

ESynapseError = class (Exception)
Public
  ErrorCode:integer;
  ErrorMessage:string;
end;

{TBlockSocket}
TBlockSocket = class (TObject)
Protected
  FSocket:TSocket;
  FLocalSin:TSockAddrIn;
  FRemoteSin:TSockAddrIn;
  FLastError:integer;
  FProtocol:integer;
  FBuffer:string;
  FRaiseExcept:boolean;

  procedure SetSin (var sin:TSockAddrIn;ip,port:string);
  function GetSinIP (sin:TSockAddrIn):string;
  function GetSinPort (sin:TSockAddrIn):integer;
  function GetSizeRecvBuffer:integer;
  procedure SetSizeRecvBuffer(size:integer);
  function GetSizeSendBuffer:integer;
  procedure SetSizeSendBuffer(size:integer);
public
  FWsaData : TWSADATA;

  constructor Create;
  destructor Destroy; override;

  Procedure CreateSocket; virtual;
  Procedure CloseSocket;
  procedure Bind(ip,port:string);
  procedure Connect(ip,port:string);
  function SendBuffer(buffer:pointer;length:integer):integer; virtual;
  procedure SendByte(data:byte); virtual;
  procedure SendString(data:string); virtual;
  function RecvBuffer(buffer:pointer;length:integer):integer; virtual;
  function RecvBufferEx(buffer:pointer;length:integer;timeout:integer):integer; virtual;
  function RecvByte(timeout:integer):byte; virtual;
  function Recvstring(timeout:integer):string; virtual;
  function PeekBuffer(buffer:pointer;length:integer):integer; virtual;
  function PeekByte(timeout:integer):byte; virtual;
  function WaitingData:integer;
  procedure SetLinger(enable:boolean;Linger:integer);
  procedure GetSins;
  function SockCheck(SockResult:integer):integer;
  procedure ExceptCheck;
  function LocalName:string;
  function GetLocalSinIP:string;
  function GetRemoteSinIP:string;
  function GetLocalSinPort:integer;
  function GetRemoteSinPort:integer;
  function CanRead(Timeout:integer):boolean;
  function CanWrite(Timeout:integer):boolean;
  function SendBufferTo(buffer:pointer;length:integer):integer;
  function RecvBufferFrom(buffer:pointer;length:integer):integer;

  property LocalSin:TSockAddrIn read FLocalSin;
  property RemoteSin:TSockAddrIn read FRemoteSin;
published
  property socket:TSocket read FSocket write FSocket;
  property LastError:integer read FLastError;
  property Protocol:integer read FProtocol;
  property LineBuffer:string read FBuffer write FBuffer;
  property RaiseExcept:boolean read FRaiseExcept write FRaiseExcept;
  property SizeRecvBuffer:integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
  property SizeSendBuffer:integer read GetSizeSendBuffer write SetSizeSendBuffer;
end;

{TUDPBlockSocket}
TUDPBlockSocket = class (TBlockSocket)
public
  procedure CreateSocket; override;
  function EnableBroadcast(Value:Boolean):Boolean;
end;

{TTCPBlockSocket}
TTCPBlockSocket = class (TBlockSocket)
public
  procedure CreateSocket; override;
  procedure Listen;
  function Accept:TSocket;
end;

function GetErrorDesc(ErrorCode:integer): string;

implementation

{TBlockSocket.Create}
constructor TBlockSocket.Create;
begin
  inherited create;
  FRaiseExcept:=false;
  FSocket:=INVALID_SOCKET;
  FProtocol:=IPPROTO_IP;
  Fbuffer:='';
  SockCheck(winsock.WSAStartup($101, FWsaData));
  ExceptCheck;
end;

{TBlockSocket.Destroy}
destructor TBlockSocket.Destroy;
begin
  CloseSocket;
  inherited destroy;
end;

{TBlockSocket.SetSin}
procedure TBlockSocket.SetSin (var sin:TSockAddrIn;ip,port:string);
var
  ProtoEnt: PProtoEnt;
  ServEnt: PServEnt;
  HostEnt: PHostEnt;
begin
  FillChar(sin,Sizeof(sin),0);
  sin.sin_family := AF_INET;
  ProtoEnt:= getprotobynumber(FProtocol);
  ServEnt:=nil;
  If ProtoEnt <> nil then
    ServEnt:= getservbyname(PChar(port), ProtoEnt^.p_name);
  if ServEnt = nil then
    Sin.sin_port:= htons(StrToIntDef(Port,0))
  else
    Sin.sin_port:= ServEnt^.s_port;
  if ip='255.255.255.255'
    then Sin.sin_addr.s_addr:=u_long(INADDR_BROADCAST)
    else
      begin
        Sin.sin_addr.s_addr:= inet_addr(PChar(ip));
        if SIn.sin_addr.s_addr = u_long(INADDR_NONE) then
          begin
            HostEnt:= gethostbyname(PChar(ip));
            if HostEnt <> nil then
              SIn.sin_addr.S_addr:= longint(plongint(HostEnt^.h_addr_list^)^);
          end;
      end;
end;

{TBlockSocket.GetSinIP}
function TBlockSocket.GetSinIP (sin:TSockAddrIn):string;
var
  p:pchar;
begin
  p:=inet_ntoa(Sin.sin_addr);
  if p=nil then result:=''
    else result:=p;
end;

{TBlockSocket.GetSinPort}
function TBlockSocket.GetSinPort (sin:TSockAddrIn):integer;
begin
  result:=ntohs(Sin.sin_port);
end;

{TBlockSocket.CreateSocket}
Procedure TBlockSocket.CreateSocket;
begin
  Fbuffer:='';
  if FSocket=INVALID_SOCKET then FLastError:=winsock.WSAGetLastError
    else FLastError:=0;
  ExceptCheck;
end;


{TBlockSocket.CloseSocket}
Procedure TBlockSocket.CloseSocket;
begin
  winsock.CloseSocket(FSocket);
end;

{TBlockSocket.Bind}
procedure TBlockSocket.Bind(ip,port:string);
var
  sin:TSockAddrIn;
  len:integer;
begin
  SetSin(sin,ip,port);
  SockCheck(winsock.bind(FSocket,sin,sizeof(sin)));
  len:=sizeof(FLocalSin);
  Winsock.GetSockName(FSocket,FLocalSin,Len);
  Fbuffer:='';
  ExceptCheck;
end;

{TBlockSocket.Connect}
procedure TBlockSocket.Connect(ip,port:string);
var
  sin:TSockAddrIn;
begin
  SetSin(sin,ip,port);
  SockCheck(winsock.connect(FSocket,sin,sizeof(sin)));
  GetSins;
  Fbuffer:='';
  ExceptCheck;
end;

{TBlockSocket.GetSins}
procedure TBlockSocket.GetSins;
var
  len:integer;
begin
  len:=sizeof(FLocalSin);
  Winsock.GetSockName(FSocket,FLocalSin,Len);
  len:=sizeof(FRemoteSin);
  Winsock.GetPeerName(FSocket,FremoteSin,Len);
end;

{TBlockSocket.SendBuffer}
function TBlockSocket.SendBuffer(buffer:pointer;length:integer):integer;
begin
  result:=winsock.send(FSocket,buffer^,length,0);
  sockcheck(result);
  ExceptCheck;
end;

{TBlockSocket.SendByte}
procedure TBlockSocket.SendByte(data:byte);
begin
  sockcheck(winsock.send(FSocket,data,1,0));
  ExceptCheck;
end;

{TBlockSocket.SendString}
procedure TBlockSocket.SendString(data:string);
begin
  sockcheck(winsock.send(FSocket,pchar(data)^,length(data),0));
  ExceptCheck;
end;

{TBlockSocket.RecvBuffer}
function TBlockSocket.RecvBuffer(buffer:pointer;length:integer):integer;
begin
  result:=winsock.recv(FSocket,buffer^,length,0);
  if result=0
    then FLastError:=WSAENOTCONN
    else sockcheck(result);
  ExceptCheck;
end;

{TBlockSocket.RecvBufferEx}
function TBlockSocket.RecvBufferEx(buffer:pointer;length:integer;timeout:integer):integer;
var
  s,ss,st:string;
  x,l,lss:integer;
  fb,fs:integer;
  max:integer;
begin
  FLastError:=0;
  x:=system.length(FBuffer);
  if length<=x
    then
      begin
        fb:=length;
        fs:=0;
      end
    else
      begin
        fb:=x;
        fs:=length-x;
      end;
  ss:='';
  if fb>0 then
    begin
      s:=copy(FBuffer,1,fb);
      delete(Fbuffer,1,fb);
    end;
  if fs>0 then
    begin
      Max:=GetSizeRecvBuffer;
      ss:='';
      while system.length(ss)<fs do
        begin
          if canread(timeout) then
            begin
              l:=WaitingData;
              if l>max
                then l:=max;
              if (system.length(ss)+l)>fs
                then l:=fs-system.length(ss);
              setlength(st,l);
              x:=winsock.recv(FSocket,pointer(st)^,l,0);
              if x=0
                then FLastError:=WSAENOTCONN
                else sockcheck(x);
              if Flasterror<>0
                then break;
              lss:=system.length(ss);
              setlength(ss,lss+x);
              Move(pointer(st)^,Pointer(@ss[lss+1])^, x);
              {It is 3x faster then ss:=ss+copy(st,1,x);}
              sleep(0);
            end
            else FLastError:=WSAETIMEDOUT;
          if Flasterror<>0
            then break;
        end;
      fs:=system.length(ss);
    end;
  result:=fb+fs;
  s:=s+ss;
  move(pointer(s)^,buffer^,result);
  ExceptCheck;
end;

{TBlockSocket.RecvByte}
function TBlockSocket.RecvByte(timeout:integer):byte;
var
  y:integer;
  data:byte;
begin
  data:=0;
  result:=0;
  if CanRead(timeout) then
    begin
      y:=winsock.recv(FSocket,data,1,0);
      if y=0 then FLastError:=WSAENOTCONN
        else sockcheck(y);
      result:=data;
    end
    else FLastError:=WSAETIMEDOUT;
  ExceptCheck;
end;

{TBlockSocket.Recvstring}
function TBlockSocket.Recvstring(timeout:integer):string;
const
  maxbuf=1024;
var
  x:integer;
  s:string;
  c:char;
  r:integer;
begin
  s:='';
  FLastError:=0;
  c:=#0;
  repeat
    if FBuffer='' then
      begin
        x:=waitingdata;
        if x=0 then x:=1;
        if x>maxbuf then x:=maxbuf;
        if x=1 then