1、界面
1.1、formMain.pas
1.1.1、
object frmMain: TfrmMainLeft = 191Top = 103Width = 542Height = 466Caption = 'frmMain'Color = clBtnFaceFont.Charset = DEFAULT_CHARSETFont.Color = clWindowTextFont.Height = -11Font.Name = 'MS Sans Serif'Font.Style = []OldCreateOrder = FalsePosition = poDesktopCenterOnCreate = FormCreateDesignSize = (534439)PixelsPerInch = 96TextHeight = 13object Label1: TLabelLeft = 16Top = 8Width = 41Height = 13AutoSize = FalseCaption = 'IP : 'endobject Label2: TLabelLeft = 176Top = 8Width = 49Height = 13AutoSize = FalseCaption = 'Port : 'endobject btnSetIpPort: TButtonLeft = 16Top = 32Width = 75Height = 25Caption = '设置信息'TabOrder = 0OnClick = btnSetIpPortClickendobject Memo1: TMemoLeft = 16Top = 128Width = 497Height = 299Anchors = [akLeft, akTop, akRight, akBottom]Lines.Strings = ('Memo1')ScrollBars = ssBothTabOrder = 1endobject btnSend: TButtonLeft = 96Top = 32Width = 75Height = 25Caption = '发送消息'TabOrder = 2OnClick = btnSendClickendobject btnStatus: TButtonLeft = 176Top = 32Width = 75Height = 25Caption = 'skt状态'TabOrder = 3OnClick = btnStatusClickendobject btnClearMemo: TButtonLeft = 256Top = 32Width = 89Height = 25Caption = '清空消息框'TabOrder = 4OnClick = btnClearMemoClickendobject btnAllClients: TButtonLeft = 208Top = 64Width = 137Height = 25Caption = '所有客户端信息'TabOrder = 5OnClick = btnAllClientsClickendobject btnSocket: TButtonLeft = 16Top = 96Width = 153Height = 25Caption = '客户端网络信息'TabOrder = 6OnClick = btnSocketClickendobject edtAddress: TEditLeft = 16Top = 64Width = 185Height = 21TabOrder = 7Text = 'edtAddress'endobject btnBlock: TButtonLeft = 192Top = 96Width = 153Height = 25Caption = '客户端内存块信息'TabOrder = 8OnClick = btnBlockClickendobject edtIP: TEditLeft = 40Top = 4Width = 121Height = 21TabOrder = 9Text = '192.168.1.233'endobject edtPort: TEditLeft = 216Top = 4Width = 89Height = 21TabOrder = 10Text = '9888'endobject btnFrmSQL: TButtonLeft = 432Top = 32Width = 75Height = 25Caption = 'btnFrmSQL'TabOrder = 11OnClick = btnFrmSQLClickend end
1.2、formSQL.pas
1.2.1、
object frmSQL: TfrmSQLLeft = 362Top = 105Width = 457Height = 480Caption = 'frmSQL'Color = clBtnFaceFont.Charset = DEFAULT_CHARSETFont.Color = clWindowTextFont.Height = -11Font.Name = 'MS Sans Serif'Font.Style = []OldCreateOrder = FalsePosition = poDesktopCenterDesignSize = (449453)PixelsPerInch = 96TextHeight = 13object Label1: TLabelLeft = 16Top = 14Width = 145Height = 13AutoSize = FalseCaption = 'SQL语句 : 'endobject lvSQL: TListViewLeft = 16Top = 96Width = 416Height = 345Anchors = [akLeft, akTop, akRight, akBottom]Columns = <>GridLines = TrueOwnerData = TrueReadOnly = TrueRowSelect = TrueTabOrder = 0ViewStyle = vsReportOnData = lvSQLDataendobject Button1: TButtonLeft = 359Top = 8Width = 75Height = 25Anchors = [akTop, akRight]Caption = 'Button1'TabOrder = 1OnClick = Button1Clickendobject edtSQL: TEditLeft = 80Top = 10Width = 264Height = 21Anchors = [akLeft, akTop, akRight]TabOrder = 2Text = 'select * from file_tbl where rownum<5'endobject btnBLOB: TButtonLeft = 16Top = 48Width = 75Height = 25Caption = 'btnBLOB'TabOrder = 3OnClick = btnBLOBClickend end
2、代码：
2.1、formMain.pas
unit formMain;interfaceusesWindows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs, StdCtrls,classDrTcp, Winsock2;typeTfrmMain = class(TForm)Memo1: TMemo;btnSetIpPort: TButton;btnSend: TButton;btnStatus: TButton;btnClearMemo: TButton;btnAllClients: TButton;btnSocket: TButton;edtAddress: TEdit;btnBlock: TButton;Label1: TLabel;edtIP: TEdit;Label2: TLabel;edtPort: TEdit;btnFrmSQL: TButton;procedure btnSetIpPortClick(Sender: TObject);procedure btnSendClick(Sender: TObject);procedure btnClearMemoClick(Sender: TObject);procedure btnStatusClick(Sender: TObject);procedure btnAllClientsClick(Sender: TObject);procedure FormCreate(Sender: TObject);procedure btnSocketClick(Sender: TObject);procedure btnBlockClick(Sender: TObject);procedure btnFrmSQLClick(Sender: TObject);publicpublicprocedure UnpackClients(_pc :PChar; _iLen :integer);procedure UnpackSocket(_pc :PChar; _iLen :integer);procedure UnpackBlock(_pc :PChar; _iLen :integer);end;varfrmMain: TfrmMain;implementationusesformSQL;{$R *.dfm}procedure TfrmMain.FormCreate(Sender: TObject); begin // edtIP.Text := '192.168.1.15'; end;procedure TfrmMain.btnSetIpPortClick(Sender: TObject); var iPort :Integer; begin//TdrTcpClient.SetIpPort('127.0.0.1', 9888);//TdrTcpClient.SetIpPort('192.168.1.15', 9888);//TdrTcpClient.SetIpPort('192.168.1.233', 9888);iPort := StrToIntDef(trim(edtPort.Text), 9888);TdrTcpClient.SetIpPort(Trim(edtIP.Text), iPort); end;procedure TfrmMain.btnSendClick(Sender: TObject); beginTdrTcpClient.SendSQL('select * from ccc'); end;procedure TfrmMain.btnStatusClick(Sender: TObject); beginMemo1.Lines.Add(IntToStr(TdrTcpClient.Status)); end;procedure TfrmMain.btnClearMemoClick(Sender: TObject); beginMemo1.Lines.Clear; end;procedure TfrmMain.UnpackClients(_pc: PChar; _iLen: integer); var iLen, iIdx :integer;str :string;ll :LONGLONG; beginMemo1.Lines.Add('所有客户端的 IP/Port 信息 :');CopyMemory(@ll, @_pc[0], SizeOf(LONGLONG));Memo1.Lines.Add(' 当前时间(ms) : '+inttostr(ll));iIdx := SizeOf(LONGLONG);Dec(_iLen, 8);while _iLen>0 dobeginCopyMemory(@ll, @_pc[iIdx], 8);Memo1.Lines.Add(' 时间(ms) : '+inttostr(ll));CopyMemory(@iLen, @_pc[iIdx+8], 4);SetLength(str, iLen);CopyMemory(@str[1], @_pc[iIdx+4+8], iLen);Inc(iIdx, 4+8+iLen);Memo1.Lines.Add(' '+str);Memo1.Lines.Add('');Dec(_iLen, 4+8+iLen);end;SetLength(str, 0); end;procedure TfrmMain.UnpackSocket(_pc: PChar; _iLen: integer); var strIpRes, strMacRes, strReq :string;iLenIpRes, iLenMacRes, iLenReq :Integer;iLenMsg :Integer;strMsg :string; beginCopyMemory(@iLenMsg, @_pc[0], 4);if (iLenMsg < 0) thenbeginiLenMsg := -iLenMsg;SetLength(strMsg, iLenMsg);CopyMemory(@strMsg[1], @_pc[4], iLenMsg);Memo1.Lines.Add('请求主机信息(未找到)：');Memo1.Lines.Add(' '+strMsg);endelsebeginCopyMemory(@iLenIpRes, @_pc[4], 4);SetLength(strIpRes, iLenIpRes - 4);CopyMemory(@strIpRes[1], @_pc[8], iLenIpRes - 4);CopyMemory(@iLenMacRes, @_pc[4+iLenIpRes], 4);SetLength(strMacRes, iLenMacRes - 4);CopyMemory(@strMacRes[1], @_pc[4+iLenIpRes+4], iLenMacRes - 4);CopyMemory(@iLenReq, @_pc[4+iLenIpRes+iLenMacRes], 4);SetLength(strReq, iLenReq - 4);CopyMemory(@strReq[1], @_pc[4+iLenIpRes+iLenMacRes+4], iLenReq - 4);Memo1.Lines.Add('请求主机"'+strReq+'"的信息：');Memo1.Lines.Add(' IP : '+strIpRes);Memo1.Lines.Add(' Mac : '+strMacRes);end; end;procedure TfrmMain.UnpackBlock(_pc: PChar; _iLen: integer); var iTotalLen :Integer;iValidBeginOffset :Integer;iValidLen :Integer;dwType :DWORD;dwLastTick :DWORD;// *** iLenBlockMsg, iOffset, iIdx :Integer;iLenReq :Integer;strReq :string;dwTick :DWORD; beginCopyMemory(@iLenBlockMsg, @_pc[0], 4);CopyMemory(@dwTick, @_pc[4], 4);CopyMemory(@iLenReq, @_pc[iLenBlockMsg], 4);SetLength(strReq, iLenReq-4);CopyMemory(@strReq[1], @_pc[iLenBlockMsg+4], iLenReq-4);Memo1.Lines.Add('请求主机"'+strReq+'"的信息：'+inttostr(dwTick));Memo1.Lines.Add(' '+inttostr(dwTick)+' : '+inttostr(Length(strReq)));iIdx := 0;iOffset := 8;Dec(iLenBlockMsg, iOffset);while iLenBlockMsg > 0 dobeginInc(iIdx);CopyMemory(@iTotalLen, @_pc[iOffset+0], 4);CopyMemory(@iValidBeginOffset,@_pc[iOffset+4], 4);CopyMemory(@iValidLen, @_pc[iOffset+8], 4);CopyMemory(@dwType, @_pc[iOffset+12], 4);CopyMemory(@dwLastTick, @_pc[iOffset+16], 4);Memo1.Lines.Add(' 内存块('+inttostr(iIdx)+') :');Memo1.Lines.Add(' 总长 : ' +inttostr(iTotalLen));Memo1.Lines.Add(' (有效数据)开始偏移 : '+inttostr(iValidBeginOffset));Memo1.Lines.Add(' (有效数据)长度 : ' +inttostr(iValidLen));Memo1.Lines.Add(' 用途 : 0x' +inttohex(dwType, 8));Memo1.Lines.Add(' 最后申请时间 : ' +inttostr(dwLastTick));Inc(iOffset, 20);Dec(iLenBlockMsg, 20);end; end;procedure TfrmMain.btnAllClientsClick(Sender: TObject); var pc :array[0..255] of Char;iPktLen, iPktIdx, iPktType :Integer; beging_callbackWnd.FfuncClients := UnpackClients;iPktLen := TCP_PACKET_HEADER_LEN;iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_CLIENTS;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);TdrTcpClient.SendBytes(@pc[0], iPktLen); end;procedure TfrmMain.btnSocketClick(Sender: TObject); var pc :array[0..255] of Char;iPktLen, iPktIdx, iPktType :Integer;strRemoteAddress :string;iLen :Integer; beginstrRemoteAddress := Trim(edtAddress.Text);g_callbackWnd.FfuncSocket := UnpackSocket;iPktLen := TCP_PACKET_HEADER_LEN + (4 + Length(strRemoteAddress));iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_SOCKET_REQ;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);// ***iLen := 4 + Length(strRemoteAddress);CopyMemory(@pc[12], @iLen, 4);CopyMemory(@pc[16], @strRemoteAddress[1], Length(strRemoteAddress));TdrTcpClient.SendBytes(@pc[0], iPktLen); end;procedure TfrmMain.btnBlockClick(Sender: TObject); var pc :array[0..255] of Char;iPktLen, iPktIdx, iPktType :Integer;strRemoteAddress :string;iLen :Integer; beginstrRemoteAddress := Trim(edtAddress.Text);g_callbackWnd.FfuncBlock := UnpackBlock;iPktLen := TCP_PACKET_HEADER_LEN + (4+Length(strRemoteAddress));iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_BLOCK_REQ;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);// ***iLen := 4 + Length(strRemoteAddress);CopyMemory(@pc[12], @iLen, 4);CopyMemory(@pc[16], @strRemoteAddress[1], Length(strRemoteAddress));TdrTcpClient.SendBytes(@pc[0], iPktLen); end;procedure TfrmMain.btnFrmSQLClick(Sender: TObject); beginfrmSQL.Show; end;end.
2.2、formSQL.pas
unit formSQL;interfaceusesWindows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs, ComCtrls, StdCtrls,classDrTcp;typeTfrmSQL = class(TForm)lvSQL: TListView;Button1: TButton;edtSQL: TEdit;Label1: TLabel;btnBLOB: TButton;procedure Button1Click(Sender: TObject);procedure lvSQLData(Sender: TObject; Item: TListItem);procedure btnBLOBClick(Sender: TObject);privateFbuffer :TdrBuffer;procedure UnpackSQL(_buffer :TdrBuffer);publicFdataSet :TdrDataSet;FiColumnCnt :Integer;end;varfrmSQL: TfrmSQL;implementationusesformMain;{$R *.dfm}procedure TfrmSQL.Button1Click(Sender: TObject); var pc :array[0..255] of Char;iPktLen, iPktIdx, iPktType :Integer;strSql :string;iLenSQL :Integer; beginif (Fbuffer <> nil) thenbeging_bufferPool.ReleaseBlock(Fbuffer);Fbuffer := nil;end;strSql := Trim(edtSQL.Text);iLenSQL := Length(strSql);if iLenSQL = 0 thenbeginfrmMain.Memo1.Lines.Add('no sql');Exit;end;g_callbackWnd.FfuncSQL := UnpackSQL;Inc(iLenSQL, 4);iPktLen := TCP_PACKET_HEADER_LEN + iLenSQL;iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_SQL;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);// ***CopyMemory(@pc[TCP_PACKET_HEADER_LEN], @iLenSQL, 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN + 4], PChar(strSql), iLenSQL - 4);TdrTcpClient.SendBytes(@pc[0], iPktLen); end;procedure TfrmSQL.UnpackSQL(_buffer :TdrBuffer); var columnNew :TListColumn;i :Integer; beginif (Fbuffer <> nil) thenbeging_bufferPool.ReleaseBlock(Fbuffer);Fbuffer := nil;end;Fbuffer := _buffer;if not Assigned(FdataSet) thenFdataSet := TdrDataSet.Create;FdataSet.Unpack(@_buffer.Fpc[TCP_PACKET_HEADER_LEN], _buffer.FiValidLen - TCP_PACKET_HEADER_LEN);if (FdataSet.ColumnCount <= 0) thenExit;lvSQL.Columns.Clear;FiColumnCnt := FdataSet.ColumnCount;for i:=0 to FiColumnCnt-1 dobegincolumnNew := lvSQL.Columns.Add;columnNew.AutoSize := True;columnNew.Caption := FdataSet.GetFieldName(i);end;lvSQL.Items.Count := FdataSet.RowCount;//lvSQL.Refresh; lvSQL.Repaint; end;procedure TfrmSQL.lvSQLData(Sender: TObject; Item: TListItem); var iColIdx :Integer;rec :TdrRecord;wstr :WideString; beginif (FdataSet = nil) then Exit;if (FdataSet.RowCount <= 0) then Exit;for iColIdx:=0 to FiColumnCnt-1 dobeginrec := FdataSet.Rec[Item.Index, iColIdx];//wstr := rec.asString;//frmMain.Memo1.Lines.Add(IntToStr(Item.Index)+','+IntToStr(iColIdx)+' : '+IntToStr(Integer(rec.FpcRecord)));if (iColIdx = 0) thenItem.Caption := rec.asStringelseItem.SubItems.Add(rec.asString);end; end;procedure TfrmSQL.btnBLOBClick(Sender: TObject); var item :TListItem;rec :TdrRecord;pc :PChar;iLen :Integer; beginitem := lvSQL.Selected;frmMain.Memo1.Lines.Add('ListView select item index : '+IntToStr(item.Index));rec := FdataSet.Rec[item.Index, 3];rec.asByteArray(nil, iLen);frmMain.Memo1.Lines.Add(IntToStr(iLen)); end;end.
2.3、classDrTcp.pas
unit classDrTcp;interfaceusesWindows, Classes, Winsock, SysUtils, Messages, Math;// Math和StrUtils里面都有 IfThen(...)函数constBUFFER_BLOCK = 1024 * 1024;TCP_PACKET_HEADER_LEN = 4 * 3;// 调试输出信息WM_TCP_RECV = WM_USER + $1000;WM_LOG_CONSOLE = WM_USER + $1001;WM_TCP_PUSH = WM_USER + 1000;WM_TCP_CLIENTS = WM_USER + 1001;WM_CLIENT_SOCKET_MSG_REQ = WM_USER + 1002;WM_CLIENT_SOCKET_MSG_RES = WM_USER + 1003; WM_CLIENT_BLOCK_MSG_REQ = WM_USER + 1004;WM_CLIENT_BLOCK_MSG_RES = WM_USER + 1005;WM_MANAGE_SQL = WM_USER + 1006;// TCP数据 操作类型：高16位:高一级类型; 低16位:低一级类型// (正值)正常的 C/S之间的业务逻辑数据OP_TYPE_SQL = $00010000;OP_TYPE_PUSH = $00020000;OP_TYPE_HEARTBEAT = $00030000;// (负值)C/S之间的 管理数据OP_TYPE_MANAGE = $80000000;OP_TYPE_MANAGE_CLIENTS = $80000001; // c请求s,所有客户端的socket信息(简单)OP_TYPE_MANAGE_SOCKET_REQ = $80000010; // c-->s,s-->c, 某个客户端的详细socket信息 (request) (搬运工)OP_TYPE_MANAGE_SOCKET_RES = $80000020; // (response)(搬运工)OP_TYPE_MANAGE_BLOCK_REQ = $80000030; // c-->s,s-->c, 某个客户端的内存block信息 (request) (搬运工)OP_TYPE_MANAGE_BLOCK_RES = $80000040; // (response)(搬运工)OP_TYPE_MANAGE_SQL = $80000002; // 我的SQL语句操作OP_TYPE_RECV = $90000000;constDR_LONGNVARCHAR = -16;DR_NCHAR = -15;DR_NVARCHAR = -9;DR_ROWID = -8;DR_BIT = -7;DR_TINYINT = -6;DR_BIGINT = -5;DR_LONGVARBINARY= -4;DR_VARBINARY = -3;DR_BINARY = -2;DR_LONGVARCHAR = -1;DR_NULL = 0;DR_CHAR = 1;DR_NUMERIC = 2;DR_DECIMAL = 3;DR_INTEGER = 4;DR_SMALLINT = 5;DR_FLOAT = 6;DR_REAL = 7;DR_DOUBLE= 8;DR_VARCHAR = 12;DR_BOOLEAN = 16;DR_DATALINK= 70;DR_DATE = 91;DR_TIME = 92;DR_TIMESTAMP = 93;DR_OTHER = 1111;DR_JAVA_OBJECT = 2000;DR_DISTINCT = 2001;DR_STRUCT = 2002;DR_ARRAY = 2003;DR_BLOB = 2004;DR_CLOB = 2005;DR_REF = 2006;DR_SQLXML = 2009;DR_NCLOB = 2011;//常量定义 ConstMAX_HOSTNAME_LEN = 128;MAX_DOMAIN_NAME_LEN = 128;MAX_SCOPE_ID_LEN = 256;MAX_ADAPTER_NAME_LENGTH = 256;MAX_ADAPTER_DESCRIPTION_LENGTH = 128;MAX_ADAPTER_ADDRESS_LENGTH = 8; //定义相关结构 TypeTIPAddressString = Array[0..4*4-1] of Char;PIPAddrString = ^TIPAddrString;TIPAddrString = RecordNext : PIPAddrString;IPAddress : TIPAddressString;IPMask : TIPAddressString;Context : Integer;end;PFixedInfo = ^TFixedInfo;TFixedInfo = Record { FIXED_INFO }HostName : Array[0..MAX_HOSTNAME_LEN+3] of Char;DomainName : Array[0..MAX_DOMAIN_NAME_LEN+3] of Char;CurrentDNSServer : PIPAddrString;DNSServerList : TIPAddrString;NodeType : Integer;ScopeId : Array[0..MAX_SCOPE_ID_LEN+3] of Char;EnableRouting : Integer;EnableProxy : Integer;EnableDNS : Integer;end;PIPAdapterInfo = ^TIPAdapterInfo;TIPAdapterInfo = Record { IP_ADAPTER_INFO }Next : PIPAdapterInfo;ComboIndex : Integer;AdapterName : Array[0..MAX_ADAPTER_NAME_LENGTH+3] of Char;Description : Array[0..MAX_ADAPTER_DESCRIPTION_LENGTH+3] of Char;AddressLength : Integer;Address : Array[1..MAX_ADAPTER_ADDRESS_LENGTH] of Byte;Index : Integer;_Type : Integer;DHCPEnabled : Integer;CurrentIPAddress : PIPAddrString;IPAddressList : TIPAddrString;GatewayList : TIPAddrString;DHCPServer : TIPAddrString;HaveWINS : Bool;PrimaryWINSServer : TIPAddrString;SecondaryWINSServer : TIPAddrString;LeaseObtained : Integer;LeaseExpires : Integer;end;function GetAdaptersInfo(_ai : PIPAdapterInfo; var _dwBufLen : DWORD) : Integer;StdCall;external 'iphlpapi.dll';typeTdrBuffer = classpublicFpc :PChar;FiTotalLen :Integer;FiValidBeginOffset :Integer;FiValidLen :Integer;FdwType :DWORD; // 用于什么的? TCP接收/SQL/PUSH/...?FdwLastTick :DWORD; // 最后一次被Aquire时候的GetTickCountend;TdrBufferPool = class//(TObject)publicconstructor create;destructor destroy;override;privateFlist :TList;FlistAll :TList;//... 这个没弄，还有加锁没弄...FhEvent :THandle;//...privatefunction NewBlock(_iLen :Integer = 0) :TdrBuffer;function DelBlock(_buffer :TdrBuffer) :Integer;publicfunction AquireBlock(_dwType :DWORD; _iLen :Integer) :TdrBuffer;function ReleaseBlock(_buffer :TdrBuffer) :Integer;publicproperty ListAll :TList read FlistAll;end;// ***TdrRecvBuffer = class//(TObject)publicconstructor Create;destructor Destroy;override;privateFlist :TList;FiTotalLen :Integer;FiPktIdx :Integer; // TCP包 序号 FhEvent :THandle;FiFirstPktLen :Integer;publicfunction BufferAuqire(out _pc :PChar; out _iLen :integer) :integer;function BufferReleaseAll :integer;function BufferRecv(_iRecv :Integer; _iBlockIdx: integer) :Integer;function BufferHandleAll :Integer;// 处理所有已经接收到的 TCP包privatefunction BufferHandle :Integer;// 处理单个 TCP包// ***private// 从接收到的缓冲区里面 得到TCP包头的信息function TcpPktHeader(out _iPktLen, _iPktIdx, _iPktType :Integer) :Integer; // 始终默认是 [0]的缓冲区块// 从TCP包头的信息中，判断 我们是否需要这个TCP包(0:不需要; >0:需要; <0:出错信息)function TcpPktIsNeed(_iPktIdx, _iPktType :integer):Integer;procedure TcpPktDispatch(_buffer :TdrBuffer);end;// ***TdrTcpClient = class(TThread)publicFiErrorNo :Integer;FiStatus :integer; // 线程的状态(0:初始状态; 1:运行中; -1:结束)publicFskt :TSocket;privatefunction RecvTimeoutSet :Integer;function RecvTimeoutCancel :Integer;function Recv01() :Integer;protectedprocedure Execute; override;publicfunction Send01(_pbyte :PByte; _iLen :integer) :Integer;publicclass procedure SetIpPort(_strDestIp :string; _iDestPort :integer);class function Conn :Integer;class procedure SendSQL(_str :string);class procedure SendBytes(_pc :PChar; _iLen :Integer);class function ConnectDest :TSocket;class function Status :Integer;class procedure SendHeartBeat;end;// ***TdrDataSet = class;TdrRecord = classpublicconstructor Create(_dataset :TdrDataSet; _iRowIdx, _iColumnIdx :Integer);procedure FenXi;privateFdataset :TdrDataSet;FiRowIdx, FiColumnIdx :Integer;FpcRecord :PChar; // 指向某个Record的指针publicfunction asByteArray(_pByte :PByte; out _iLen :Integer) :Integer;function asInteger :Integer;function asSingle :Single;function asDouble :Double;function asString :string;privatefunction GetFieldType :Integer;function GetFieldTypeName :string;function GetFieldName :string;publicproperty FieldType :Integer read GetFieldType;property FieldTypeName :string read GetFieldTypeName;property FieldName :string read GetFieldName;end;TdrDataSet = classpublicfunction Unpack(_pc :PChar; _iLen :Integer) :integer;privateFpcBuf :PChar;FiBufLen :Integer; // 缓冲区中 有效数据的长度FaryColumnType :array of Integer;FaryColumnName :array of string;FaryaryRecord :array of array of Integer; // 指向各个Record的指针publicfunction GetFieldType(_iColumnIdx :integer) :Integer;function GetFieldTypeName(_iColumnIdx :integer) :string;function GetFieldName(_iColumnIdx :integer) :string;privateFfield :TdrRecord; // 这个属性有且只有一个publicfunction GetRecord(_iRowIdx, _iColumnIdx :integer):TdrRecord;property Rec[_iRow, _iCol :Integer] :TdrRecord read GetRecord;publicfunction GetRowCount :Integer;function GetColumnCount :Integer;property RowCount: integer read GetRowCount;property ColumnCount: integer read GetColumnCount;end;// ***TfuncPush = procedure(_pc :PChar; _iLen :integer) of Object;TfuncCallback = procedure(_pc :PChar; _iLen :integer) of Object;TfuncCallback_Buf = procedure(_buffer :TdrBuffer) of Object;TcallbackWnd = classpublicconstructor Create;publicFhWnd :HWND;FdwErrNo :DWORD;privateprocedure CreateWindow;public // 打包 信息function PackSocket(_pc :PChar; _iLen :integer) :integer;procedure PackBlock(_pc :PChar; _iLen :integer);publicFfuncPush :TfuncPush;FfuncClients :TfuncCallback; // 拆包 信息 FfuncSocket :TfuncCallback;FfuncBlock :TfuncCallback;FfuncSQL :TfuncCallback_Buf;end;function ProcWindow(_hWnd :HWND; _uMsg :UINT; _wParam :WPARAM; _lParam :LPARAM):longint;stdcall;function ErrorNo2Str(_dwErrNo :DWORD):string;procedure BufferBlockUsage(_iOpType :Integer; var _str :string);varg_callbackWnd :TcallbackWnd = nil; // 需要 自己新建g_bufferPool :TdrBufferPool = nil; // 需要 自己新建implementationusesformMain;varg_drRecvBuffer :TdrRecvBuffer = nil;// 需要 自己新建g_tcpClient :TdrTcpClient = nil; // 需要 自己新建(动态创建，不是在initialization下面创建)g_bufferSql :TdrBuffer = nil;//g_bufferPush :TdrBuffer = nil; // ***g_strDestIp :string;g_iDestPort :integer;//g_tcpClient :TdrTcpClient = nil; // 需要 自己新建(动态创建，不是在initialization下面创建)// ***procedure LogConsole(_str :string); var pc :PChar;iLen :Integer; beginiLen := Length(_str);GetMem(pc, iLen);PostMessage(g_callbackWnd.FhWnd, WM_LOG_CONSOLE, WParam(iLen), LParam(pc)); end;function LogFile(_str :string) :integer; var hFile :THandle;strFileName :string;dwWritten :DWORD;lb :LongBool; beginResult := 0;strFileName := ParamStr(0)+'.'+FormatDateTime('yyyymmdd', now)+'.log';hFile := CreateFile(PChar(strFileName), GENERIC_WRITE, FILE_SHARE_READ, 0, CREATE_NEW, 0, 0);if (hFile = INVALID_HANDLE_VALUE) thenbeginResult := GetLastError;Exit;end;lb := Windows.SetEndOfFile(hFile);if (not lb) thenbeginResult := GetLastError;CloseHandle(hFile);Exit;end;dwWritten := 0;lb := Windows.WriteFile(hFile, _str[1], Length(_str), dwWritten, nil);if (not lb) thenbeginResult := GetLastError;CloseHandle(hFile);Exit;end;CloseHandle(hFile); end;function FieldTypeName_f(_iFieldType :Integer; var _strFieldTypeName :string) :Integer; begincase _iFieldType ofDR_LONGNVARCHAR : _strFieldTypeName := 'DR_LONGNVARCHAR';DR_NCHAR : _strFieldTypeName := 'DR_NCHAR';DR_NVARCHAR : _strFieldTypeName := 'DR_NVARCHAR';DR_ROWID : _strFieldTypeName := 'DR_ROWID';DR_BIT : _strFieldTypeName := 'DR_BIT';DR_TINYINT : _strFieldTypeName := 'DR_TINYINT';DR_BIGINT : _strFieldTypeName := 'DR_BIGINT';DR_LONGVARBINARY : _strFieldTypeName := 'DR_LONGVARBINARY';DR_VARBINARY : _strFieldTypeName := 'DR_VARBINARY';DR_BINARY : _strFieldTypeName := 'DR_BINARY';DR_LONGVARCHAR : _strFieldTypeName := 'DR_LONGVARCHAR';DR_NULL : _strFieldTypeName := 'DR_NULL';DR_CHAR : _strFieldTypeName := 'DR_CHAR';DR_NUMERIC : _strFieldTypeName := 'DR_NUMERIC';DR_DECIMAL : _strFieldTypeName := 'DR_DECIMAL';DR_INTEGER : _strFieldTypeName := 'DR_INTEGER';DR_SMALLINT : _strFieldTypeName := 'DR_SMALLINT';DR_FLOAT : _strFieldTypeName := 'DR_FLOAT';DR_REAL : _strFieldTypeName := 'DR_REAL';DR_DOUBLE : _strFieldTypeName := 'DR_DOUBLE';DR_VARCHAR : _strFieldTypeName := 'DR_VARCHAR';DR_BOOLEAN : _strFieldTypeName := 'DR_BOOLEAN';DR_DATALINK : _strFieldTypeName := 'DR_DATALINK';DR_DATE : _strFieldTypeName := 'DR_DATE';DR_TIME : _strFieldTypeName := 'DR_TIME';DR_TIMESTAMP : _strFieldTypeName := 'DR_TIMESTAMP';DR_OTHER : _strFieldTypeName := 'DR_OTHER';DR_JAVA_OBJECT : _strFieldTypeName := 'DR_JAVA_OBJECT';DR_DISTINCT : _strFieldTypeName := 'DR_DISTINCT';DR_STRUCT : _strFieldTypeName := 'DR_STRUCT';DR_ARRAY : _strFieldTypeName := 'DR_ARRAY';DR_BLOB : _strFieldTypeName := 'DR_BLOB';DR_CLOB : _strFieldTypeName := 'DR_CLOB';DR_REF : _strFieldTypeName := 'DR_REF';DR_SQLXML : _strFieldTypeName := 'DR_SQLXML';DR_NCLOB : _strFieldTypeName := 'DR_NCLOB';else_strFieldTypeName := 'Unknown('+inttostr(_iFieldType)+')';end; end;procedure GetMacByIP(_iIp :integer; var _strMac :string); var adapterInfo, pInfo : PIPAdapterInfo;dwSize : DWORD;iRes : Integer;ipAddrStr :TIPAddrString;pIpAddrStr :PIPAddrString;i :Integer;iIp :Integer;bFind :Boolean; beginbFind := false;dwSize := 0;GetAdaptersInfo(nil, dwSize);GetMem(adapterInfo, dwSize);iRes := GetAdaptersInfo(adapterInfo, dwSize);If (iRes <> ERROR_SUCCESS) ThenbeginMessageBoxA(0,'获取IP信息失败', '错误', MB_OK or MB_ICONERROR);exit;end;pInfo := adapterInfo;repeat// IP地址ipAddrStr := pInfo.IPAddressList;iIp := inet_addr(ipAddrStr.IPAddress);if (_iIp = iIp) thenbeginbFind := True;_strMac := '';for i:=1 to pInfo.AddressLength dobegin_strMac := _strMac + IntToHex(pInfo.Address[i], 2);if (i <> pInfo.AddressLength) then_strMac := _strMac + ':';end;Break;end;pIpAddrStr := ipAddrStr.Next;while pIpAddrStr<>nil dobeginiIp := inet_addr(ipAddrStr.IPAddress);if (_iIp = iIp) thenbeginbFind := True;_strMac := '';for i:=1 to pInfo.AddressLength dobegin_strMac := _strMac + IntToHex(pInfo.Address[i], 2);if (i <> pInfo.AddressLength) then_strMac := _strMac + ':';end;Break;end;pIpAddrStr := pIpAddrStr.Next;end;if (bFind) then Break;pInfo := pInfo^.Next;until (pInfo = nil);FreeMem(adapterInfo); end;procedure BufferBlockUsage(_iOpType :Integer; var _str :string); beginif (_iOpType = OP_TYPE_SQL) then_str := 'SQL语句'else if (_iOpType = OP_TYPE_PUSH) then_str := 'TCP推送'else if (_iOpType = OP_TYPE_MANAGE) then_str := '管理数据'else if (_iOpType = OP_TYPE_MANAGE_CLIENTS) then_str := '管理(所有客户端IP/Port)'else if (_iOpType = OP_TYPE_MANAGE_SOCKET_RES) then_str := '管理(某客户端socket信息)'else if (_iOpType = OP_TYPE_MANAGE_BLOCK_RES) then_str := '管理(某客户端内存块信息)'else if (_iOpType = OP_TYPE_RECV) then_str := 'TCP接收缓冲'; end;function MAKELANGID(_p, _s :word) :DWORD; beginResult := (_s shl 10) or (_p); end;function ErrorNo2Str(_dwErrNo :DWORD):string; constLANG_NEUTRAL = $0;SUBLANG_DEFAULT = $01; var buf :array[0..255] of Char; beginZeroMemory(@buf[0], Length(buf));Windows.FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS,nil,_dwErrNo, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),buf,Length(buf),nil);Result := buf; end;{ TdrBufferPool }constructor TdrBufferPool.create; begin//inherited Create;Flist := TList.Create;FlistAll := TList.Create;FhEvent := CreateEvent(nil, False, true, nil); end;destructor TdrBufferPool.destroy;//override; beginif Assigned(Flist) thenFlist.Free;inherited; end;function TdrBufferPool.NewBlock(_iLen: Integer): TdrBuffer; var iYuShu :Integer; beginiYuShu := _iLen mod BUFFER_BLOCK;Result := TdrBuffer.Create;if (_iLen<>0)and(iYuShu = 0) thenResult.FiTotalLen := _iLenelseResult.FiTotalLen := (_iLen div BUFFER_BLOCK + 1) * BUFFER_BLOCK;GetMem(Result.Fpc, Result.FiTotalLen);Result.FiValidBeginOffset := 0;Result.FiValidLen := 0;FlistAll.Add(Result); end;function TdrBufferPool.DelBlock(_buffer :TdrBuffer) :Integer; var iIdx :Integer; beginResult := 0;iIdx := FlistAll.IndexOf(_buffer);FlistAll.Delete(iIdx);if (iIdx = -1) thenResult := -1; end;function TdrBufferPool.AquireBlock(_dwType :DWORD; _iLen: Integer): TdrBuffer; var iAquireLen, i, iIdx, iYuShu :Integer;buffer :TdrBuffer; beginResult := nil;WaitForSingleObject(FhEvent, INFINITE);tryif (Flist.Count = 0) thenResult := NewBlock(_iLen)elsebeginiIdx := -1;iYuShu := _iLen mod BUFFER_BLOCK;if (_iLen<>0)and(iYuShu = 0) theniAquireLen := _iLenelseiAquireLen := (_iLen div BUFFER_BLOCK + 1) * BUFFER_BLOCK;for i:=0 to Flist.Count-1 dobeginbuffer := TdrBuffer(Flist.Items[i]);if iAquireLen <= buffer.FiTotalLen thenbeginiIdx := i;break;end;end;if (iIdx = -1) thenResult := NewBlock(_iLen)elsebeginResult := TdrBuffer(Flist.Items[iIdx]);Flist.Delete(iIdx);end;Result.FiValidBeginOffset := 0;Result.FiValidLen := 0;end;Result.FdwType := _dwType;PostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 1, _dwType);Result.FdwLastTick := GetTickCount;finallySetEvent(FhEvent);end; end;function TdrBufferPool.ReleaseBlock(_buffer: TdrBuffer): Integer; constBUFFER_BLOCK_MAX_LEN = 1024 * 1024 * 500; // >=这个数的内存，采取直接释放内存缓冲区的操作方式 var i :Integer;buffer0, buffer1 :TdrBuffer; beginPostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 2, _buffer.FdwType);_buffer.FdwType := 0;Result := 0;WaitForSingleObject(FhEvent, INFINITE);tryif (_buffer.FiTotalLen >= BUFFER_BLOCK_MAX_LEN) then // >=这个数的内存，采取直接释放内存缓冲区的操作方式beginDelBlock(_buffer);FreeMem(_buffer.Fpc, _buffer.FiTotalLen);_buffer.Free;Exit;end;if (Flist.Count = 0) thenbeginFlist.Add(_buffer);Exit;end;buffer0 := TdrBuffer(Flist.Items[0]);if (_buffer.FiTotalLen <= buffer0.FiTotalLen) thenbeginFlist.Insert(0, _buffer);Exit;endelsebeginfor i:=1 to Flist.Count-1 dobeginbuffer0 := TdrBuffer(Flist.Items[i-1]);buffer1 := TdrBuffer(Flist.Items[i]);if (_buffer.FiTotalLen > buffer0.FiTotalLen)and(_buffer.FiTotalLen <= buffer1.FiTotalLen) thenbeginFlist.Insert(i, _buffer);Exit;end;end;Flist.Add(_buffer);end;finallySetEvent(FhEvent);end; end;{ TdrRecvBuffer }constructor TdrRecvBuffer.Create; beginFlist := TList.Create;FhEvent := CreateEvent(nil, False, false, nil); end;destructor TdrRecvBuffer.destroy;//override; beginif Assigned(Flist) thenFlist.Free;if (FhEvent<>0) thenCloseHandle(FhEvent);inherited; end;function TdrRecvBuffer.BufferAuqire(out _pc: PChar; out _iLen: integer): integer; var buffer, bufferNew :TdrBuffer;iCnt1, iCntUsed :Integer; beginResult := -1;if (Flist.Count = 0) thenbeginbufferNew := g_bufferPool.AquireBlock(OP_TYPE_RECV, 0);Flist.Add(bufferNew);Result := Flist.Count - 1;_pc := bufferNew.Fpc;_iLen := bufferNew.FiTotalLen;endelsebeginbuffer := TdrBuffer(Flist.Items[Flist.Count - 1]);if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen thenraise Exception.CreateFmt('TdrRecvBuffer.BufferAuqire 缓冲区错误(1) : %d, %d, %d',[buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen])else if (buffer.FiValidBeginOffset + buffer.FiValidLen) = buffer.FiTotalLen thenbeginbufferNew := g_bufferPool.AquireBlock(OP_TYPE_RECV, 0);Flist.Add(bufferNew);Result := Flist.Count - 1;_pc := bufferNew.Fpc;_iLen := bufferNew.FiTotalLen;endelse// if (buffer.FiValidBeginOffset + buffer.FiValidLen) < buffer.FiTotalLen thenbeginiCntUsed := buffer.FiValidBeginOffset + buffer.FiValidLen;_pc := @buffer.Fpc[iCntUsed];_iLen := buffer.FiTotalLen - iCntUsed;Result := Flist.Count - 1;end;end; end;function TdrRecvBuffer.BufferReleaseAll :integer; beginwhile Flist.Count > 0 dobeging_bufferPool.ReleaseBlock(TdrBuffer(Flist.Items[0]));Flist.Delete(0);end; end;function TdrRecvBuffer.BufferRecv(_iRecv: Integer; _iBlockIdx: integer): Integer; var iCntUsed :Integer;buffer :TdrBuffer; beginResult := 0;Inc(FiTotalLen, _iRecv);buffer := TdrBuffer(Flist.Items[_iBlockIdx]);Inc(buffer.FiValidLen, _iRecv);if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen thenraise Exception.CreateFmt('TdrRecvBuffer.BufferRecv 缓冲区错误(1) : %d, %d, %d',[buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen]); end;function TdrRecvBuffer.BufferHandle: Integer; // 处理单个 TCP包 var bufferCopy, buffer :TdrBuffer;iRtn, iPktIsNeed :Integer;iPktLen, iPktIdx, iPktType :Integer;iPktLen01 :Integer;iBlockIdx, iBlockDropEndIdx :Integer;iCopyOffset, i, iCopyLen :Integer;bNeedBreak :Boolean; beginResult := 0;if (FiTotalLen < TCP_PACKET_HEADER_LEN) then // 一个TCP包都没有接收完毕beginResult := 1;Exit;end;if (FiFirstPktLen <> 0) and (FiTotalLen < FiFirstPktLen) thenbeginResult := 2;Exit;end;iRtn := TcpPktHeader(iPktLen, iPktIdx, iPktType);FiFirstPktLen := iPktLen;if (FiTotalLen < iPktLen) then // 一个TCP包都没有接收完毕beginResult := 3;Exit;end;FiFirstPktLen := 0;iPktIsNeed := TcpPktIsNeed(iPktIdx, iPktType);// *** (1) *** 缓冲区的分配/获取bufferCopy := nil;if (iPktIsNeed > 0) thenbufferCopy := g_bufferPool.AquireBlock(iPktType, iPktLen);// *** (2) *** 缓冲区内容填充iCopyOffset := 0;iBlockIdx := 0;iPktLen01 := iPktLen;iBlockDropEndIdx := -1;while (iPktLen01 > 0) dobeginbNeedBreak := false;if (iBlockIdx >= Flist.Count) thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(1) : %d, %d', [iBlockIdx, Flist.Count]);buffer := TdrBuffer(Flist.Items[iBlockIdx]);if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(2) : %d, %d, %d, %d',[iBlockIdx, buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen])else if (buffer.FiValidBeginOffset + buffer.FiValidLen) = buffer.FiTotalLen thenbeginif iBlockDropEndIdx <> (iBlockIdx-1) thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(3) : %d, %d, %d', [iBlockIdx, iBlockDropEndIdx, iBlockIdx]);iBlockDropEndIdx := iBlockIdx;endelse// if (buffer.FiValidBeginOffset + buffer.FiValidLen) < buffer.FiTotalLen thenbNeedBreak := True;if (not bNeedBreak) thenbegin // 不是 某TCP包中的最后一块内存块的话，内存块的尾端肯定是占满的if (buffer.FiValidBeginOffset + buffer.FiValidLen) <> buffer.FiTotalLen thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(4) : %d, %d, %d, %d',[iBlockIdx, buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen]);end;// 缓冲区数据 复制// 三部曲：(1)计算iCopyLen (2)CopyMemory (3)计算3个数值iCopyLen := 0;if (iBlockIdx = 0) thenbeginiCopyLen := Math.IfThen(iPktLen01 > buffer.FiValidLen, buffer.FiValidLen, iPktLen01);if (bufferCopy <> nil) thenCopyMemory(@bufferCopy.Fpc[iCopyOffset], @buffer.Fpc[buffer.FiValidBeginOffset], iCopyLen);Dec(iPktLen01, iCopyLen);Inc(buffer.FiValidBeginOffset, iCopyLen); // 缓冲区指针移动 Dec(buffer.FiValidLen, iCopyLen);endelsebeginif buffer.FiValidBeginOffset <> 0 thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(5) : %d, %d', [iBlockIdx, buffer.FiValidBeginOffset]);iCopyLen := Math.IfThen(iPktLen01 > buffer.FiValidLen, buffer.FiValidLen, iPktLen01);if (bufferCopy <> nil) thenCopyMemory(@bufferCopy.Fpc[iCopyOffset], @buffer.Fpc[0], iCopyLen);Dec(iPktLen01, iCopyLen);Inc(buffer.FiValidBeginOffset, iCopyLen); // 缓冲区指针移动 Dec(buffer.FiValidLen, iCopyLen);end;Inc(bufferCopy.FiValidLen, iCopyLen);Inc(iCopyOffset, iCopyLen);// ***if (iCopyOffset > bufferCopy.FiTotalLen) thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(6) : %d, %d, %d', [iBlockIdx, iCopyOffset, bufferCopy.FiTotalLen]);if (bNeedBreak) thenbeginif (iPktLen01 <> 0) thenraise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(7) : %d, %d', [iBlockIdx, buffer.FiValidBeginOffset]);break;end;Inc(iBlockIdx);end; // while// *** (3) *** 缓冲区 分发 TcpPktDispatch(bufferCopy);// 扫尾处理 Dec(FiTotalLen, iPktLen);if iBlockDropEndIdx > -1 thenfor i:=0 to iBlockDropEndIdx dobeging_bufferPool.ReleaseBlock(TdrBuffer(Flist.Items[0]));Flist.Delete(0);end; end;function TdrRecvBuffer.BufferHandleAll: Integer; // 处理所有已经接收到的 TCP包 var iRtn : integer; beginResult := 0;while FiTotalLen > (TCP_PACKET_HEADER_LEN) dobeginiRtn := BufferHandle;if (iRtn > 0) thenbreak;end; end;function TdrRecvBuffer.TcpPktHeader(out _iPktLen, _iPktIdx, _iPktType: Integer): Integer; // 始终默认是 [0]的缓冲区块 var aryByte12 :array[0..11] of Char;buffer :TdrBuffer;iCntLeft :Integer;pi :PInteger; beginResult := 0;buffer := TdrBuffer(Flist.Items[0]);if (buffer.FiValidLen >= TCP_PACKET_HEADER_LEN) thenbeginpi := @buffer.Fpc[buffer.FiValidBeginOffset + 0]; _iPktLen := pi^;pi := @buffer.Fpc[buffer.FiValidBeginOffset + 4]; _iPktIdx := pi^;pi := @buffer.Fpc[buffer.FiValidBeginOffset + 8]; _iPktType:= pi^;endelsebeginif (Flist.Count = 1) thenraise Exception.CreateFmt('TdrRecvBuffer.TcpPktHeader 缓冲区错误(1) : %d', [Flist.Count]);iCntLeft := TCP_PACKET_HEADER_LEN - buffer.FiValidLen;CopyMemory(@aryByte12[0], @buffer.Fpc[buffer.FiValidBeginOffset], buffer.FiValidLen);buffer := TdrBuffer(Flist.Items[1]);if (buffer.FiValidBeginOffset <> 0)or(buffer.FiValidLen < iCntLeft) thenraise Exception.CreateFmt('TdrRecvBuffer.TcpPktHeader 缓冲区错误(2) : %d, %d, %d',[buffer.FiValidBeginOffset, buffer.FiValidLen, iCntLeft]);CopyMemory(@aryByte12[0], @buffer.Fpc[0], iCntLeft);pi := @aryByte12[0]; _iPktLen := pi^;pi := @aryByte12[4]; _iPktIdx := pi^;pi := @aryByte12[8]; _iPktType:= pi^;end; end;function TdrRecvBuffer.TcpPktIsNeed(_iPktIdx, _iPktType :integer):Integer; beginResult := 0;if (_iPktType = OP_TYPE_SQL) then // 主动的SQL语句请求beginif (_iPktIdx = FiPktIdx) thenResult := 1;endelse if (_iPktType = OP_TYPE_PUSH) then // TCP服务端推送消息beginResult := 1;endelse if (_iPktType and OP_TYPE_MANAGE) <> 0 then // 管理beginResult := 1;end; end;procedure TdrRecvBuffer.TcpPktDispatch(_buffer :TdrBuffer); var pi :PInteger;iPktLen, iPktIdx, iPktType :Integer; beginpi := @_buffer.Fpc[4]; iPktIdx := pi^;pi := @_buffer.Fpc[8]; iPktType:= pi^;if (iPktType = OP_TYPE_SQL) then // 主动的SQL语句请求beginif (iPktIdx = FiPktIdx) thenSetEvent(FhEvent);endelse if (iPktType = OP_TYPE_PUSH) then // TCP服务端推送消息beginPostMessage(g_callbackWnd.FhWnd, WM_TCP_PUSH, 0, LParam(_buffer));endelse if (iPktType and OP_TYPE_MANAGE) <> 0 then // 管理beginif DWORD(iPktType) = OP_TYPE_MANAGE_CLIENTS then // 所有客户端的信息PostMessage(g_callbackWnd.FhWnd, WM_TCP_CLIENTS, 0, LParam(_buffer))else if DWORD(iPktType) = OP_TYPE_MANAGE_SOCKET_REQ thenPostMessage(g_callbackWnd.FhWnd, WM_CLIENT_SOCKET_MSG_REQ, 0, LParam(_buffer))else if DWORD(iPktType) = OP_TYPE_MANAGE_SOCKET_RES thenPostMessage(g_callbackWnd.FhWnd, WM_CLIENT_SOCKET_MSG_RES, 0, LParam(_buffer))else if DWORD(iPktType) = OP_TYPE_MANAGE_BLOCK_REQ thenPostMessage(g_callbackWnd.FhWnd, WM_CLIENT_BLOCK_MSG_REQ, 0, LParam(_buffer))else if DWORD(iPktType) = OP_TYPE_MANAGE_BLOCK_RES thenPostMessage(g_callbackWnd.FhWnd, WM_CLIENT_BLOCK_MSG_RES, 0, LParam(_buffer))else if DWORD(iPktType) = OP_TYPE_MANAGE_SQL thenPostMessage(g_callbackWnd.FhWnd, WM_MANAGE_SQL, 0, LParam(_buffer))elsebeginend;end; end;{ TdrTcpClient }function TdrTcpClient.RecvTimeoutSet: Integer; var iRecvTimeout, iRtn :Integer; beginResult := 0;iRecvTimeout := 1; // 毫秒iRtn := setsockopt(Fskt, SOL_SOCKET, SO_RCVTIMEO, PChar(@iRecvTimeout), sizeof(integer));if SOCKET_ERROR = iRtn thenbeginResult := GetLastError;FiErrorNo := Result;end; end;function TdrTcpClient.RecvTimeoutCancel: Integer; var iRecvTimeout, iRtn :Integer; beginResult := 0;iRecvTimeout := 0; // 毫秒iRtn := setsockopt(Fskt, SOL_SOCKET, SO_RCVTIMEO, PChar(@iRecvTimeout), sizeof(integer));if SOCKET_ERROR = iRtn thenbeginResult := GetLastError;FiErrorNo := Result;end; end;procedure TdrTcpClient.Execute; var pcRecv :PChar;iLenRecv :Integer;iRecvBlockIdx :integer;iRecv, iRtn :Integer; begin//inherited; g_drRecvBuffer.BufferReleaseAll;FiStatus := 1;while True dobeginiRecvBlockIdx := g_drRecvBuffer.BufferAuqire(pcRecv, iLenRecv);iRecv := recv(Fskt, pcRecv^, iLenRecv, 0);if (iRecv = 0) then // 连接优雅(gracefully)关闭beginFiErrorNo := 0;break;endelse if (iRecv < 0) thenbeginFiErrorNo := GetLastError;break;endelse// if (iRecv > 0) thenbeging_drRecvBuffer.BufferRecv(iRecv, iRecvBlockIdx);g_drRecvBuffer.BufferHandleAll;PostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 0, iRecv);end; // ZC: 用timeout操作的时候，在数据读完之后 有明显感觉的卡顿现象(大概有1s左右)...于是，放弃使用timeout读数据 // iRtn := Recv01; // if (iRtn <= 0) then // break; // g_drRecvBuffer.BufferHandleAll;end;closesocket(Fskt);FiStatus := -1;// 线程执行完毕(退出)//raise Exception.CreateFmt('socket线程退出 : %d', [FiErrorNo]); end;function TdrTcpClient.Recv01: Integer; var pcRecv :PChar;iLenRecv :Integer;iRecvBlockIdx :integer;iRecv :Integer; beginResult := 0;if RecvTimeoutSet<>0 thenbeginResult := GetLastError;Exit;end;while true dobeginiRecvBlockIdx := g_drRecvBuffer.BufferAuqire(pcRecv, iLenRecv);iRecv := recv(Fskt, pcRecv^, iLenRecv, 0);if (iRecv = 0) then // 连接优雅(gracefully)关闭beginResult := -1;FiErrorNo := 0;endelse if (iRecv < 0) thenbeginFiErrorNo := GetLastError;if WSAETIMEDOUT <> FiErrorNo thenbeginResult := -2;endelsebeginResult := 1;end;break;endelse// if (iRecv > 0) thenbeging_drRecvBuffer.BufferRecv(iRecv, iRecvBlockIdx);if (iRecv <> iLenRecv) thenbeginResult := 2;Break;end;end;end;if RecvTimeoutCancel <> 0 thenResult := GetLastError; end;function TdrTcpClient.Send01(_pbyte: PByte; _iLen: integer): Integer; var iRtn :Integer; beginResult := 0;iRtn := send(Fskt, _pbyte^, _iLen, 0);if iRtn = SOCKET_ERROR thenResult := GetLastError; end;class function TdrTcpClient.Conn :integer; var skt :TSocket;bNeedCreate :boolean; beginResult := 0;if (length(g_strDestIp)=0)or(g_iDestPort=0) thenbeginraise Exception.Create('服务器IP/Poer 未设置');Exit;end;bNeedCreate := false;if (g_tcpClient = nil) thenbNeedCreate := trueelsebeginif (g_tcpClient.FiStatus = 0) thenbeginResult := -1;Exit;endelse if (g_tcpClient.FiStatus = -1) thenbeginbNeedCreate := True;g_tcpClient.Free;end;end;if (bNeedCreate) thenbeginskt := TdrTcpClient.ConnectDest;g_tcpClient := TdrTcpClient.Create(false);g_tcpClient.Fskt := skt;end; end;class procedure TdrTcpClient.SendSQL(_str: string); var iPktLen, iPktIdx, iPktType :Integer;bytesSend :array[0..255] of byte;iRtn :Integer; beginif Conn < 0 thenraise Exception.Create('TCP接收线程正在初始化，请稍后再试...');Inc(g_drRecvBuffer.FiPktIdx);iPktLen := TCP_PACKET_HEADER_LEN + Length(_str);iPktIdx := g_drRecvBuffer.FiPktIdx;iPktType := OP_TYPE_SQL;CopyMemory(@bytesSend[0], @iPktLen, 4); // TCP包头 --(1) 总长CopyMemory(@bytesSend[4], @iPktIdx, 4); // TCP包头 --(2) 序号CopyMemory(@bytesSend[8], @iPktType, 4); // TCP包头 --(3) 类型CopyMemory(@bytesSend[12], PChar(_str), Length(_str)); // TCP包 内容 iRtn := g_tcpClient.Send01(@bytesSend[0], iPktLen);if (iRtn <> 0) thenraise Exception.CreateFmt('发送消息异常 : (%d)%s', [iRtn, ErrorNo2Str(iRtn)]);WaitForSingleObject(g_drRecvBuffer.FhEvent, INFINITE); end;class procedure TdrTcpClient.SendBytes(_pc :PChar; _iLen :Integer); var iRtn :Integer; beginif Conn < 0 thenraise Exception.Create('TCP接收线程正在初始化，请稍后再试...');iRtn := g_tcpClient.Send01(@_pc[0], _iLen);if (iRtn <> 0) thenraise Exception.CreateFmt('发送消息异常 : (%d)%s', [iRtn, ErrorNo2Str(iRtn)]); end;class function TdrTcpClient.ConnectDest :TSocket; var wsadata1 :WSADATA;addrSrv :SOCKADDR_IN;iRtn :Integer;skt :TSocket;dwErrorNo :DWORD; beginResult := 0;WSAStartup(MAKEWORD(1,1), wsadata1);skt := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);if (skt <= 0) thenbegindwErrorNo := GetLastError;raise Exception.CreateFmt('%s %d', ['套接字创建异常:', dwErrorNo]);end;addrSrv.sin_family := AF_INET;addrSrv.sin_port := htons(g_iDestPort);addrSrv.sin_addr.S_addr := inet_addr(PChar(g_strDestIp));iRtn := connect(skt, addrSrv, sizeof(addrSrv));if(iRtn <> 0) thenbegindwErrorNo := GetLastError;raise Exception.CreateFmt('%s %d %s', ['服务器连接异常:', dwErrorNo, ErrorNo2Str(dwErrorNo)]);end;Result := skt; end;class procedure TdrTcpClient.SetIpPort(_strDestIp: string; _iDestPort: integer); beging_strDestIp := _strDestIp;g_iDestPort := _iDestPort; end;class function TdrTcpClient.Status: Integer; beginif (g_tcpClient = nil) thenResult := -100elseResult := g_tcpClient.FiStatus; end;class procedure TdrTcpClient.SendHeartBeat; var pc :array[0..12] of Char;iPktLen, iPktIdx, iPktType :Integer; beginiPktLen := 12;iPktIdx := 0;iPktType := OP_TYPE_HEARTBEAT;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);SendBytes(pc, iPktLen); end;{ TcallbackWnd }function ProcWindow(_hWnd :HWND;_uMsg :UINT;_wParam :WPARAM;_lParam :LPARAM):longint;stdcall; var buffer :TdrBuffer;pc :PChar; beginResult := 0; // 用户已经处理if (_uMsg = WM_TCP_PUSH) thenbeginif Assigned(g_callbackWnd.FfuncPush) thenbegin// 得到 缓冲区buffer := TdrBuffer(_lParam);// 业务逻辑处理g_callbackWnd.FfuncPush(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);// 释放缓冲区 g_bufferPool.ReleaseBlock(buffer);end;endelse if (_uMsg = WM_TCP_CLIENTS) thenbeginif Assigned(g_callbackWnd.FfuncClients) thenbeginbuffer := TdrBuffer(_lParam);g_callbackWnd.FfuncClients(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);g_bufferPool.ReleaseBlock(buffer);end;endelse if (_uMsg = WM_CLIENT_SOCKET_MSG_REQ) thenbeginbuffer := TdrBuffer(_lParam);g_callbackWnd.PackSocket(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);g_bufferPool.ReleaseBlock(buffer);endelse if (_uMsg = WM_CLIENT_BLOCK_MSG_REQ) thenbeginbuffer := TdrBuffer(_lParam);g_callbackWnd.PackBlock(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);g_bufferPool.ReleaseBlock(buffer);endelse if (_uMsg = WM_CLIENT_SOCKET_MSG_RES) thenbeginif Assigned(g_callbackWnd.FfuncSocket) thenbeginbuffer := TdrBuffer(_lParam);g_callbackWnd.FfuncSocket(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);g_bufferPool.ReleaseBlock(buffer);end;endelse if (_uMsg = WM_CLIENT_BLOCK_MSG_RES) thenbeginif Assigned(g_callbackWnd.FfuncBlock) thenbeginbuffer := TdrBuffer(_lParam);g_callbackWnd.FfuncBlock(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN);g_bufferPool.ReleaseBlock(buffer);end;endelse if (_uMsg = WM_MANAGE_SQL) thenbeginbuffer := TdrBuffer(_lParam);if Assigned(g_callbackWnd.FfuncSQL) theng_callbackWnd.FfuncSQL(buffer);g_bufferPool.ReleaseBlock(buffer);endelse if (WM_TCP_RECV = _uMsg) thenbeginif (_wParam = 0) thenfrmMain.Memo1.Lines.Add('Recv : '+inttostr(_lParam))else if (_wParam = 1) thenfrmMain.Memo1.Lines.Add('Allocate buffer block for : 0x'+inttohex(_lParam, 8))else if (_wParam = 2) thenfrmMain.Memo1.Lines.Add('Release buffer block from : 0x'+inttohex(_lParam, 8))else if (_wParam = 3) thenfrmMain.Memo1.Lines.Add('Space for unicode string : '+inttostr(_lParam))else if (_wParam = 4) thenfrmMain.Memo1.Lines.Add('Space for ansi string : '+inttostr(_lParam))else if (_wParam = 5) thenfrmMain.Memo1.Lines.Add('UTF-8 string space is : '+inttostr(_lParam));endelse if (WM_LOG_CONSOLE = _uMsg) thenbeginpc := PChar(_lParam);frmMain.Memo1.Lines.Add(PChar(_lParam));FreeMem(pc, _wParam);endelse if (_uMsg = WM_TIMER) thenbeginif (1 = _wParam) thenbeginif (g_tcpClient<>nil)and(g_tcpClient.FiStatus = 1) thenTdrTcpClient.SendHeartBeat;end;endelse if (_uMsg = WM_DESTROY) thenbeginDestroyWindow(_hwnd);PostQuitMessage(0);endelse Result := DefWindowProc(_hWnd, _uMsg, _wParam, _lParam); end;constructor TcallbackWnd.Create; beginCreateWindow;//SetTimer(FhWnd, 1, 1000 * 10, nil); end;procedure TcallbackWnd.CreateWindow; var wndcls :WNDCLASS;hInstance :THandle; beginhInstance := Windows.GetModuleHandle(nil);ZeroMemory(@wndcls, sizeof(wndcls));wndcls.cbClsExtra := 0;wndcls.cbWndExtra := 0;wndcls.hbrBackground := HBRUSH(GetStockObject(WHITE_BRUSH)); // 背景画刷wndcls.hCursor := LoadCursor(0, IDC_CROSS);wndcls.hIcon := LoadIcon(0, IDI_ERROR); // 窗口图标wndcls.hInstance := hInstance;wndcls.lpfnWndProc := @ProcWindow;wndcls.lpszClassName:= 'DrTcpCallbackWnd';wndcls.lpszMenuName := nil;wndcls.style := CS_HREDRAW or CS_VREDRAW;Windows.RegisterClass(wndcls);FhWnd := CreateWindowEx(WS_EX_CLIENTEDGE,wndcls.lpszClassName,wndcls.lpszClassName,WS_OVERLAPPEDWINDOW,100, 100,400, 300,0,0, //g_hMenu, hInstance,0);if (FhWnd = 0) thenFdwErrNo := GetLastError;// ShowWindow(hWnd1, SW_SHOWNORMAL); UpdateWindow(FhWnd); end;function TcallbackWnd.PackSocket(_pc :PChar; _iLen :integer) :integer; var sockAddr :TSockAddr;iNameLen :Integer;dwErrNo :DWORD;strMac, strIP :string;iLenIp, iLenMac, iLenMsg :Integer;pc :array[0..255] of Char;iPktLen, iPktIdx, iPktType :Integer; beginResult := 0;iNameLen := SizeOf(sockAddr);if SOCKET_ERROR = getsockname(g_tcpClient.Fskt, sockAddr, iNameLen) thenbegindwErrNo := GetLastError;Result := dwErrNo;Exit;end;strIP := inet_ntoa(sockAddr.sin_addr);strMac := '';GetMacByIP(sockAddr.sin_addr.S_addr, strMac);iLenIp := 4 + length(strIP);iLenMac:= 4 + length(strMac);iLenMsg := 4 + iLenIp + iLenMac;iPktLen := TCP_PACKET_HEADER_LEN + iLenMsg + _iLen;iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_SOCKET_RES;CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);// ***CopyMemory(@pc[TCP_PACKET_HEADER_LEN], @iLenMsg, 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN + 4], @iLenIp, 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN + 8], PChar(strIP), iLenIp - 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN + 4 + iLenIp], @iLenMac, 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN + 4 + iLenIp + 4], PChar(strMac), iLenMac - 4);// ***CopyMemory(@pc[TCP_PACKET_HEADER_LEN+iLenMsg], _pc, _iLen);TdrTcpClient.SendBytes(@pc[0], iPktLen); end;procedure TcallbackWnd.PackBlock(_pc :PChar; _iLen :integer); var iPktLen, iPktIdx, iPktType :Integer;iIdx :Integer;buffer :TdrBuffer;mem :TMemoryStream;iLenMsg :Integer;pc :PChar;dwTick :DWORD; beginmem := TMemoryStream.Create;tryiPktLen := TCP_PACKET_HEADER_LEN;iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_BLOCK_RES;mem.Write(iPktLen, 4);mem.Write(iPktIdx, 4);mem.Write(iPktType, 4);iLenMsg := 8;mem.Write(iLenMsg, 4);dwTick := GetTickCount;mem.Write(dwTick, 4);iIdx := 0;while iIdx < g_bufferPool.ListAll.Count dobeginbuffer := TdrBuffer(g_bufferPool.ListAll.Items[iIdx]);mem.Write(buffer.FiTotalLen, 4);mem.Write(buffer.FiValidBeginOffset, 4);mem.Write(buffer.FiValidLen, 4);mem.Write(buffer.FdwType, 4);mem.Write(buffer.FdwLastTick, 4);Inc(iLenMsg, 20);Inc(iIdx);end;iPktLen := TCP_PACKET_HEADER_LEN + iLenMsg + _iLen;iPktIdx := 0;iPktType:= OP_TYPE_MANAGE_BLOCK_RES;pc := PChar(mem.Memory);CopyMemory(@pc[0], @iPktLen, 4);CopyMemory(@pc[4], @iPktIdx, 4);CopyMemory(@pc[8], @iPktType, 4);CopyMemory(@pc[TCP_PACKET_HEADER_LEN], @iLenMsg, 4); mem.Write(_pc^, _iLen);TdrTcpClient.SendBytes(mem.Memory, iPktLen);finallymem.Free;end; end;{ TdrDataSet }function TdrDataSet.Unpack(_pc :PChar; _iLen :Integer) :integer; var iTotalLen, iColumnCnt, iRowCnt :Integer;i, iOffset, iLenColumnName, iRowIdx, iColIdx :Integer;iLenRecord :Integer; beginResult := 0;FpcBuf := _pc;FiBufLen := _iLen;CopyMemory(@iTotalLen, @_pc[0], 4);if (iTotalLen <> _iLen) thenbeginResult := -1;Exit;end;CopyMemory(@iColumnCnt, @_pc[4], 4);CopyMemory(@iRowCnt, @_pc[8], 4);SetLength(FaryColumnType, iColumnCnt);SetLength(FaryColumnName, iColumnCnt);SetLength(FaryaryRecord, iRowCnt, iColumnCnt);// 列类型for i:=0 to (iColumnCnt-1) doCopyMemory(@FaryColumnType[i], @_pc[12 + i * 4], 4);iOffset := 12 + iColumnCnt * 4;// 列名称for i:=0 to (iColumnCnt-1) dobeginCopyMemory(@iLenColumnName, @_pc[iOffset], 4);SetLength(FaryColumnName[i], iLenColumnName);CopyMemory(@((FaryColumnName[i])[1]), @_pc[iOffset + 4], iLenColumnName);Inc(iOffset, 4 + iLenColumnName);end;// [2]、字段值(长度 + 内容)for iRowIdx:=0 to iRowCnt-1 dofor iColIdx:=0 to iColumnCnt-1 dobeginCopyMemory(@iLenRecord, @_pc[iOffset], 4);FaryaryRecord[iRowIdx, iColIdx] := iOffset + 4;Inc(iOffset, 4 + iLenRecord);end; end;function TdrDataSet.GetRecord(_iRowIdx, _iColumnIdx: integer): TdrRecord; beginif not Assigned(Ffield) thenFfield := TdrRecord.Create(Self, _iRowIdx, _iColumnIdx)elsebeginFfield.FiRowIdx := _iRowIdx;Ffield.FiColumnIdx := _iColumnIdx;end;Ffield.FenXi;Result := Ffield; end;function TdrDataSet.GetFieldType(_iColumnIdx: integer): Integer; beginResult := FaryColumnType[_iColumnIdx]; end;function TdrDataSet.GetFieldTypeName(_iColumnIdx: integer): string; beginFieldTypeName_f(GetFieldType(_iColumnIdx), Result); end;function TdrDataSet.GetFieldName(_iColumnIdx: integer): string; beginResult := FaryColumnName[_iColumnIdx]; end;function TdrDataSet.GetRowCount: Integer; beginResult := Length(FaryaryRecord); end;function TdrDataSet.GetColumnCount: Integer; beginResult := Length(FaryColumnType); end;{ TdrRecord }constructor TdrRecord.Create(_dataset: TdrDataSet; _iRowIdx, _iColumnIdx: Integer); beginFdataset := _dataset;FiRowIdx := _iRowIdx;FiColumnIdx := _iColumnIdx; end;procedure TdrRecord.FenXi; var iOffset :Integer; beginiOffset := Fdataset.FaryaryRecord[FiRowIdx, FiColumnIdx];FpcRecord := @Fdataset.FpcBuf[iOffset]; end;function TdrRecord.asByteArray(_pByte: PByte; out _iLen: Integer): Integer; beginCopyMemory(@_iLen, FpcRecord-4, 4);if (_pByte <> nil) thenCopyMemory(_pByte, FpcRecord, _iLen); end;function TdrRecord.asInteger: Integer; beginCopyMemory(@Result, FpcRecord, 4); end;function TdrRecord.asSingle: Single; beginCopyMemory(@Result, FpcRecord, SizeOf(Single)); end;function TdrRecord.asDouble: Double; beginCopyMemory(@Result, FpcRecord, SizeOf(Double)); end;function TdrRecord.asString: string; var iLen :Integer;iFieldType :Integer;d :Double;iUnicodeLen, iAnsiLen :Integer;pwc :PWideChar;pc :PChar; beginiFieldType := GetFieldType;case iFieldType ofDR_NUMERIC :beginCopyMemory(@iLen, FpcRecord - 4, 4);CopyMemory(@d, FpcRecord, iLen);Result := FloatToStr(d);end;DR_LONGNVARCHAR, DR_NCHAR, DR_NVARCHAR, DR_LONGVARCHAR, DR_CHAR, DR_VARCHAR :beginpwc := nil;pc := nil;tryCopyMemory(@iLen, FpcRecord - 4, 4);//PostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 5, iLen);if (iLen = 0) thenbeginResult := 'Empty string .';Exit;end;SetLength(Result, iLen);CopyMemory(@Result[1], FpcRecord, iLen);{iUnicodeLen := MultiByteToWideChar(CP_UTF8, 0, FpcRecord, iLen, nil, 0);GetMem(pwc, iUnicodeLen * 2);MultiByteToWideChar(CP_UTF8, 0, FpcRecord, iLen, pwc, iUnicodeLen);iAnsiLen := WideCharToMultiByte(CP_ACP, 0, pwc, iUnicodeLen, nil, 0, nil, nil);GetMem(pc, iAnsiLen + 1);WideCharToMultiByte(CP_ACP, 0, pwc, iUnicodeLen, pc, iAnsiLen, nil, nil);pc[iAnsiLen] := Char(0);Result := pc; }finallyif (pwc <> nil) then FreeMem(pwc, iUnicodeLen * 2);if (pc <> nil) then FreeMem(pc, iAnsiLen + 1);end;end;else FieldTypeName_f(iFieldType, Result);end; end;function TdrRecord.GetFieldType: Integer; beginResult := Fdataset.GetFieldType(FiColumnIdx); end;function TdrRecord.GetFieldTypeName: string; beginResult := Fdataset.GetFieldTypeName(FiColumnIdx); end;function TdrRecord.GetFieldName: string; beginResult := Fdataset.GetFieldName(FiColumnIdx); end;initializationg_bufferPool := TdrBufferPool.create;g_drRecvBuffer := TdrRecvBuffer.Create;g_callbackWnd := TcallbackWnd.Create;g_strDestIp := '';g_iDestPort := 0;finalizationif Assigned(g_bufferPool) then g_bufferPool.Free;if Assigned(g_drRecvBuffer) then g_drRecvBuffer.Free;end.
3、
