fssockm.pas

千年源代码,只缺少控件,可以做二次开发用,好不容易得来的

unit FSSockM;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, WinSock, adeftype, barutil, AnsUnit, AUtil32, StdCtrls, NMUDP;

const
   SERVEREVENT_NONE       = 0;
   SERVEREVENT_CONNECT    = 1;
   SERVEREVENT_DISCONNECT = 2;
   SERVEREVENT_ACCEPT     = 3;

type
   TServerEvent = function  (ConID, EventID: integer; var awstr: WString): Boolean of object;

   TConnect = class
     private
      FConId : integer;
      FAllowClose: Boolean;
      boWriteAllow : Boolean;

      RecieveBuffer: TBufferClass;
      SendBuffer : TBufferClass;
      WouldBlock : array [0..8192] of byte;
      WouldBlockSize: integer;
      cwsocket : TCustomWinSocket;
     public
      constructor Create;
      destructor Destroy; override;
      procedure  Initial (aSocket: TCustomWinSocket);
      procedure  Final;

      function   SendData (cnt: integer; pb: pbyte): integer;
      procedure  RecieveProcess (aSocket: TCustomWinSocket);
      procedure  SendProcess;

      property   ConID : integer read FConId;
      property   AllowClose: Boolean read FAllowClose write FAllowClose;
   end;

   TEventData = record
      ConId : integer;
      EventID : integer;
      bytearr: array [0..64-1] of byte;
   end;
   PTEventData = ^TEventData;

   TErrorData = record
      bytearr: array [0..128-1] of byte;
   end;
   PTErrorData = ^TErrorData;

   TUdpData = record
      ipaddr: array [0..32] of char;
      bytearr: array [0..256-1] of char;
   end;
   PTUdpData = ^TUdpData;

   TFrmSocketM = class(TForm)
      ServerSocket: TServerSocket;
      ListBox1: TListBox;
      BtnSave: TButton;
      BtnClear: TButton;
      LbCount: TLabel;
      procedure FormCreate(Sender: TObject);
      procedure ServerSocketAccept(Sender: TObject; Socket: TCustomWinSocket);
      procedure ServerSocketClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
      procedure ServerSocketClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
      procedure ServerSocketClientRead(Sender: TObject; Socket: TCustomWinSocket);
      procedure ServerSocketClientWrite(Sender: TObject; Socket: TCustomWinSocket);
      procedure FormDestroy(Sender: TObject);
      procedure BtnSaveClick(Sender: TObject);
      procedure BtnClearClick(Sender: TObject);
   private
      DataList : TAnsList;
      FServerEvent : TServerEvent;

      UdpComList : TComDataList;
      ErrorList : TComDataList;
      EventList : TBigComDataList;
      ConIdIndex : TAnsIndexClass;
      ConIdArr : array [0..100000-1] of integer;

      NMUDP0: TNMUDP;

      procedure AddEvent (Conid, EventId: integer; var awstr: WString);
      procedure AddError (str: string);
      function  ListAllocFunction: pointer;
      procedure ListFreeFunction (item: pointer);
      procedure NMUDP0DataReceived(Sender: TComponent; NumberBytes: Integer; FromIP: String; Port : Integer);
      { Private declarations }
   public
      procedure  Update1 (CurTick: integer);
      procedure  ProcessUdp (apu: PTUdpData);
      procedure  AddListBox (str: string);
      function   RecieveData (aConid, cnt: integer; pb: pbyte): integer;
      function   ViewData (aConid, cnt: integer; pb: pbyte): integer;
      function   GetDataSize (aConid: integer): integer;
      function   SendData (aConid, cnt: integer; pb: pbyte): integer;
      function   CloseConnect (aConId: integer): Boolean;
      function   GetIpAddress (aConid: integer; pb: pbyte): Boolean;
      function   AllowSend (aConId: integer): Boolean;
      function   IsConId (aConId: integer): Boolean;
      property   OnServerEvent : TServerEvent read FServerEvent write FServerEvent;
      { Public declarations }
   end;

   procedure DllSSocketSetVisible (aVisible: Boolean);
   function  DllSSocketGetConnections: integer;
   function  DllSSocketUpDate (CurTick: integer): Boolean;
   function  DllSSocketSetPort (aPort: integer): Boolean;
   procedure DllSSocketSetActive (aActive: Boolean);
   procedure DllSSocketSetAllowConnect (aAllowConnect: Boolean);
   procedure DllSSocketSetOnEvent (aServerEvent: TServerEvent);

   function  DllSSocketIsConId (ConId: integer): Boolean;
   function  DllSSocketRecieveData (ConId, cnt: integer; pb: pbyte): integer;
   function  DllSSocketViewData (ConId, cnt: integer; pb: pbyte): integer;
   function  DllSSocketGetDataSize (ConId: integer): integer;
   function  DllSSocketAllowSend (ConId: integer): Boolean;
   function  DllSSocketSendData (ConId, cnt: integer; pb: pbyte): integer;
   function  DllSSocketCloseConnect (ConId: integer): Boolean;
   function  DllSSocketGetIpAddress (ConId: integer; pb: pbyte): Boolean;

   procedure DllSSocketSetMaxUnUsedCount (aCount: Integer);

   procedure DllSUdpSetting (aPort: Integer);

{
   function  DllUdpAlloc (aPort: integer): integer;
   procedure DllUdpFree (aHandle: integer);
   procedure DllUdpAddIp (aHandle: integer; var awip: wstring);

   procedure DllUdpSendData (var wip: wstring; aPort: integer; cnt: integer; pb: pbyte);
   function  DllUdpGetData (aHandle: integer; var awip: wstring; var code: TComData): Boolean;
}
var
  FrmSocketM: TFrmSocketM;

implementation

{$R *.DFM}

var
   boAllowConnect : Boolean = TRUE;
   ProcessCount: integer = 35;
   CurProcess: integer = 0;
   WouldBlockCount: integer = 0;
   ServerSayString : string = '';

   NMUdpForSend : TNMUDP = nil;

   boFormStarted : Boolean = FALSE;

procedure DllUdpSendData (var wip: wstring; aPort: integer; cnt: integer; pb: pbyte);
var
   psd: PTComData;
   buffer : array[0..WSTRINGSIZE-1] of char;
begin
   if NMUdpForSend = nil then exit;
   psd := @Buffer;

   psd^.cnt := cnt;
   move (pb^, psd^.data, cnt);

   NMUdpForSend.ReportLevel := Status_Basic;
   NMUdpForSend.RemoteHost := GetWSString (wip);
   NMUdpForSend.RemotePort := aPort;
   try
      NMUdpForSend.SendBuffer(buffer, cnt+4);
   except
      FrmSocketM.AddError ('Udp Send Except');
   end;
end;

function  DllSSocketGetIpAddress (ConId: integer; pb: pbyte): Boolean;
begin
   Result := FrmSocketM.GetIpAddress (Conid, pb);
end;

procedure DllSSocketSetVisible (aVisible: Boolean);
begin
   FrmSocketM.Visible := aVisible;
end;

function  DllSSocketGetConnections: integer;
begin
   Result := FrmSocketM.ServerSocket.Socket.ActiveConnections;
end;

function  DllSSocketIsConId (ConId: integer): Boolean;
begin
   Result := FrmSocketM.IsConId (Conid);
end;

function  DllSSocketRecieveData (ConId, cnt: integer; pb: pbyte): integer;
begin
   Result := FrmSocketM.RecieveData (Conid, cnt, pb);
end;

function  DllSSocketViewData (ConId, cnt: integer; pb: pbyte): integer;
begin
   Result := FrmSocketM.ViewData (Conid, cnt, pb);
end;

function  DllSSocketGetDataSize (ConId: integer): integer;
begin
   Result := FrmSocketM.GetDataSize (Conid);
end;

function  DllSSocketAllowSend (ConId: integer): Boolean;
begin
   Result := FrmSocketM.AllowSend (Conid);
end;

function  DllSSocketSendData (ConId, cnt: integer; pb: pbyte): integer;
begin
   Result := FrmSocketM.SendData (Conid, cnt, pb);
end;

function  DllSSocketCloseConnect (ConId: integer): Boolean;
begin
   Result := FrmSocketM.CloseConnect (Conid);
end;

function  DllSSocketUpDate (CurTick: integer): Boolean;
begin
   if boFormStarted then FrmSocketM.Update1 (CurTick);
   Result := TRUE;
end;

var
   StartMaxUnUsedCount : integer = -1;
   
   StartPort : integer = -1;
   StartboActive : Boolean = FALSE;
   StartServerEvent : TServerEvent = nil;

   StartUdpPort : integer = 0;

procedure DllSSocketSetMaxUnUsedCount (aCount: Integer);
begin
   if boFormStarted then begin
      FrmSocketM.DataList.MaxUnUsedCount := aCount;
   end else begin
      StartMaxUnUsedCount := aCount;
   end;
end;

procedure DllSUdpSetting (aPort: Integer);
begin
   StartUdpPort := aPort;
end;

function  DllSSocketSetPort (aPort: integer): Boolean;
begin
   if boFormStarted then begin
      Result := FALSE;
      if FrmSocketM.ServerSocket.Active then exit;
      FrmSocketM.ServerSocket.Port := aPort;
      Result := TRUE;
   end else begin
      Result := FALSE;
      if StartboActive then exit;
      StartPort := aPort;
      Result := TRUE;
   end;
end;

procedure DllSSocketSetOnEvent (aServerEvent: TServerEvent);
begin
   if boFormStarted then begin
      FrmSocketM.OnServerEvent := aServerEvent;
   end else begin
      StartServerEvent := aServerEvent;
   end;
end;

procedure DllSSocketSetActive (aActive: Boolean);
begin
   if boFormStarted then begin
      FrmSocketM.ServerSocket.Active := aActive;
   end else begin
      StartboActive := aActive;
   end;
end;

procedure DllSSocketSetAllowConnect (aAllowConnect: Boolean);
begin
   boAllowConnect := aAllowConnect;
end;

//////////////////////////////////
//          Connet
//////////////////////////////////

constructor TConnect.Create;
begin
   boWriteAllow := FALSE;
   FConId    := -1;

   RecieveBuffer := TBufferClass.Create;
   SendBuffer := TBufferClass.Create;
   WouldBlockSize := 0;
end;

destructor  TConnect.Destroy;
begin
   RecieveBuffer.Free;
   SendBuffer.Free;
   inherited destroy;
end;

procedure  TConnect.Initial (aSocket: TCustomWinSocket);
begin
   FAllowClose := FALSE;
   FConId    := aSocket.SocketHandle;

   boWriteAllow := FALSE;
   cwSocket := aSocket;

   RecieveBuffer.Clear;
   SendBuffer.Clear;
   WouldBlockSize := 0;
end;

procedure  TConnect.Final;
begin
   boWriteAllow := FALSE;
   FConId := -1;

   RecieveBuffer.Clear;
   SendBuffer.Clear;
   WouldBlockSize := 0;
end;

procedure   TConnect.RecieveProcess (aSocket: TCustomWinSocket);
var
   cnt : integer;
   buffer : array [0..8192] of byte;
begin
   try
      cnt := cwSocket.ReceiveLength;
      if cnt > 8192 then cnt := 8192;
      cnt := cwSocket.ReceiveBuf (Buffer, cnt);
      if cnt <> SOCKET_ERROR then begin
         Buffer[cnt] := 0;
         RecieveBuffer.Add (cnt, @Buffer);
      end else begin
         FrmSocketM.AddError ('Recieve error');
      end;
   except
      FrmSocketM.AddError ('cwSocket.Recieve Except');
   end;
end;

function    TConnect.SendData (cnt: integer; pb: pbyte): integer;
begin
   if SendBuffer.Add (cnt, pb) then Result := cnt
   else Result := 0;
end;

procedure   TConnect.SendProcess;
   function GetSendData (pb: pbyte): integer;
   begin
      if Wouldblocksize <> 0 then begin
         Result := WouldBlockSize;
         move (Wouldblock, pb^, WouldBlockSize);
         WouldBlocksize :=0;
      end else begin
         Result := SendBuffer.Count;
         if Result = 0 then exit;
         if Result > 8192 then Result := 8192;
         Result := SendBuffer.Get (Result, pb);
      end;
   end;
var
   buf : array [0..8192] of byte;
   n, ret : integer;
begin
   if boWriteAllow = FALSE then exit;
   if AllowClose then exit;

   n := GetSendData (@buf);
   if n = 0 then exit;

   ret := cwSocket.SendBuf (buf, n);
   if ret <> n then begin
      Wouldblocksize := n;
      move (buf, WouldBlock, n);
      boWriteAllow := FALSE;
      FrmSocketM.AddError ('WouldBlock');
   end;
end;

///////////////////////
//
///////////////////////

function  TFrmSocketM.ListAllocFunction: pointer;
begin
   Result := TConnect.Create;
end;

procedure TFrmSocketM.ListFreeFunction (item: pointer);
begin
   TConnect(item).Free;
end;

procedure TFrmSocketM.FormCreate(Sender: TObject);
begin
   ConIdIndex := TAnsIndexClass.Create ('Conid', 4, FALSE);
   FillChar (ConIdArr, sizeof(ConIdArr), 0);

   UdpComList := TComDataList.Create;
   ErrorList := TComDataList.Create;
   EventList := TBigComDataList.Create;
   DataList := TAnsList.Create (5, ListAllocFunction, ListFreeFunction);

   boFormStarted := TRUE;

   if StartPort <> -1 then ServerSocket.Port := StartPort;
   if assigned (StartServerEvent) then OnServerEvent := StartServerEvent;
   if StartboActive then ServerSocket.Active := TRUE;

   if StartMaxUnUsedCount <> -1 then DataList.MaxUnUsedCount := StartMaxUnUsedCount;

   if StartUdpPort <> 0 then begin
      NMUDP0 := TNMUDP.Create (Self);
      NMUDP0.LocalPort := StartUdpPort;
      NMUDP0.RemotePort := StartUdpPort;
      NMUDP0.OnDataReceived := NMUDP0DataReceived;
   end else NMUDP0 := nil;
end;

procedure TFrmSocketM.FormDestroy(Sender: TObject);
begin
   if NMUDP0 <> nil then NMUDP0.Free;

   if ServerSocket.Active then ServerSocket.Active := FALSE;
   boFormStarted := FALSE;

   DataList.Free;
   EventList.Free;
   ErrorList.Free;
   UdpComList.Free;
   ConIdIndex.Free;
end;

procedure TFrmSocketM.ServerSocketAccept(Sender: TObject; Socket: TCustomWinSocket);
var
   n : integer;
   wstr: WString;
   bo : Boolean;
   Connect: TConnect;
begin
   if boAllowConnect = FALSE then begin Socket.Close; exit; end;

   if (Socket.SocketHandle > 0) and (Socket.SocketHandle < 100000) then n := ConIdArr[Socket.SocketHandle]
   else n := ConIdIndex.Select (IntToStr(Socket.SocketHandle));
   if (n <> 0) and (n <> -1) then begin AddError ('Aready Handle:'+IntToStr(Socket.SocketHandle)); Socket.Close; exit;  end;