CapIp.pas

unit CapIp;

interface

uses
  Windows, Messages,Classes,winsock,sysutils;

const
  WM_CapIp = WM_USER + ;

  STATUS_FAILED        =$FFFF;      //定义异常出错代码
  MAX_PACK_LEN         =;      //接收的最大IP报文
  MAX_ADDR_LEN         =;     //点分十进制地址的最大长度
  MAX_PROTO_TEXT_LEN   =;     //子协议名称(如"TCP")最大长度
  MAX_PROTO_NUM        =;     //子协议数量
  MAX_HOSTNAME_LAN     =;        //最大主机名长度
  CMD_PARAM_HELP       =true;

  IOC_IN               =$;
  IOC_VENDOR           =$;
  IOC_out              =$;
  SIO_RCVALL           =IOC_IN or IOC_VENDOR or ;// or IOC_out;
  SIO_RCVALL_MCAST     =IOC_IN or IOC_VENDOR or ;
  SIO_RCVALL_IGMPMCAST =IOC_IN or IOC_VENDOR or ;
  SIO_KEEPALIVE_VALS   =IOC_IN or IOC_VENDOR or ;
  SIO_ABSORB_RTRALERT  =IOC_IN or IOC_VENDOR or ;
  SIO_UCAST_IF         =IOC_IN or IOC_VENDOR or ;
  SIO_LIMIT_BROADCASTS =IOC_IN or IOC_VENDOR or ;
  SIO_INDEX_BIND       =IOC_IN or IOC_VENDOR or ;
  SIO_INDEX_MCASTIF    =IOC_IN or IOC_VENDOR or ;
  SIO_INDEX_ADD_MCAST  =IOC_IN or IOC_VENDOR or ;
  SIO_INDEX_DEL_MCAST  =IOC_IN or IOC_VENDOR or ;

type
  tcp_keepalive=record
      onoff:Longword;
      keepalivetime:Longword;
      keepaliveinterval:Longword;
end;

// New WSAIoctl Options

//IP头
type
  _iphdr=record
      h_lenver        :byte;        //4位首部长度+4位IP版本号
      tos             :char;        //8位服务类型TOS
      total_len       :char;        //16位总长度（字节）
      ident           :word;        //16位标识
      frag_and_flags  :word;            //3位标志位
      ttl             :byte;        //8位生存时间 TTL
      proto           :byte;        //8位协议 (TCP, UDP 或其他)
      checksum        :word;        //16位IP首部校验和
      sourceIP  :Longword;  //32位源IP地址
      destIP          :Longword;    //32位目的IP地址
end;

IP_HEADER=_iphdr;

type
  _tcphdr=record             //定义TCP首部
      TCP_Sport        :word;       //16位源端口
      TCP_Dport        :word;       //16位目的端口
      th_seq          :longword;    //32位序列号
      th_ack          :longword;    //32位确认号
      th_lenres       :byte;    //4位首部长度/6位保留字
      th_flag         :char;        //6位标志位
      th_win          :word;        //16位窗口大小
      th_sum          :word;            //16位校验和
      th_urp          :word;            //16位紧急数据偏移量
end;

TCP_HEADER=_tcphdr;

type
  _udphdr=record                //定义UDP首部
      uh_sport          :word;      //16位源端口
      uh_dport          :word;      //16位目的端口
      uh_len            :word;          //16位长度
      uh_sum            :word;          //16位校验和
end;

UDP_HEADER=_udphdr;

type
  _icmphdr=record               //定义ICMP首部
      i_type          :byte;            //8位类型
      i_code          :byte;            //8位代码
      i_cksum         :word;            //16位校验和
      i_id            :word;            //识别号（一般用进程号作为识别号）
//      i_seq           :word;          //报文序列号
      timestamp       :word;            //时间戳
end;

ICMP_HEADER=_icmphdr;

type
  _protomap=record          //定义子协议映射表
      ProtoNum    :integer;
      ProtoText   :array[..MAX_PROTO_TEXT_LEN] of char;
end;

TPROTOMAP=_protomap;

type
  ESocketException   = class(Exception);
  TWSAStartup            = function (wVersionRequired: word;
                                       var WSData: TWSAData): Integer; stdcall;
  TOpenSocket            = function (af, Struct, protocol: Integer): TSocket; stdcall;
  TInet_addr             = function (cp: PChar): u_long; stdcall;
  Thtons                 = function (hostshort: u_short): u_short; stdcall;
  TConnect               = function (s: TSocket; var name: TSockAddr;
                                       namelen: Integer): Integer; stdcall;
  TWSAIoctl              = function (s: TSocket; cmd: DWORD;lpInBuffer: PCHAR;
                                 dwInBufferLen:DWORD;lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;
                                 lpdwOutBytesReturned: LPDWORD;lpOverLapped: POINTER;
                                 lpOverLappedRoutine: POINTER): Integer; stdcall;
  TCloseSocket           = function (s: TSocket): Integer; stdcall;
  Tsend                  = function( s:TSOCKET; buf:pchar;Len:integer;flags:integer):Integer;stdcall;
  Trecv                  = function( s:TSOCKET; var buf;Len:integer;flags:integer):Integer;stdcall;
  TWSAAsyncSelect        =function (s: TSocket; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer; stdcall;
  TWSACleanup            =function():integer;stdcall;
  //TOnCap = procedure(ip,proto,sourceIP,destIP,SourcePort,DestPort: string;
  //                     header:pchar;header_size:integer;data:pchar;data_size:integer) of object;
  //TOnCap = procedure(dateStr,timeStr,protoType,PaKnum,direct,proto,Flag,
  //                     remoteIP,DestPort,data_size: string) of object;
  TOnCap = procedure(Allinfo:string) of object;
  TOnError = procedure(Error : string) of object;

   TCapIp = class
  private
    Fhand_dll   :HModule;         // Handle for mpr.dll
    FWindowHandle : HWND;
    FOnCap      :TOnCap;          //捕捉数据的事件
    FOnError    :TOnError;        //发生错误的事件
    Fsocket     :array of Tsocket;
    FActiveIP   :array of string; //存放可用的IP

    FWSAStartup            : TWSAStartup;
    FOpenSocket            : TOpenSocket;
    FInet_addr             : TInet_addr;
    Fhtons                 : Thtons;
    FConnect               : TConnect;
    FCloseSocket           : TCloseSocket;
    Fsend                  :Tsend;
    FWSAIoctl              :TWSAIoctl;
    Frecv                  :Trecv;
    FWSACleanup            :TWSACleanup;
    FWSAAsyncSelect        :TWSAAsyncSelect;
    direct,proto,Flag,remoteIP,DestPort,data_size:string;
    localIp:string;
  protected
    procedure   WndProc(var MsgRec: TMessage);
    //IP解包函数
    function DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer;
    //TCP解包函数
    //function DecodeTcpPack(TcpBuf:pchar;iBufSize:integer):integer;
    //UDP解包函数
    //function DecodeUdpPack(p:pchar;i:integer):integer;
    //ICMP解包函数
    //function DecodeIcmpPack(p:pchar;i:integer):integer;
    //协议检查
    function  CheckProtocol(iProtocol:integer):string;
    procedure CapIp(socket_no:integer);
    //得当前的IP列表
    procedure get_ActiveIP;
    //设置网卡状态
    procedure set_socket_state;
    //出错处理函数
    function  CheckSockError(iErrorCode:integer):boolean;
  public
    Fpause                 :boolean;//暂停
    Finitsocket            :boolean;//是否已初始化
    constructor Create();
    destructor  Destroy; override;
    function    init_socket:boolean;//初始化
    procedure   StartCap;//开始捕捉
    procedure   pause;   //暂停
    procedure   StopCap;//结束捕捉
    property    Handle   : HWND       read FWindowHandle;
  published
    property    OnCap    : TOnCap     read  FOnCap write FOnCap;
    property    OnError  : TOnError   read  FOnError write FOnError;
end;

implementation

function XSocketWindowProc(ahWnd   : HWND;auMsg   : Integer;awParam : WPARAM; alParam : LPARAM): Integer; stdcall;
var
  Obj    : TCapIp;
  MsgRec : TMessage;
begin
  { At window creation ask windows to store a pointer to our object       }
  {GetWindowLong:his function returns the 32 bit value at the specified   }
  {offset into the extra window memory for the specified window.          }
  Obj := TCapIp(GetWindowLong(ahWnd, ));

  { If the pointer is not assigned, just call the default procedure       }
  {  DefWindowProc: This function ensures that all incoming
                       Windows messages are processed. }
  if not Assigned(Obj) then
    Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
  else
  begin
    { Delphi use a TMessage type to pass paramter to his own kind of    }
    { windows procedure. So we are doing the same...                    }
    MsgRec.Msg    := auMsg;
    MsgRec.wParam := awParam;
    MsgRec.lParam := alParam;
    Obj.WndProc(MsgRec);
    Result := MsgRec.Result;
  end;
end;

var
  XSocketWindowClass: TWndClass = (
          style         : ;
          lpfnWndProc   : @XSocketWindowProc;
          cbClsExtra    : ;
          cbWndExtra    : SizeOf(Pointer);
          hInstance     : ;
          hIcon         : ;
          hCursor       : ;
          hbrBackground : ;
          lpszMenuName  : nil;
          lpszClassName : 'TCapIp');

function XSocketAllocateHWnd(Obj : TObject): HWND;
var
  TempClass       : TWndClass;
  ClassRegistered : Boolean;
begin
  { Check if the window class is already registered                       }
  XSocketWindowClass.hInstance := HInstance;
  ClassRegistered := GetClassInfo(HInstance,
                                    XSocketWindowClass.lpszClassName,
                                    TempClass);
  if not ClassRegistered then
  begin
  { Not yet registered, do it right now                                }
    Result := Windows.RegisterClass(XSocketWindowClass);
    if Result =  then
      Exit;
  end;

  { Now create a new window                                               }
  Result := CreateWindowEx(WS_EX_TOOLWINDOW,
                           XSocketWindowClass.lpszClassName,
                           '',        { Window name   }
                           WS_POPUP,  { Window Style  }
                           , ,      { X, Y          }
                           , ,      { Width, Height }
                           ,         { hWndParent    }
                           ,         { hMenu         }
                           HInstance, { hInstance     }
                           nil);      { CreateParam   }

  { if successfull, the ask windows to store the object reference         }
  { into the reserved byte (see RegisterClass)                            }
  if (Result <> ) and Assigned(Obj) then
    SetWindowLong(Result, , Integer(Obj));
end;

procedure XSocketDeallocateHWnd(Wnd: HWND);
begin
  DestroyWindow(Wnd);
end;

procedure TCapIp.get_ActiveIP;
type
  TaPInAddr = Array[..] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: Array[..] of Char;
  I: Integer;
begin
  setlength(FActiveIP,);

  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(buffer);
  if phe = nil then
  begin
    setlength(FActiveIP,);
    if Assigned(FOnError) then
      FOnError('没有找到可绑定的IP!');
    exit;
  end;
  pPtr:= PaPInAddr(phe^.h_addr_list);
  I:= ;
  while (pPtr^[I] <> nil) and (i<) do
  begin
    FActiveIP[I]:=inet_ntoa(pptr^[I]^);
    Inc(I);
  end;
  setlength(FActiveIP,i);
  localIp:=FActiveIP[i-];
end;

procedure TCapIp.set_socket_state;
var
  i,iErrorCode:integer;
  sa: tSockAddrIn;
  dwBufferLen:array[..]of DWORD;
  dwBufferInLen:DWORD;
  dwBytesReturned:DWORD;
begin
  if high(FActiveIP)=- then
    exit;
  setlength(Fsocket,high(FActiveIP)+);
  for i:= to high(FActiveIP) do
  begin
    Fsocket[i]:= socket(AF_INET , SOCK_RAW , IPPROTO_IP);
    sa.sin_family:= AF_INET;
    sa.sin_port := htons(i);
    sa.sin_addr.S_addr:=Inet_addr(pchar(FActiveIP[i]));
    iErrorCode := bind(Fsocket[i],sa, sizeof(sa));
    CheckSockError(iErrorCode);

    dwBufferInLen :=;
    dwBytesReturned:=;
    //receive all packages !
    iErrorCode:=FWSAIoctl(Fsocket[i], SIO_RCVALL,@dwBufferInLen, sizeof(dwBufferInLen),
      @dwBufferLen, sizeof(dwBufferLen),@dwBytesReturned ,nil ,nil);

    CheckSockError(iErrorCode);
    iErrorCode:=WSAAsyncSelect(Fsocket[i],FWindowHandle,WM_CapIp+i,FD_READ or FD_CLOSE);
    CheckSockError(iErrorCode);
  end;
end;

procedure TCapIp.CapIp(socket_no:integer);
var
  iErrorCode:integer;
  RecvBuf:array[..MAX_PACK_LEN] of char;
begin
  fillchar(RecvBuf,sizeof(RecvBuf),);
  iErrorCode := frecv(Fsocket[socket_no], RecvBuf, sizeof(RecvBuf), );
  CheckSockError(iErrorCode);
  data_size:=inttostr(iErrorCode);
  if not Fpause then
  begin
    iErrorCode := DecodeIpPack(FActiveIP[socket_no],RecvBuf, iErrorCode);
    CheckSockError(iErrorCode);
  end;
end;

function TCapIp.CheckProtocol(iProtocol:integer):string;
begin
  result:='';
  case iProtocol of
    IPPROTO_IP   :result:='IP';
    IPPROTO_ICMP :result:='ICMP';
    IPPROTO_IGMP :result:='IGMP';
    IPPROTO_GGP  :result:='GGP';
    IPPROTO_TCP  :result:='TCP';
    IPPROTO_PUP  :result:='PUP';
    IPPROTO_UDP  :result:='UDP';
    IPPROTO_IDP  :result:='IDP';
    IPPROTO_ND   :result:='NP';
    IPPROTO_RAW  :result:='RAW';
    IPPROTO_MAX  :result:='MAX';
  else
    result:='';
  end;
end;

function TCapIp.DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer;
var
//  LSourcePort,LDestPort:word;
  LDestPort:word;
  iProtocol, iTTL:integer;
  szProtocol :array[..MAX_PROTO_TEXT_LEN] of char;
  szSourceIP :array[..MAX_ADDR_LEN] of char;
  szDestIP   :array[..MAX_ADDR_LEN] of char;

  pIpheader:IP_HEADER;
  pTcpHeader:TCP_HEADER;
  pUdpHeader:UDP_HEADER;
  pIcmpHeader:ICMP_HEADER;
  saSource, saDest:TSockAddrIn;
  iIphLen:integer;
//  TcpHeaderLen:integer;
//  TcpData:pchar;
  AllInfo:string;
begin
  result:=;
  CopyMemory(@pIpheader,buf,sizeof(pIpheader));

  iProtocol := pIpheader.proto;
  StrLCopy(szProtocol, pchar(CheckProtocol(iProtocol)),);

  saSource.sin_addr.s_addr := pIpheader.sourceIP;
  strlcopy(szSourceIP, inet_ntoa(saSource.sin_addr), MAX_ADDR_LEN);

  saDest.sin_addr.s_addr := pIpheader.destIP;
  strLcopy(szDestIP, inet_ntoa(saDest.sin_addr), MAX_ADDR_LEN);
    iTTL := pIpheader.ttl;

  Flag:='';
  iIphLen :=sizeof(pIpheader);

  case iProtocol of
    IPPROTO_TCP :
                begin
                  CopyMemory(@pTcpHeader,buf+iIphLen,sizeof(pTcpHeader));

                  //LSourcePort := ntohs(pTcpHeader.TCP_Sport);
                  LDestPort := ntohs(pTcpHeader.TCP_Dport);
                  //TcpData:=buf+iIphLen+sizeof(pTcpHeader);
                  //data_size:=iBufSize-iIphLen-sizeof(pTcpHeader);
                  flag:='';
                end;
    IPPROTO_UDP :
                begin
                  CopyMemory(@pUdpHeader,buf+iIphLen,sizeof(pUdpHeader));
                  //LSourcePort := ntohs(pUdpHeader.uh_sport);
                  LDestPort := ntohs(pUdpHeader.uh_dport);
                  //TcpData:=buf+iIphLen+sizeof(pUdpHeader);
                  //data_size:=iBufSize-iIphLen-sizeof(pUdpHeader);
                end;
    IPPROTO_ICMP    :
                begin
                  CopyMemory(@pIcmpHeader,buf+iIphLen,sizeof(pIcmpHeader));
                  //LSourcePort := pIcmpHeader.i_type;
                  LDestPort := pIcmpHeader.i_code;
                  //TcpData:=buf+iIphLen+sizeof(pIcmpHeader);
                  //data_size:=iBufSize-iIphLen-sizeof(pIcmpHeader);
                end;
    else
    begin
      //LSourcePort :=0;
      LDestPort := ;
      //TcpData:=buf+iIphLen;
      //data_size:=iBufSize-iIphLen;
    end;
  end;

  if StrLIComp(szDestIP,pchar(localIp),)= then
  begin
    direct:='';
    Proto:=string(szProtocol);
    remoteIP:=string(szSourceIP);
    DestPort:=inttostr(LDestPort);
  end
  else
  begin
    direct:='';
    Proto:=string(szProtocol);
    remoteIP:=string(szDestIP);
    DestPort:=inttostr(LDestPort);
  end;
/////////////
  //protoType:='NET';
  AllInfo:=''+direct+'|'+''+'|'+proto+'|'+ remoteIP
    +'|'+ DestPort;//+'|'+ data_size;
  if (Assigned(FOnCap)) and (iTTL>) then
    //FOnCap(dateStr,timeStr,'NET','1',direct,proto,Flag,remoteIP,DestPort,data_size);
    FOnCap(AllInfo);
/////////////
end;

function TCapIp.CheckSockError(iErrorCode:integer):boolean;
begin
  if(iErrorCode=SOCKET_ERROR) then
  begin
    if Assigned(FOnError) then
      FOnError(inttostr(GetLastError)+SysErrorMessage(GetLastError));
    result:=true;
  end
  else
    result:=false;
end;

procedure TCapIp.WndProc(var MsgRec: TMessage);
begin
  with MsgRec do
  if (Msg >=WM_CapIp) and (Msg <= WM_CapIp+high(FActiveIP)) then
    CapIp(msg-WM_CapIp)
  else
    Result := DefWindowProc(Handle, Msg, wParam, lParam);
end;

constructor TCapIp.Create();
begin
  Fpause:=false;
  Finitsocket:=false;
  setlength(Fsocket,);
  FWindowHandle := XSocketAllocateHWnd(Self);
end;

destructor TCapIp.Destroy;
var
  i:integer;
begin
  for i:= to high(Fsocket) do
    FCloseSocket(Fsocket[i]);
  if self.Finitsocket then
  begin
    FWSACleanup;
    if Fhand_dll <>  then
      FreeLibrary(Fhand_dll);
  end;
end;

function TCapIp.init_socket:boolean;//初始化
var
  GInitData:TWSAData;
begin
  result:=true;
  if Finitsocket then
    exit;
  Fhand_dll := LoadLibrary('ws2_32.dll');
  if Fhand_dll =  then
  begin
    raise ESocketException.Create('Unable to register ws2_32.dll');
    result:=false;
    exit;
  end;
  @FWSAStartup  := GetProcAddress(Fhand_dll, 'WSAStartup');

  @FOpenSocket :=  GetProcAddress(Fhand_dll, 'socket');
  @FInet_addr :=   GetProcAddress(Fhand_dll, 'inet_addr');
  @Fhtons  :=      GetProcAddress(Fhand_dll, 'htons');
  @FConnect :=     GetProcAddress(Fhand_dll, 'connect');
  @FCloseSocket := GetProcAddress(Fhand_dll, 'closesocket');
  @Fsend        := GetProcAddress(Fhand_dll, 'send');
  @FWSAIoctl := GetProcAddress(Fhand_dll, 'WSAIoctl');
  @Frecv        := GetProcAddress(Fhand_dll, 'recv');
  @FWSACleanup  := GetProcAddress(Fhand_dll, 'WSACleanup');
  @FWSAAsyncSelect:=GetProcAddress(Fhand_dll, 'WSAAsyncSelect');
  if (@FWSAStartup =nil) or(@Fhtons =nil) or (@FConnect =nil) or (@Fsend =nil)
    or (@FWSACleanup=nil) or (@FOpenSocket =nil) or (@FInet_addr =nil)
    or (@FCloseSocket =nil) or (@recv=nil)or (@FWSAIoctl=nil)
    or (@FWSAAsyncSelect=nil) then
  begin
    raise ESocketException.Create('加载dll函数错误!');
    result:=false;
    exit;
  end;

  if FWSAStartup($,GInitData)<> then
  begin
    raise ESocketException.Create('初始化SOCKET2函数失败!');
    result:=false;
    exit;
  end;
  Finitsocket:=true;
end;

procedure TCapIp.StartCap;
begin
  if not Finitsocket then
    if not init_socket then
      exit;
  get_ActiveIP;
  set_socket_state;
end;

procedure  TCapIp.pause;
begin
  if Finitsocket and (high(Fsocket)>-) then
    Fpause:=not Fpause;
end;

procedure TCapIp.StopCap;
var
  i:integer;
begin
  for i:= to high(Fsocket) do
    FCloseSocket(Fsocket[i]);
end;

end.