TCP中间件_Delphi_client
1、界面
1.1、formMain.pas
1.1.1、
object frmMain: TfrmMain Left = 191 Top = 103 Width = 542 Height = 466 Caption = 'frmMain' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False Position = poDesktopCenter OnCreate = FormCreate DesignSize = ( 534 439) PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 16 Top = 8 Width = 41 Height = 13 AutoSize = False Caption = 'IP : ' end object Label2: TLabel Left = 176 Top = 8 Width = 49 Height = 13 AutoSize = False Caption = 'Port : ' end object btnSetIpPort: TButton Left = 16 Top = 32 Width = 75 Height = 25 Caption = '设置信息' TabOrder = 0 OnClick = btnSetIpPortClick end object Memo1: TMemo Left = 16 Top = 128 Width = 497 Height = 299 Anchors = [akLeft, akTop, akRight, akBottom] Lines.Strings = ( 'Memo1') ScrollBars = ssBoth TabOrder = 1 end object btnSend: TButton Left = 96 Top = 32 Width = 75 Height = 25 Caption = '发送消息' TabOrder = 2 OnClick = btnSendClick end object btnStatus: TButton Left = 176 Top = 32 Width = 75 Height = 25 Caption = 'skt状态' TabOrder = 3 OnClick = btnStatusClick end object btnClearMemo: TButton Left = 256 Top = 32 Width = 89 Height = 25 Caption = '清空消息框' TabOrder = 4 OnClick = btnClearMemoClick end object btnAllClients: TButton Left = 208 Top = 64 Width = 137 Height = 25 Caption = '所有客户端信息' TabOrder = 5 OnClick = btnAllClientsClick end object btnSocket: TButton Left = 16 Top = 96 Width = 153 Height = 25 Caption = '客户端网络信息' TabOrder = 6 OnClick = btnSocketClick end object edtAddress: TEdit Left = 16 Top = 64 Width = 185 Height = 21 TabOrder = 7 Text = 'edtAddress' end object btnBlock: TButton Left = 192 Top = 96 Width = 153 Height = 25 Caption = '客户端内存块信息' TabOrder = 8 OnClick = btnBlockClick end object edtIP: TEdit Left = 40 Top = 4 Width = 121 Height = 21 TabOrder = 9 Text = '192.168.1.233' end object edtPort: TEdit Left = 216 Top = 4 Width = 89 Height = 21 TabOrder = 10 Text = '9888' end object btnFrmSQL: TButton Left = 432 Top = 32 Width = 75 Height = 25 Caption = 'btnFrmSQL' TabOrder = 11 OnClick = btnFrmSQLClick end end
1.2、formSQL.pas
1.2.1、
object frmSQL: TfrmSQL Left = 362 Top = 105 Width = 457 Height = 480 Caption = 'frmSQL' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False Position = poDesktopCenter DesignSize = ( 449 453) PixelsPerInch = 96 TextHeight = 13 object Label1: TLabel Left = 16 Top = 14 Width = 145 Height = 13 AutoSize = False Caption = 'SQL语句 : ' end object lvSQL: TListView Left = 16 Top = 96 Width = 416 Height = 345 Anchors = [akLeft, akTop, akRight, akBottom] Columns = <> GridLines = True OwnerData = True ReadOnly = True RowSelect = True TabOrder = 0 ViewStyle = vsReport OnData = lvSQLData end object Button1: TButton Left = 359 Top = 8 Width = 75 Height = 25 Anchors = [akTop, akRight] Caption = 'Button1' TabOrder = 1 OnClick = Button1Click end object edtSQL: TEdit Left = 80 Top = 10 Width = 264 Height = 21 Anchors = [akLeft, akTop, akRight] TabOrder = 2 Text = 'select * from file_tbl where rownum<5' end object btnBLOB: TButton Left = 16 Top = 48 Width = 75 Height = 25 Caption = 'btnBLOB' TabOrder = 3 OnClick = btnBLOBClick end end
2、代码：
2.1、formMain.pas
unit formMain; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, classDrTcp, Winsock2; type TfrmMain = 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); public public procedure UnpackClients(_pc :PChar; _iLen :integer); procedure UnpackSocket(_pc :PChar; _iLen :integer); procedure UnpackBlock(_pc :PChar; _iLen :integer); end; var frmMain: TfrmMain; implementation uses formSQL; {$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); begin TdrTcpClient.SendSQL('select * from ccc'); end; procedure TfrmMain.btnStatusClick(Sender: TObject); begin Memo1.Lines.Add(IntToStr(TdrTcpClient.Status)); end; procedure TfrmMain.btnClearMemoClick(Sender: TObject); begin Memo1.Lines.Clear; end; procedure TfrmMain.UnpackClients(_pc: PChar; _iLen: integer); var iLen, iIdx :integer; str :string; ll :LONGLONG; begin Memo1.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 do begin CopyMemory(@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; begin CopyMemory(@iLenMsg, @_pc[0], 4); if (iLenMsg < 0) then begin iLenMsg := -iLenMsg; SetLength(strMsg, iLenMsg); CopyMemory(@strMsg[1], @_pc[4], iLenMsg); Memo1.Lines.Add('请求主机信息(未找到)：'); Memo1.Lines.Add(' '+strMsg); end else begin CopyMemory(@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; begin CopyMemory(@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 do begin Inc(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; begin g_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; begin strRemoteAddress := 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; begin strRemoteAddress := 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); begin frmSQL.Show; end; end.
2.2、formSQL.pas
unit formSQL; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StdCtrls, classDrTcp; type TfrmSQL = 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); private Fbuffer :TdrBuffer; procedure UnpackSQL(_buffer :TdrBuffer); public FdataSet :TdrDataSet; FiColumnCnt :Integer; end; var frmSQL: TfrmSQL; implementation uses formMain; {$R *.dfm} procedure TfrmSQL.Button1Click(Sender: TObject); var pc :array[0..255] of Char; iPktLen, iPktIdx, iPktType :Integer; strSql :string; iLenSQL :Integer; begin if (Fbuffer <> nil) then begin g_bufferPool.ReleaseBlock(Fbuffer); Fbuffer := nil; end; strSql := Trim(edtSQL.Text); iLenSQL := Length(strSql); if iLenSQL = 0 then begin frmMain.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; begin if (Fbuffer <> nil) then begin g_bufferPool.ReleaseBlock(Fbuffer); Fbuffer := nil; end; Fbuffer := _buffer; if not Assigned(FdataSet) then FdataSet := TdrDataSet.Create; FdataSet.Unpack(@_buffer.Fpc[TCP_PACKET_HEADER_LEN], _buffer.FiValidLen - TCP_PACKET_HEADER_LEN); if (FdataSet.ColumnCount <= 0) then Exit; lvSQL.Columns.Clear; FiColumnCnt := FdataSet.ColumnCount; for i:=0 to FiColumnCnt-1 do begin columnNew := 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; begin if (FdataSet = nil) then Exit; if (FdataSet.RowCount <= 0) then Exit; for iColIdx:=0 to FiColumnCnt-1 do begin rec := FdataSet.Rec[Item.Index, iColIdx]; //wstr := rec.asString; //frmMain.Memo1.Lines.Add(IntToStr(Item.Index)+','+IntToStr(iColIdx)+' : '+IntToStr(Integer(rec.FpcRecord))); if (iColIdx = 0) then Item.Caption := rec.asString else Item.SubItems.Add(rec.asString); end; end; procedure TfrmSQL.btnBLOBClick(Sender: TObject); var item :TListItem; rec :TdrRecord; pc :PChar; iLen :Integer; begin item := 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; interface uses Windows, Classes, Winsock, SysUtils, Messages, Math;// Math和StrUtils里面都有 IfThen(...)函数 const BUFFER_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; const DR_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; //常量定义 Const MAX_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; //定义相关结构 Type TIPAddressString = Array[0..4*4-1] of Char; PIPAddrString = ^TIPAddrString; TIPAddrString = Record Next : 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'; type TdrBuffer = class public Fpc :PChar; FiTotalLen :Integer; FiValidBeginOffset :Integer; FiValidLen :Integer; FdwType :DWORD; // 用于什么的? TCP接收/SQL/PUSH/...? FdwLastTick :DWORD; // 最后一次被Aquire时候的GetTickCount end; TdrBufferPool = class//(TObject) public constructor create; destructor destroy;override; private Flist :TList; FlistAll :TList;//... 这个没弄，还有加锁没弄... FhEvent :THandle;//... private function NewBlock(_iLen :Integer = 0) :TdrBuffer; function DelBlock(_buffer :TdrBuffer) :Integer; public function AquireBlock(_dwType :DWORD; _iLen :Integer) :TdrBuffer; function ReleaseBlock(_buffer :TdrBuffer) :Integer; public property ListAll :TList read FlistAll; end; // *** TdrRecvBuffer = class//(TObject) public constructor Create; destructor Destroy;override; private Flist :TList; FiTotalLen :Integer; FiPktIdx :Integer; // TCP包 序号 FhEvent :THandle; FiFirstPktLen :Integer; public function BufferAuqire(out _pc :PChar; out _iLen :integer) :integer; function BufferReleaseAll :integer; function BufferRecv(_iRecv :Integer; _iBlockIdx: integer) :Integer; function BufferHandleAll :Integer;// 处理所有已经接收到的 TCP包 private function 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) public FiErrorNo :Integer; FiStatus :integer; // 线程的状态(0:初始状态; 1:运行中; -1:结束) public Fskt :TSocket; private function RecvTimeoutSet :Integer; function RecvTimeoutCancel :Integer; function Recv01() :Integer; protected procedure Execute; override; public function Send01(_pbyte :PByte; _iLen :integer) :Integer; public class 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 = class public constructor Create(_dataset :TdrDataSet; _iRowIdx, _iColumnIdx :Integer); procedure FenXi; private Fdataset :TdrDataSet; FiRowIdx, FiColumnIdx :Integer; FpcRecord :PChar; // 指向某个Record的指针 public function asByteArray(_pByte :PByte; out _iLen :Integer) :Integer; function asInteger :Integer; function asSingle :Single; function asDouble :Double; function asString :string; private function GetFieldType :Integer; function GetFieldTypeName :string; function GetFieldName :string; public property FieldType :Integer read GetFieldType; property FieldTypeName :string read GetFieldTypeName; property FieldName :string read GetFieldName; end; TdrDataSet = class public function Unpack(_pc :PChar; _iLen :Integer) :integer; private FpcBuf :PChar; FiBufLen :Integer; // 缓冲区中 有效数据的长度 FaryColumnType :array of Integer; FaryColumnName :array of string; FaryaryRecord :array of array of Integer; // 指向各个Record的指针 public function GetFieldType(_iColumnIdx :integer) :Integer; function GetFieldTypeName(_iColumnIdx :integer) :string; function GetFieldName(_iColumnIdx :integer) :string; private Ffield :TdrRecord; // 这个属性有且只有一个 public function GetRecord(_iRowIdx, _iColumnIdx :integer):TdrRecord; property Rec[_iRow, _iCol :Integer] :TdrRecord read GetRecord; public function 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 = class public constructor Create; public FhWnd :HWND; FdwErrNo :DWORD; private procedure CreateWindow; public // 打包 信息 function PackSocket(_pc :PChar; _iLen :integer) :integer; procedure PackBlock(_pc :PChar; _iLen :integer); public FfuncPush :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); var g_callbackWnd :TcallbackWnd = nil; // 需要 自己新建 g_bufferPool :TdrBufferPool = nil; // 需要 自己新建 implementation uses formMain; var g_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; begin iLen := 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; begin Result := 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) then begin Result := GetLastError; Exit; end; lb := Windows.SetEndOfFile(hFile); if (not lb) then begin Result := GetLastError; CloseHandle(hFile); Exit; end; dwWritten := 0; lb := Windows.WriteFile(hFile, _str[1], Length(_str), dwWritten, nil); if (not lb) then begin Result := GetLastError; CloseHandle(hFile); Exit; end; CloseHandle(hFile); end; function FieldTypeName_f(_iFieldType :Integer; var _strFieldTypeName :string) :Integer; begin case _iFieldType of DR_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; begin bFind := false; dwSize := 0; GetAdaptersInfo(nil, dwSize); GetMem(adapterInfo, dwSize); iRes := GetAdaptersInfo(adapterInfo, dwSize); If (iRes <> ERROR_SUCCESS) Then begin MessageBoxA(0,'获取IP信息失败', '错误', MB_OK or MB_ICONERROR); exit; end; pInfo := adapterInfo; repeat // IP地址 ipAddrStr := pInfo.IPAddressList; iIp := inet_addr(ipAddrStr.IPAddress); if (_iIp = iIp) then begin bFind := True; _strMac := ''; for i:=1 to pInfo.AddressLength do begin _strMac := _strMac + IntToHex(pInfo.Address[i], 2); if (i <> pInfo.AddressLength) then _strMac := _strMac + ':'; end; Break; end; pIpAddrStr := ipAddrStr.Next; while pIpAddrStr<>nil do begin iIp := inet_addr(ipAddrStr.IPAddress); if (_iIp = iIp) then begin bFind := True; _strMac := ''; for i:=1 to pInfo.AddressLength do begin _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); begin if (_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; begin Result := (_s shl 10) or (_p); end; function ErrorNo2Str(_dwErrNo :DWORD):string; const LANG_NEUTRAL = $0; SUBLANG_DEFAULT = $01; var buf :array[0..255] of Char; begin ZeroMemory(@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; begin if Assigned(Flist) then Flist.Free; inherited; end; function TdrBufferPool.NewBlock(_iLen: Integer): TdrBuffer; var iYuShu :Integer; begin iYuShu := _iLen mod BUFFER_BLOCK; Result := TdrBuffer.Create; if (_iLen<>0)and(iYuShu = 0) then Result.FiTotalLen := _iLen else Result.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; begin Result := 0; iIdx := FlistAll.IndexOf(_buffer); FlistAll.Delete(iIdx); if (iIdx = -1) then Result := -1; end; function TdrBufferPool.AquireBlock(_dwType :DWORD; _iLen: Integer): TdrBuffer; var iAquireLen, i, iIdx, iYuShu :Integer; buffer :TdrBuffer; begin Result := nil; WaitForSingleObject(FhEvent, INFINITE); try if (Flist.Count = 0) then Result := NewBlock(_iLen) else begin iIdx := -1; iYuShu := _iLen mod BUFFER_BLOCK; if (_iLen<>0)and(iYuShu = 0) then iAquireLen := _iLen else iAquireLen := (_iLen div BUFFER_BLOCK + 1) * BUFFER_BLOCK; for i:=0 to Flist.Count-1 do begin buffer := TdrBuffer(Flist.Items[i]); if iAquireLen <= buffer.FiTotalLen then begin iIdx := i; break; end; end; if (iIdx = -1) then Result := NewBlock(_iLen) else begin Result := 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; finally SetEvent(FhEvent); end; end; function TdrBufferPool.ReleaseBlock(_buffer: TdrBuffer): Integer; const BUFFER_BLOCK_MAX_LEN = 1024 * 1024 * 500; // >=这个数的内存，采取直接释放内存缓冲区的操作方式 var i :Integer; buffer0, buffer1 :TdrBuffer; begin PostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 2, _buffer.FdwType); _buffer.FdwType := 0; Result := 0; WaitForSingleObject(FhEvent, INFINITE); try if (_buffer.FiTotalLen >= BUFFER_BLOCK_MAX_LEN) then // >=这个数的内存，采取直接释放内存缓冲区的操作方式 begin DelBlock(_buffer); FreeMem(_buffer.Fpc, _buffer.FiTotalLen); _buffer.Free; Exit; end; if (Flist.Count = 0) then begin Flist.Add(_buffer); Exit; end; buffer0 := TdrBuffer(Flist.Items[0]); if (_buffer.FiTotalLen <= buffer0.FiTotalLen) then begin Flist.Insert(0, _buffer); Exit; end else begin for i:=1 to Flist.Count-1 do begin buffer0 := TdrBuffer(Flist.Items[i-1]); buffer1 := TdrBuffer(Flist.Items[i]); if (_buffer.FiTotalLen > buffer0.FiTotalLen)and(_buffer.FiTotalLen <= buffer1.FiTotalLen) then begin Flist.Insert(i, _buffer); Exit; end; end; Flist.Add(_buffer); end; finally SetEvent(FhEvent); end; end; { TdrRecvBuffer } constructor TdrRecvBuffer.Create; begin Flist := TList.Create; FhEvent := CreateEvent(nil, False, false, nil); end; destructor TdrRecvBuffer.destroy;//override; begin if Assigned(Flist) then Flist.Free; if (FhEvent<>0) then CloseHandle(FhEvent); inherited; end; function TdrRecvBuffer.BufferAuqire(out _pc: PChar; out _iLen: integer): integer; var buffer, bufferNew :TdrBuffer; iCnt1, iCntUsed :Integer; begin Result := -1; if (Flist.Count = 0) then begin bufferNew := g_bufferPool.AquireBlock(OP_TYPE_RECV, 0); Flist.Add(bufferNew); Result := Flist.Count - 1; _pc := bufferNew.Fpc; _iLen := bufferNew.FiTotalLen; end else begin buffer := TdrBuffer(Flist.Items[Flist.Count - 1]); if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen then raise Exception.CreateFmt('TdrRecvBuffer.BufferAuqire 缓冲区错误(1) : %d, %d, %d', [buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen]) else if (buffer.FiValidBeginOffset + buffer.FiValidLen) = buffer.FiTotalLen then begin bufferNew := g_bufferPool.AquireBlock(OP_TYPE_RECV, 0); Flist.Add(bufferNew); Result := Flist.Count - 1; _pc := bufferNew.Fpc; _iLen := bufferNew.FiTotalLen; end else// if (buffer.FiValidBeginOffset + buffer.FiValidLen) < buffer.FiTotalLen then begin iCntUsed := buffer.FiValidBeginOffset + buffer.FiValidLen; _pc := @buffer.Fpc[iCntUsed]; _iLen := buffer.FiTotalLen - iCntUsed; Result := Flist.Count - 1; end; end; end; function TdrRecvBuffer.BufferReleaseAll :integer; begin while Flist.Count > 0 do begin g_bufferPool.ReleaseBlock(TdrBuffer(Flist.Items[0])); Flist.Delete(0); end; end; function TdrRecvBuffer.BufferRecv(_iRecv: Integer; _iBlockIdx: integer): Integer; var iCntUsed :Integer; buffer :TdrBuffer; begin Result := 0; Inc(FiTotalLen, _iRecv); buffer := TdrBuffer(Flist.Items[_iBlockIdx]); Inc(buffer.FiValidLen, _iRecv); if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen then raise 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; begin Result := 0; if (FiTotalLen < TCP_PACKET_HEADER_LEN) then // 一个TCP包都没有接收完毕 begin Result := 1; Exit; end; if (FiFirstPktLen <> 0) and (FiTotalLen < FiFirstPktLen) then begin Result := 2; Exit; end; iRtn := TcpPktHeader(iPktLen, iPktIdx, iPktType); FiFirstPktLen := iPktLen; if (FiTotalLen < iPktLen) then // 一个TCP包都没有接收完毕 begin Result := 3; Exit; end; FiFirstPktLen := 0; iPktIsNeed := TcpPktIsNeed(iPktIdx, iPktType); // *** (1) *** 缓冲区的分配/获取 bufferCopy := nil; if (iPktIsNeed > 0) then bufferCopy := g_bufferPool.AquireBlock(iPktType, iPktLen); // *** (2) *** 缓冲区内容填充 iCopyOffset := 0; iBlockIdx := 0; iPktLen01 := iPktLen; iBlockDropEndIdx := -1; while (iPktLen01 > 0) do begin bNeedBreak := false; if (iBlockIdx >= Flist.Count) then raise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(1) : %d, %d', [iBlockIdx, Flist.Count]); buffer := TdrBuffer(Flist.Items[iBlockIdx]); if (buffer.FiValidBeginOffset + buffer.FiValidLen) > buffer.FiTotalLen then raise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(2) : %d, %d, %d, %d', [iBlockIdx, buffer.FiValidBeginOffset, buffer.FiValidLen, buffer.FiTotalLen]) else if (buffer.FiValidBeginOffset + buffer.FiValidLen) = buffer.FiTotalLen then begin if iBlockDropEndIdx <> (iBlockIdx-1) then raise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(3) : %d, %d, %d', [iBlockIdx, iBlockDropEndIdx, iBlockIdx]); iBlockDropEndIdx := iBlockIdx; end else// if (buffer.FiValidBeginOffset + buffer.FiValidLen) < buffer.FiTotalLen then bNeedBreak := True; if (not bNeedBreak) then begin // 不是 某TCP包中的最后一块内存块的话，内存块的尾端肯定是占满的 if (buffer.FiValidBeginOffset + buffer.FiValidLen) <> buffer.FiTotalLen then raise 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) then begin iCopyLen := Math.IfThen(iPktLen01 > buffer.FiValidLen, buffer.FiValidLen, iPktLen01); if (bufferCopy <> nil) then CopyMemory(@bufferCopy.Fpc[iCopyOffset], @buffer.Fpc[buffer.FiValidBeginOffset], iCopyLen); Dec(iPktLen01, iCopyLen); Inc(buffer.FiValidBeginOffset, iCopyLen); // 缓冲区指针移动 Dec(buffer.FiValidLen, iCopyLen); end else begin if buffer.FiValidBeginOffset <> 0 then raise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(5) : %d, %d', [iBlockIdx, buffer.FiValidBeginOffset]); iCopyLen := Math.IfThen(iPktLen01 > buffer.FiValidLen, buffer.FiValidLen, iPktLen01); if (bufferCopy <> nil) then CopyMemory(@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) then raise Exception.CreateFmt('TdrRecvBuffer.BufferHandle 缓冲区错误(6) : %d, %d, %d', [iBlockIdx, iCopyOffset, bufferCopy.FiTotalLen]); if (bNeedBreak) then begin if (iPktLen01 <> 0) then raise 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 then for i:=0 to iBlockDropEndIdx do begin g_bufferPool.ReleaseBlock(TdrBuffer(Flist.Items[0])); Flist.Delete(0); end; end; function TdrRecvBuffer.BufferHandleAll: Integer; // 处理所有已经接收到的 TCP包 var iRtn : integer; begin Result := 0; while FiTotalLen > (TCP_PACKET_HEADER_LEN) do begin iRtn := BufferHandle; if (iRtn > 0) then break; 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; begin Result := 0; buffer := TdrBuffer(Flist.Items[0]); if (buffer.FiValidLen >= TCP_PACKET_HEADER_LEN) then begin pi := @buffer.Fpc[buffer.FiValidBeginOffset + 0]; _iPktLen := pi^; pi := @buffer.Fpc[buffer.FiValidBeginOffset + 4]; _iPktIdx := pi^; pi := @buffer.Fpc[buffer.FiValidBeginOffset + 8]; _iPktType:= pi^; end else begin if (Flist.Count = 1) then raise 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) then raise 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; begin Result := 0; if (_iPktType = OP_TYPE_SQL) then // 主动的SQL语句请求 begin if (_iPktIdx = FiPktIdx) then Result := 1; end else if (_iPktType = OP_TYPE_PUSH) then // TCP服务端推送消息 begin Result := 1; end else if (_iPktType and OP_TYPE_MANAGE) <> 0 then // 管理 begin Result := 1; end; end; procedure TdrRecvBuffer.TcpPktDispatch(_buffer :TdrBuffer); var pi :PInteger; iPktLen, iPktIdx, iPktType :Integer; begin pi := @_buffer.Fpc[4]; iPktIdx := pi^; pi := @_buffer.Fpc[8]; iPktType:= pi^; if (iPktType = OP_TYPE_SQL) then // 主动的SQL语句请求 begin if (iPktIdx = FiPktIdx) then SetEvent(FhEvent); end else if (iPktType = OP_TYPE_PUSH) then // TCP服务端推送消息 begin PostMessage(g_callbackWnd.FhWnd, WM_TCP_PUSH, 0, LParam(_buffer)); end else if (iPktType and OP_TYPE_MANAGE) <> 0 then // 管理 begin if 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 then PostMessage(g_callbackWnd.FhWnd, WM_CLIENT_SOCKET_MSG_REQ, 0, LParam(_buffer)) else if DWORD(iPktType) = OP_TYPE_MANAGE_SOCKET_RES then PostMessage(g_callbackWnd.FhWnd, WM_CLIENT_SOCKET_MSG_RES, 0, LParam(_buffer)) else if DWORD(iPktType) = OP_TYPE_MANAGE_BLOCK_REQ then PostMessage(g_callbackWnd.FhWnd, WM_CLIENT_BLOCK_MSG_REQ, 0, LParam(_buffer)) else if DWORD(iPktType) = OP_TYPE_MANAGE_BLOCK_RES then PostMessage(g_callbackWnd.FhWnd, WM_CLIENT_BLOCK_MSG_RES, 0, LParam(_buffer)) else if DWORD(iPktType) = OP_TYPE_MANAGE_SQL then PostMessage(g_callbackWnd.FhWnd, WM_MANAGE_SQL, 0, LParam(_buffer)) else begin end; end; end; { TdrTcpClient } function TdrTcpClient.RecvTimeoutSet: Integer; var iRecvTimeout, iRtn :Integer; begin Result := 0; iRecvTimeout := 1; // 毫秒 iRtn := setsockopt(Fskt, SOL_SOCKET, SO_RCVTIMEO, PChar(@iRecvTimeout), sizeof(integer)); if SOCKET_ERROR = iRtn then begin Result := GetLastError; FiErrorNo := Result; end; end; function TdrTcpClient.RecvTimeoutCancel: Integer; var iRecvTimeout, iRtn :Integer; begin Result := 0; iRecvTimeout := 0; // 毫秒 iRtn := setsockopt(Fskt, SOL_SOCKET, SO_RCVTIMEO, PChar(@iRecvTimeout), sizeof(integer)); if SOCKET_ERROR = iRtn then begin Result := 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 do begin iRecvBlockIdx := g_drRecvBuffer.BufferAuqire(pcRecv, iLenRecv); iRecv := recv(Fskt, pcRecv^, iLenRecv, 0); if (iRecv = 0) then // 连接优雅(gracefully)关闭 begin FiErrorNo := 0; break; end else if (iRecv < 0) then begin FiErrorNo := GetLastError; break; end else// if (iRecv > 0) then begin g_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; begin Result := 0; if RecvTimeoutSet<>0 then begin Result := GetLastError; Exit; end; while true do begin iRecvBlockIdx := g_drRecvBuffer.BufferAuqire(pcRecv, iLenRecv); iRecv := recv(Fskt, pcRecv^, iLenRecv, 0); if (iRecv = 0) then // 连接优雅(gracefully)关闭 begin Result := -1; FiErrorNo := 0; end else if (iRecv < 0) then begin FiErrorNo := GetLastError; if WSAETIMEDOUT <> FiErrorNo then begin Result := -2; end else begin Result := 1; end; break; end else// if (iRecv > 0) then begin g_drRecvBuffer.BufferRecv(iRecv, iRecvBlockIdx); if (iRecv <> iLenRecv) then begin Result := 2; Break; end; end; end; if RecvTimeoutCancel <> 0 then Result := GetLastError; end; function TdrTcpClient.Send01(_pbyte: PByte; _iLen: integer): Integer; var iRtn :Integer; begin Result := 0; iRtn := send(Fskt, _pbyte^, _iLen, 0); if iRtn = SOCKET_ERROR then Result := GetLastError; end; class function TdrTcpClient.Conn :integer; var skt :TSocket; bNeedCreate :boolean; begin Result := 0; if (length(g_strDestIp)=0)or(g_iDestPort=0) then begin raise Exception.Create('服务器IP/Poer 未设置'); Exit; end; bNeedCreate := false; if (g_tcpClient = nil) then bNeedCreate := true else begin if (g_tcpClient.FiStatus = 0) then begin Result := -1; Exit; end else if (g_tcpClient.FiStatus = -1) then begin bNeedCreate := True; g_tcpClient.Free; end; end; if (bNeedCreate) then begin skt := 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; begin if Conn < 0 then raise 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) then raise Exception.CreateFmt('发送消息异常 : (%d)%s', [iRtn, ErrorNo2Str(iRtn)]); WaitForSingleObject(g_drRecvBuffer.FhEvent, INFINITE); end; class procedure TdrTcpClient.SendBytes(_pc :PChar; _iLen :Integer); var iRtn :Integer; begin if Conn < 0 then raise Exception.Create('TCP接收线程正在初始化，请稍后再试...'); iRtn := g_tcpClient.Send01(@_pc[0], _iLen); if (iRtn <> 0) then raise 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; begin Result := 0; WSAStartup(MAKEWORD(1,1), wsadata1); skt := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); if (skt <= 0) then begin dwErrorNo := 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) then begin dwErrorNo := GetLastError; raise Exception.CreateFmt('%s %d %s', ['服务器连接异常:', dwErrorNo, ErrorNo2Str(dwErrorNo)]); end; Result := skt; end; class procedure TdrTcpClient.SetIpPort(_strDestIp: string; _iDestPort: integer); begin g_strDestIp := _strDestIp; g_iDestPort := _iDestPort; end; class function TdrTcpClient.Status: Integer; begin if (g_tcpClient = nil) then Result := -100 else Result := g_tcpClient.FiStatus; end; class procedure TdrTcpClient.SendHeartBeat; var pc :array[0..12] of Char; iPktLen, iPktIdx, iPktType :Integer; begin iPktLen := 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; begin Result := 0; // 用户已经处理 if (_uMsg = WM_TCP_PUSH) then begin if Assigned(g_callbackWnd.FfuncPush) then begin // 得到 缓冲区 buffer := TdrBuffer(_lParam); // 业务逻辑处理 g_callbackWnd.FfuncPush(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); // 释放缓冲区 g_bufferPool.ReleaseBlock(buffer); end; end else if (_uMsg = WM_TCP_CLIENTS) then begin if Assigned(g_callbackWnd.FfuncClients) then begin buffer := TdrBuffer(_lParam); g_callbackWnd.FfuncClients(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); g_bufferPool.ReleaseBlock(buffer); end; end else if (_uMsg = WM_CLIENT_SOCKET_MSG_REQ) then begin buffer := TdrBuffer(_lParam); g_callbackWnd.PackSocket(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); g_bufferPool.ReleaseBlock(buffer); end else if (_uMsg = WM_CLIENT_BLOCK_MSG_REQ) then begin buffer := TdrBuffer(_lParam); g_callbackWnd.PackBlock(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); g_bufferPool.ReleaseBlock(buffer); end else if (_uMsg = WM_CLIENT_SOCKET_MSG_RES) then begin if Assigned(g_callbackWnd.FfuncSocket) then begin buffer := TdrBuffer(_lParam); g_callbackWnd.FfuncSocket(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); g_bufferPool.ReleaseBlock(buffer); end; end else if (_uMsg = WM_CLIENT_BLOCK_MSG_RES) then begin if Assigned(g_callbackWnd.FfuncBlock) then begin buffer := TdrBuffer(_lParam); g_callbackWnd.FfuncBlock(@buffer.Fpc[TCP_PACKET_HEADER_LEN], buffer.FiValidLen - TCP_PACKET_HEADER_LEN); g_bufferPool.ReleaseBlock(buffer); end; end else if (_uMsg = WM_MANAGE_SQL) then begin buffer := TdrBuffer(_lParam); if Assigned(g_callbackWnd.FfuncSQL) then g_callbackWnd.FfuncSQL(buffer); g_bufferPool.ReleaseBlock(buffer); end else if (WM_TCP_RECV = _uMsg) then begin if (_wParam = 0) then frmMain.Memo1.Lines.Add('Recv : '+inttostr(_lParam)) else if (_wParam = 1) then frmMain.Memo1.Lines.Add('Allocate buffer block for : 0x'+inttohex(_lParam, 8)) else if (_wParam = 2) then frmMain.Memo1.Lines.Add('Release buffer block from : 0x'+inttohex(_lParam, 8)) else if (_wParam = 3) then frmMain.Memo1.Lines.Add('Space for unicode string : '+inttostr(_lParam)) else if (_wParam = 4) then frmMain.Memo1.Lines.Add('Space for ansi string : '+inttostr(_lParam)) else if (_wParam = 5) then frmMain.Memo1.Lines.Add('UTF-8 string space is : '+inttostr(_lParam)); end else if (WM_LOG_CONSOLE = _uMsg) then begin pc := PChar(_lParam); frmMain.Memo1.Lines.Add(PChar(_lParam)); FreeMem(pc, _wParam); end else if (_uMsg = WM_TIMER) then begin if (1 = _wParam) then begin if (g_tcpClient<>nil)and(g_tcpClient.FiStatus = 1) then TdrTcpClient.SendHeartBeat; end; end else if (_uMsg = WM_DESTROY) then begin DestroyWindow(_hwnd); PostQuitMessage(0); end else Result := DefWindowProc(_hWnd, _uMsg, _wParam, _lParam); end; constructor TcallbackWnd.Create; begin CreateWindow; //SetTimer(FhWnd, 1, 1000 * 10, nil); end; procedure TcallbackWnd.CreateWindow; var wndcls :WNDCLASS; hInstance :THandle; begin hInstance := 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) then FdwErrNo := 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; begin Result := 0; iNameLen := SizeOf(sockAddr); if SOCKET_ERROR = getsockname(g_tcpClient.Fskt, sockAddr, iNameLen) then begin dwErrNo := 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; begin mem := TMemoryStream.Create; try iPktLen := 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 do begin buffer := 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); finally mem.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; begin Result := 0; FpcBuf := _pc; FiBufLen := _iLen; CopyMemory(@iTotalLen, @_pc[0], 4); if (iTotalLen <> _iLen) then begin Result := -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) do CopyMemory(@FaryColumnType[i], @_pc[12 + i * 4], 4); iOffset := 12 + iColumnCnt * 4; // 列名称 for i:=0 to (iColumnCnt-1) do begin CopyMemory(@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 do for iColIdx:=0 to iColumnCnt-1 do begin CopyMemory(@iLenRecord, @_pc[iOffset], 4); FaryaryRecord[iRowIdx, iColIdx] := iOffset + 4; Inc(iOffset, 4 + iLenRecord); end; end; function TdrDataSet.GetRecord(_iRowIdx, _iColumnIdx: integer): TdrRecord; begin if not Assigned(Ffield) then Ffield := TdrRecord.Create(Self, _iRowIdx, _iColumnIdx) else begin Ffield.FiRowIdx := _iRowIdx; Ffield.FiColumnIdx := _iColumnIdx; end; Ffield.FenXi; Result := Ffield; end; function TdrDataSet.GetFieldType(_iColumnIdx: integer): Integer; begin Result := FaryColumnType[_iColumnIdx]; end; function TdrDataSet.GetFieldTypeName(_iColumnIdx: integer): string; begin FieldTypeName_f(GetFieldType(_iColumnIdx), Result); end; function TdrDataSet.GetFieldName(_iColumnIdx: integer): string; begin Result := FaryColumnName[_iColumnIdx]; end; function TdrDataSet.GetRowCount: Integer; begin Result := Length(FaryaryRecord); end; function TdrDataSet.GetColumnCount: Integer; begin Result := Length(FaryColumnType); end; { TdrRecord } constructor TdrRecord.Create(_dataset: TdrDataSet; _iRowIdx, _iColumnIdx: Integer); begin Fdataset := _dataset; FiRowIdx := _iRowIdx; FiColumnIdx := _iColumnIdx; end; procedure TdrRecord.FenXi; var iOffset :Integer; begin iOffset := Fdataset.FaryaryRecord[FiRowIdx, FiColumnIdx]; FpcRecord := @Fdataset.FpcBuf[iOffset]; end; function TdrRecord.asByteArray(_pByte: PByte; out _iLen: Integer): Integer; begin CopyMemory(@_iLen, FpcRecord-4, 4); if (_pByte <> nil) then CopyMemory(_pByte, FpcRecord, _iLen); end; function TdrRecord.asInteger: Integer; begin CopyMemory(@Result, FpcRecord, 4); end; function TdrRecord.asSingle: Single; begin CopyMemory(@Result, FpcRecord, SizeOf(Single)); end; function TdrRecord.asDouble: Double; begin CopyMemory(@Result, FpcRecord, SizeOf(Double)); end; function TdrRecord.asString: string; var iLen :Integer; iFieldType :Integer; d :Double; iUnicodeLen, iAnsiLen :Integer; pwc :PWideChar; pc :PChar; begin iFieldType := GetFieldType; case iFieldType of DR_NUMERIC : begin CopyMemory(@iLen, FpcRecord - 4, 4); CopyMemory(@d, FpcRecord, iLen); Result := FloatToStr(d); end; DR_LONGNVARCHAR, DR_NCHAR, DR_NVARCHAR, DR_LONGVARCHAR, DR_CHAR, DR_VARCHAR : begin pwc := nil; pc := nil; try CopyMemory(@iLen, FpcRecord - 4, 4); //PostMessage(g_callbackWnd.FhWnd, WM_TCP_RECV, 5, iLen); if (iLen = 0) then begin Result := '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; } finally if (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; begin Result := Fdataset.GetFieldType(FiColumnIdx); end; function TdrRecord.GetFieldTypeName: string; begin Result := Fdataset.GetFieldTypeName(FiColumnIdx); end; function TdrRecord.GetFieldName: string; begin Result := Fdataset.GetFieldName(FiColumnIdx); end; initialization g_bufferPool := TdrBufferPool.create; g_drRecvBuffer := TdrRecvBuffer.Create; g_callbackWnd := TcallbackWnd.Create; g_strDestIp := ''; g_iDestPort := 0; finalization if Assigned(g_bufferPool) then g_bufferPool.Free; if Assigned(g_drRecvBuffer) then g_drRecvBuffer.Free; end.
3、
