fssockm.pas

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

   SetWSString (wstr, Socket.RemoteAddress);

   bo := TRUE;
   if Assigned (FServerEvent) then bo := FServerEvent (Socket.SocketHandle, SERVEREVENT_ACCEPT, wstr);
   if bo = FALSE then begin Socket.Close; exit; end;        // 立加芭何..

   Connect := DataList.GetUnUsedPointer;
   Connect.Initial (Socket);
   DataList.Add (Connect);

   if (Socket.SocketHandle > 0) and (Socket.SocketHandle < 100000) then ConidArr[Socket.SocketHandle] := Integer (Connect)
   else ConIdIndex.Insert (Integer(Connect), IntToStr(Socket.SocketHandle));

   AddEvent (Connect.ConId, SERVEREVENT_CONNECT, wstr);
end;

procedure TFrmSocketM.ServerSocketClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
var
   n: integer;
   wstr: WString;
begin
   if (Socket.SocketHandle > 0) and (Socket.SocketHandle < 100000) then n := ConIdArr[Socket.SocketHandle]
   else n := ConIdIndex.Select (IntToStr(Socket.SocketHandle));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Handle: disconnect:'+IntToStr(Socket.SocketHandle)); exit; end;
   TConnect(n).AllowClose := TRUE;
   SetWSString (wstr, Socket.RemoteAddress);
   AddEvent (TConnect(n).ConId, SERVEREVENT_DISCONNECT, wstr);
end;

procedure TFrmSocketM.ServerSocketClientError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
   ErrorCode := 0;
   Socket.Close;
end;

procedure TFrmSocketM.ServerSocketClientRead(Sender: TObject; Socket: TCustomWinSocket);
var n: integer;
begin
   if (Socket.SocketHandle > 0) and (Socket.SocketHandle < 100000) then n := ConIdArr[Socket.SocketHandle]
   else n := ConIdIndex.Select (IntToStr(Socket.SocketHandle));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Handle: Read:'+IntToStr(Socket.SocketHandle)); exit; end;
   TConnect(n).RecieveProcess (Socket);
end;

procedure TFrmSocketM.ServerSocketClientWrite(Sender: TObject; Socket: TCustomWinSocket);
var n: integer;
begin
   if (Socket.SocketHandle > 0) and (Socket.SocketHandle < 100000) then n := ConIdArr[Socket.SocketHandle]
   else n := ConIdIndex.Select (IntToStr(Socket.SocketHandle));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Handle:Write:'+IntToStr(Socket.SocketHandle)); exit; end;
   TConnect(n).boWriteAllow := TRUE;
end;

function   TFrmSocketM.RecieveData (aConid, cnt: integer; pb: pbyte): integer;
var n: integer;
begin
   Result := 0;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: RecieveData:'+IntToStr(aConid)); exit; end;
   Result := TConnect(n).RecieveBuffer.Get (cnt, pb);
end;

function   TFrmSocketM.ViewData (aConid, cnt: integer; pb: pbyte): integer;
var n: integer;
begin
   Result := 0;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: ViewData:'+IntToStr(aConid)); exit; end;
   Result := TConnect(n).RecieveBuffer.View (cnt, pb);
end;

function   TFrmSocketM.GetDataSize (aConid: integer): integer;
var n: integer;
begin
   Result := 0;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: GetDatasize:'+IntToStr(aConid)); exit; end;
   Result := TConnect(n).RecieveBuffer.Count;
end;

function   TFrmSocketM.IsConId (aConId: integer): Boolean;
var n: integer;
begin
   Result := FALSE;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin
      exit;
   end;
   Result := TRUE;
end;

function   TFrmSocketM.AllowSend (aConId: integer): Boolean;
var n: integer;
begin
   Result := FALSE;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: AllowSend:'+IntToStr(aConid)); exit; end;
   Result := TConnect(n).boWriteAllow;
end;

function   TFrmSocketM.SendData (aConid, cnt: integer; pb: pbyte): integer;
var n: integer;
begin
   Result := 0;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: SendData:'+IntToStr(aConid)); exit; end;
   Result := TConnect(n).SendData (cnt, pb);
end;

function   TFrmSocketM.GetIpAddress (aConid: integer; pb: pbyte): Boolean;
var
   n: integer;
begin
   pb^ := 0;
   Result := FALSE;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin AddError ('NotFound Conid: GetIpAddress:'+IntToStr(aConid)); exit; end;
   if TConnect(n).AllowClose then exit;
   if TConnect(n).cwSocket <> nil then begin
      StrPCopy (pchar (pb), TConnect(n).cwSocket.RemoteAddress);
      Result := TRUE
   end;
end;

function   TFrmSocketM.CloseConnect (aConId: integer): Boolean;
var
   n: integer;
begin
   Result := FALSE;
   if (aConid > 0) and (aConid < 100000) then n := ConIdArr[aConId]
   else n := ConIdIndex.Select (IntToStr(aConId));
   if (n = 0) or (n = -1) then begin
      AddError ('NotFound Conid: CloseConnect:' + IntToStr(aconid));
      exit;
   end;
   if not TConnect(n).AllowClose then TConnect(n).cwSocket.Close;
   Result := TRUE
end;

procedure TFrmSocketM.AddEvent (Conid, EventId: integer; var awstr: WString);
var ed : TEventData;
begin
   ed.ConId := Conid;
   ed.EventID := EventId;
   GetWSpChar (awstr, @ed.bytearr);
   EventList.AddComData (sizeof(ed), @ed);
end;

procedure  TFrmSocketM.AddError (str: string);
var er : TErrorData;
begin
   StrPCopy (@er.bytearr, str);
   ErrorList.AddComData (sizeof(er), @er);
end;

procedure  TFrmSocketM.AddListBox (str: string);
begin
   if Listbox1.Items.Count >= 10000 then ListBox1.items.delete (0);
   if str = 'WouldBlock' then inc (WouldBlockCount)
   else ListBox1.items.Add (str);
   listbox1.ItemIndex := listbox1.items.count -1;

   FrmSocketM.LbCount.Caption := 'WouldBlock : ' + inttostr (WouldBlockCount);    // 傈价 角菩
end;

procedure TFrmSocketM.BtnSaveClick(Sender: TObject);
begin
   ListBox1.Items.SaveToFile ('DllError.txt');
end;

procedure TFrmSocketM.BtnClearClick(Sender: TObject);
var
   str: string;
begin
   WouldBlockCount := 0;
   ListBox1.Items.Clear;
   str := format ('Clear: %s %s',[DateToStr(Date), TimeToStr(Time)]);
   AddError (str);
end;

procedure TFrmSocketM.NMUDP0DataReceived(Sender: TComponent; NumberBytes: Integer; FromIP: String; Port : Integer);
var
   n : integer;
   ud : TUdpData;
begin
   StrPCopy (ud.ipaddr, FromIp);
   byte (ud.ipaddr[Length(FromIp)]) := 0;

   if NumberBytes < 255 then begin
      NMUDP0.ReadBuffer(ud.bytearr,NumberBytes);
      byte (ud.bytearr[NumberBytes]) := 0;
      UdpComList.AddComData (sizeof(ud), @ud);
   end else begin
      while TRUE do begin
         n := 255;
         if NumberBytes > 255 then begin
            NMUDP0.ReadBuffer(ud.bytearr,n);
            NumberBytes := NumberBytes - n;
         end else begin
            NMUDP0.ReadBuffer(ud.bytearr,NumberBytes);
            break;
         end;
      end;
   end;
end;

procedure  TFrmSocketM.ProcessUdp (apu: PTUdpData);
var
   cmdstr: string;
   Buffer : array [0..256-1] of char;
begin
   cmdstr := StrPas (apu^.bytearr);

   if cmdstr = 'GETCONNECTCOUNT' then begin
      NMUDP0.ReportLevel := Status_Basic;
      NMUDP0.RemoteHost := StrPas (@apu^.ipaddr);
      StrPCopy (Buffer, 'CONNECTCOUNT:'+IntToStr(DataList.Count));
      try
         NMUDP0.SendBuffer(Buffer, StrLen (Buffer));
      finally
      end;
   end;

   if cmdstr = 'GETSERVERSAY' then begin
      NMUDP0.ReportLevel := Status_Basic;
      NMUDP0.RemoteHost := StrPas (@apu^.ipaddr);;
      if Length(ServerSayString) < 200 then StrPCopy (Buffer, 'SERVERSAY:'+ServerSayString)
      else StrPCopy (Buffer, 'SERVERSAY:');
      try
         NMUDP0.SendBuffer(Buffer, StrLen (Buffer));
      finally
      end;
   end;
end;

procedure  TFrmSocketM.Update1 (CurTick: integer);
var
   i : integer;
   sd: TComData;
   Connect : TConnect;
   pe : PTEventData;
   pr : PTErrorData;
   pu : PTUdpData;
   wstr: WString;
begin
   while TRUE do begin
      if not UdpComList.GetComData (sd) then break;
      pu := @sd.data;
      ProcessUdp (pu);
   end;

   while TRUE do begin
      if not EventList.GetComData (sd) then break;
      pe := @sd.data;
      if Assigned (FServerEvent) then begin
         SetWSpChar (wstr, @pe^.bytearr);
         FServerEvent (pe^.Conid, pe^.EventId, wstr);
      end;
   end;

   while TRUE do begin
      if not ErrorList.GetComData (sd) then break;
      pr := @sd.data;
      AddListBox (StrPas (@pr^.bytearr));
   end;


   for i := 0 to ProcessCount -1 do begin
      if CurProcess >= DataList.Count then CurProcess := 0;
      if DataList.Count = 0 then break;
      Connect := DataList[CurProcess];
      if Connect.AllowClose then begin
         if (Connect.Conid > 0) and (Connect.Conid < 100000) then ConIdArr[Connect.Conid] := 0
         else ConIdIndex.Delete (IntToStr(Connect.Conid));
         Connect.Final;
         DataList.Delete (CurProcess);
      end else begin
         Connect.SendProcess;
         inc (CurProcess);
      end;
   end;
end;

{
const
   udpmaxsize = 16384;
type
   TUdpClassData = record
      rip : string[32];
      rwip : wstring;
      rReceiveBuffer : TBigBufferClass;
   end;
   PTUdpClassData = ^TUdpClassData;

   TUdpClass = class
     private
      Udp : TNMUDP;
      IpList : TList;
      procedure UDPDataReceived(Sender: TComponent; NumberBytes: Integer; FromIP: String);
     public
      constructor Create (aPort: integer);
      destructor Destroy; override;
      procedure  AddIp (var awip: wstring);
      function   GetData (var awip : wstring; var code: TComData): Boolean;
   end;

var
   UdpClassList : TList;

//////////////////////////////
//    UdpClass
//////////////////////////////
constructor TUdpClass.Create(aPort: integer);
begin
   IpList := TList.Create;
   Udp := TNMUdp.Create (Application);
   Udp.LocalPort := aPort;
   Udp.OnDataReceived := UDPDataReceived;
end;

destructor TUdpClass.Destroy;
begin
//   Udp.Free;
   IpList.Free;
   inherited destroy;
end;

procedure TUdpClass.UDPDataReceived(Sender: TComponent; NumberBytes: Integer; FromIP: String);
var
   i : integer;
   buffer : array [0..udpmaxsize-1] of char;
begin
   try
      if NumberBytes > udpmaxsize-1 then NumberBytes := udpmaxsize-1;
      Udp.ReadBuffer(buffer,NumberBytes);
      for i := 0 to IpList.Count -1 do begin
         if PTUdpClassData (IpList[i])^.rip = FromIp then begin
            PTUdpClassData (IpList[i])^.rReceiveBuffer.Add (NumberBytes, @Buffer);
            break;
         end;
      end;
   except
      FrmSocketM.AddError ('Udp Recieve Except');
   end;
end;

procedure TUdpClass.AddIp (var awip : wstring);
var ucd : PTUdpClassData;
begin
   new (ucd);
   ucd^.rip := GetWSString (awip);
   MoveWs (awip, ucd^.rwip);
   ucd^.rReceiveBuffer := TBigBufferClass.Create;
   IpList.Add (ucd);
end;

function  TUdpClass.GetData (var awip : wstring; var code: TComData): Boolean;
var
   i, cnt : integer;
   pu : PTUdpClassData;
begin
   Result := FALSE;

   for i := 0 to IpList.Count -1 do begin
      pu := IpList[i];
      if CompareWs (pu^.rwip, awip) = 0 then begin
         if pu^.rReceiveBuffer.Count < 4 then break;
         pu^.rReceiveBuffer.View (4, @cnt);
         if pu^.rReceiveBuffer.Count < cnt + 4 then break;
         code.cnt := cnt;
         pu^.rReceiveBuffer.Get (code.cnt + 4, @code);
         Result := TRUE;
         exit;
      end;
   end;
end;

//////////////////////////////
//    Udp procedure
//////////////////////////////
function  GetUdpClassByHandle (aHandle: integer): TUdpClass;
var i: integer;
begin
   Result := nil;
   for i := 0 to UdpClassList.Count -1 do begin
      if aHandle = Integer (UdpClassList[i]) then begin
         Result := UdpClassList[i];
         exit;
      end;
   end;
end;

procedure DllUdpFree (aHandle: integer);
var i : integer;
begin
   for i := 0 to UdpClassList.Count -1 do begin
      if aHandle = Integer (UdpClassList[i]) then begin
         TUdpClass (UdpClassList[i]).free;
         UdpClassList.Delete (i);
         exit;
      end;
   end;
end;

function  DllUdpAlloc (aPort: integer): integer;
var uc: TUdpClass;
begin
   uc := TUdpClass.Create (aPort);
   UdpClassList.Add (uc);
   Result := Integer (uc);
end;

procedure DllUdpAddIp (aHandle: integer; var awip: wstring);
var uc: TUdpClass;
begin
   uc := GetUdpClassByHandle (aHandle);
   if uc = nil then exit;
   uc.AddIp (awip);
end;

function  DllUdpGetData (aHandle: integer; var awip: wstring; var code: TComData): Boolean;
var i: integer;
begin
   Result := FALSE;
   for i := 0 to UdpClassList.Count -1 do begin
      if aHandle = Integer (UdpClassList[i]) then begin
         Result := TUdpClass (UdpClassList[i]).GetData (awip, code);
         exit;
      end;
   end;
end;

procedure UdpListClear;
var i : integer;
begin
   for i := 0 to UdpClassList.Count -1 do TUdpClass (UdpClassList[i]).Free;
   UdpClassList.Clear;
end;

initialization
begin
   UdpClassList := TList.Create;
   NMUdpForSend := TNMUDP.Create (Application);
end;

finalization
begin
//   NMUdpForSend.Free;
//   UdpListClear;
   UdpClassList.Free;
end;
}
end.