labradpacketqueues.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 LabRADPacketQueues;

interface

 uses
  Classes, LabRADDataStructures, SyncObjs, LabRADSocket;

 type
  PLabRADQueueObject = ^TLabRADQueueObject;
  TLabRADQueueObject = record
    Packet: TLabRADPacket;
    Next:   PLabRADQueueObject;
  end;

  TLabRADPacketQueue = class (TThread)
   private
    fFirstPkt:  PLabRADQueueObject;
    fLastPkt:   PLabRADQueueObject;

    fOnPacket:  TLabRADPacketProcedure;

    fNewPacket: TSimpleEvent;
    fProtector: TCriticalSection;

    fRunning:   Boolean;

    procedure SyncCall;

   protected
    procedure Execute; override;

   public
    constructor Create(OnPacket: TLabRADPacketProcedure); reintroduce;
    procedure Enqueue(Packet: TLabRADPacket);
    procedure Terminate; reintroduce;
    procedure Kill;
  end;

implementation

constructor TLabRADPacketQueue.Create(OnPacket: TLabRADPacketProcedure);
begin
  inherited Create(True);
  fFirstPkt:=nil;
  fLastPkt:= nil;
  fNewPacket:= TSimpleEvent.Create;
  fProtector:= TCriticalSection.Create;
  fOnPacket:=OnPacket;
  Resume;
end;

procedure TLabRADPacketQueue.SyncCall;
var QObj: PLabRADQueueObject;
begin
  if assigned(fOnPacket) then begin
    fOnPacket(fFirstPkt.Packet);
    QObj:=fFirstPkt;
    fProtector.Acquire;
      fFirstPkt:=fFirstPkt.Next;
      if fFirstPkt=nil then fLastPkt:=nil;
    fProtector.Release;
    QObj.Packet.Free;
    Dispose(QObj);
  end;
end;

procedure TLabRADPacketQueue.Execute;
begin
  fRunning:=True;
  while not terminated do begin
    fNewPacket.WaitFor($FFFFFFFF);
    fProtector.Acquire;
      if fFirstPkt=fLastPkt then fNewPacket.ResetEvent;
    fProtector.Release;
    if assigned(fFirstPkt) then Synchronize(SyncCall);
  end;

  fProtector.Acquire;
    fRunning:=False;
    while assigned(fFirstPkt) do begin
      fFirstPkt.Packet.Free;
      fLastPkt:=fFirstPkt;
      fFirstPkt:=fFirstPkt.Next;
      Dispose(fLastPkt);
    end;
  fProtector.Release;
end;

procedure TLabRADPacketQueue.Enqueue(Packet: TLabRADPacket);
var QObj: PLabRADQueueObject;
begin
  New(QObj);
  Packet.Keep;
  QObj.Packet:=Packet;
  QObj.Next:=nil;
  fProtector.Acquire;
    if fRunning then begin
      if fFirstPkt=nil then fFirstPkt:=QObj else fLastPkt.Next:=QObj;
      fLastPkt:=QObj;
     end else begin
      QObj.Packet.Free;
      Dispose(QObj);
    end;
  fProtector.Release;
  fNewPacket.SetEvent;
end;

procedure TLabRADPacketQueue.Terminate;
begin
  fOnPacket:=nil;
  inherited;
  fNewPacket.SetEvent;
end;

procedure TLabRADPacketQueue.Kill;
begin
  FreeOnTerminate:=True;
  Terminate;
end;

end.