INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Networking

How do I make components to wrap the TServerSocket and TClientSocket? by djjd47130
Posted: 22 Jul 11 (Edited 13 Feb 13)


IMPORTANT NOTICE
This FAQ is considered out of date because the ScktComp units with TServerSocket and TClientSocket are obsolete and unsupported.

There are many different sockets out there which you can use to communicate on the network, but for this, we will just be using the simple sockets provided with Delphi in the ScktComp unit. This includes the TServerSocket and TClientSocket. These components I've built to wrap these two sockets (TJDServerSocket and TJDClientSocket) along with some extra abilities.

The difference of these components is that login validation is built in, and data is transferred through command/parameter packets, rather than just a huge block of raw text. These sockets take care of all the nasty parsing everyone hates and jumps straight to a standard command structure.

A - Login Validation
On the client socket, you specify a Username and Password. When the client socket connects to the server, it will automatically send a login request to the server. When the server socket receives this request, it will trigger an event "OnLoginRequest" providing the Socket, username, password, and a variable "Accept" where you can validate whether to allow this user to connect. After specifying this boolean in the event handler, the server will continue to automatically authenticate the client, and send the result of the login back to the client. The client socket will then trigger a corresponding event "OnLoginResponse" which provides a constant "Accept" which specifies whether the login was successful or not. This event OnLoginResponse on the client socket basically is where you want to catch if Accept then BeginSomeProcedure; to continue with whatever custom commands you have.
B - Command/Parameter Packets
Both the Server and Client sockets have the same command structure. All this communication is done through an internal socket on either side. In other words, if you are using the TJDClientSocket, then all communication is actually done through the TJDClientServerSocket, and on the TJDServerSocket, all communication is actually done through numerous instances of TJDServerClientSocket. Both of these special sockets wrap the TCustomWinSocket in the ScktComp unit.
Rather than sending raw string data through these sockets, instead you call a procedure "SendPacket". This procedure has two overloads: (Command: Integer; Data: TStrings) or (Command: Integer; Data: Array of String). So, you could either create a TStringList of parameters and pass it like SendPacket(1234, MyList); or with an array of parameters, like SendPacket(1234, ['abc', 'def', 'ghi']); and the Command parameter (here I put '1234') you can specify any integer value to represent a unique command of yours.
On the other end, when one of these commands is received, it triggers an event OnCommand which provides the Socket the command came from, along with the Command and the Data which was sent. The code may look something like this:

CODE

//Send Command:
Socket.SendPacket(SOME_COMMAND_CONSTANT, ['First Param Data', 'Parameter2', 'SomeMoreData']);

//Receive Command:
procedure TfrmSockTest.CliCommand(Sender: TObject;
  Socket: TJDClientServerSocket; const Cmd: Integer; const Data: TStrings);
begin
  case Cmd of
    CMD_CONST_ONE: begin
      ProcessCommandNumberOne(Socket, Data);
    end;
    CMD_CONST_TWO: begin
      ProcessCommandNumberTwo(Socket, Data);
    end;
    CMD_CONST_THREE: begin
      ProcessCommandNumberThree(Socket, Data);
    end;
    else begin
      PostLog('Unrecognized Command');
    end;
  end;
end; 
C - Command Collections (NOT YET READY)
On both sides, I am building a TCollection set where you can pre-specify all the possible commands. For each of these commands, rather than using a case statement as I put above in one event handler, instead you can specify a unique event handler for each individual command. When a command is received on either end, rather than executing this OnCommand event on the socket, it will execute the OnCommand event associated with the unique command created in this collection. However, this part is not ready yet. The code is there, but is not being used yet because it doesn't work yet.

Otherwise, these components both do work fully functionally, and have been (somewhat) load tested. They can use some more extensive load testing with massive amounts of data.

And finally, the source code is below. It is referring to a component resource file (.DCR) which you won't have.

Install these two components into any package, and I have them listed under a tab 'JD Custom'.

CODE

{
  JD Socket Classes
  by Jerry Dodge

  TJDServerSocket: Wraps TServerSocket
  TJDClientSocket: Wraps TClientSocket
  TJDServerClientSocket: Wraps server side TCustomWinSocket
  TJDClientServerSocket: Wraps client side TCustomWinSocket

  Extra abilities:
  - Automatic login authentication
    > Client specifies credentials
    > Server triggers event OnLoginRequest, and property "Accept" is set accordingly
    > Client triggers event OnLoginResponse, and property "Accept" is used accordingly
  - Integer/Parameter based command structure
    > Both sides can send/receive command packets the same way
    > Integer based command ID, followed by array of string for parameters (or TStrings)
  - SOON TO COME: Collection of commands with unique names and events
    > TCollection property on both sides, holding a set of Commands
    > Each command has unique ID (command number) and a Name
    > Each command has its own event handler (OnCommand)
}

unit JDSockets;

interface

uses
  Classes, Windows, SysUtils, StrUtils, ScktComp, Variants, Messages, ExtCtrls;


const         
  CMD_LOGIN =   -1;
  DAT_DIV =     '#';

  
type
  TJDServerClientSocket = class;
  TJDClientServerSocket = class;
  TJDServerSocket = class;
  TJDClientSocket = class;
  TSvrCommands = class;
  TSvrCommand = class;  
  TCliCommands = class;
  TCliCommand = class;


  TJDScktConnState = (csConnected, csDisconnected, csConnecting, csDisconnecting);
  TJDScktLoginState = (lsNone, lsAllow, lsDeny, lsError);
  TJDScktRecState = (rsIdle, rsCommand);




  //Command Collections - NOT YET READY TO USE

  TJDScktSvrCmdEvent = procedure(Sender: TObject; Socket: TJDServerClientSocket;
    const Data: TStrings) of object;

  TSvrCommands = class(TCollection)
  private
    fOwner: TJDServerSocket;
    function GetItem(Index: Integer): TSvrCommand;
    procedure SetItem(Index: Integer; Value: TSvrCommand);
  public
    constructor Create(ASocket: TJDServerSocket);
    destructor Destroy;
    procedure DoCommand(const Socket: TJDServerClientSocket;
      const Cmd: Integer; const Data: TStrings);
    function Add: TSvrCommand;
    property Items[Index: Integer]: TSvrCommand read GetItem write SetItem;
  end;

  TSvrCommand = class(TCollectionItem)
  private
    fID: Integer;
    fOnCommand: TJDScktSvrCmdEvent;
    fName: String;
    procedure SetID(Value: Integer);
    procedure SetName(Value: String);
  protected
    function GetDisplayName: String; override;
  public
    procedure Assign(Source: TPersistent); override;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property ID: Integer read fID write SetID;
    property Name: String read fName write SetName;
    property OnCommand: TJDScktSvrCmdEvent read fOnCommand write fOnCommand;
  end;


  TJDScktCliCmdEvent = procedure(Sender: TObject; Socket: TJDClientServerSocket;
    const Data: TStrings) of object;
              
  TCliCommands = class(TCollection)
  private
    fOwner: TJDClientSocket;
    function GetItem(Index: Integer): TCliCommand;   
    procedure SetItem(Index: Integer; Value: TCliCommand);
  public
    constructor Create(ASocket: TJDClientSocket);
    destructor Destroy;
    procedure DoCommand(const Socket: TJDClientServerSocket;
      const Cmd: Integer; const Data: TStrings);
    function Add: TCliCommand;
    property Items[Index: Integer]: TCliCommand read GetItem write SetItem;
  end;

  TCliCommand = class(TCollectionItem)
  private
    fID: Integer;
    fName: String;
    fOnCommand: TJDScktCliCmdEvent;
    procedure SetID(Value: Integer);
    procedure SetName(Value: String);
  protected
    function GetDisplayName: String; override; 
  public
    procedure Assign(Source: TPersistent); override;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property ID: Integer read fID write SetID;
    property Name: String read fName write SetName;
    property OnCommand: TJDScktCliCmdEvent read fOnCommand write fOnCommand;
  end;

  //END Command Collections




                 
  //Server side - client connection

  TJDSvrCliConnEvent = procedure(Sender: TObject; Socket: TJDServerClientSocket;
    const OldState, NewState: TJDScktConnState) of object;
  TJDSvrCliErrEvent = procedure(Sender: TObject; Socket: TJDServerClientSocket;
    var ErrMsg: String; var ErrCode: Integer) of object;
  TJDSvrCliCmdEvent = procedure(Sender: TObject; Socket: TJDServerClientSocket;
    const Cmd: Integer; const Data: TStrings) of object;
  TJDScktLoginRequestEvent = procedure(Sender: TObject; Socket: TJDServerClientSocket;
    const Username, Password: String; var Accept: Bool) of object;

  TJDServerClientSocket = class(TObject)
  private     
    fErrors: TStringList;
    fTimer: TTimer;
    fSocket: TCustomWinSocket;
    fConnState: TJDScktConnState;
    fLoginState: TJDScktLoginState;
    fRecState: TJDScktRecState;
    fBusy: Bool;
    fBuffer: String;
    fSize: Integer;
    fCommand: Integer;
    fProtocol: Integer;
    fData: Pointer;
    fOnConnection: TJDSvrCliConnEvent;
    fOnCommand: TJDSvrCliCmdEvent;
    fOnError: TJDSvrCliErrEvent;
    fOnLoginRequest: TJDScktLoginRequestEvent;
    procedure TimerOnTimer(Sender: TObject);
    procedure ProcessHeader(const S: String);
    procedure ProcessCommand(const S: String);
  public
    constructor Create(ASocket: TCustomWinSocket);
    destructor Destroy; override;
    procedure SendPacket(Cmd: Integer; Data: TStrings); overload;
    procedure SendPacket(Cmd: Integer; Data: array of String); overload;
    procedure SendStream(Cmd: Integer; Data: TStream);
    property Socket: TCustomWinSocket read fSocket;
    property ConnState: TJDScktConnState read fConnState;
    property LoginState: TJDScktLoginState read fLoginState;
    property ReceiveState: TJDScktRecState read fRecState;
    property Command: Integer read fCommand;
    property Size: Integer read fSize;
    property Protocol: Integer read fProtocol;
    property Data: Pointer read fData write fData;
    property OnConnection: TJDSvrCliConnEvent
      read fOnConnection write fOnConnection;
    property OnCommand: TJDSvrCliCmdEvent
      read fOnCommand write fOnCommand;
    property OnError: TJDSvrCliErrEvent
      read fOnError write fOnError;
    property OnLoginRequest: TJDScktLoginRequestEvent
      read fOnLoginRequest write fOnLoginRequest;
  end;


         
  //Client side - server connection
      
  TJDCliSvrConnEvent = procedure(Sender: TObject; Socket: TJDClientServerSocket;
    const OldState, NewState: TJDScktConnState) of object;
  TJDCliSvrErrEvent = procedure(Sender: TObject; Socket: TJDClientServerSocket;
    var ErrMsg: String; var ErrCode: Integer) of object;
  TJDCliSvrCmdEvent = procedure(Sender: TObject; Socket: TJDClientServerSocket;
    const Cmd: Integer; const Data: TStrings) of object;
  TJDScktLoginResponseEvent = procedure(Sender: TObject; Socket: TJDClientServerSocket;
    const Accept: Bool) of object;

  TJDClientServerSocket = class(TObject)
  private    
    fErrors: TStringList;
    fTimer: TTimer;
    fSocket: TCustomWinSocket;
    fConnState: TJDScktConnState;
    fLoginState: TJDScktLoginState;
    fRecState: TJDScktRecState;
    fBusy: Bool;
    fBuffer: String;
    fSize: Integer;
    fCommand: Integer;
    fProtocol: Integer;
    fOnConnection: TJDCliSvrConnEvent;
    fOnCommand: TJDCliSvrCmdEvent;
    fOnError: TJDCliSvrErrEvent;
    fOnLoginResponse: TJDScktLoginResponseEvent;
    procedure TimerOnTimer(Sender: TObject);    
    procedure Login(const Username, Password: String); 
    procedure ProcessHeader(const S: String);
    procedure ProcessCommand(const S: String);
  public
    constructor Create(ASocket: TCustomWinSocket); 
    destructor Destroy; override;
    procedure SendPacket(Cmd: Integer; Data: TStrings); overload;
    procedure SendPacket(Cmd: Integer; Data: Array of String); overload;
    property Socket: TCustomWinSocket read fSocket;
    property ConnState: TJDScktConnState read fConnState;
    property LoginState: TJDScktLoginState read fLoginState;
    property ReceiveState: TJDScktRecState read fRecState;
    property Command: Integer read fCommand;
    property Size: Integer read fSize;
    property Buffer: String read fBuffer;
    property Protocol: Integer read fProtocol;
    property OnConnection: TJDCliSvrConnEvent
      read fOnConnection write fOnConnection;
    property OnCommand: TJDCliSvrCmdEvent
      read fOnCommand write fOnCommand;
    property OnError: TJDCliSvrErrEvent
      read fOnError write fOnError;
    property OnLoginResponse: TJDScktLoginResponseEvent
      read fOnLoginResponse write fOnLoginResponse;
  end;











  //Server Socket Component

  TJDServerSocket = class(TComponent)
  private
    fSocket: TServerSocket;
    fPcktPrefix: String;
    fClients: TList;      
    fCommands: TSvrCommands;
    fOnConnection: TJDSvrCliConnEvent;   
    fOnError: TJDSvrCliErrEvent;
    fOnLoginRequest: TJDScktLoginRequestEvent;
    fOnCommand: TJDSvrCliCmdEvent;
    function GetPort: Integer;
    function GetActive: Bool;
    function GetClient(Index: Integer): TJDServerClientSocket;
    procedure SetPort(Value: Integer);
    procedure SetActive(Value: Bool);
    procedure ScktConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ScktDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ScktRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ScktError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ScktCommand(Sender: TObject; Socket: TJDServerClientSocket;
      const Cmd: Integer; const Data: TStrings);
    procedure ScktLoginRequest(Sender: TObject; Socket: TJDServerClientSocket;
      const Username, Password: String; var Accept: Bool);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Active: Bool read GetActive write SetActive;
    property Port: Integer read GetPort write SetPort;   
    //property Commands: TSvrCommands read fCommands;
    property OnConnection: TJDSvrCliConnEvent
      read fOnConnection write fOnConnection;      
    property OnError: TJDSvrCliErrEvent read fOnError write fOnError;
    property OnLoginRequest: TJDScktLoginRequestEvent
      read fOnLoginRequest write fOnLoginRequest;
    property OnCommand: TJDSvrCliCmdEvent
      read fOnCommand write fOnCommand;
  end;




  //Client Socket Component

  TJDClientSocket = class(TComponent)
  private
    fSocket: TClientSocket;
    fPcktPrefix: String;
    fUsername: String;
    fPassword: String;   
    fCommands: TCliCommands;
    fOnConnection: TJDCliSvrConnEvent;        
    fOnError: TJDCliSvrErrEvent;
    fOnLoginResponse: TJDScktLoginResponseEvent;
    fOnCommand: TJDCliSvrCmdEvent;
    function GetPort: Integer;
    function GetHost: String;
    function GetActive: Bool;
    function GetSocket: TJDClientServerSocket;
    procedure SetPort(Value: Integer);
    procedure SetHost(Value: String);
    procedure SetActive(Value: Bool);
    procedure SetUsername(Value: String);
    procedure SetPassword(Value: String);
    procedure ScktConnection(Sender: TObject; Socket: TJDClientServerSocket;
      const OldState, NewState: TJDScktConnState);
    procedure ScktCommand(Sender: TObject; Socket: TJDClientServerSocket;
      const Cmd: Integer; const Data: TStrings);
    procedure ScktLoginResponse(Sender: TObject; Socket: TJDClientServerSocket;
      const Accept: Bool);
    procedure ScktConnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ScktDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure ScktRead(Sender: TObject; Socket: TCustomWinSocket); 
    procedure ScktError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Socket: TJDClientServerSocket read GetSocket;
  published
    property Host: String read GetHost write SetHost;
    property Port: Integer read GetPort write SetPort;
    property Active: Bool read GetActive write SetActive;
    property Username: String read fUsername write SetUsername;
    property Password: String read fPassword write SetPassword; 
    //property Commands: TCliCommands read fCommands;
    property OnConnection: TJDCliSvrConnEvent
      read fOnConnection write fOnConnection;
    property OnError: TJDCliSvrErrEvent read fOnError write fOnError;
    property OnLoginResponse: TJDScktLoginResponseEvent
      read fOnLoginResponse write fOnLoginResponse;
    property OnCommand: TJDCliSvrCmdEvent
      read fOnCommand write fOnCommand;
  end;



function MakePacketData(const Strings: Array of String): String; overload;
function MakePacketData(const Strings: TStrings): String; overload;
function MakePacketData(const Strings: Array of String; var Lst: TStrings): Bool; overload;

function ReadPacketData(const Data: String; var Strings: TStrings): Bool; overload;
function ReadPacketData(const Data: String; var Strings: Array of String): Bool; overload;



procedure Register;



implementation

{$R JDSockets.dcr}



procedure Register;
begin
  RegisterComponents('JD Custom', [TJDServerSocket, TJDClientSocket]);
end;




function MakePacketData(const Strings: Array of String): String;
var
  X: Integer;
  T: String;
begin
  for X:= 0 to Length(Strings) - 1 do begin
    T:= Strings[X];
    Result:= Result + IntToStr(Length(T)) + DAT_DIV + T;
  end;
end;

function MakePacketData(const Strings: TStrings): String;
var
  X: Integer;
begin
  for X:= 0 to Strings.Count - 1 do
    Result:= Result + IntToStr(Length(Strings[X])) + DAT_DIV + Strings[X];
end;

function MakePacketData(const Strings: Array of String; var Lst: TStrings): Bool; 
var
  X: Integer;
begin
  for X:= 0 to Length(Strings) - 1 do
    Lst.Append(Strings[X]);
end;



function ReadPacketData(const Data: String; var Strings: TStrings): Bool;    
begin

end;

function ReadPacketData(const Data: String; var Strings: Array of String): Bool;  
begin

end;





{ TJDServerClientSocket }

constructor TJDServerClientSocket.Create(ASocket: TCustomWinSocket);
begin
  fBusy:= True;
  try
    fErrors:= TStringList.Create;
    fTimer:= TTimer.Create(nil);
      fTimer.OnTimer:= TimerOnTimer;
      fTimer.Interval:= 1;
    fSocket:= ASocket;
    fSocket.Data:= Self;
    Self.fLoginState:= lsNone;
  finally
    fBusy:= False;
  end;
end;

destructor TJDServerClientSocket.Destroy;
begin
  if assigned(fErrors) then fErrors.Free;
  if assigned(fTimer) then fTimer.Free;
  inherited;
end;

procedure TJDServerClientSocket.ProcessCommand(const S: String);
var
  P, Z: Integer;
  Str, T: String;
  L, LR: TStringList;
  Usr, Pas: String;
  Val: Bool;
begin
  L:= TStringList.Create;
  try
    Str:= S;
    while Length(Str) > 0 do begin
      P:= Pos(DAT_DIV, Str);
      if P > 0 then begin
        T:= Copy(Str, 1, P-1);
        Delete(Str, 1, P);
        Z:= StrToIntDef(T, 0);
        L.Append(Copy(Str, 1, Z));
        Delete(Str, 1, Z);

      end else begin
        Str:= '';
        //Raise error - invalid packet
      end;
    end;
    if fCommand = CMD_LOGIN then begin
      //Login
      if assigned(fOnLoginRequest) then begin
        Usr:= L[0];
        Pas:= L[1];
        Val:= False;
        Self.fOnLoginRequest(Self, Self, Usr, Pas, Val);
        LR:= TStringList.Create;
        try
          if Val then begin
            LR.Append('1');
            Self.fLoginState:= lsAllow;
          end else begin
            LR.Append('0');
            Self.fLoginState:= lsDeny;
          end;
          SendPacket(CMD_LOGIN, LR);
        finally
          LR.Free;
        end;
      end else begin
        //No procedure assigned to event - raise error

      end;
    end else begin
      if fLoginState = lsAllow then begin
        if assigned(fOnCommand) then begin
          fOnCommand(Self, Self, fCommand, L);
        end else begin
          //No procedure assigned to event - raise error

        end;
      end else begin
        //Not logged in, drop packet
        
      end;
    end;
  finally
    L.Free;
  end;
end;

procedure TJDServerClientSocket.ProcessHeader(const S: String);
var
  Str, T: String;
begin
  Str:= S;
  T:= Copy(Str, 1, Pos(DAT_DIV, Str)-1);
  Delete(Str, 1, Pos(DAT_DIV, Str));
  fCommand:= StrToIntDef(T, 0);
  T:= Copy(Str, 1, Length(Str));
  fSize:= StrToIntDef(T, 0);
end;

procedure TJDServerClientSocket.SendPacket(Cmd: Integer; Data: TStrings);
var
  S: String;
  X: Integer;
begin
  S:= '';
  if assigned(Data) then
    if Data <> nil then
      for X:= 0 to Data.Count - 1 do
        S:= S + IntToStr(Length(Data[X])) + DAT_DIV + Data[X];
  Socket.SendText(IntToStr(Cmd) + DAT_DIV + IntToStr(Length(S)) + DAT_DIV + S);
end;

procedure TJDServerClientSocket.SendPacket(Cmd: Integer;
  Data: array of String);
var
  S: String;
  X: Integer;
begin
  S:= '';
  for X:= 0 to Length(Data) - 1 do
    S:= S + IntToStr(Length(Data[X])) + DAT_DIV + Data[X];
  Socket.SendText(IntToStr(Cmd) + DAT_DIV + IntToStr(Length(S)) + DAT_DIV + S);
end;

procedure TJDServerClientSocket.SendStream(Cmd: Integer; Data: TStream);
begin
  Data.Position:= 0;
  Socket.SendText(IntToStr(Cmd) + DAT_DIV + IntToStr(Data.Size) + DAT_DIV);
  Socket.SendStream(Data);
end;

procedure TJDServerClientSocket.TimerOnTimer(Sender: TObject);
var
  S: String;
  P: Integer;
begin
  if not fBusy then begin
    fBusy:= True;
    try
      case fRecState of
        rsIdle: begin
          P:= Pos(DAT_DIV, fBuffer);
          if P > 1 then begin
            S:= Copy(fBuffer, 1, P-1);
            Delete(fBuffer, 1, P+(Length(DAT_DIV)-1));
            try
              P:= Pos(DAT_DIV, fBuffer);
              if P > 1 then begin
                S:= S + DAT_DIV + Copy(fBuffer, 1, P-1);
                Delete(fBuffer, 1, P+(Length(DAT_DIV)-1));
                ProcessHeader(S);
              end;
            finally
              fRecState:= rsCommand;
            end;
          end;
        end;
        rsCommand: begin
          if Length(fBuffer) >= fSize then begin
            S:= Copy(fBuffer, 1, fSize);
            Delete(fBuffer, 1, fSize);
            try
              ProcessCommand(S);
            finally
              fRecState:= rsIdle;
            end;
          end;
        end;
      end;
    finally
      fBusy:= False;
    end;
  end;
end;

{ TJDClientServerSocket }
     
constructor TJDClientServerSocket.Create(ASocket: TCustomWinSocket);
begin
  fErrors:= TStringList.Create;
  fTimer:= TTimer.Create(nil);    
    fTimer.Interval:= 1;
    fTimer.OnTimer:= TimerOnTimer;
    fTimer.Enabled:= True;
  fSocket:= ASocket;
  fSocket.Data:= Self;

end;

destructor TJDClientServerSocket.Destroy;
begin
  if assigned(fErrors) then fErrors.Free;
  if assigned(fTimer) then fTimer.Free;
  inherited;
end;

procedure TJDClientServerSocket.Login(const Username, Password: String);
begin
  Self.SendPacket(CMD_LOGIN, [Username, Password]);
end;

procedure TJDClientServerSocket.ProcessCommand(const S: String);
var
  P, Z: Integer;
  Str, T: String;
  L, LR: TStringList;
  Val: Bool;
begin
  L:= TStringList.Create;
  try
    Str:= S;
    while Length(Str) > 0 do begin
      P:= Pos(DAT_DIV, Str);
      if P > 0 then begin
        T:= Copy(Str, 1, P-1);
        Delete(Str, 1, P);
        Z:= StrToIntDef(T, 0);
        L.Append(Copy(Str, 1, Z));
        Delete(Str, 1, Z);

      end else begin
        Str:= '';
        //Raise error - invalid packet
      end;
    end;
    if fCommand = CMD_LOGIN then begin
      //Login
      if assigned(fOnLoginResponse) then begin
        Val:= L[0] = '1';
        Self.fOnLoginResponse(Self, Self, Val);
        if Val then begin
          Self.fLoginState:= lsAllow;
        end else begin
          Self.fLoginState:= lsDeny;
        end;
      end else begin
        //No procedure assigned to event - raise error

      end;
    end else begin
      if assigned(fOnCommand) then begin
        fOnCommand(Self, Self, fCommand, L);
      end else begin
        //No procedure assigned to event - raise error
        
      end;
    end;
  finally
    L.Free;
  end;
end;

procedure TJDClientServerSocket.ProcessHeader(const S: String);
var
  Str, T: String;
begin
  Str:= S;
  T:= Copy(Str, 1, Pos(DAT_DIV, Str)-1);
  Delete(Str, 1, Pos(DAT_DIV, Str));
  fCommand:= StrToIntDef(T, 0);
  T:= Copy(Str, 1, Length(Str));
  fSize:= StrToIntDef(T, 0);
end;

procedure TJDClientServerSocket.SendPacket(Cmd: Integer;
  Data: array of String);
var
  S: String;
  X: Integer;
begin
  S:= '';
  for X:= 0 to Length(Data) - 1 do
    S:= S + IntToStr(Length(Data[X])) + DAT_DIV + Data[X];
  Socket.SendText(IntToStr(Cmd) + DAT_DIV + IntToStr(Length(S)) + DAT_DIV + S);
end;
       
procedure TJDClientServerSocket.SendPacket(Cmd: Integer; Data: TStrings);
var
  S: String;
  X: Integer;
begin
  S:= '';
  if assigned(Data) then
    if Data <> nil then
      for X:= 0 to Data.Count - 1 do
        S:= S + IntToStr(Length(Data[X])) + DAT_DIV + Data[X];
  Socket.SendText(IntToStr(Cmd) + DAT_DIV + IntToStr(Length(S)) + DAT_DIV + S);
end;

procedure TJDClientServerSocket.TimerOnTimer(Sender: TObject);
var
  S: String;
  P: Integer;
begin
  if not fBusy then begin
    fBusy:= True;
    try
      case fRecState of
        rsIdle: begin
          P:= Pos(DAT_DIV, fBuffer);
          if P > 1 then begin
            S:= Copy(fBuffer, 1, P-1);
            Delete(fBuffer, 1, P+(Length(DAT_DIV)-1));
            try
              P:= Pos(DAT_DIV, fBuffer);
              if P > 1 then begin
                S:= S + DAT_DIV + Copy(fBuffer, 1, P-1);
                Delete(fBuffer, 1, P+(Length(DAT_DIV)-1));
                ProcessHeader(S);
              end;
            finally
              fRecState:= rsCommand;
            end;
          end;
        end;
        rsCommand: begin
          if Length(fBuffer) >= fSize then begin
            S:= Copy(fBuffer, 1, fSize);
            Delete(fBuffer, 1, fSize);
            try
              ProcessCommand(S);
            finally
              fRecState:= rsIdle;
            end;
          end;
        end;
      end;
    finally
      fBusy:= False;
    end;
  end;
end;

{ TJDServerSocket }

constructor TJDServerSocket.Create(AOwner: TComponent);
begin
  inherited;
  fSocket:= TServerSocket.Create(nil);
    fSocket.OnClientConnect:= ScktConnect;
    fSocket.OnClientDisconnect:= ScktDisconnect;
    fSocket.OnClientRead:= ScktRead;
    fSocket.OnClientError:= ScktError;
  fCommands:= TSvrCommands.Create(Self);
end;

destructor TJDServerSocket.Destroy;
begin
  fSocket.Free;
  fCommands.Free;
  inherited;
end;

function TJDServerSocket.GetActive: Bool;
begin
  Result:= fSocket.Active;
end;

function TJDServerSocket.GetClient(Index: Integer): TJDServerClientSocket;
begin
  Result:= TJDServerClientSocket(fSocket.Socket.Connections[Index].Data);
end;

function TJDServerSocket.GetPort: Integer;
begin
  Result:= fSocket.Port;
end;

procedure TJDServerSocket.ScktCommand(Sender: TObject;
  Socket: TJDServerClientSocket; const Cmd: Integer; const Data: TStrings);
begin
  if assigned(fOnCommand) then fOnCommand(Self, Socket, Cmd, Data);
end;

procedure TJDServerSocket.ScktConnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  S: TJDServerClientSocket;
begin
  S:= TJDServerClientSocket.Create(Socket);
  Socket.Data:= S;
    S.OnCommand:= Self.ScktCommand;
    S.OnLoginRequest:= Self.ScktLoginRequest;
  if assigned(fOnConnection) then
    fOnConnection(Self, S, csConnecting, csConnected);
end;

procedure TJDServerSocket.ScktDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
var
  S: TJDServerClientSocket;
begin
  S:= TJDServerClientSocket(Socket.Data);
  if assigned(fOnConnection) then
    fOnConnection(Self, S, csDisconnecting, csDisconnected);
  S.Free;
end;

procedure TJDServerSocket.ScktError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
begin

  ErrorCode:= 0;
end;

procedure TJDServerSocket.ScktLoginRequest(Sender: TObject;
  Socket: TJDServerClientSocket; const Username, Password: String;
  var Accept: Bool);
begin
  if assigned(fOnLoginRequest) then begin
    fOnLoginRequest(Self, Socket, Username, Password, Accept);
  end else begin
    //
  end;
end;

procedure TJDServerSocket.ScktRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  S: TJDServerClientSocket;
begin
  S:= TJDServerClientSocket(Socket.Data);
  S.fBuffer:= S.fBuffer + Socket.ReceiveText;
end;

procedure TJDServerSocket.SetActive(Value: Bool);
begin
  
  fSocket.Active:= Value;
end;

procedure TJDServerSocket.SetPort(Value: Integer);
begin
  fSocket.Port:= Value;
end;

{ TJDClientSocket }

constructor TJDClientSocket.Create(AOwner: TComponent);
var
  S: TJDClientServerSocket;
begin
  inherited;
  fSocket:= TClientSocket.Create(nil);
  S:= TJDClientServerSocket.Create(fSocket.Socket);
    S.OnCommand:= Self.ScktCommand;
    S.OnLoginResponse:= Self.ScktLoginResponse;

  fSocket.Socket.Data:= S;
    fSocket.OnConnect:= ScktConnect;
    fSocket.OnDisconnect:= ScktDisconnect;
    fSocket.OnRead:= ScktRead;
    fSocket.OnError:= ScktError;
  fCommands:= TCliCommands.Create(Self);
end;

destructor TJDClientSocket.Destroy;
var
  S: TJDClientServerSocket;
begin
  S:= TJDClientServerSocket(fSocket.Socket.Data);
  S.Free;
  fSocket.Free;
  fCommands.Free;
  inherited;
end;

function TJDClientSocket.GetActive: Bool;
begin
  Result:= fSocket.Active;
end;

function TJDClientSocket.GetHost: String;
begin
  Result:= fSocket.Host;
end;

function TJDClientSocket.GetPort: Integer;
begin
  Result:= fSocket.Port;
end;

function TJDClientSocket.GetSocket: TJDClientServerSocket;
begin
  Result:= TJDClientServerSocket(fSocket.Socket.Data);
end;

procedure TJDClientSocket.ScktCommand(Sender: TObject;
  Socket: TJDClientServerSocket; const Cmd: Integer; const Data: TStrings);
begin
  if assigned(fOnCommand) then
    fOnCommand(Self, Socket, Cmd, Data);
end;
      
procedure TJDClientSocket.ScktConnection(Sender: TObject;
  Socket: TJDClientServerSocket; const OldState,
  NewState: TJDScktConnState);
begin
  if assigned(fOnConnection) then
    fOnConnection(Self, Socket, OldState, NewState);
end;

procedure TJDClientSocket.ScktConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  ScktConnection(Self, Self.GetSocket, csConnecting, csConnected);
  Self.Socket.Login(fUsername, fPassword);
end;

procedure TJDClientSocket.ScktDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  ScktConnection(Self, Self.GetSocket, csDisconnecting, csDisconnected);
end;

procedure TJDClientSocket.ScktError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
var
  EM: String;
  S: TJDClientServerSocket;
begin
  S:= TJDClientServerSocket(Socket.Data);
  EM:= 'Socket Error Code: '+IntToStr(ErrorCode);
  if assigned(fOnError) then
    fOnError(Self, TJDClientServerSocket(Socket.Data), EM, ErrorCode);
  if ErrorCode <> 0 then begin
    raise Exception.Create(EM);
  end;
  ErrorCode:= 0;
end;

procedure TJDClientSocket.ScktRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  S: TJDClientServerSocket;
begin
  S:= TJDClientServerSocket(Socket.Data);
  S.fBuffer:= S.fBuffer + Socket.ReceiveText;
end;
      
procedure TJDClientSocket.ScktLoginResponse(Sender: TObject;
  Socket: TJDClientServerSocket; const Accept: Bool);
begin
  if assigned(fOnLoginResponse) then
    fOnLoginResponse(Self, Socket, Accept);
end;

procedure TJDClientSocket.SetActive(Value: Bool);
begin
  if Value then begin
    if assigned(fOnConnection) then
      fOnConnection(Self, Self.GetSocket, csDisconnected, csConnecting);
  end else begin
    if assigned(fOnConnection) then
      fOnConnection(Self, Self.GetSocket, csConnected, csDisconnecting);
  end;
  fSocket.Active:= Value;
end;

procedure TJDClientSocket.SetHost(Value: String);
begin
  fSocket.Host:= Value;
end;

procedure TJDClientSocket.SetPort(Value: Integer);
begin
  fSocket.Port:= Value;
end;

procedure TJDClientSocket.SetPassword(Value: String);
begin
  fPassword:= Value;
end;

procedure TJDClientSocket.SetUsername(Value: String);
begin
  fUsername:= Value;
end;









{ Command Collections - NOT YET READY }

{ TSvrCommands }

function TSvrCommands.Add: TSvrCommand;
begin
  Result:= inherited Add as TSvrCommand;
end;

constructor TSvrCommands.Create(ASocket: TJDServerSocket);
begin
  inherited Create(TSvrCommand);
  Self.fOwner:= ASocket;
end;

destructor TSvrCommands.Destroy;
begin
  inherited Destroy;
end;

procedure TSvrCommands.DoCommand(const Socket: TJDServerClientSocket;
  const Cmd: Integer; const Data: TStrings);
var
  X: Integer;
  C: TSvrCommand;
  F: Bool;
begin
  F:= False;
  for X:= 0 to Self.Count - 1 do begin
    C:= GetItem(X);
    if C.ID = Cmd then begin
      F:= True;
      if assigned(C.fOnCommand) then
        C.fOnCommand(Self, Socket, Data);
      Break;
    end;
  end;
  if not F then begin
    //Command not found

  end;
end;

function TSvrCommands.GetItem(Index: Integer): TSvrCommand;
begin
  Result:= TSvrCommand(inherited Items[Index]);
end;

procedure TSvrCommands.SetItem(Index: Integer; Value: TSvrCommand);
begin
  inherited Items[Index]:= Value;
end;

{ TSvrCommand }

procedure TSvrCommand.Assign(Source: TPersistent);
begin
  inherited;

end;

constructor TSvrCommand.Create(Collection: TCollection);
begin
  inherited Create(Collection);

end;

destructor TSvrCommand.Destroy;
begin

  inherited Destroy;
end;

function TSvrCommand.GetDisplayName: String;
begin
  Result:= Name;
end;

procedure TSvrCommand.SetID(Value: Integer);
begin
  fID:= Value;
end;

procedure TSvrCommand.SetName(Value: String);
begin
  fName:= Value;
end;

{ TCliCommands }

function TCliCommands.Add: TCliCommand;
begin
  Result:= inherited Add as TCliCommand;
end;

constructor TCliCommands.Create(ASocket: TJDClientSocket);
begin
  inherited Create(TCliCommand);
  Self.fOwner:= ASocket;
end;

destructor TCliCommands.Destroy;
begin
  inherited Destroy;
end;

procedure TCliCommands.DoCommand(const Socket: TJDClientServerSocket;
  const Cmd: Integer; const Data: TStrings);
var
  X: Integer;
  C: TCliCommand;
  F: Bool;
begin
  F:= False;
  for X:= 0 to Self.Count - 1 do begin
    C:= GetItem(X);
    if C.ID = Cmd then begin
      F:= True;
      if assigned(C.fOnCommand) then
        C.fOnCommand(Self, Socket, Data);
      Break;
    end;
  end;
  if not F then begin
    //Command not found

  end;
end;

function TCliCommands.GetItem(Index: Integer): TCliCommand;
begin
  Result:= TCliCommand(inherited Items[Index]);
end;

procedure TCliCommands.SetItem(Index: Integer; Value: TCliCommand);
begin
  inherited Items[Index]:= Value;
end;

{ TCliCommand }

procedure TCliCommand.Assign(Source: TPersistent);
begin
  inherited;

end;

constructor TCliCommand.Create(Collection: TCollection);
begin
  inherited;

end;

destructor TCliCommand.Destroy;
begin

  inherited;
end;

function TCliCommand.GetDisplayName: String;
begin
  Result:= Name;
end;

procedure TCliCommand.SetID(Value: Integer);
begin
  fID:= Value;
end;

procedure TCliCommand.SetName(Value: String);
begin
  fName:= Value;
end;

end. 


Back to Embarcadero: Delphi FAQ Index
Back to Embarcadero: Delphi Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close