pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
053b9c89c76cdb2fd23e7a77ad0bf52b51f8da6a
lazarus-ccr/components/flashfiler/sourcelaz/ffdtmsgq.pas
wp_xxyyzz 27aea1d1ad flashfiler: Initial commit (ported by A.Soner). Not working yet (server error). 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5438 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2016-12-07 13:31:59 +00:00

590 lines
19 KiB
ObjectPascal
Raw Blame History

{*********************************************************}
{* FlashFiler: Data message queue class *}
{*********************************************************}
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower FlashFiler
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$I ffdefine.inc}
unit ffdtmsgq;
interface
uses
Windows,
Messages,
SysUtils,
Classes,
ExtCtrls,
ffllbase,
ffllcomm,
ffnetmsg;
type
PffDataMessageNode = ^TffDataMessageNode;
TffDataMessageNode = record
dmnMsg : PffDataMessage;
dmnNext : PFFDataMessageNode;
dmnOffset : TffMemSize;
dmnPrev : PFFDataMessageNode;
dmnProcessing : boolean;
end;
{ This class is used to store partial or completed messages until
a) the message has been received completely and
b) the message is examined by a consumer.
By default, this class is not thread-safe. You can make it thread-safe
by using the BeginRead/EndRead and BeginWrite/EndWrite methods.
}
TffDataMessageQueue = class(TffObject)
protected {private}
FCount : integer;
FNotifyHandle : HWND;
dmqPortal : TffReadWritePortal;
dmqHead : PFFDataMessageNode;
dmqTail : PFFDataMessageNode;
dmqStack : PFFDataMessageNode;
protected
procedure dmqPopStack;
procedure dmqSplitMultiPartMessage;
public
constructor Create;
destructor Destroy; override;
function AddToData(aMsg : longint;
aClientID : TFFClientID;
aRequestID : longint;
aData : pointer;
aDataLen : TffMemSize) : PffDataMessageNode;
{-copy extra data to partially received data message; if the message
is complete then returns a pointer to the node in the queue otherwise
returns nil. }
function Append(aMsg : longint;
aClientID : longint;
aRequestID : longint;
aTimeOut : TffWord32;
aError : longint;
aData : pointer;
aDataLen : TffMemSize;
aTotalLen : TffMemSize) : PffDataMessageNode;
{-append a data message to the queue; a copy of the Data
memory block is made; if the message is complete then
returns a pointer to the node in the queue otherwise
returns nil. }
function BeginRead : TffDataMessageQueue;
{-A thread must call this method to gain read access to the list.
Returns Self as a convenience. }
function BeginWrite : TffDataMessageQueue;
{-A thread must call this method to gain write access to the list.
Returns Self as a convenience.}
procedure EndRead;
{-A thread must call this method when it no longer needs read access
to the list. If it does not call this method, all writers will
be perpetually blocked. }
procedure EndWrite;
{-A thread must call this method when it no longer needs write access
to the list. If it does not call this method, all readers and writers
will be perpetualy blocked. }
function Examine : PFFDataMessage;
{-return the data message at the top of the queue; no pop
occurs, the message remains at the top of the queue}
function IsEmpty : boolean;
{-return true if there are no data messages in the queue}
function SoftPop : PFFDataMessage;
{-destroys the data message at the top of the queue; the data
memory block is _not_ destroyed}
procedure Pop;
{-destroys the data message at the top of the queue; the data
memory block is also freed}
procedure Remove(aNode : PffDataMessageNode;
const freeMessageData : boolean);
{-Use this method to remove a node from the queue. If you want this
method to free the message data then set the freeMessageData
parameter to True. Otherwise it will just dispose of the node
and assume somebody else is freeing the message data. }
procedure SendFrontToBack;
{-sends the data message at the front of the queue to the
back}
property Count : integer
read FCount;
{-number of messages in the queue}
property NotifyHandle : HWND
read FNotifyHandle write FNotifyHandle;
{-handle to notify that there are messages available}
end;
function FFCreateSubMessage(aSubMsg : PffsmHeader;
aMsgID : longint;
aError : longint;
aDataType : TffNetMsgDataType;
aData : pointer;
aDataLen : longint) : PffsmHeader;
{-Create a submessage in a multipart message, return pointer to next
submessage}
implementation
{===helper routines==================================================}
procedure NodeDestroy(aNode : PffDataMessageNode);
begin
with aNode^ do begin
if assigned(dmnMsg) and
assigned(dmnMsg^.dmData) and
(dmnMsg^.dmDataLen > 0) then
FFFreeMem(dmnMsg^.dmData, dmnMsg^.dmDataLen);
FFFreeMem(dmnMsg, sizeOf(TffDataMessage));
end;
FFFreeMem(aNode, sizeOf(TffDataMessageNode));
end;
{--------}
function StackIsEmpty(aStack : PffDataMessageNode) : boolean;
begin
Result := (aStack^.dmnNext = nil);
end;
{--------}
procedure StackPop(aStack : PffDataMessageNode;
var aNode : PffDataMessageNode);
begin
aNode := aStack^.dmnNext;
aStack^.dmnNext := aNode^.dmnNext;
end;
{--------}
procedure StackPush(aStack : PffDataMessageNode;
aNode : PffDataMessageNode);
begin
aNode^.dmnNext := aStack^.dmnNext;
aStack^.dmnNext := aNode;
end;
{--------}
procedure QAppend(aHead : PffDataMessageNode;
var aTail : PffDataMessageNode;
aNode : PffDataMessageNode);
begin
aTail^.dmnNext := aNode;
aNode^.dmnPrev := aTail;
aTail := aNode;
end;
{--------}
procedure QJump(aHead : PffDataMessageNode;
var aTail : PffDataMessageNode;
aNode : PffDataMessageNode);
begin
aNode^.dmnPrev := aHead;
aNode^.dmnNext := aHead^.dmnNext;
if assigned(aHead^.dmnNext) then
aHead^.dmnNext^.dmnPrev := aNode;
aHead^.dmnNext := aNode;
if (aHead = aTail) then
aTail := aNode;
end;
{--------}
procedure QPop(aHead : PffDataMessageNode;
var aTail : PffDataMessageNode;
var aNode : PffDataMessageNode);
begin
aNode := aHead^.dmnNext;
aHead^.dmnNext := aNode^.dmnNext;
if assigned(aHead^.dmnNext) then
aHead^.dmnNext^.dmnPrev := aHead;
if (aNode = aTail) then
aTail := aHead;
end;
{--------}
procedure QRemove(aHead : PffDataMessageNode;
var aTail : PffDataMessageNode;
aNode : PffDataMessageNode);
begin
if assigned(aNode^.dmnPrev) then
aNode^.dmnPrev^.dmnNext := aNode^.dmnNext;
if assigned(aNode^.dmnNext) then
aNode^.dmnNext^.dmnPrev := aNode^.dmnPrev;
if (aNode = aTail) then
aTail := aHead;
end;
{====================================================================}
{===TffDataMsgQueue==================================================}
constructor TffDataMessageQueue.Create;
begin
inherited Create;
{create the head and tail of the queue}
FFGetZeroMem(dmqHead, sizeof(TffDataMessageNode));
{dmqHead^.dmnNext := nil;}
dmqTail := dmqHead;
{FCount := 0;}
{create the stack for partial messages}
FFGetZeroMem(dmqStack, sizeof(TffDataMessageNode));
{dmqStack^.dmnNext := nil;}
{create the lock}
dmqPortal := TffReadWritePortal.Create;
end;
{--------}
destructor TffDataMessageQueue.Destroy;
begin
{pop all messages from main queue, dispose of it}
while not IsEmpty do
Pop;
NodeDestroy(dmqHead);
{pop all messages from partial message stack, dispose of it}
dmqPopStack;
NodeDestroy(dmqStack);
{clean up other stuff}
if assigned(dmqPortal) then
dmqPortal.Free;
inherited Destroy;
end;
{--------}
function TffDataMessageQueue.AddToData(aMsg : longint;
aClientID : TffClientID;
aRequestID : longint;
aData : pointer;
aDataLen : TffMemSize) : PffDataMessageNode;
var
Temp : PffDataMessageNode;
Dad : PffDataMessageNode;
BytesToCopy : longint;
begin
Result := nil;
{find the partially created message in the stack}
Temp := dmqStack^.dmnNext;
Dad := dmqStack;
while (Temp <> nil) and
not ((Temp^.dmnMsg^.dmMsg = aMsg) and
(Temp^.dmnMsg^.dmClientID = aClientID) and
(Temp^.dmnMsg^.dmRequestID = aRequestID)) do begin
Dad := Temp;
Temp := Temp^.dmnNext;
end;
{if it ain't there forget it}
if (Temp = nil) then
Exit;
with Temp^ do begin
{move this next chunk o' data into the data message}
BytesToCopy := FFMinL(aDataLen, dmnMsg^.dmDataLen - dmnOffset);
Move(aData^, PffByteArray(dmnMsg^.dmData)^[dmnOffset], BytesToCopy);
inc(dmnOffset, BytesToCopy);
{if the data message is now complete..}
if (dmnOffset = dmnMsg^.dmDataLen) then begin
{..remove it from the stack}
Dad^.dmnNext := dmnNext;
{add it to the end of the queue}
QAppend(dmqHead, dmqTail, Temp);
Result := Temp;
inc(FCount);
end;
end;
end;
{--------}
function TffDataMessageQueue.Append(aMsg : longint;
aClientID : longint;
aRequestID : longint;
aTimeOut : TffWord32;
aError : longint;
aData : pointer;
aDataLen : TffMemSize;
aTotalLen : TffMemSize) : PffDataMessageNode;
var
Temp : PFFDataMessageNode;
begin
Result := nil;
{get a new node}
FFGetZeroMem(Temp, sizeof(TffDataMessageNode));
FFGetZeroMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
try
{fill the node with data, get the complete data buffer as well}
with Temp^ do begin
if (aTotalLen > 0) then begin
FFGetZeroMem(dmnMsg^.dmData, aTotalLen);
Move(aData^, dmnMsg^.dmData^, aDataLen);
end;
dmnMsg^.dmMsg := aMsg;
dmnMsg^.dmClientID := aClientID;
dmnMsg^.dmRequestId := aRequestID;
dmnMsg^.dmTime := GetTickCount;
dmnMsg^.dmRetryUntil := dmnMsg^.dmTime + aTimeOut;
dmnMsg^.dmErrorCode := aError;
dmnMsg^.dmDataLen := aTotalLen;
dmnOffset := aDataLen;
dmnProcessing := false;
end;
{add this new message to the relevant structure}
{if the data message is complete, add it to the queue}
if (aDataLen = aTotalLen) then begin
QAppend(dmqHead, dmqTail, Temp);
Result := Temp;
inc(FCount);
end
{if the data message is not all there, add it to the stack}
else begin
StackPush(dmqStack, Temp);
end;
except
if assigned(Temp^.dmnMsg^.dmData) then
FFFreeMem(Temp^.dmnMsg^.dmData, aTotalLen);
FFFreeMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
FFFreeMem(Temp, sizeof(TffDataMessageNode));
raise;
end;{try..except}
end;
{--------}
function TffDataMessageQueue.BeginRead : TffDataMessageQueue;
begin
dmqPortal.BeginRead;
Result := Self;
end;
{--------}
function TffDataMessageQueue.BeginWrite : TffDataMessageQueue;
begin
dmqPortal.BeginWrite;
Result := Self;
end;
{--------}
procedure TffDataMessageQueue.EndRead;
begin
dmqPortal.EndRead;
end;
{--------}
procedure TffDataMessageQueue.EndWrite;
begin
dmqPortal.EndWrite;
end;
{--------}
function TffDataMessageQueue.Examine : PFFDataMessage;
begin
if (Count > 0) then begin
if dmqHead^.dmnNext^.dmnProcessing then
Result := nil
else begin
Result := dmqHead^.dmnNext^.dmnMsg;
if (Result^.dmMsg = ffnmMultiPartMessage) then
dmqSplitMultiPartMessage;
Result := dmqHead^.dmnNext^.dmnMsg;
dmqHead^.dmnNext^.dmnProcessing := true;
end
end
else
Result := nil;
end;
{--------}
function TffDataMessageQueue.IsEmpty : boolean;
begin
Result := (FCount = 0);
end;
{--------}
function TffDataMessageQueue.SoftPop : PFFDataMessage;
var
Temp : PFFDataMessageNode;
begin
{nothing to do if there are no messages}
if (Count > 0) then begin
{ Check for multipart messages. }
if (dmqHead^.dmnNext^.dmnMsg^.dmMsg = ffnmMultiPartMessage) then
dmqSplitMultiPartMessage;
{pop the topmost message}
QPop(dmqHead, dmqTail, Temp);
dec(FCount);
Temp^.dmnProcessing := false;
Result := Temp^.dmnMsg;
FFFreeMem(Temp, sizeOf(TffDataMessageNode));
end else
Result := nil;
end;
{--------}
procedure TffDataMessageQueue.Pop;
var
Temp : PFFDataMessageNode;
begin
{nothing to do if there are no messages}
if (Count > 0) then begin
{pop the topmost message}
QPop(dmqHead, dmqTail, Temp);
dec(FCount);
Temp^.dmnProcessing := false;
NodeDestroy(Temp)
end;
end;
{--------}
procedure TffDataMessageQueue.Remove(aNode : PffDataMessageNode;
const freeMessageData : boolean);
begin
QRemove(dmqHead, dmqTail, aNode);
if freeMessageData then
NodeDestroy(aNode)
else
FFFreeMem(aNode, sizeOf(TffDataMessageNode));
dec(FCount);
end;
{--------}
procedure TffDataMessageQueue.dmqPopStack;
var
Temp : PFFDataMessageNode;
begin
while not StackIsEmpty(dmqStack) do begin
StackPop(dmqStack, Temp);
NodeDestroy(Temp);
end;
end;
{--------}
procedure TffDataMessageQueue.SendFrontToBack;
var
Temp : PFFDataMessageNode;
begin
{note: there's nothing to do if there are no data messages in the
queue, similarly if there's only one data message (it's
already *at* the back of the queue)}
if (Count > 1) then begin
Temp := dmqHead^.dmnNext;
dmqHead^.dmnNext := Temp^.dmnNext;
Temp^.dmnNext := nil;
dmqTail^.dmnNext := Temp;
dmqTail := Temp;
end;
end;
{--------}
procedure TffDataMessageQueue.dmqSplitMultiPartMessage;
var
MPMsgNode : PffDataMessageNode;
Stack : PffDataMessageNode;
Temp : PffDataMessageNode;
Offset : longint;
SubMsgHdr : PffsmHeader;
FirstMsg : boolean;
begin
{we assume that the message at the top of the queue is a multipart
message; we need to split this into the relevant messages and add
them to the queue (as queue jumpers)}
{pop off the multipart message}
QPop(dmqHead, dmqTail, MPMsgNode);
dec(FCount);
{create a stack to push the sub-messages onto first; think about it:
we'll be creating messages from the front of the multipart message
to the back and yet we must push them onto the queue as queue
jumpers from the back to the front, so we push them onto an
intermediary stack and then pop stack/queue jump}
FFGetZeroMem(Stack, sizeof(TffDataMessageNode));
try
{prepare for the loop}
FirstMsg := true;
Offset := 0;
SubMsgHdr := PffsmHeader(MPMsgNode^.dmnMsg^.dmData);
{loop through the sub-messages and create a new message for each,
push onto temp stack}
while (Offset < MPMsgNode^.dmnMsg^.dmDataLen) do begin
FFGetZeroMem(Temp, sizeof(TffDataMessageNode));
FFGetZeroMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
try
{fill the node with data, get the complete data buffer as well}
with Temp^, SubMsgHdr^ do begin
dmnMsg^.dmDataLen := smhReplyLen - ffc_SubMsgHeaderSize;
if (dmnMsg^.dmDataLen > 0) then begin
if (smhDataType = nmdByteArray) then begin
FFGetMem(dmnMsg^.dmData, dmnMsg^.dmDataLen);
Move(smhData, dmnMsg^.dmData^, dmnMsg^.dmDataLen);
end
else begin
dmnMsg^.dmData := pointer(TMemoryStream.Create);
TMemoryStream(dmnMsg^.dmData).Write(smhData, dmnMsg^.dmDataLen);
end;
end;
dmnMsg^.dmMsg := smhMsgID;
dmnMsg^.dmClientID := MPMsgNode^.dmnMsg^.dmClientID;
dmnMsg^.dmTime := MPMsgNode^.dmnMsg^.dmTime;
dmnMsg^.dmRetryUntil := MPMsgNode^.dmnMsg^.dmRetryUntil;
dmnMsg^.dmErrorCode := smhErrorCode;
dmnOffset := smhReplyLen;
dmnProcessing := false;
end;
StackPush(Stack, Temp);
except
NodeDestroy(Temp);
raise;
end;
{advance to next submessage}
if FirstMsg and (SubMsgHdr^.smhErrorCode <> 0) then
Break;
FirstMsg := false;
inc(Offset, SubMsgHdr^.smhReplyLen);
SubMsgHdr := PffsmHeader(PAnsiChar(SubMsgHdr) + SubMsgHdr^.smhReplyLen);
end;
{destroy the original multipart message}
NodeDestroy(MPMsgNode);
{transfer messages over from stack to queue}
while not StackIsEmpty(Stack) do begin
StackPop(Stack, Temp);
QJump(dmqHead, dmqTail, Temp);
inc(FCount);
end;
finally
while not StackIsEmpty(Stack) do begin
StackPop(Stack, Temp);
NodeDestroy(Temp);
end;
FFFreeMem(Stack, sizeof(TffDataMessageNode));
end;{try..finally}
end;
{====================================================================}
{===CreateSubMessage=================================================}
function FFCreateSubMessage(aSubMsg : PffsmHeader;
aMsgID : longint;
aError : longint;
aDataType : TffNetMsgDataType;
aData : pointer;
aDataLen : longint) : PffsmHeader;
begin
with aSubMsg^ do begin
smhMsgID := aMsgID;
smhReplyLen := ffc_SubMsgHeaderSize + aDataLen;
smhErrorCode := aError;
smhDataType := aDataType;
if (aData <> @smhData) and (aDataLen <> 0) then
if (aData = nil) then
Move(aData^, smhData, aDataLen)
else
FillChar(smhData, aDataLen, 0);
Result := PffsmHeader(PAnsiChar(aSubMsg) + smhReplyLen);
end;
end;
{====================================================================}
end.
Reference in New Issue View Git Blame Copy Permalink