{*********************************************************} {* FlashFiler: Base unit for transports & cmd handlers *} {*********************************************************} (* ***** 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 ffllcomm; interface uses classes, forms, windows, ffllbase, ffllcomp, fflleng, fflllog, ffllreq, ffllthrd, ffnetmsg; type { TffDataMessage contains the message information passed from a transport to a server command handler, plugin command handler, or engine manager. } PffDataMessage = ^TffDataMessage; TffDataMessage = record dmMsg : Longint; { the unique ID identifying the msg type } dmClientID : TffClientID; { the client sending the message } dmRequestID : Longint; { the unique ID of the request } dmTime : TffWord32; { the time the message was received } dmRetryUntil : TffWord32; dmErrorCode : TffResult; dmData : pointer; dmDataLen : TffMemSize; end; { The following options may be used to control logging in the transports. Values: fftpLogErrors - Write errors to the event log. fftpLogRequests - Write requests to the event log. If in Send mode then logs all sent requests. If in Listen mode then logs all received requests. fftpLogReplies - If in Send mode then logs all received replies. If in Listen mode then logs all sent replies. } TffTransportLogOption = (fftpLogErrors, fftpLogRequests, fftpLogReplies); TffTransportLogOptions = set of TffTransportLogOption; { A transport will send a request to the server. When the reply is received, the transport must notify the object submitting the request. To be notified, the object submitting the request must define a procedure of type TffReplyCallback. Parameters passed to this procedure are as follows: @param msgID The message identifier returned by the server. @param errorCode The error code returned by the server. @param replyData The data returned by the server. @param replyDataLen The length of the data returned by the server. @param replyType The format of the data: byteArray (e.g., packed record) or stream. @param replyCookie The replyCookie parameter originally supplied to the TffBaseTransport.Request method. The meaning of this parameter is specific to the object submitting the request. For the TffRemoteServerEngine, this is a pointer to TffProxyClient. } TffReplyCallback = procedure(msgID : Longint; errorCode : TffResult; replyData : pointer; replyDataLen : Longint; replyCookie : Longint); TffBasePluginCommandHandler = class; { forward declaration } TffBaseEngineManager = class; { forward declaration } TffBaseTransport = class; { forward declaration } { This is the base class for the command handler. A command handler receives requests from a transport and routes them to a destination. The base class supports routing of commands to plugins that have themselves with the command handler. } TffBaseCommandHandler = class(TffStateComponent) protected {private} FManager : TffBaseEngineManager; {-The engine manager that may receive shutdown and startup requests through this command handler. Note that the command handler doesn't really know about shutdown and startup requests. The engine manager is like a special plugin. If a plugin does not handle the message, it is routed to the engine manager. The engine manager may or may not handle the message. } FPlugins : TffThreadList; {-The list of plugins that reference the command handler. } FSkipInitial : Boolean; {!!.01} {-Internal state that reflects whether the Engine Manager Wizard has created this component as a proxy (true) or not} FTransports : TffThreadList; {-The list of transports that reference the command handler. } protected procedure bchFreeMsg(msg : PffDataMessage); virtual; { When a transport passes off a request to the command handler, it becomes the command handler's responsibility to free the message data associated with the request. This method frees the TffDataMessage structure as well as the message content contained by TffDataMessage. Command handlers should call this method, or find some other way of freeing the memory, once a request has been processed. } function bchGetTransport(aInx : Integer) : TffBaseTransport; virtual; { Retrieves a transport from the command handler's list.} function bchGetTransportCount : Longint; virtual; { Retrieves the number of transports owned by this command handler.} procedure bchSetEngineManager(aManager : TffBaseEngineManager); virtual; {-Used to set the manager to which messages may be routed. } procedure scSetState(const aState : TffState); override; { This method is called when the command handler's state changes. This implementation sets the state of the associated transports. } property SkipInitial : Boolean {BEGIN !!.01} read FSkipInitial write FSkipInitial; { This property is used by the engine manager wizard. It's purpose is to keep the bchSetEngineManger routine from generating an access violation when the expert creates a new engine manager } {END !!.01} public constructor Create(AOwner : TComponent); override; destructor Destroy; override; procedure FFAddDependent(ADependent : TffComponent); override; {!!.11} procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11} procedure Process(Msg : PffDataMessage); virtual; { This method is called by the transport in order to process a message. The default implementation forwards the message to the registered plugin(s). If a plugin does not handle the message and an engine manager has been specified, the message is forwarded to the engine manager. If the message is not handled, a reply is sent to the client stating the message is unrecognized. } property TransportCount : Longint read bchGetTransportCount; { The number of transports passing requests to this command handler.} property Transports[aInx : Longint] : TffBaseTransport read bchGetTransport; { Use this property to access the transports connected to the command handler. } published property EngineManager : TffBaseEngineManager read FManager write bchSetEngineManager; end; {This is the base class for a plugin engine. All plugin engines inherit from this class. A client application may interface with a plugin engine via direct calls to the plugin engine or via calls to a remote plugin engine. To create a custom plugin engine, you must do the following: 1. Create an abstract plugin engine that defines the interface of your engine. 2. From the abstract plugin engine, create a real plugin engine that implements the engine interface. 3. From the abstract plugin engine, create a remote plugin engine. Assign it a property Transport of type TffBaseTransport. The remote plugin engine is placed on the client application and transfers the commands to a listener on the server. The commands are routed from the listener to a plugin command handler to your real plugin engine. 4. From the abstract TffBasePluginCommandHandler class, create a command handler for the plugin. } TffBasePluginEngine = class(TffStateComponent) private FPluginCmdHandlers : TffThreadList; {-The list of plugin command handlers registered with this engine. } protected procedure scSetState(const aState : TffState); override; {-Sets the state of the engine. This will also set the state of any associated plugin command handlers. } public constructor Create(aOwner : TComponent); override; destructor Destroy; override; procedure FFAddDependent(ADependent : TffComponent); override; {!!.11} procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11} end; {This is the base class for a plugin command handler. A plugin command handler receives requests through a standard command handler. It passes the requests on to a plugin engine. As a plugin designer, you will need to create a class that inherits from TffBasePluginCommandHandler. The class must recognize the messages to be handled by your real plugin engine. Note: Descendants of TffBaseCommandHandler must free the message data in their overridden Process methods. However, this does not apply to plugin command handlers. That is because they are typically passed a request from TffBaseCommandHandler.Process and TffBaseCommandHandler.Process handles the freeing of the message data on behalf of the plugin command handlers. } TffBasePluginCommandHandler = class(TffStateComponent) protected FCmdHandler : TffBaseCommandHandler; FPluginEngine : TffBasePluginEngine; {-The plugin engine receiving commands through this plugin. } procedure pchSetCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual; {-The command handler forwarding commands to this plugin command handler. } procedure pchSetPluginEngine(anEngine : TffBasePluginEngine); virtual; {-The plugin engine receiving commands through this plugin. This method calls TffBasePluginEngine.AddCmdHandler. Because a plugin command handler is associated with a specific plugin engine class, the plugin designer must specify his own PluginEngine property. The custom PluginEngine property should eventually call this SetPluginEngine method. } public constructor Create(aOwner : TComponent); override; destructor Destroy; override; procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11} const AData : TffWord32); override; {!!.11} procedure Process(Msg : PffDataMessage; var handled : boolean); virtual; abstract; { This method is called by a command handler when it has a message that may be processed by a plugin. If the plugin handles the message, set handled to True. } published property CommandHandler : TffBaseCommandHandler read FCmdHandler write pchSetCmdHandler; { The command handler passing requests to this plugin command handler. } end; {The engine manager is a type of data module that contains one or more engines (e.g., TffBasePluginEngine or TffBaseServerEngine) and controls their startup and shutdown. The manager can be controlled by the GUI of its parent application or remotely via startup and shutdown commands received through a command handler. } TffBaseEngineManager = class(TDataModule) private FCmdHandlers : TffThreadList; {-The command handlers registered with the engine manager. } protected procedure bemAddCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual; {-When a command handler references an engine manager, it registers itself with the engine manager via this method. } function bemGetCmdHandler(aInx : Longint) : TffBaseCommandHandler; virtual; {-Returns a specified command handler registered with the engine manager. } function bemGetCmdHandlerCount : Longint; {-Returns the number of command handlers routing requests to the engine manager. } procedure bemRemoveCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual; {-When a command handler no longer references an engine manager, it unregisters itself with the engine manager via this method. } public constructor Create(aOwner : TComponent); override; destructor Destroy; override; procedure Process(msg : PffDataMessage; var handled : boolean); virtual; abstract; { The command handler calls this method when it has a message that is not handled by another engine. } procedure Restart; virtual; abstract; { Use this method to stop and restart all engines and their associated components. } procedure Shutdown; virtual; abstract; { Use this method to stop all engines and their associated components. Because the associated components (i.e., the manager's command handler) are shutdown, the manager may not be instructed to restart. The manager must be instructed to restart from the server GUI or the computer must be restarted. } procedure Startup; virtual; abstract; { Use this method to start all engines and their associated components. } procedure Stop; virtual; abstract; { Use this method to stop all engines but leave their associated components in an active state. This allows a Startup command to be received from a remote client. } public property CmdHandler[aInx : Longint] : TffBaseCommandHandler read bemGetCmdHandler; property CmdHandlerCount : Longint read bemGetCmdHandlerCount; end; TffAddClientEvent = procedure(Listener : TffBaseTransport; const userID : TffName; const timeout : Longint; const clientVersion : Longint; var passwordHash : TffWord32; var aClientID : TffClientID; var errorCode : TffResult; var isSecure : boolean; var serverVersion : Longint) of object; { This is the type of event raised when a listening transport requires a new clientID in order to establish a new client connection. Inputs: UserID - Provided by the client application and assumed to be the login ID of an existing user. Timeout - The timeout value associated with client-level operations. ClientVersion - The client's version number. The server should use this to determine if the client is compatible. Outputs: Passwordhash - The user's encrypted password, supplied by the event handler. In situations where a secure connection is to be established, this hash can be used to encrypt the outgoing communications. aClientID - The unique identifier assigned to the client. The client must supply this ID with each subsequent request sent to th server. If the value zero is returned for this parameter then it is assumed a failure occurred. errorCode - If an error occurred then the error code is returned in this parameter. isSecure - If True then the server requires this connection to be encrypted. If False then no encryption is required. serverVersion - The server's version number. Gives the client the opportunity to determine if any compatibility issues are present. } TffConnectionLostEvent = procedure(Sender : TffBaseTransport; aClientID : TffClientID) of object; { This is the type of event raised when a client connection is unexpectedly terminated by the other end of the connection. aClientID is the unique client identifier returned by EstablishConnection. } TffRemoveClientEvent = procedure(Listener : TffBaseTransport; const aClientID : TffClientID; var errorCode : TffResult) of object; { This is the type of event raised when a listening transport needs to disconnect a client. AClientID is the unique client identifier returned by TffAddClientEvent when the connection was initially established. errorCode will be zero if the client was successfully removed or a non-zero value if an error occurred. } TffTransportMode = (fftmSend, fftmListen); { The valid modes for a transport. Values: fftmSend - The transport sends messages. fftmListen - The transport listens for messages. } { This is the base transport class. It includes support for sending and receiving requests. A transport that receives requests is referred to as a listener. A transport that sends requests is to as a sender. To use a transport, you must do the following: 1. Instantiate the transport. 2. Set the ServerName property. 3. Set the State to ffesInitializing, ffesStarting, and then ffesStarted. This normally occurs when a server engine starts up and sets the states of the command handlers connected to the server. Each command handler then passes on the state to the transports connected to the command handler. 4. Obtain a clientID by calling the EstablishConnection method. 5. Submit requests to the transport using either the Post or Request methods. You cannot call Post or Request unless you have a valid clientID. 6. When you have finished using the transport, call TerminateConnection for each established connection. 7. After terminating the connections, set the State to ffesShuttingDown and then ffesInactive. } TffBaseTransport = class(TffStateComponent) protected {private} { We need a scheme in the class to store potential properties, and then apply them. To do this we add BeginUpdate, and EndUpdate methods to the class. When BeginUpdate is called the _* fields will be set to match their associated fields. While updating, property set methods store their values in _* Fields. When EndUpdate is called the _* values are copied into their associated fields. BeginUpdate, and EndUpdate are reference counted. IOW if BeginUpdate is called twice, then EndUpdate must also be called twice.} FCmdHandler : TffBaseCommandHandler; _FCmdHandler : TffBaseCommandHandler; {-The command handler to which requests are routed. } FEnabled : boolean; _FEnabled : boolean; {-If True then the transport can send/receive messages. Note that it will send/receive only if enabled and state = ffesStarted. } _FLogEnabled : Boolean; {-If True then event logging is enabled. Defaults to False. } FLogOptions : TffTransportLogOptions; _FLogOptions : TffTransportLogOptions; {-The type of logging to be performed. } FMode : TffTransportMode; _FMode : TffTransportMode; {-The current mode of the transport. } FMsgCount : Longint; {-The number of messages processed by this transport. } FOnAddClient : TffAddClientEvent; {-Event handler to call when need to establish a new client. } FOnConnectionLost : TffConnectionLostEvent; {-Handler for OnConnectionLost. } FOnRemoveClient : TffRemoveClientEvent; {-Event handler to call when need to remove an existing client. } _FOnStateChange : TNotifyEvent; {-Event handler to call when the transport's state has changed. } FRespondToBroadcasts : boolean; _FRespondToBroadcasts : Boolean; {-If True and FListen := True then this transport will respond to broadcasts for active listeners. } FServerName : TffNetAddress; _FServerName : TffNetAddress; {-The name of the server to which this transport connects. } FServerNameRequired : boolean; {-This variable influences the btCheckServerName method. If set to True then a servername is required. There may be some transports where a servername is not required (e.g., Single User Protocol in TffLegacyTransport) in which case those transports should set this variable to False. } _FState : TffState; {-The state of the transport. } FUpdateCount : Integer; { Update ReferenceCount field } protected { Property access methods } function btGetCmdHandler : TffBaseCommandHandler; virtual; procedure btSetCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual; {-The command handler forwarding commands to this plugin command handler. } function btGetEnabled : boolean; virtual; procedure btSetEnabled(const aEnabled : boolean); virtual; {-Whether or not the transport is enabled. } function btGetLogOptions : TffTransportLogOptions; virtual; procedure btSetLogOptions(const anOptions : TffTransportLogOptions); virtual; {-The type of information to be logged. } function btGetMode : TffTransportMode; virtual; procedure btSetMode(const aMode : TffTransportMode); virtual; {-Whether or not the transport is to listen for requests. For a Client set Mode to fftmSend. For a Server, set Mode to fftmListen. } procedure btSetOnStateChange(const aHandler : TNotifyEvent); virtual; {-Event raised when transport's state changes. } function btGetRespondToBroadcasts : Boolean; virtual; procedure btSetRespondToBroadcasts(const aRespond : Boolean); virtual; {-Whether or not a transport in server mode (i.e., Listen = True) is to respond to broadcast messages. } function btGetServerName : string; virtual; {!!.10} procedure btSetServername(const aServername : string); virtual; {!!.10} {-For a transport in Listen mode (i.e., Server), the server's name. For a transport in Send mode (i.e., Client), the name of the server to which the client is to send information. The implementation for this class does not perform any validation. Transport subclasses should perform their own validation. } { Other protected methods } procedure btCheckListener; { When setting certain properties or calling certain methods, this method is called to ensure the transport is in listening mode. If the transport is not listening then this method raises exception ffsce_MustBeListening. } procedure btCheckSender; { When setting certain properties or calling certain methods, this method is called to ensure the transport is in sending mode. If the transport is not a sender then this method raises exception ffsce_MustBeSender. } procedure btCheckServerName; { Verifies the servername has been specified. } function btGetConnectionID(const anIndex : Longint) : TffClientID; virtual; abstract; { Used to obtain the IDs of the protocol's connections. Handy for when a server wants to send messages to one or more client connections. } procedure btInternalReply(msgID : Longint; errorCode : TffResult; replyData : pointer; replyDataLen : Longint); virtual; { This method is called from TffBaseTransport.Reply. It must send the reply to the client. The base implementation verifies the transport is started and is listening. } procedure btStoreSelfInThreadvar; virtual; {-This method stores Self in ffitvTransport. This is isolated into its own function because an inherited class may need to Reply to a message (e.g., add client) before calling the inherited Process method where the setting of ffitvTransport is normally done. } procedure btBeginUpdatePrim; virtual; procedure btEndUpdatePrim; virtual; procedure lcSetLogEnabled(const aEnabled : boolean); override; property UpdateCount : Integer read FUpdateCount; {-This represents the current updating state. If updating is taking place this value will be > 0 } public constructor Create(aOwner : TComponent); override; destructor Destroy; override; procedure BeginUpdate; { redirect property set routines to _* fields } procedure CancelUpdate; { cancel the property changes. } procedure EndUpdate; { Apply the new properties. } procedure AutoConnectionLost(Sender : TffBaseTransport; aClientID : TffClientID); function ConnectionCount : Longint; virtual; abstract; { Returns the number of established connections. For a sender (i.e., client), this will be the number of connections to the remote server. For a listener (i.e., server), this will be the number of connections establshed by remote clients. } class function CurrentTransport : TffBaseTransport; { Returns the transport used by the current thread. In other words, the transport pointed to by ffitvTransportID. } function EstablishConnection(const aUserName : TffName; aPasswordHash : integer; timeOut : Longint; var aClientID : TffClientID ) : TffResult; virtual; abstract; { Use this method to establish a connection with the server. If the return code is DBIERR_NONE then aClientID will contain the clientID supplied by the server. This clientID must be used in all subsequent requests to the server. } function GetName : string; virtual; abstract; { Retrieves the transport's name. Must be specified for each subclass. Note that this is not a class function because we want the legacy transport to be able to return a name based upon the selected protocol. } procedure GetServerNames(aList : TStrings; const timeout : Longint); virtual; abstract; { Returns the list of servers available via this transport. Timeout is the number of milliseconds in which all responses must be received. } function IsConnected : boolean; virtual; abstract; { This method returns True if the transport is connected to a server. } procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11} const AData : TffWord32); override; {!!.11} procedure Post(transportID : Longint; clientID : TffClientID; msgID : Longint; requestData : pointer; requestDataLen : Longint; timeout : Longint; replyMode : TffReplyModeType); virtual; abstract; { Call this method in order to submit a request to the transport. The request will be routed to the remote transport. This method does not expect a reply and will return as soon as the request is handed off. This method may be called when in Send or Listen mode. Parameters are as follows: @param transportID - For use by future protocols. @param clientID - The ID of the client submitting the request. This must be the clientID originally supplied by the server or it may be zero for unsecured calls (e.g., initially asking for a connection to the server). @param msgID - The type of message being sent. @param requestData - Pointer to a data buffer containing the message data. requestDataLen - The length of requestData. timeout - The number of milliseconds in which the operation must complete. replyMode - Indicates whether or not the request should wait for the request to be sent to the server. } procedure Process(Msg : PffDataMessage); virtual; { When in listening mode, this method is called when a message is to be processed by the transport. } class procedure Reply(msgID : Longint; errorCode : TffResult; replyData : pointer; replyDataLen : Longint); virtual; { When acting as a listener, this method is called to send a reply back to a client. The base implementation stores a pointer to Self in the threadvar fftviTransportID. This allows the command handler to call TffBaseTransport.Reply(...) without having to know which transport told it to process the command. Implementation: fftviTransport.InternalReply(...) } procedure Request(transportID : Longint; clientID : TffClientID; msgID : Longint; timeout : Longint; requestData : pointer; requestDataLen : Longint; replyCallback : TffReplyCallback; replyCookie : Longint); virtual; abstract; { When the transport is in Send mode, call this method in order to submit a request to the transport. Parameters are as follows: @param transportID - For use by future transports. @param clientID - The ID of the client submitting the request. This must be the clientID originally supplied by the server or it may be zero for unsecured calls (e.g., initially asking for a connection to the server). @param msgID - The type of message being sent. @param timeout - The number of milliseconds in which a reply must be received from the server. @param requestData - Pointer to a data buffer containing the message data. @param requestDataLen - The length of requestData. @param replyCallback - The procedure to be called when the reply has been received from the server. @param replyCookie - Whatever the calling object wants it to be. This parameter is supplied to the replyCallback. } procedure ResetMsgCount; virtual; { Resets the MsgCount property to zero. } function Sleep(const timeOut : Longint) : boolean; virtual; { Use this function to have the client disconnect from the server but leave the server-side resources intact so that the client may reconnect at a later time. Returns True if the Sleep was successful or False if the Sleep failed or is not supported. Note that any activity on the client side will cause the connection to be re-opened. } function Supported : boolean; virtual; { Returns True if the transport is supported on this workstation otherwise returns False. } procedure TerminateConnection(const aClientID : TffClientID; const timeout : Longint); virtual; abstract; { Use this method to terminate a connection with the server. aClientID is the clientID originally returned in the call to EstablishConnection. } procedure Work; virtual; abstract; { Based upon the transport's mode, this method tells the transport to perform some work: 1. When in sending mode, start sending requests and processing replies. 2. When in listening mode, start listening for requests and passing requests off to the command handler. } property ConnectionIDs[const anIndex : Longint] : TffClientID read btGetConnectionID; { Use this to access the client IDs of a listening transport. } published property CommandHandler : TffBaseCommandHandler read btGetCmdHandler write btSetCmdHandler; { The command handler to which requests are routed. } property Enabled : boolean read btGetEnabled write btSetEnabled default False; { Use this property to control whether or not the transport can send or receive messages as per its Mode property. If this property is set to True, the State property must still be set to ffesStarted before the transport will actually send or receive messages. } property EventLogOptions : TffTransportLogOptions read btGetLogOptions write btSetLogOptions default []; {!!.01} { The type of logging to be performed. Applicable only when EventLogEnabled = True and EventLog is assigned. } property Mode : TffTransportMode read btGetMode write btSetMode default fftmSend; { Use this property to determine whether the transport should be used for sending requests or listening for requests. } property MsgCount : Longint read FMsgCount; { The number of messages processed by this transport. } property OnAddClient : TffAddClientEvent read FOnAddClient write FOnAddClient; { The handler for the event raised when a listening transport must establish a new connection. } property OnConnectionLost : TffConnectionLostEvent read FOnConnectionLost write FOnConnectionLost; { This event is raised when the other end of the connection unexpectedly hangs up on the transport. } property OnRemoveClient : TffRemoveClientEvent read FOnRemoveClient write FOnRemoveClient; { The handler for the event raised when a listening transport must disconnect an existing client. } property OnStateChange : TNotifyEvent read scOnStateChange write btSetOnStateChange; { Raised when the transport's state changes. } property RespondToBroadcasts : boolean read btGetRespondToBroadcasts write btSetRespondToBroadcasts default False; { Use this property to indicate wheher or not a listener should respond to a broadcast for active listeners. } property ServerName : string {!!.10} read btGetServerName write btSetServerName; { The name and address of the server to be accessed by this transport. } end; { This class provides support for protocols requiring a thread pool. } TffThreadedTransport = class(TffBaseTransport) protected {private} FThreadPool : TffThreadPool; {-The thread pool providing threads to this transport. } FUnsentRequestQueue : TffThreadQueue; {-When in Send mode and a client submits a request, the transport creates a TffRequest object and places it in this queue.} FWaitingForReplyList : TffThreadList; {-When a request has been submitted to the server, the TffRequest object is appended to this list. } protected procedure SetThreadPool(aPool : TffThreadPool); virtual; {-Sets the thread pool to be used by this transport. } procedure tpInternalRequest(aRequest : TffRequest; timeout : Longint; aCookie : HWND); virtual; {-Internal method for sending a request. aRequest is the request to send. timeout is the number of milliseconds the transport should wait for a reply to the request. aCookie can be used as the transport sees fit. } procedure tpLogReq(aRequest : TffRequest; const prefix : string); virtual; { Write a request to the event log. } procedure tpLogReq2(const aPrefix : string; const aRequestID : Longint; const aClientID : TffClientID; const aMsgID : Longint; const aData : pointer; const aDataLen : Longint; const aTimeout : Longint); { Write a reply to the event log. Used by a transport in Listen mode. } procedure tpLogReqMisc(const aMsg : string); virtual; { Write a request-related string to the event log. } procedure tpLogReply(aRequest : TffRequest); virtual; { Write a reply to the event log. } procedure tpLogReply2(const aRequestID : Longint; const aClientID : TffClientID; const aMsgID : Longint; const aDataLen : Longint; const anError : TffResult); { Write a reply to the event log. Used by a transport in Listen mode. } public constructor Create(aOwner : TComponent); override; destructor Destroy; override; procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11} const AData : TffWord32); override; {!!.11} {-Called when the thread pool we're referencing has been operated upon. We need to catch the case where the thread pool has been removed from the form. } procedure Post(transportID : Longint; clientID : TffClientID; msgID : Longint; requestData : pointer; requestDataLen : Longint; timeout : Longint; replyMode : TffReplyModeType); override; { This method is called when a request is to be sent but a reply is not needed. This implementation does the following: 1. Creates a TffRequest instance. 2. Assigns the request data to the TffRequest instance. 3. Adds the TffRequest instance to the Unsent Request Queue. 4. Exits from this method since a reply is not needed. } procedure Request(transportID : Longint; clientID : TffClientID; msgID : Longint; timeout : Longint; requestData : pointer; requestDataLen : Longint; replyCallback : TffReplyCallback; replyCookie : Longint); override; { This method is called when a proxy client submits a request to the transport. This implementation does the following: 1. Creates a TffRequest instance. 2. Assigns the request data to the TffRequest instance. 3. Adds the TffRequest instance to the Unsent Request Queue. 4. Calls TffRequest.WaitForReply. At this point, the calling thread is blocked until a reply is received or a timeout occurs. 5. When TffRequest.WaitForReply returns, the reply is on the TffRequest object. This method calls replyCallback, passing the message ID, error code, reply data, length, and cookie. 6. The TffRequest instance is freed. Could also be recycled to improve performance. In either case, the TffRequest instance frees the memory occupied by the reply. } published property ThreadPool : TffThreadPool read FThreadPool write SetThreadPool; { The thread pool providing worker threads for this protocol. } end; const ffc_Data = 'Data'; ffc_ReqAborted = '*** Req %d aborted, Clnt %d, Err %d, Tmout %d'; ffc_ReqLogString = '%s: %d, Clnt %d, Msg %d, Len %d, Tmout %d'; ffc_ReplyLogString = 'Reply: %d, Clnt %d, Msg %d, Len %d, Err %d'; ffc_SendErr = 'Snd Err %d: %s, Req %d, Clnt %d, Msg %d, Len %d, Tmout %d'; ffcl_RequestLatencyAdjustment : Longint = 500; {-The number of additional milliseconds to wait for a reply. } implementation {Begin !!.03} uses ffSrBase, {!!.13} SysUtils; {End !!.03} {$I ffconst.inc} {$I ffllscst.inc} { The following thread variable is an optimization for the TffBaseTransport. A rule is that the thread that processes a request must be the thread to send a reply back to the client. Since the reply is initiated outside the transport, we don't want to pass a lot of information about the connection. Our solution is to store a pointer to the transport issuing the request in a threadvar. This allows a command handler to call TffBaseTransport.Reply without having to know the originating Transport. } threadvar ffitvTransportID : Longint; { Pointer to the transport that originally passed the request to the command handler. } {===TffBaseCommandHandler============================================} constructor TffBaseCommandHandler.Create(aOwner : TComponent); begin inherited Create(aOwner); FManager := nil; FPlugins := TffThreadList.Create; FTransports := TffThreadList.Create; end; {--------} destructor TffBaseCommandHandler.Destroy; begin { Make sure we have a clean shutdown. } if scState <> ffesInactive then scSetState(ffesInactive); FFNotifyDependents(ffn_Destroy); {!!.11} FPlugins.Free; {!!.11} FTransports.Free; {!!.11} if assigned(FManager) and (not FSkipInitial) then {!!.01} FManager.bemRemoveCmdHandler(Self); inherited Destroy; end; {--------} procedure TffBaseCommandHandler.bchFreeMsg(msg : PffDataMessage); begin if Msg^.dmDataLen > 0 then FFFreeMem(Msg^.dmData, Msg^.dmDataLen); FFFreeMem(Msg, SizeOf(TffDataMessage)); end; {--------} function TffBaseCommandHandler.bchGetTransportCount: Integer; begin Result := FTransports.Count; end; {--------} function TffBaseCommandHandler.bchGetTransport(aInx: Integer): TffBaseTransport; begin Result := TffBaseTransport(TffIntListItem(FTransports[aInx]).KeyAsInt); end; {--------} procedure TffBaseCommandHandler.bchSetEngineManager(aManager : TffBaseEngineManager); {-Used to set the manager to which messages may be routed. } begin if FSkipInitial then begin {BEGIN !!.01} FManager := aManager; Exit; end; {END !!.01} if assigned(FManager) then FManager.bemRemoveCmdHandler(Self); if assigned(aManager) then aManager.bemAddCmdHandler(Self); end; {Begin !!.11} {--------} procedure TffBaseCommandHandler.FFAddDependent(ADependent : TffComponent); var aListItem : TffIntListItem; begin inherited; if ADependent is TffBaseTransport then begin aListItem := TffIntListItem.Create(Longint(ADependent)); with FTransports.BeginWrite do try Insert(aListItem); finally EndWrite; end; end else if ADependent is TffBasePluginCommandHandler then begin aListItem := TffIntListItem.Create(Longint(ADependent)); with FPlugins.BeginWrite do try Insert(aListItem); finally EndWrite; end; end; end; {--------} procedure TffBaseCommandHandler.FFRemoveDependent(ADependent : TffComponent); begin inherited; if ADependent is TffBaseTransport then with FTransports.BeginWrite do try Delete(Longint(ADependent)); finally EndWrite; end else if ADependent is TffBasePluginCommandHandler then with FPlugins.BeginWrite do try Delete(Longint(ADependent)); finally EndWrite; end; end; {End !!.11} {--------} procedure TffBaseCommandHandler.Process(Msg : PffDataMessage); var aPlugin : TffBasePluginCommandHandler; Handled : boolean; anIndex : Longint; begin Handled := False; { See if a plugin recognizes the message. } if assigned(FPlugins) then with FPlugins.BeginRead do try for anIndex := 0 to pred(Count) do begin aPlugin := TffBasePluginCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt); aPlugin.Process(Msg, Handled); if Handled then break; end; finally EndRead; end; { If no plugin recognizes the message and we have an engine manager then see if the engine manager will handle the message. } if not Handled and assigned(FManager) then FManager.Process(Msg, Handled); { If the message has not been handled by this point, tell the client this is an unrecognized message. Note that we are calling a TffBaseTransport class function which gets the reply to the correct transport. } {Begin !!.13} if not Handled then begin lcLog(Format(ffStrResServer[ffErrUnknownMsg], [Msg.dmMsg])); TffBaseTransport.Reply(Msg.dmMsg, ffErrUnknownMsg, nil, 0); end; {End !!.13} end; {--------} procedure TffBaseCommandHandler.scSetState(const aState : TffState); var aTransport : TffBaseTransport; anIndex : Longint; NextState : TffState; OldState : TffState; begin if (aState = scState) or {!!.01} (aState in [ffesStopping, ffesStopped]) then exit; {!!.01} OldState := scState; aTransport := nil; try if assigned(FTransports) then with FTransports.BeginRead do try while scState <> aState do begin { Based upon our current state & the target state, get the next state. } NextState := ffStateDiagram[scState, aState]; { Move all transports to the specified state. } try for anIndex := pred(Count) downto 0 do begin aTransport := TffBaseTransport(TffIntListItem(Items[anIndex]).KeyAsInt); if aTransport.Enabled then aTransport.scSetState(NextState); end; except on E:Exception do begin { If a transport raises an exception, disable the transport. The server must be restarted before we try this transport again. } lcLog(format('Transport state failure: %s', [aTransport.GetName, E.message])); try aTransport.State := ffesFailed; aTransport.Enabled := False; except { Eat any exception raised by changing the state. } end; end; end; scState := NextState; { Call the appropriate internal method for this state. } case NextState of ffesInactive : scShutdown; ffesInitializing : scInitialize; ffesStarting : scStartup; ffesShuttingDown : scPrepareForShutdown; end; { case } if assigned(scOnStateChange) then scOnStateChange(Self); end; { while } finally EndRead; end; except scState := OldState; raise; end; end; {====================================================================} {===TffBasePluginCommandHandler======================================} constructor TffBasePluginCommandHandler.Create(aOwner : TComponent); begin inherited Create(aOwner); FCmdHandler := nil; FPluginEngine := nil; end; {--------} destructor TffBasePluginCommandHandler.Destroy; begin if assigned(FCmdHandler) then FCmdHandler.FFRemoveDependent(Self); {!!.11} if assigned(FPluginEngine) then FPluginEngine.FFRemoveDependent(Self); {!!.11} inherited Destroy; end; {Begin !!.11} {--------} procedure TffBasePluginCommandHandler.FFNotificationEx (const AOp : Byte; AFrom : TffComponent; const AData : TffWord32); begin inherited; if AOp in [ffn_Destroy, ffn_Remove] then begin if AFrom = FCmdHandler then begin FCmdHandler.FFRemoveDependent(Self); FCmdHandler := nil; end else if AFrom = FPluginEngine then begin FPluginEngine.FFRemoveDependent(Self); FPluginEngine := nil; end; end; end; {--------} procedure TffBasePluginCommandHandler.pchSetCmdHandler(aCmdHandler : TffBaseCommandHandler); {-The command handler forwarding commands to this plugin command handler. } begin if aCmdHandler <> FCmdHandler then begin if assigned(FCmdHandler) then FCmdHandler.FFRemoveDependent(Self); if assigned(aCmdHandler) then aCmdHandler.FFAddDependent(Self); FCmdHandler := aCmdHandler; end; {Note: It is entirely possible for the plugin command handler to be active and have its associated command handler set to nil. In such a case, the plugin command handler never receives PrepareForShutdown and Shutdown commands. } end; {--------} procedure TffBasePluginCommandHandler.pchSetPluginEngine(anEngine : TffBasePluginEngine); begin if anEngine <> FPluginEngine then begin if assigned(FPluginEngine) then FPluginEngine.FFRemoveDependent(Self); if assigned(anEngine) then anEngine.FFAddDependent(Self); FPluginEngine := anEngine; end; end; {End !!.11} {====================================================================} {===TffBasePluginEngine==============================================} constructor TffBasePluginEngine.Create(aOwner : TComponent); begin inherited Create(aOwner); FPluginCmdHandlers := TffThreadList.Create; end; {--------} destructor TffBasePluginEngine.Destroy; {Begin !!.11} begin scSetState(ffesInactive); FFNotifyDependents(ffn_Destroy); FPluginCmdHandlers.Free; inherited Destroy; end; {--------} procedure TffBasePluginEngine.FFAddDependent(ADependent : TffComponent); var aListItem : TffIntListItem; begin inherited; if ADependent is TffBasePluginCommandHandler then begin aListItem := TffIntListItem.Create(Longint(ADependent)); with FPluginCmdHandlers.BeginWrite do try Insert(aListItem); finally EndWrite; end; end; end; {--------} procedure TffBasePluginEngine.FFRemoveDependent(ADependent : TffComponent); begin inherited; if ADependent is TffBasePluginCommandHandler then with FPluginCmdHandlers.BeginWrite do try Delete(Longint(ADependent)); finally EndWrite; end; end; {End !!.11} {--------} procedure TffBasePluginEngine.scSetState(const aState : TffState); {-Sets the state of the engine. This will also set the state of any associated plugin command handlers. } var aCmdHandler : TffBasePluginCommandHandler; anIndex : Longint; NextState : TffState; OldState : TffState; begin { If we are at the specified state then exit without doing anything. } if aState = scState then exit; OldState := scState; try if assigned(FPluginCmdHandlers) then with FPluginCmdHandlers.BeginRead do try while scState <> aState do begin { Based upon our current state & the target state, get the next state. } NextState := ffStateDiagram[scState, aState]; { Move all command handlers to that state. } for anIndex := 0 to pred(FPluginCmdHandlers.Count) do begin aCmdHandler := TffBasePluginCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt); if not (aState in [ffesStopping, ffesStopped, ffesUnsupported, ffesFailed]) then aCmdHandler.scSetState(aState); end; { Call the appropriate method for the new state. } case NextState of ffesInactive, ffesStopped : scShutdown; ffesInitializing : scInitialize; ffesStarting : scStartup; ffesStopping, ffesShuttingDown : scPrepareForShutdown; end; { case } { Update our state. } scState := NextState; if assigned(scOnStateChange) then scOnStateChange(Self); end; finally EndRead; end; except { Some kind of failure occurred. We need to rollback the engine to its original state. We will leave the command handlers as is. } scState := OldState; raise; end; end; {====================================================================} {===TffBaseEngineManager=============================================} constructor TffBaseEngineManager.Create(aOwner : TComponent); begin FCmdHandlers := TffThreadList.Create; inherited Create(aOwner); end; {--------} destructor TffBaseEngineManager.Destroy; var aCmdHandler : TffBaseCommandHandler; anIndex : Longint; begin { Note: The real engine manager must do a graceful shutdown of the server engine. } if assigned(FCmdHandlers) then with FCmdHandlers.BeginWrite do try { Make sure none of the plugin command handlers reference this engine. } for anIndex := pred(Count) downto 0 do begin aCmdHandler := TffBaseCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt); aCmdHandler.bchSetEngineManager(nil); end; finally EndWrite; FCmdHandlers.Free; end; inherited Destroy; end; {--------} procedure TffBaseEngineManager.bemAddCmdHandler(aCmdHandler : TffBaseCommandHandler); var aListItem : TffIntListItem; begin aListItem := TffIntListItem.Create(Longint(aCmdHandler)); with FCmdHandlers.BeginWrite do try Insert(aListItem); aCmdHandler.FManager := Self; finally EndWrite; end; end; {--------} function TffBaseEngineManager.bemGetCmdHandler(aInx : Longint) : TffBaseCommandHandler; begin with FCmdHandlers.BeginRead do try Result := TffBaseCommandHandler(TffIntListItem(Items[aInx]).KeyAsInt); finally EndRead; end; end; {--------} function TffBaseEngineManager.bemGetCmdHandlerCount : Longint; begin Result := FCmdHandlers.Count; end; {--------} procedure TffBaseEngineManager.bemRemoveCmdHandler(aCmdHandler : TffBaseCommandHandler); begin aCmdHandler.FManager := nil; with FCmdHandlers.BeginWrite do try Delete(Longint(aCmdHandler)); finally EndWrite; end; end; {====================================================================} {===TffBaseTransport=================================================} procedure TffBaseTransport.AutoConnectionLost(Sender : TffBaseTransport; aClientID : TffClientID); begin Sender.FFNotifyDependentsEx(ffn_ConnectionLost, aClientID); end; {--------} constructor TffBaseTransport.Create(aOwner : TComponent); begin inherited Create(aOwner); FCmdHandler := nil; FEnabled := False; FMode := fftmSend; FRespondToBroadcasts := False; FServerName := ''; FServerNameRequired := True; scState := ffesInactive; OnConnectionLost := AutoConnectionLost; end; {--------} destructor TffBaseTransport.Destroy; begin FFNotifyDependents(ffn_Destroy); if assigned(FCmdHandler) then FCmdHandler.FFRemoveDependent(Self); {!!.11} inherited Destroy; end; {--------} procedure TffBaseTransport.BeginUpdate; begin if FUpdateCount = 0 then begin { Give the descendent classes a chance to set their stored properties } btBeginUpdatePrim; { Set the _* fields to match their counterparts } _FCmdHandler := FCmdHandler; _FEnabled := FEnabled; _FLogEnabled := FLogEnabled; _FLogOptions := FLogOptions; _FMode := FMode; _FOnStateChange := scOnStateChange; _FRespondToBroadcasts := FRespondToBroadcasts; _FServerName := FServerName; _FState := scState; end; Inc(FUpdateCount); end; {--------} procedure TffBaseTransport.btBeginUpdatePrim; begin { do nothing } end; {--------} procedure TffBaseTransport.CancelUpdate; begin FUpdateCount := 0; end; {--------} procedure TffBaseTransport.EndUpdate; begin if FUpdateCount <> 0 then begin Dec(FUpdateCount); if FUpdateCount = 0 then begin { Let the descendent classes do their work } btEndUpdatePrim; { Update the fields with the new values in their _* counterparts } { We do not set the private field directly, since some processing may need to be done by a properties write method. } CommandHandler := _FCmdHandler; { Make sure State is set prior to Enabled property and other state-dependent properties. } State := _FState; Enabled := _FEnabled; EventLogEnabled := _FLogEnabled; EventLogOptions := _FLogOptions; Mode := _FMode; OnStateChange := _FOnStateChange; RespondToBroadcasts := _FRespondToBroadcasts; ServerName := _FServerName; end; end; end; {--------} procedure TffBaseTransport.btEndUpdatePrim; begin { do nothing } end; {--------} function TffBaseTransport.btGetCmdHandler : TffBaseCommandHandler; begin Result := FCmdHandler; end; {--------} function TffBaseTransport.btGetEnabled : boolean; begin Result := FEnabled; end; {--------} function TffBaseTransport.btGetLogOptions : TffTransportLogOptions; begin Result := FLogOptions; end; {--------} function TffBaseTransport.btGetMode : TffTransportMode; begin Result := FMode; end; {--------} function TffBaseTransport.btGetRespondToBroadcasts : Boolean; begin Result := FRespondToBroadcasts; end; {--------} function TffBaseTransport.btGetServerName : string; {!!.10} begin Result := FServerName; end; {--------} procedure TffBaseTransport.btSetCmdHandler(aCmdHandler : TffBaseCommandHandler); begin if (FUpdateCount > 0) then _FCmdHandler := aCmdHandler else begin {Check to make sure the new property is different.} if FCmdHandler = aCmdHandler then Exit; if assigned(FCmdHandler) then FCmdHandler.FFRemoveDependent(Self); {!!.11} if assigned(aCmdHandler) then aCmdHandler.FFAddDependent(Self); {!!.11} FCmdHandler := aCmdHandler; {!!.11} end; end; {--------} procedure TffBaseTransport.btSetEnabled(const aEnabled : Boolean); begin if (FUpdateCount > 0) then _FEnabled := aEnabled else begin {Check to make sure the new property is different.} if FEnabled = aEnabled then Exit; { If the transport is being disabled but the State indicates some amount of activity then make sure the transport is inactive. } if (not aEnabled) and (scState <> ffesInactive) then begin FFNotifyDependents(ffn_Deactivate); scSetState(ffesInactive); end; FEnabled := aEnabled; end; end; {--------} procedure TffBaseTransport.btSetLogOptions(const anOptions : TffTransportLogOptions); begin if (UpdateCount > 0) then _FLogOptions := anOptions else FLogOptions := anOptions; end; {--------} procedure TffBaseTransport.btSetMode(const aMode : TffTransportMode); begin if (FUpdateCount > 0) then _FMode := aMode else begin {Check to make sure the new property is different.} if FMode = aMode then Exit; scCheckInactive; FMode := aMode; end; end; {--------} procedure TffBaseTransport.btSetOnStateChange(const aHandler : TNotifyEvent); begin if (FUpdateCount > 0) then _FOnStateChange := aHandler else scOnStateChange := aHandler; end; {--------} procedure TffBaseTransport.btSetRespondToBroadcasts(const aRespond : Boolean); begin if (FUpdateCount > 0) then _FRespondToBroadcasts := aRespond else FRespondToBroadcasts := aRespond; end; {--------} procedure TffBaseTransport.btSetServername(const aServername : string); {!!.10} begin if (FUpdateCount > 0) then _FServerName := aServerName else begin {Check to make sure the new property is different.} if FServerName = aServername then Exit; scCheckInactive; FServerName := aServerName; end; end; {--------} procedure TffBaseTransport.btCheckListener; begin if FMode = fftmSend then RaiseSCErrorCode(ffsce_MustBeListener); end; {--------} procedure TffBaseTransport.btCheckSender; begin if FMode = fftmListen then RaiseSCErrorCode(ffsce_MustBeSender); end; {--------} procedure TffBaseTransport.btCheckServerName; begin if FServerNameRequired and (FServerName = '') then RaiseSCErrorCode(ffsce_MustHaveServerName); end; {--------} procedure TffBaseTransport.btInternalReply(msgID : Longint; errorCode : TffResult; replyData : pointer; replyDataLen : Longint); begin scCheckStarted; end; {--------} procedure TffBaseTransport.lcSetLogEnabled(const aEnabled : Boolean); begin if (UpdateCount > 0) then _FLogEnabled := aEnabled else FLogEnabled := aEnabled; end; {--------} procedure TffBaseTransport.Process(Msg : PffDataMessage); begin btStoreSelfInThreadvar; { If we have a command handler, tell the command handler to process the message. } if assigned(FCmdHandler) then begin { Increment the message count. Note: This happens whether or not the message was handled by a command handler, plugin command handler, or server engine. } InterlockedIncrement(FMsgCount); FCmdHandler.Process(Msg); end; end; {--------} class function TffBaseTransport.CurrentTransport : TffBaseTransport; begin Result := TffBaseTransport(ffitvTransportID); end; {--------} {Rewritten !!.11} procedure TffBaseTransport.FFNotificationEx(const AOp : Byte; AFrom : TffComponent; const AData : TffWord32); begin inherited; if AOp in [ffn_Destroy, ffn_Remove] then if (AFrom = FCmdHandler) then begin FCmdHandler.FFRemoveDependent(Self); FCmdHandler := nil end else if (AFrom = FEventLog) then begin FEventLog.FFRemoveDependent(Self); FEventLog := nil; end; end; {--------} class procedure TffBaseTransport.Reply(msgID : Longint; errorCode : TffResult; replyData : pointer; replyDataLen : Longint); begin CurrentTransport.btInternalReply(msgID, errorCode, replyData, replyDataLen); end; {--------} procedure TffBaseTransport.ResetMsgCount; begin FMsgCount := 0; end; {--------} function TffBaseTransport.Sleep(const timeOut : Longint) : boolean; begin Result := False; end; {--------} function TffBaseTransport.Supported : boolean; begin Result := True; end; {--------} procedure TffBaseTransport.btStoreSelfInThreadvar; begin { Store a pointer to this instance so the command handler may quickly find us and submit a reply. } ffitvTransportID := Longint(Self); end; {====================================================================} {===TffThreadedTransport=============================================} constructor TffThreadedTransport.Create(aOwner : TComponent); begin inherited Create(aOwner); FThreadPool := nil; FUnsentRequestQueue := TffThreadQueue.Create; FWaitingForReplyList := TffThreadList.Create; end; {--------} destructor TffThreadedTransport.Destroy; var anIndex : Longint; aRequest : TffRequest; begin FFNotifyDependents(ffn_Destroy); if assigned(FThreadPool) then FThreadPool.FFRemoveDependent(Self); {!!.11} if assigned(FUnsentRequestQueue) then with FUnsentRequestQueue.BeginWrite do try for anIndex := pred(Count) downto 0 do begin aRequest := TffRequest(TffIntListItem(Items[anIndex]).KeyAsInt); aRequest.Free; end; finally EndWrite; Free; end; if assigned(FWaitingForReplyList) then with FWaitingForReplyList.BeginWrite do try for anIndex := pred(Count) downto 0 do begin aRequest := TffRequest(TffIntListItem(Items[anIndex]).KeyAsInt); aRequest.Free; end; finally EndWrite; Free; end; inherited Destroy; end; {--------} {Rewritten !!.11} procedure TffThreadedTransport.FFNotificationEx(const AOp : Byte; AFrom : TffComponent; const AData : TffWord32); begin inherited; if (AFrom = FThreadPool) and (AOp in[ffn_Destroy, ffn_Remove]) then begin FThreadPool.FFRemoveDependent(Self); FThreadPool := nil; end; end; {--------} procedure TffThreadedTransport.SetThreadPool(aPool : TffThreadPool); begin if aPool <> FThreadPool then begin if assigned(FThreadPool) then FThreadPool.FFRemoveDependent(Self); {!!.11} if Assigned(aPool) then begin FThreadPool := aPool; FThreadPool.FFAddDependent(Self); {!!.11} end; end; end; {--------} procedure TffThreadedTransport.Post(transportID : Longint; clientID : TffClientID; msgID : Longint; requestData : pointer; requestDataLen : Longint; timeout : Longint; replyMode : TffReplyModeType); var aRequest : TffRequest; anItem : TffIntListItem; begin scCheckStarted; aRequest := TffRequest.Create(clientID, msgID, requestData, requestDataLen, timeout, replyMode); anItem := TffIntListItem.Create(Longint(aRequest)); with FUnsentRequestQueue.BeginWrite do try Enqueue(anItem); finally EndWrite; end; if replyMode = ffrmNoReplyWaitUntilSent then begin aRequest.WaitForReply(timeout); if not aRequest.Aborted then aRequest.Free else with aRequest do tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID, ErrorCode, Timeout])); end; end; {--------} procedure TffThreadedTransport.Request(transportID : Longint; clientID : TffClientID; msgID : Longint; timeout : Longint; requestData : pointer; requestDataLen : Longint; replyCallback : TffReplyCallback; replyCookie : Longint); var aRequest : TffRequest; begin scCheckStarted; aRequest := TffRequest.Create(clientID, msgID, requestData, requestDataLen, timeout, ffrmReplyExpected); tpInternalRequest(aRequest, timeout, 0); if assigned(replyCallback) then replyCallback(aRequest.ReplyMsgID, aRequest.ErrorCode, aRequest.ReplyData, aRequest.ReplyDataLen, replyCookie); if not aRequest.Aborted then aRequest.Free else with aRequest do tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID, ErrorCode, Timeout])); end; {--------} procedure TffThreadedTransport.tpInternalRequest(aRequest : TffRequest; timeout : Longint; aCookie : HWND); var anItem : TffIntListItem; begin anItem := TffIntListItem.Create(Longint(aRequest)); with FUnsentRequestQueue.BeginWrite do try Enqueue(anItem); finally EndWrite; end; { Wait for the reply. If a timeout occurs, assume the request object will be freed by the transport thread at some point. Timeout exceptions are raised to the calling object. } if timeout = 0 then aRequest.WaitForReply(timeout) else aRequest.WaitForReply(timeout + ffcl_RequestLatencyAdjustment); end; {--------} procedure TffThreadedTransport.tpLogReq(aRequest : TffRequest; const prefix : string); begin if FLogEnabled and (fftpLogRequests in FLogOptions) and assigned(FEventLog) and assigned(aRequest) then with aRequest do begin FEventLog.WriteStringFmt(ffc_ReqLogString, [prefix, Longint(aRequest), ClientID, MsgID, RequestDataLen, Timeout]); FEventLog.WriteBlock('Data', aRequest.RequestData, aRequest.RequestDataLen); end; end; {--------} procedure TffThreadedTransport.tpLogReq2(const aPrefix : string; const aRequestID : Longint; const aClientID : TffClientID; const aMsgID : Longint; const aData : pointer; const aDataLen : Longint; const aTimeout : Longint); begin FEventLog.WriteStringFmt(ffc_ReqLogString, [aPrefix, aRequestID, aClientID, aMsgID, aDataLen, aTimeout]); FEventLog.WriteBlock(ffc_Data, aData, aDataLen); end; {--------} procedure TffThreadedTransport.tpLogReqMisc(const aMsg : string); begin if FLogEnabled and (fftpLogRequests in FLogOptions) and assigned(FEventLog) then FEventLog.WriteString(aMsg); end; {--------} procedure TffThreadedTransport.tpLogReply(aRequest : TffRequest); begin if FLogEnabled and (fftpLogReplies in FLogOptions) and assigned(FEventLog) and assigned(aRequest) then with aRequest do begin FEventLog.WriteStringFmt(ffc_ReplyLogString, [Longint(aRequest), ClientID, ReplyMsgID, ReplyDataLen, ErrorCode]); FEventLog.WriteBlock(ffc_Data, ReplyData, ReplyDataLen); end; end; {--------} procedure TffThreadedTransport.tpLogReply2(const aRequestID : Longint; const aClientID : TffClientID; const aMsgID : Longint; const aDataLen : Longint; const anError : TffResult); begin { Assumption: Calling routine will only call if it is legitimate to log the data. We do it this way so that we avoid passing tons of data on the stack. } FEventLog.WriteStringFmt(ffc_ReplyLogString, [aRequestID, aClientID, aMsgID, aDataLen, anError]); end; {====================================================================} end.