unit cap_ip;

interface

uses
  Windows, Messages,Classes,winsock,sysutils;
const
   WM_CapIp = WM_USER + 200;

   STATUS_FAILED        =$FFFF;		//定義異常出錯代碼
   MAX_PACK_LEN         =65535;		//接收的最大IP報文
   MAX_ADDR_LEN         =16;		//點分十進制地址的最大長度
   MAX_PROTO_TEXT_LEN   =16;		//子協議名稱(如"TCP")最大長度
   MAX_PROTO_NUM        =12;		//子協議數量
   MAX_HOSTNAME_LAN     =255;		//最大主機名長度
   CMD_PARAM_HELP       =true;

   IOC_IN               =$80000000;
   IOC_VENDOR           =$18000000;
   IOC_out              =$40000000;
   SIO_RCVALL           =IOC_IN or IOC_VENDOR or 1;// or IOC_out;
   SIO_RCVALL_MCAST     =IOC_IN or IOC_VENDOR or 2;
   SIO_RCVALL_IGMPMCAST =IOC_IN or IOC_VENDOR or 3;
   SIO_KEEPALIVE_VALS   =IOC_IN or IOC_VENDOR or 4;
   SIO_ABSORB_RTRALERT  =IOC_IN or IOC_VENDOR or 5;
   SIO_UCAST_IF         =IOC_IN or IOC_VENDOR or 6;
   SIO_LIMIT_BROADCASTS =IOC_IN or IOC_VENDOR or 7;
   SIO_INDEX_BIND       =IOC_IN or IOC_VENDOR or 8;
   SIO_INDEX_MCASTIF    =IOC_IN or IOC_VENDOR or 9;
   SIO_INDEX_ADD_MCAST  =IOC_IN or IOC_VENDOR or 10;
   SIO_INDEX_DEL_MCAST  =IOC_IN or IOC_VENDOR or 11;


 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[0..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;
  TOnError = procedure(Error : string) of object;

  Tcap_ip = class(TComponent)
  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;

  protected
     procedure   WndProc(var MsgRec: TMessage);
     function DecodeIpPack(ip:string;buf:pchar;iBufSize:integer):integer;         //IP解包函數
//     function DecodeTcpPack(TcpBuf:pchar;iBufSize:integer):integer; 	//TCP解包函數
     //function DecodeUdpPack(p:pchar;i:integer):integer;		//UDP解包函數
     //function DecodeIcmpPack(p:pchar;i:integer):integer;        	//ICMP解包函數
     function  CheckProtocol(iProtocol:integer):string;			//協議檢查
     procedure cap_ip(socket_no:integer);
     procedure get_ActiveIP;                                            //得當前的IP列表
     procedure set_socket_state;                                        //設置網卡狀態
     function  CheckSockError(iErrorCode:integer):boolean;              	//出錯處理函數
  public
    Fpause                 :boolean;//暫停
    Finitsocket            :boolean;//是否已初始化
    constructor Create(Owner : TComponent); override;
    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;

procedure Register;

implementation
function XSocketWindowProc(ahWnd   : HWND;auMsg   : Integer;awParam : WPARAM; alParam : LPARAM): Integer; stdcall;
var
    Obj    : Tcap_ip;
    MsgRec : TMessage;
begin
    { At window creation ask windows to store a pointer to our object       }
    Obj := Tcap_ip(GetWindowLong(ahWnd, 0));

    { If the pointer is not assigned, just call the default procedure       }
    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         : 0;
        lpfnWndProc   : @XSocketWindowProc;
        cbClsExtra    : 0;
        cbWndExtra    : SizeOf(Pointer);
        hInstance     : 0;
        hIcon         : 0;
        hCursor       : 0;
        hbrBackground : 0;
        lpszMenuName  : nil;
        lpszClassName : 'TCap_ip');


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 = 0 then
           Exit;
    end;

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

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


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Free the window handle                                                    }
procedure XSocketDeallocateHWnd(Wnd: HWND);
begin
    DestroyWindow(Wnd);
end;

//當前機的所有IP地址
procedure Tcap_ip.get_ActiveIP;
type
  TaPInAddr = Array[0..20] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: Array[0..63] of Char;
  I: Integer;
begin
  setlength(FActiveIP,20);

  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(buffer);
  if phe = nil then
   begin
    setlength(FActiveIP,0);
    if Assigned(FOnError) then FOnError('沒有找到可綁定的IP!');
    exit;
   end;