labradsocket.pas

As science advances, novel experiments are becoming more and more complex, requiring a zoo of contro

{ Copyright (C) 2007 Markus Ansmann
 
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 2 of the License, or
  (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.  }

unit LabRADSocket;

interface

 uses
  Classes, LabRADWSAThreadSocket, LabRADDataStructures, SyncObjs;

 type
  TLabRADPacketCallback  = procedure(Sender: TObject; const Packet: TLabRADPacket; Data: integer) of object;
  TLabRADPacketProcedure = procedure(const Packet: TLabRADPacket) of object;
  TLabRADProcedure       = procedure of object;

  TLabRADRequestInfo = record
    Status:  (osIdle, osWaiting, osNotified, osCompleted);
    Answer:   TLabRADPacket;
    Event:    TSimpleEvent;
    Callback: TLabRADPacketCallback;
    CBData:   integer;
  end;

  TLabRADSocket = class(TCustomWSAThreadSocket)
   private
    fRequests:     array of TLabRADRequestInfo;
    fProtector:    TCriticalSection;
    fPacket:       TLabRADPacket;

    fConnection:   TObject;

    fOnDisconnect: TLabRADProcedure;
    fOnRequest:    TLabRADPacketProcedure;
    fOnMessage:    TLabRADPacketProcedure;
    fOnReply:      TLabRADPacketProcedure;

    procedure DoCallback(Sender: TObject; Data: integer);

   protected
    procedure DoReceive(const Buffer; Len: LongInt); override;
    procedure DoDisconnect;                          override;

   public
    constructor Create(Host: string; Port: Word; CallbackSender: TObject; OnDisconnect: TLabRADProcedure; OnRequest, OnMessage, OnReply: TLabRADPacketProcedure); reintroduce;
    destructor Destroy; override;

    procedure Kill;

    procedure Send(Packet: TLabRADPacket; FreePacket: Boolean);
    function  Request(Packet: TLabRADPacket; FreePacket: Boolean = True; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;       overload;
    procedure Request(Packet: TLabRADPacket; Callback: TLabRADPacketCallback; Data: integer = 0; FreePacket: Boolean = True); overload;
    function  AsyncRequest(Packet: TLabRADPacket; FreePacket: Boolean = True): Integer;
    function  WaitForRequest(ID: Integer; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;
  end;

implementation

uses LabRADCallback;

constructor TLabRADSocket.Create(Host: string; Port: Word; CallbackSender: TObject; OnDisconnect: TLabRADProcedure; OnRequest, OnMessage, OnReply: TLabRADPacketProcedure);
begin
  inherited Create(False, Host, Port);
  fConnection:=CallbackSender;
  fOnDisconnect:=OnDisconnect;
  fOnMessage:=OnMessage;
  fOnRequest:=OnRequest;
  fOnReply:=OnReply;
  fProtector:=TCriticalSection.Create;
  setlength(fRequests, 0);
  fPacket:=nil;
end;

destructor TLabRADSocket.Destroy;
begin
  if assigned(fPacket) then fPacket.Free;
  inherited;
end;

procedure TLabRADSocket.DoReceive(const Buffer; Len: LongInt);
var BufferPtr: PByte;
    Request:   integer;
begin
  if not assigned(fConnection) then exit;
  BufferPtr:=@Buffer;
  while Len>0 do begin
    if not assigned(fPacket) then fPacket:=TLabRADPacket.Create(enLittleEndian);
    if fPacket.Unflatten(BufferPtr, Len) then begin
      // Incoming Request
      if (fPacket.Request>0) and assigned(fOnRequest) then fOnRequest(fPacket);
      // Message
      if (fPacket.Request=0) and assigned(fOnMessage) then fOnMessage(fPacket);
      // Reply
      if fPacket.Request<0 then begin
        fProtector.Acquire;
        Request:=-fPacket.Request-1;
        if (Request>=length(fRequests)) or assigned(fRequests[Request].Answer) or (fRequests[Request].Status<>osWaiting) then begin
          fProtector.Release;
          if assigned(fOnReply) then fOnReply(fPacket);
         end else begin
          fPacket.Keep;
          fRequests[Request].Answer:=fPacket;
          if assigned(fRequests[Request].Event) then begin
            fRequests[Request].Status:=osNotified;
            fRequests[Request].Event.SetEvent;
          end;
          if assigned(fRequests[Request].Callback) then begin
            fRequests[Request].Status:=osCompleted;
            fProtector.Release;
            TLabRADCallback.Create(DoCallback, Request);
           end else begin
            fProtector.Release;
          end;  
        end;
      end;
      fPacket.Free;
      fPacket:=nil;
    end;
  end;
end;

procedure TLabRADSocket.DoDisconnect;
begin
  if assigned(fOnDisconnect) then Synchronize(fOnDisconnect);
end;

procedure TLabRADSocket.DoCallback(Sender: TObject; Data: integer);
var Pkt: TLabRADPacket;
begin
  Pkt:=fRequests[Data].Answer;
  fProtector.Acquire;
    fRequests[Data].Status:=osIdle;
    fRequests[Data].Answer:=nil;
  fProtector.Release;
  fRequests[Data].Callback(fConnection, Pkt, fRequests[Data].CBData);
  Pkt.Free;
end;

procedure TLabRADSocket.Kill;
begin
  fOnDisconnect:=nil;
  fConnection:=nil;
  FreeOnTerminate:=True;
  Disconnect;
end;

procedure TLabRADSocket.Send(Packet: TLabRADPacket; FreePacket: Boolean);
begin
  if not assigned(Packet) then exit;
  Write(Packet.Flatten);
  if FreePacket then Packet.Free;
end;

function TLabRADSocket.Request(Packet: TLabRADPacket; FreePacket: Boolean = True; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;
var a: integer;
    Completion: TSimpleEvent;
begin
  a:=0;
  Completion:=TSimpleEvent.Create;
  fProtector.Acquire;
    while (a<length(fRequests)) and (fRequests[a].Status<>osIdle) do inc(a);
    if a=length(fRequests) then setlength(fRequests, a+1);
    fRequests[a].Status:=osWaiting;
  fProtector.Release;
  fRequests[a].Answer:=nil;
  fRequests[a].Event:=Completion;
  fRequests[a].Callback:=nil;
  Packet.Request:=a+1;
  Send(Packet, FreePacket);
  Completion.WaitFor(Timeout);
  Result:=fRequests[a].Answer;
  fRequests[a].Status:=osIdle;
  Completion.Free;
end;

procedure TLabRADSocket.Request(Packet: TLabRADPacket; Callback: TLabRADPacketCallback; Data: integer = 0; FreePacket: Boolean = True);
var a: integer;
begin
  if not assigned(Callback) then exit;
  a:=0;
  fProtector.Acquire;
    while (a<length(fRequests)) and (fRequests[a].Status<>osIdle) do inc(a);
    if a=length(fRequests) then setlength(fRequests, a+1);
    fRequests[a].Status:=osWaiting;
  fProtector.Release;
  fRequests[a].Answer:=nil;
  fRequests[a].Event:=nil;
  fRequests[a].Callback:=Callback;
  fRequests[a].CBData:=Data;
  Packet.Request:=a+1;
  Send(Packet, FreePacket);
end;

function TLabRADSocket.AsyncRequest(Packet: TLabRADPacket; FreePacket: Boolean = True): Integer;
var Completion: TSimpleEvent;
begin
  Result:=0;
  Completion:=TSimpleEvent.Create;
  fProtector.Acquire;
    while (Result<length(fRequests)) and (fRequests[Result].Status<>osIdle) do inc(Result);
    if Result=length(fRequests) then setlength(fRequests, Result+1);
    fRequests[Result].Status:=osWaiting;
  fProtector.Release;
  fRequests[Result].Answer:=nil;
  fRequests[Result].Event:=Completion;
  fRequests[Result].Callback:=nil;
  fRequests[Result].CBData:=0;
  inc(Result);
  Packet.Request:=Result;
  Send(Packet, FreePacket);
end;

function TLabRADSocket.WaitForRequest(ID: Integer; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;
var Completion: TSimpleEvent;
begin
  Result:=nil;
  dec(ID);
  if (ID<0) or (ID>=length(fRequests)) then exit; // BARF
  Completion:=nil;
  if fRequests[ID].Status in [osWaiting, osNotified] then Completion:=fRequests[ID].Event;
  if not assigned(Completion) then exit;
  Completion.WaitFor(Timeout);
  Result:=fRequests[ID].Answer;
  fRequests[ID].Status:=osIdle;
  Completion.Free;
end;

end.