4887 lines
156 KiB
ObjectPascal
4887 lines
156 KiB
ObjectPascal
(***** 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 Async Professional
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 1991-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
* Stephen W. Boyd - Rewrote the Win32 dispatcher to reduce vulnerability
|
|
* August 2005 to badly behaved event handlers. Rather than having
|
|
* the read thread block until all events have been processed
|
|
* the read thread now places input onto an 'endless'
|
|
* queue. The dispatch thread reads this queue and
|
|
* calls the event handlers. This allows input the be
|
|
* continuously read from the input device while the
|
|
* event handlers are executing. Should cut down on
|
|
* input overruns. To use the old Win32 dispatcher rather
|
|
* then mine define the conditional UseAwWin32 and rebuild
|
|
* the library.
|
|
* Kevin G. McCoy
|
|
* 1 Feb 2008 - Found and fixed the status buffer memory leak. Buffers
|
|
* were being popped off the queue but not freed; Added
|
|
* D2006 / D2007 compiler strings
|
|
*
|
|
* Sulaiman Mah
|
|
* Sean B. Durkin
|
|
* Sebastian Zierer
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{*********************************************************}
|
|
{* AWUSER.PAS 5.00 *}
|
|
{*********************************************************}
|
|
{* Low-level dispatcher *}
|
|
{*********************************************************}
|
|
{* Thanks to David Hudder for his substantial *}
|
|
{* contributions to improve efficiency and reliability *}
|
|
{*********************************************************}
|
|
|
|
{
|
|
This unit defines the dispatcher, com and output threads. When
|
|
a serial port is opened (Winsock does not use a multi-threaded
|
|
architecture), these three threads are created. The dispatcher
|
|
thread is the interface between your application and the port.
|
|
The dispatcher thread synchronizes with the thread that opened
|
|
the port via SendMessageTimeout, in case of timeout (usually 3
|
|
seconds), we will discard whatever we were trying to notify you
|
|
about and resume the thread. For this reason, the thread that
|
|
opened the port should not be blocked for more than a few ticks,
|
|
and the event handler should get the data and return as quickly
|
|
as possible. Do not do any DB or file access inside an OnTriggerXxx
|
|
event, those actions can take too long. Instead, collect the data
|
|
and process it later. A good approach is to collect the data,
|
|
post a message to yourself, and process the data from the message
|
|
handler.
|
|
The dispatcher thread is the interface between the application
|
|
layer and the port. The dispatcher thread runs in the context of
|
|
the thread that opened the port. The com thread is tied to the
|
|
serial port drivers to receive notification when things change.
|
|
The com thread wakes the dispatcher thread, the dispatcher thread
|
|
then generates the events. The output thread is there to process
|
|
the internal output buffer.
|
|
Be extrememly cautious when making changes here. The multi-threaded
|
|
nature, and very strict timing requirements, can lead to very
|
|
unpredictable results. Things as simple as doing a writeln to a
|
|
console window can dramatically change the results.
|
|
}
|
|
{Global defines potentially affecting this unit}
|
|
{$I AWDEFINE.INC}
|
|
|
|
{Options required for this unit}
|
|
{$X+,B-,I-,T-,J+}
|
|
|
|
{.$DEFINE DebugThreads}
|
|
|
|
{$IFDEF CONSOLE}
|
|
{.$DEFINE DebugThreadConsole}
|
|
{$ENDIF}
|
|
|
|
{!!.02} { removed Win16 references }
|
|
unit AwUser;
|
|
{-Basic API provided by APRO}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows,
|
|
Messages,
|
|
SysUtils,
|
|
Classes,
|
|
MMSystem,
|
|
OoMisc,
|
|
AdExcept,
|
|
LNSQueue; // SWB
|
|
|
|
const
|
|
FirstTriggerCounter = 1;
|
|
MaxTriggerHandle = 65536 shr 4;{Highest trigger handle number (4096)}
|
|
StatusTypeMask = $0007;
|
|
ThreadStartWait = 3000; {Milliseconds to wait for sub-threads to start}
|
|
ModemEvent = EV_CTS or EV_DSR or EV_RLSD or EV_RING or EV_RINGTE; // SWB
|
|
LineEvent = EV_ERR or EV_BREAK; // SWB
|
|
{Use these event bits for fast checking of serial events} // SWB
|
|
DefEventMask = ev_CTS + ev_DSR + ev_RLSD + ev_Ring + ev_RingTe + // SWB
|
|
ev_RxChar + ev_Err + ev_Break; // SWB
|
|
|
|
|
|
type
|
|
TApHandlerFlagUpdate = (fuKeepPort, fuEnablePort, fuDisablePort);
|
|
|
|
TApdBaseDispatcher = class;
|
|
TApdDispatcherThread = class(TThread)
|
|
private
|
|
pMsg, pTrigger : Cardinal;
|
|
plParam : Integer;
|
|
pTriggerEvent : TApdNotifyEvent;
|
|
procedure SyncEvent;
|
|
protected
|
|
H : TApdBaseDispatcher; // SWB
|
|
public
|
|
constructor Create(Disp : TApdBaseDispatcher);
|
|
procedure SyncNotify(Msg, Trigger : Cardinal; lParam : Integer; Event : TApdNotifyEvent);
|
|
procedure Sync(Method: TThreadMethod);
|
|
property ReturnValue; // SWB
|
|
end;
|
|
|
|
TOutThread = class(TApdDispatcherThread)
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TComThread = class(TApdDispatcherThread)
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
TDispThread = class(TApdDispatcherThread)
|
|
procedure Execute; override;
|
|
end;
|
|
|
|
{Standard comm port record}
|
|
TApdDispatcherClass = class of TApdBaseDispatcher;
|
|
TApdBaseDispatcher = class
|
|
protected
|
|
fOwner : TObject;
|
|
fHandle : Integer; {Handle for this comm port}
|
|
OpenHandle : Boolean;
|
|
CidEx : Integer; {Comm or other device ID}
|
|
LastError : Integer; {Last error from COM API}
|
|
InQue : Cardinal; {Size of device input buffer}
|
|
OutQue : Cardinal; {Size of device output buffer}
|
|
ModemStatus : Cardinal; {Modem status register}
|
|
ComStatus : TComStat; {Results of last call for com status}
|
|
DCB : TDCB; {Results of last call for DCB}
|
|
LastBaud : Integer; {Last baud set}
|
|
Flags : Cardinal; {Option flags}
|
|
DTRState : Boolean; {Last set DTR state}
|
|
DTRAuto : Boolean; {True if in handshake mode}
|
|
RTSState : Boolean; {Last set RTS state}
|
|
RTSAuto : Boolean; {True if in handshake mode}
|
|
fDispatcherWindow : Cardinal; {Handle to dispatcher window}
|
|
LastModemStatus : Cardinal; {Last modem status read}
|
|
LastLineErr : Cardinal; {Last line error read}
|
|
RS485Mode : Boolean; {True if in RS485 mode}
|
|
BaseAddress : Word; {Base address of port}
|
|
|
|
{Trigger stuff}
|
|
PortHandlerInstalled : Boolean; {True if any of the comport's trigger handlers <> nil}
|
|
HandlerServiceNeeded : Boolean; {True if handlers need to be serviced}
|
|
WndTriggerHandlers : TList;
|
|
ProcTriggerHandlers : TList;
|
|
EventTriggerHandlers : TList;
|
|
TimerTriggers : TList; {Timer triggers}
|
|
DataTriggers : TList; {Data triggers}
|
|
StatusTriggers : TList; {Status triggers}
|
|
LastTailData : Cardinal; {Tail of last data checked for data}
|
|
LastTailLen : Cardinal; {Tail of last data sent in len msg}
|
|
LenTrigger : Cardinal; {Number of bytes before length trigger}
|
|
GlobalStatHit : Boolean; {True if at least one status trigger hit}
|
|
InAvailMessage : Boolean; {True when within Avail msg}
|
|
GetCount : Cardinal; {Chars looked at in Avail msg}
|
|
MaxGetCount : Cardinal; {Max chars looked at in Avail}
|
|
DispatchFull : Boolean; {True when dispatch buffer full}
|
|
NotifyTail : Cardinal; {Position of last character notified}
|
|
|
|
{Thread stuff}
|
|
KillThreads : Boolean; {True to kill threads}
|
|
ComThread : TApdDispatcherThread; // SWB
|
|
fDispThread : TDispThread;
|
|
OutThread : TApdDispatcherThread; // SWB
|
|
StatusThread : TapdDispatcherThread; // SWB
|
|
ThreadBoost : Byte;
|
|
DataSection : TRTLCriticalSection; {For all routines}
|
|
OutputSection : TRTLCriticalSection; {For output buffer and related data}
|
|
DispSection : TRTLCriticalSection; {For dispatcher buffer and related data}
|
|
ComEvent : THandle; {Signals com thread is ready}
|
|
ReadyEvent : THandle; {Signals completion of com thread}
|
|
GeneralEvent : THandle; {For general misc signalling}
|
|
OutputEvent : THandle; {Signals output buf has data to send}
|
|
SentEvent : THandle; {Signals completion of overlapped write}
|
|
OutFlushEvent : THandle; {Signals request to flush output buffer}
|
|
OutWaitObjects1: array[0..1] of THandle; {Output thread wait objects}
|
|
OutWaitObjects2: array[0..1] of THandle; {More output thread wait objects}
|
|
CurrentEvent : DWORD; {Current communications event}
|
|
RingFlag : Boolean; {True when ringte event received}
|
|
FQueue : TIOQueue; {Input queue} // SWB
|
|
|
|
{ Output buffer -- protected by OutputSection }
|
|
OBuffer : POBuffer; {Output buffer}
|
|
OBufHead : Cardinal; {Head offset in OBuffer}
|
|
OBufTail : Cardinal; {Tail offset in OBuffer}
|
|
OBufFull : Boolean; {True when output buffer full}
|
|
|
|
{ Dispatcher stuff -- protected by DispSection }
|
|
DBuffer : PDBuffer; {Dispatcher buffer}
|
|
DBufHead : Cardinal; {Head offset in DBuffer}
|
|
DBufTail : Cardinal; {Tail offset in DBuffer}
|
|
fEventBusy : Boolean; {True if we're processing a COM event}
|
|
DeletePending : Boolean; {True if an event handler was deleted during a busy state}
|
|
ClosePending : Boolean; {True if close pending}
|
|
OutSentPending: Boolean; {True if stOutSent trigger pending}
|
|
|
|
{Tracing stuff}
|
|
TracingOn : Boolean; {True if tracing is on}
|
|
TraceQueue : PTraceQueue; {Circular trace buffer}
|
|
TraceIndex : Cardinal; {Head of trace queue}
|
|
TraceMax : Cardinal; {Number of trace entries}
|
|
TraceWrapped : Boolean; {True if trace wrapped}
|
|
|
|
{DispatchLogging stuff}
|
|
DLoggingOn : Boolean; {True if dispatch logging is on}
|
|
DLoggingQueue : TIOQueue; { 'endless' dispatching buffer } // SWB
|
|
DLoggingMax : Cardinal; {Number of bytes in logging buffer}
|
|
TimeBase : DWORD; {Time dispatching was turned on}
|
|
|
|
{DispatcherMode : Cardinal;}
|
|
TimerID : Cardinal;
|
|
TriggerCounter : Cardinal; {Last allocated trigger handle}
|
|
DispActive : Boolean;
|
|
{Protected virtual dispatcher functions:}
|
|
|
|
DoDonePortPrim : Boolean;
|
|
ActiveThreads : Integer;
|
|
CloseComActive : Boolean; // SWB
|
|
|
|
function EscapeComFunction(Func : Integer) : Integer; virtual; abstract;
|
|
function FlushCom(Queue : Integer) : Integer; virtual; abstract;
|
|
function GetComError(var Stat : TComStat) : Integer; virtual; abstract;
|
|
function GetComEventMask(EvtMask : Integer) : Cardinal; virtual; abstract;
|
|
function GetComState(var DCB: TDCB): Integer; virtual; abstract;
|
|
function ReadCom(Buf : PAnsiChar; Size: Integer) : Integer; virtual; abstract;
|
|
function SetComState(var DCB : TDCB) : Integer; virtual; abstract;
|
|
function WriteCom(Buf : PAnsiChar; Size: Integer) : Integer; virtual; abstract;
|
|
function WriteComSafe(ABuf: PAnsiChar; ASize: Integer): Integer;
|
|
function WaitComEvent(var EvtMask : DWORD;
|
|
lpOverlapped : POverlapped) : Boolean; virtual; abstract;
|
|
function SetupCom(InSize, OutSize : Integer) : Boolean; virtual; abstract;
|
|
|
|
function CheckReceiveTriggers : Boolean;
|
|
function CheckStatusTriggers : Boolean;
|
|
function CheckTimerTriggers : Boolean;
|
|
function CheckTriggers : Boolean;
|
|
procedure CreateDispatcherWindow;
|
|
procedure DonePortPrim; virtual;
|
|
function DumpDispatchLogPrim(
|
|
FName : string;
|
|
AppendFile, InHex, AllHex : Boolean) : Integer;
|
|
function DumpTracePrim(FName : string;
|
|
AppendFile, InHex, AllHex : Boolean) : Integer;
|
|
function ExtractData : Boolean;
|
|
function FindTriggerFromHandle(TriggerHandle : Cardinal; Delete : Boolean;
|
|
var T : TTriggerType; var Trigger : Pointer) : Integer;
|
|
function GetDispatchTime : DWORD;
|
|
function GetModemStatusPrim(ClearMask : Byte) : Byte;
|
|
function GetTriggerHandle : Cardinal;
|
|
|
|
procedure MapEventsToMS(Events : Integer);
|
|
function PeekBlockPrim(
|
|
Block : PAnsiChar;
|
|
Offset : Cardinal;
|
|
Len : Cardinal;
|
|
var NewTail : Cardinal) : Integer;
|
|
function PeekCharPrim(var C : AnsiChar; Count : Cardinal) : Integer;
|
|
procedure RefreshStatus;
|
|
procedure ResetStatusHits;
|
|
procedure ResetDataTriggers;
|
|
function SendNotify(Msg, Trigger, Data: Cardinal) : Boolean;
|
|
function SetCommStateFix(var DCB : TDCB) : Integer;
|
|
procedure StartDispatcher; virtual; abstract;
|
|
procedure StopDispatcher; virtual; abstract;
|
|
procedure ThreadGone(Sender: TObject); // SWB
|
|
procedure ThreadStart(Sender : TObject); // SWB
|
|
procedure WaitTxSent;
|
|
function OutBufUsed: Cardinal; virtual; abstract; // SWB
|
|
function InQueueUsed : Cardinal; virtual; // SWB
|
|
public
|
|
DataPointers : TDataPointerArray; {Array of data pointers}
|
|
DeviceName : string; {Name of device being used, for log }
|
|
LastWinError : Integer; // SWB
|
|
|
|
property Active : Boolean read DispActive;
|
|
property Logging : Boolean read DLoggingOn;
|
|
procedure AddDispatchEntry(
|
|
DT : TDispatchType;
|
|
DST : TDispatchSubType;
|
|
Data : Cardinal;
|
|
Buffer : Pointer;
|
|
BufferLen : Cardinal);
|
|
procedure AddStringToLog(S : Ansistring);
|
|
property ComHandle : Integer read CidEx;
|
|
{Public virtual dispatcher functions:}
|
|
function OpenCom(ComName: PChar; InQueue,
|
|
OutQueue : Cardinal) : Integer; virtual; abstract;
|
|
function CloseCom : Integer; virtual; abstract;
|
|
function CheckPort(ComName: PChar): Boolean; virtual; abstract; //SZ
|
|
|
|
property DispatcherWindow : Cardinal read fDispatcherWindow;
|
|
property DispThread : TDispThread read fDispThread;
|
|
property EventBusy : boolean read fEventBusy write fEventBusy;
|
|
property Handle : Integer read fHandle;
|
|
property Owner : TObject read fOwner;
|
|
|
|
constructor Create(Owner : TObject);
|
|
destructor Destroy; override;
|
|
|
|
procedure AbortDispatchLogging;
|
|
procedure AbortTracing;
|
|
function AddDataTrigger(Data : PAnsiChar; // --sm PansiChar
|
|
IgnoreCase : Boolean) : Integer;
|
|
function AddDataTriggerLen(Data : PAnsiChar; // --sm Pansichar
|
|
IgnoreCase : Boolean;
|
|
Len : Cardinal) : Integer;
|
|
function AddStatusTrigger(SType : Cardinal) : Integer;
|
|
function AddTimerTrigger : Integer;
|
|
procedure AddTraceEntry(CurEntry : AnsiChar; CurCh : AnsiChar);
|
|
function AppendDispatchLog(FName : string;
|
|
InHex, AllHex : Boolean) : Integer;
|
|
function AppendTrace(FName : string;
|
|
InHex, AllHEx : Boolean) : Integer;
|
|
procedure BufferSizes(var InSize, OutSize : Cardinal);
|
|
function ChangeBaud(NewBaud : Integer) : Integer;
|
|
procedure ChangeLengthTrigger(Length : Cardinal);
|
|
function CheckCTS : Boolean;
|
|
function CheckDCD : Boolean;
|
|
function CheckDeltaCTS : Boolean;
|
|
function CheckDeltaDSR : Boolean;
|
|
function CheckDeltaRI : Boolean;
|
|
function CheckDeltaDCD : Boolean;
|
|
function CheckDSR : Boolean;
|
|
function CheckLineBreak : Boolean;
|
|
function CheckRI : Boolean;
|
|
function ClassifyStatusTrigger(TriggerHandle : Cardinal) : Cardinal;
|
|
procedure ClearDispatchLogging;
|
|
class procedure ClearSaveBuffers(var Save : TTriggerSave);
|
|
function ClearTracing : Integer;
|
|
procedure DeregisterWndTriggerHandler(HW : TApdHwnd);
|
|
procedure DeregisterProcTriggerHandler(NP : TApdNotifyProc);
|
|
procedure DeregisterEventTriggerHandler(NP : TApdNotifyEvent);
|
|
procedure DonePort;
|
|
function DumpDispatchLog(FName : string; InHex, AllHex : Boolean) : Integer;
|
|
function DumpTrace(FName : string; InHex, AllHex : Boolean) : Integer;
|
|
function ExtendTimer(TriggerHandle : Cardinal;
|
|
Ticks : Integer) : Integer;
|
|
function FlushInBuffer : Integer;
|
|
function FlushOutBuffer : Integer;
|
|
function CharReady : Boolean;
|
|
function GetBaseAddress : Word;
|
|
function GetBlock(Block : PAnsiChar; Len : Cardinal) : Integer;
|
|
function GetChar(var C : AnsiChar) : Integer;
|
|
function GetDataPointer(var P : Pointer; Index : Cardinal) : Integer;
|
|
function GetFlowOptions(var HWOpts, SWOpts, BufferFull,
|
|
BufferResume : Cardinal; var OnChar, OffChar : AnsiChar): Integer;
|
|
procedure GetLine(var Baud : Integer; var Parity : Word;
|
|
var DataBits : TDatabits; var StopBits : TStopbits);
|
|
function GetLineError : Integer;
|
|
function GetModemStatus : Byte;
|
|
function HWFlowOptions(BufferFull, BufferResume : Cardinal;
|
|
Options : Cardinal) : Integer;
|
|
function HWFlowState : Integer;
|
|
function InBuffUsed : Cardinal;
|
|
function InBuffFree : Cardinal;
|
|
procedure InitDispatchLogging(QueueSize : Cardinal);
|
|
function InitPort(AComName : PChar; Baud : Integer;
|
|
Parity : Cardinal; DataBits : TDatabits; StopBits : TStopbits;
|
|
InSize, OutSize : Cardinal; FlowOpts : DWORD) : Integer;
|
|
function InitSocket(InSize, OutSize : Cardinal) : Integer;
|
|
function InitTracing(NumEntries : Cardinal) : Integer;
|
|
function OptionsAreOn(Options : Cardinal) : Boolean;
|
|
procedure OptionsOn(Options : Cardinal);
|
|
procedure OptionsOff(Options : Cardinal);
|
|
function OutBuffUsed : Cardinal;
|
|
function OutBuffFree : Cardinal;
|
|
function PeekBlock(Block : PAnsiChar; Len : Cardinal) : Integer;
|
|
function PeekChar(var C : AnsiChar; Count : Cardinal) : Integer;
|
|
function ProcessCommunications : Integer; virtual; abstract;
|
|
function PutBlock(const Block; Len : Cardinal) : Integer;
|
|
function PutChar(C : AnsiChar) : Integer; // --sm ansi
|
|
function PutString(S : AnsiString) : Integer;
|
|
procedure RegisterWndTriggerHandler(HW : TApdHwnd);
|
|
procedure RegisterProcTriggerHandler(NP : TApdNotifyProc);
|
|
procedure RegisterSyncEventTriggerHandler(NP : TApdNotifyEvent);
|
|
procedure RegisterEventTriggerHandler(NP : TApdNotifyEvent);
|
|
procedure RemoveAllTriggers;
|
|
function RemoveTrigger(TriggerHandle : Cardinal) : Integer;
|
|
procedure RestoreTriggers( var Save : TTriggerSave);
|
|
procedure SaveTriggers( var Save : TTriggerSave);
|
|
procedure SetBaseAddress(NewBaseAddress : Word);
|
|
procedure SendBreak(Ticks : Cardinal; Yield : Boolean);
|
|
procedure SetBreak(BreakOn : Boolean);
|
|
procedure SetThreadBoost(Boost : Byte); virtual;
|
|
function SetDataPointer( P : Pointer; Index : Cardinal) : Integer;
|
|
function SetDtr(OnOff : Boolean) : Integer;
|
|
procedure SetEventBusy(var WasOn : Boolean; SetOn : Boolean);
|
|
procedure SetRS485Mode(OnOff : Boolean);
|
|
function SetRts(OnOff : Boolean) : Integer;
|
|
function SetLine(Baud : Integer; Parity : Cardinal;
|
|
DataBits : TDatabits; StopBits : TStopbits) : Integer;
|
|
function SetModem(DTR, RTS : Boolean) : Integer;
|
|
function SetStatusTrigger(TriggerHandle : Cardinal;
|
|
Value : Cardinal; Activate : Boolean) : Integer;
|
|
function SetTimerTrigger(TriggerHandle : Cardinal;
|
|
Ticks : Integer; Activate : Boolean) : Integer;
|
|
function SetCommBuffers(InSize, OutSize : Integer) : Integer;
|
|
procedure StartDispatchLogging;
|
|
procedure StartTracing;
|
|
procedure StopDispatchLogging;
|
|
procedure StopTracing;
|
|
function SWFlowChars( OnChar, OffChar : AnsiChar) : Integer;
|
|
function SWFlowDisable : Integer;
|
|
function SWFlowEnable(BufferFull, BufferResume : Cardinal;
|
|
Options : Cardinal) : Integer;
|
|
function SWFlowState : Integer;
|
|
function TimerTicksRemaining(TriggerHandle : Cardinal;
|
|
var TicksRemaining : Integer) : Integer;
|
|
procedure UpdateHandlerFlags(FlagUpdate : TApHandlerFlagUpdate); virtual;
|
|
end;
|
|
|
|
function GetTComRecPtr(Cid : Integer; DeviceLayerClass : TApdDispatcherClass) : Pointer;
|
|
|
|
var
|
|
PortList : TList;
|
|
|
|
procedure LockPortList;
|
|
procedure UnlockPortList;
|
|
function PortIn(Address: Word): Byte; // SWB
|
|
|
|
var
|
|
GShowExceptionHandler: procedure(ExceptObject: TObject; ExceptAddr: Pointer) = nil;
|
|
|
|
implementation
|
|
|
|
uses
|
|
AnsiStrings;
|
|
|
|
var
|
|
PortListSection : TRTLCriticalSection;
|
|
|
|
const
|
|
{ This should be the same in ADSOCKET.PAS }
|
|
CM_APDSOCKETMESSAGE = WM_USER + $0711;
|
|
|
|
{For setting stop bits}
|
|
StopBitArray : array[TStopbits] of Byte = (OneStopbit, TwoStopbits, 0);
|
|
|
|
{For quick checking and disabling of all flow control options}
|
|
InHdwFlow = dcb_DTRBit2 + dcb_RTSBit2;
|
|
OutHdwFlow = dcb_OutxDSRFlow + dcb_OutxCTSFlow;
|
|
AllHdwFlow = InHdwFlow + OutHdwFlow;
|
|
AllSfwFlow = dcb_InX + dcb_OutX;
|
|
|
|
{Mask of errors we care about}
|
|
ValidErrorMask =
|
|
ce_RXOver + {receive queue overflow}
|
|
ce_Overrun + {receive overrun error}
|
|
ce_RXParity + {receive parity error}
|
|
ce_Frame + {receive framing error}
|
|
ce_Break; {break detected}
|
|
|
|
{For clearing modem status}
|
|
ClearDelta = $F0;
|
|
ClearNone = $FF;
|
|
ClearDeltaCTS = Byte(not DeltaCTSMask);
|
|
ClearDeltaDSR = Byte(not DeltaDSRMask);
|
|
ClearDeltaRI = Byte(not DeltaRIMask);
|
|
ClearDeltaDCD = Byte(not DeltaDCDMask);
|
|
|
|
{General purpose routines}
|
|
|
|
const
|
|
LastCID : Integer = -1;
|
|
LastDispatcher : TApdBaseDispatcher = nil;
|
|
|
|
//SZ: this was removed, but it is needed by AWWNSOCK.pas
|
|
function GetTComRecPtr(Cid : Integer; DeviceLayerClass : TApdDispatcherClass) : Pointer;
|
|
{-Find the entry into the port array which has the specified Cid}
|
|
var
|
|
i : Integer;
|
|
begin
|
|
LockPortList;
|
|
try
|
|
{find the correct com port record}
|
|
if (LastCID = Cid) and (LastDispatcher <> nil) then
|
|
Result := LastDispatcher
|
|
else begin
|
|
for i := 0 to pred(PortList.Count) do
|
|
if PortList[i] <> nil then
|
|
with TApdBaseDispatcher(PortList[i]) do
|
|
if (CidEx = Cid) and (TObject(PortList[i]) is DeviceLayerClass) then begin
|
|
Result := TApdBaseDispatcher(PortList[i]);
|
|
LastCID := Cid;
|
|
LastDispatcher := Result;
|
|
exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
finally
|
|
UnlockPortList;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
type
|
|
TThreadStatus = (ComStart, ComWake, ComSleep, ComKill,
|
|
DispStart, DispWake, DispSleep, DispKill,
|
|
OutStart, OutWake, OutSleep, OutKill);
|
|
var
|
|
C, D, O : Char; {!!.02}
|
|
function ThreadStatus(Stat : TThreadStatus) : string;
|
|
begin
|
|
C := '.'; {!!.02}
|
|
D := '.'; {!!.02}
|
|
O := '.'; {!!.02}
|
|
case Stat of
|
|
ComStart,
|
|
ComWake : C := 'C';
|
|
ComSleep : C := 'c';
|
|
ComKill : C := 'x';
|
|
DispStart,
|
|
DispWake : D := 'D';
|
|
DispSleep : D := 'd';
|
|
DispKill : D := 'x';
|
|
OutStart,
|
|
OutWake : O := 'O';
|
|
OutSleep : O := 'o';
|
|
OutKill : O := 'x';
|
|
end;
|
|
Result := C + D + O + ' ' + IntToStr(AdTimeGetTime);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function BuffCount(Head, Tail: Cardinal; Full : Boolean) : Cardinal;
|
|
{-Return number of chars between Tail and Head}
|
|
begin
|
|
if Head = Tail then
|
|
if Full then
|
|
BuffCount := DispatchBufferSize
|
|
else
|
|
BuffCount := 0
|
|
else if Head > Tail then
|
|
BuffCount := Head-Tail
|
|
else
|
|
BuffCount := (Head+DispatchBufferSize)-Tail;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InQueueUsed : Cardinal; // SWB
|
|
begin // SWB
|
|
Result := 0; // SWB
|
|
end; // SWB
|
|
|
|
procedure TApdBaseDispatcher.ThreadGone(Sender: TObject);
|
|
begin
|
|
try // SWB
|
|
CheckException(TComponent(Owner), // SWB
|
|
TApdDispatcherThread(Sender).ReturnValue); // SWB
|
|
except // SWB
|
|
on E: Exception do // SWB
|
|
begin // SWB
|
|
if Assigned(GShowExceptionHandler) then
|
|
GShowExceptionHandler(E, ExceptAddr)
|
|
else
|
|
ShowException(E, ExceptAddr);
|
|
end; // SWB
|
|
end; // SWB
|
|
|
|
if Sender = ComThread then
|
|
ComThread := nil;
|
|
|
|
if Sender = OutThread then
|
|
OutThread := nil;
|
|
|
|
if Sender = fDispThread then begin
|
|
fDispThread := nil;
|
|
if DoDonePortPrim then begin
|
|
DonePortPrim;
|
|
DoDonePortPrim := False;
|
|
end;
|
|
end;
|
|
|
|
if Sender = StatusThread then // SWB
|
|
StatusThread := nil; // SWB
|
|
|
|
if (InterLockedDecrement(ActiveThreads) = 0) then begin
|
|
DispActive := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.ThreadStart(Sender : TObject); // SWB
|
|
begin // SWB
|
|
InterLockedIncrement(ActiveThreads); // SWB
|
|
SetEvent(GeneralEvent); // SWB
|
|
end; // SWB
|
|
|
|
procedure TApdBaseDispatcher.SetThreadBoost(Boost : Byte);
|
|
begin
|
|
if Boost <> ThreadBoost then begin
|
|
ThreadBoost := Boost;
|
|
|
|
if Assigned(ComThread) then
|
|
ComThread.Priority := TThreadPriority(Ord(tpNormal) + Boost);
|
|
|
|
if Assigned(fDispThread) then
|
|
fDispThread.Priority := TThreadPriority(Ord(tpNormal) + Boost);
|
|
|
|
if Assigned(fDispThread) then
|
|
if RS485Mode then
|
|
OutThread.Priority := TThreadPriority(Ord(tpHigher) + Boost)
|
|
else
|
|
OutThread.Priority := TThreadPriority(Ord(tpNormal) + Boost);
|
|
|
|
if Assigned(StatusThread) then // SWB
|
|
StatusThread.Priority := TThreadPriority(Ord(tpNormal) + Boost); // SWB
|
|
end;
|
|
end;
|
|
|
|
constructor TApdBaseDispatcher.Create(Owner : TObject);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
inherited Create;
|
|
fOwner := Owner;
|
|
ComEvent := INVALID_HANDLE_VALUE;
|
|
ReadyEvent := INVALID_HANDLE_VALUE;
|
|
GeneralEvent := INVALID_HANDLE_VALUE;
|
|
OutputEvent := INVALID_HANDLE_VALUE;
|
|
SentEvent := INVALID_HANDLE_VALUE;
|
|
OutFlushEvent := INVALID_HANDLE_VALUE;
|
|
|
|
LockPortList;
|
|
try
|
|
{Find a free slot in PortListX or append if none found (see Destroy) }
|
|
fHandle := -1;
|
|
for i := 0 to pred(PortList.Count) do
|
|
if PortList[i] = nil then begin
|
|
PortList[i] := Self;
|
|
fHandle := i;
|
|
break;
|
|
end;
|
|
if fHandle = -1 then
|
|
fHandle := PortList.Add(Self);
|
|
finally
|
|
UnlockPortList;
|
|
end;
|
|
{Allocate critical section objects}
|
|
FillChar(DataSection, SizeOf(DataSection), 0);
|
|
InitializeCriticalSection(DataSection);
|
|
|
|
FillChar(OutputSection, SizeOf(OutputSection), 0);
|
|
InitializeCriticalSection(OutputSection);
|
|
|
|
FillChar(DispSection, SizeOf(DispSection), 0);
|
|
InitializeCriticalSection(DispSection);
|
|
WndTriggerHandlers := TList.Create;
|
|
ProcTriggerHandlers := TList.Create;
|
|
EventTriggerHandlers := TList.Create;
|
|
TimerTriggers := TList.Create;
|
|
DataTriggers := TList.Create;
|
|
StatusTriggers:= TList.Create;
|
|
TriggerCounter := FirstTriggerCounter;
|
|
FQueue := TIOQueue.Create; // SWB
|
|
DLoggingQueue := TIOQueue.Create; // SWB
|
|
end;
|
|
|
|
destructor TApdBaseDispatcher.Destroy;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
if ClosePending then begin
|
|
DonePortPrim
|
|
end else
|
|
DonePort;
|
|
|
|
{ it's possible for the main VCL thread (or whichever thread opened }
|
|
{ the port) to destroy the dispatcher while we're still waiting for }
|
|
{ our Com, Output and Dispatcher threads to terminate, we'll spin }
|
|
{ here waiting for the threads to terminate. }
|
|
while ActiveThreads > 0 do {!!.02}
|
|
SafeYield; {!!.02}
|
|
|
|
LockPortList;
|
|
try
|
|
{ We can't just call Remove since there may be other ports open where }
|
|
{ we use the index into the PortListX array as a handle }
|
|
PortList[PortList.IndexOf(Self)] := nil;
|
|
for i := PortList.Count - 1 downto 0 do
|
|
if PortList[i] = nil then
|
|
PortList.Delete(i)
|
|
else
|
|
break;
|
|
if LastDispatcher = Self then begin
|
|
LastDispatcher := nil;
|
|
LastCID := -1;
|
|
end;
|
|
finally
|
|
UnlockPortList;
|
|
end;
|
|
|
|
while TimerTriggers.Count > 0 do begin
|
|
Dispose(PTimerTrigger(TimerTriggers[0]));
|
|
TimerTriggers.Delete(0);
|
|
end;
|
|
TimerTriggers.Free;
|
|
|
|
while DataTriggers.Count > 0 do begin
|
|
Dispose(PDataTrigger(DataTriggers[0]));
|
|
DataTriggers.Delete(0);
|
|
end;
|
|
DataTriggers.Free;
|
|
|
|
while StatusTriggers.Count > 0 do begin
|
|
Dispose(PStatusTrigger(StatusTriggers[0]));
|
|
StatusTriggers.Delete(0);
|
|
end;
|
|
StatusTriggers.Free;
|
|
|
|
while WndTriggerHandlers.Count > 0 do begin
|
|
Dispose(PWndTriggerHandler(WndTriggerHandlers[0]));
|
|
WndTriggerHandlers.Delete(0);
|
|
end;
|
|
WndTriggerHandlers.Free;
|
|
|
|
while ProcTriggerHandlers.Count > 0 do begin
|
|
Dispose(PProcTriggerHandler(ProcTriggerHandlers[0]));
|
|
ProcTriggerHandlers.Delete(0);
|
|
end;
|
|
ProcTriggerHandlers.Free;
|
|
|
|
while EventTriggerHandlers.Count > 0 do begin
|
|
Dispose(PEventTriggerHandler(EventTriggerHandlers[0]));
|
|
EventTriggerHandlers.Delete(0);
|
|
end;
|
|
EventTriggerHandlers.Free;
|
|
|
|
{Free the critical sections}
|
|
DeleteCriticalSection(DataSection);
|
|
DeleteCriticalSection(OutputSection);
|
|
DeleteCriticalSection(DispSection);
|
|
|
|
if (Assigned(FQueue)) then // SWB
|
|
FQueue.Free; // SWB
|
|
if (Assigned(DLoggingQueue)) then // SWB
|
|
DLoggingQueue.Free; // SWB
|
|
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.RefreshStatus;
|
|
{-Get current ComStatus}
|
|
var
|
|
NewError : Integer;
|
|
begin
|
|
{Get latest ComStatus and LastError}
|
|
NewError := GetComError(ComStatus);
|
|
|
|
{Mask off those bits we don't care about}
|
|
LastError := LastError or (NewError and ValidErrorMask);
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.MapEventsToMS(Events : Integer);
|
|
{-Set bits in ModemStatus according to flags in Events}
|
|
var
|
|
OldMS : Byte;
|
|
Delta : Byte;
|
|
begin
|
|
{Note old, get new}
|
|
OldMS := ModemStatus;
|
|
GetModemStatusPrim($FF);
|
|
|
|
{Set delta bits}
|
|
Delta := (OldMS xor ModemStatus) and $F0;
|
|
ModemStatus := ModemStatus or (Delta shr 4);
|
|
end;
|
|
|
|
{Routines used by constructor}
|
|
|
|
procedure TApdBaseDispatcher.RemoveAllTriggers;
|
|
{-Remove all triggers}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
LenTrigger := 0;
|
|
while TimerTriggers.Count > 0 do begin
|
|
Dispose(PTimerTrigger(TimerTriggers[0]));
|
|
TimerTriggers.Delete(0);
|
|
end;
|
|
while DataTriggers.Count > 0 do begin
|
|
Dispose(PDataTrigger(DataTriggers[0]));
|
|
DataTriggers.Delete(0);
|
|
end;
|
|
while StatusTriggers.Count > 0 do begin
|
|
Dispose(PStatusTrigger(StatusTriggers[0]));
|
|
StatusTriggers.Delete(0);
|
|
end;
|
|
|
|
TriggerCounter := FirstTriggerCounter;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetCommStateFix(var DCB : TDCB) : Integer;
|
|
{-Preserve DTR and RTS states}
|
|
begin
|
|
if not DTRAuto then begin
|
|
DCB.Flags := DCB.Flags and not (dcb_DTRBit1 or dcb_DTRBit2);
|
|
if DTRState then begin
|
|
{ Assert DTR }
|
|
DCB.Flags := DCB.Flags or dcb_DTR_CONTROL_ENABLE;
|
|
end;
|
|
end;
|
|
if not RTSAuto then begin
|
|
DCB.Flags := DCB.Flags and not (dcb_RTSBit1 or dcb_RTSBit2);
|
|
if RTSState then begin
|
|
{ Assert RTS }
|
|
DCB.Flags := DCB.Flags or dcb_RTS_CONTROL_ENABLE;
|
|
end;
|
|
end;
|
|
Result := SetComState(DCB);
|
|
LastBaud := DCB.BaudRate;
|
|
SetDtr(DtrState);
|
|
if not RS485Mode then
|
|
SetRts(RtsState);
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.ResetStatusHits;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := pred(StatusTriggers.Count) downto 0 do
|
|
PStatusTrigger(StatusTriggers[i])^.StatusHit := False;
|
|
GlobalStatHit := False;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.ResetDataTriggers;
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := pred(DataTriggers.Count) downto 0 do
|
|
with PDataTrigger(DataTriggers[i])^ do
|
|
FillChar(tChkIndex, SizeOf(TCheckIndex), 0);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InitPort(
|
|
AComName : PChar;
|
|
Baud : Integer;
|
|
Parity : Cardinal;
|
|
DataBits : TDatabits;
|
|
StopBits : TStopbits;
|
|
InSize, OutSize : Cardinal;
|
|
FlowOpts : DWORD) : Integer;
|
|
type
|
|
OS = record
|
|
O : Cardinal;
|
|
S : Cardinal;
|
|
end;
|
|
var
|
|
Error : Integer;
|
|
begin
|
|
RingFlag := False;
|
|
|
|
{Required inits in case DonePort is called}
|
|
DBuffer := nil;
|
|
OBuffer := nil;
|
|
fEventBusy := False;
|
|
DeletePending := False;
|
|
|
|
{Create event objects}
|
|
ComEvent := CreateEvent(nil, False, False, nil);
|
|
ReadyEvent := CreateEvent(nil, False, False, nil);
|
|
GeneralEvent := CreateEvent(nil, False, False, nil);
|
|
OutputEvent := CreateEvent(nil, False, False, nil);
|
|
SentEvent := CreateEvent(nil, True, False, nil);
|
|
OutFlushEvent := CreateEvent(nil, False, False, nil);
|
|
{wake up xmit thread when it's waiting for data}
|
|
OutWaitObjects1[0] := OutputEvent;
|
|
OutWaitObjects1[1] := OutFlushEvent;
|
|
{wake up xmit thread when it's waiting for i/o completion}
|
|
OutWaitObjects2[0] := SentEvent;
|
|
OutWaitObjects2[1] := OutFlushEvent;
|
|
|
|
{Ask Windows to open the comm port}
|
|
CidEx := OpenCom(AComName, InSize, OutSize);
|
|
if CidEx < 0 then
|
|
begin
|
|
if CidEx = ecOutOfMemory then
|
|
Result := ecOutOfMemory
|
|
else
|
|
Result := -Integer(GetLastError);
|
|
CloseHandle(ComEvent);
|
|
CloseHandle(ReadyEvent);
|
|
CloseHandle(GeneralEvent);
|
|
CloseHandle(OutputEvent);
|
|
CloseHandle(SentEvent);
|
|
CloseHandle(OutFlushEvent);
|
|
DonePort;
|
|
Exit;
|
|
end;
|
|
|
|
{set the buffer sizes}
|
|
Result := SetCommBuffers(InSize, OutSize);
|
|
if Result <> 0 then begin
|
|
DonePort;
|
|
Exit;
|
|
end;
|
|
|
|
{Allocate dispatch buffer}
|
|
DBuffer := AllocMem(DispatchBufferSize);
|
|
|
|
{Allocate output buffer}
|
|
OBuffer := AllocMem(OutSize);
|
|
OBufHead := 0;
|
|
OBufTail := 0;
|
|
OBufFull := False;
|
|
|
|
{Initialize fields}
|
|
InQue := InSize;
|
|
OutQue := OutSize;
|
|
LastError := 0;
|
|
OutSentPending := False;
|
|
ClosePending := False;
|
|
fDispatcherWindow := 0;
|
|
DispatchFull := False;
|
|
GetCount := 0;
|
|
LastLineErr := 0;
|
|
LastModemStatus := 0;
|
|
RS485Mode := False;
|
|
BaseAddress := 0;
|
|
|
|
{Assure DCB is up to date in all cases}
|
|
GetComState(DCB);
|
|
|
|
{ Set initial flow control options }
|
|
if (FlowOpts and ipAutoDTR) <> 0 then begin
|
|
DTRAuto := True;
|
|
end else begin
|
|
DTRAuto := False;
|
|
SetDTR((FlowOpts and ipAssertDTR) <> 0);
|
|
end;
|
|
|
|
if (FlowOpts and ipAutoRTS) <> 0 then begin
|
|
RTSAuto := True;
|
|
end else begin
|
|
RTSAuto := False;
|
|
SetRTS((FlowOpts and ipAssertRTS) <> 0);
|
|
end;
|
|
|
|
{Trigger inits}
|
|
LastTailData := 0;
|
|
LastTailLen := 1;
|
|
RemoveAllTriggers;
|
|
DBufHead := 0;
|
|
DBufTail := 0;
|
|
NotifyTail := 0;
|
|
ResetStatusHits;
|
|
|
|
InAvailMessage := False;
|
|
|
|
ModemStatus := 0;
|
|
GetModemStatusPrim($F0);
|
|
|
|
{Set the requested line parameters}
|
|
LastBaud := 115200;
|
|
|
|
Error := SetLine(Baud, Parity, DataBits, StopBits);
|
|
if Error <> ecOk then begin
|
|
Result := Error;
|
|
DonePort;
|
|
Exit;
|
|
end;
|
|
|
|
{Get initial status}
|
|
RefreshStatus;
|
|
|
|
TracingOn := False;
|
|
TraceQueue := nil;
|
|
TraceIndex := 0;
|
|
TraceMax := 0;
|
|
TraceWrapped := False;
|
|
|
|
TimeBase := AdTimeGetTime;
|
|
DLoggingOn := False;
|
|
DLoggingMax := 0;
|
|
|
|
{Start the dispatcher}
|
|
StartDispatcher;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InitSocket(Insize, OutSize : Cardinal) : Integer;
|
|
begin
|
|
Result := ecOK;
|
|
|
|
{Create a socket}
|
|
CidEx := OpenCom(nil, InSize, OutSize);
|
|
if CidEx < 0 then begin
|
|
Result := -CidEx;
|
|
DonePort;
|
|
Exit;
|
|
end;
|
|
|
|
{Connect or bind socket}
|
|
if not SetupCom(0, 0) then begin
|
|
Result := -GetComError(ComStatus);
|
|
DonePort;
|
|
Exit;
|
|
end;
|
|
|
|
{Allocate dispatch buffer}
|
|
DBuffer := AllocMem(DispatchBufferSize);
|
|
|
|
{Initialize fields}
|
|
InQue := InSize;
|
|
OutQue := OutSize;
|
|
|
|
{Trigger inits}
|
|
LastTailLen := 1;
|
|
|
|
{Set default options}
|
|
ModemStatus := 0;
|
|
|
|
{Get initial status}
|
|
RefreshStatus;
|
|
|
|
TimeBase := AdTimeGetTime;
|
|
|
|
{Start the dispatcher}
|
|
StartDispatcher;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetCommBuffers(InSize, OutSize : Integer) : Integer;
|
|
{-Set the new buffer sizes, win32 only}
|
|
begin
|
|
if SetupCom(InSize, OutSize) then
|
|
Result := ecOK
|
|
else
|
|
Result := -Integer(GetLastError);
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.DonePortPrim;
|
|
{-Close the port and free the handle}
|
|
begin
|
|
{Stop dispatcher}
|
|
DoDonePortPrim := False; {!!.02}
|
|
if DispActive then
|
|
StopDispatcher;
|
|
{ Free memory for the output buffer }
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if OBuffer <> nil then begin
|
|
FreeMem(OBuffer);
|
|
OBuffer := nil;
|
|
end;
|
|
|
|
{ Free memory for the dispatcher buffer }
|
|
if DBuffer <> nil then begin
|
|
FreeMem(DBuffer, DispatchBufferSize);
|
|
DBuffer := nil;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.DonePort;
|
|
{-Close the port and free the handle}
|
|
begin
|
|
{Always close the physical port...}
|
|
if CidEx >= 0 then begin
|
|
{Flush the output queue}
|
|
FlushOutBuffer;
|
|
FlushInBuffer;
|
|
|
|
CloseCom;
|
|
end;
|
|
|
|
{...but destroy our object only if not within a notify}
|
|
if fEventBusy then begin
|
|
ClosePending := True;
|
|
end else
|
|
DonePortPrim;
|
|
end;
|
|
|
|
function ActualBaud(BaudCode : Integer) : Integer;
|
|
const
|
|
BaudTable : array[0..23] of Integer =
|
|
(110, 300, 600, 1200, 2400, 4800, 9600, 14400,
|
|
19200, 0, 0, 38400, 0, 0, 0, 56000,
|
|
0, 0, 0, 128000, 0, 0, 0, 256000);
|
|
var
|
|
Index : Cardinal;
|
|
Baud : Integer;
|
|
begin
|
|
if BaudCode = $FEFF then
|
|
{COMM.DRV's 115200 hack}
|
|
Result := 115200
|
|
else if BaudCode < $FF10 then
|
|
{Must be a baud rate, return it}
|
|
Result := BaudCode
|
|
else begin
|
|
{It's a code, look it up}
|
|
Index := BaudCode - $FF10;
|
|
if Index > 23 then
|
|
{Unknown code, just return it}
|
|
Result := BaudCode
|
|
else begin
|
|
Baud := BaudTable[Index];
|
|
if Baud = 0 then
|
|
{Unknown code, just return it}
|
|
Result := BaudCode
|
|
else
|
|
Result := Baud;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Wait till pending Tx Data is sent for H -- used for line parameter }
|
|
{ changes -- so the data in the buffer at the time the change is made }
|
|
{ goes out under the "old" line parameters. }
|
|
procedure TApdBaseDispatcher.WaitTxSent;
|
|
var
|
|
BitsPerChar : DWORD;
|
|
BPS : Integer;
|
|
MicroSecsPerBit : DWORD;
|
|
MicroSecs : DWORD;
|
|
MilliSecs : DWORD;
|
|
TxWaitCount : Integer;
|
|
begin
|
|
{ Wait till our Output Buffer becomes free. }
|
|
{ If output hasn't drained in 10 seconds, punt. }
|
|
TxWaitCount := 0;
|
|
while((OutBuffUsed > 0) and (TxWaitCount < 5000)) do begin
|
|
Sleep(2);
|
|
Inc(TxWaitCount);
|
|
end;
|
|
|
|
{ Delay based upon a 16-character TX FIFO + 1 character for TX output }
|
|
{ register + 1 extra character for slop (= 18). Delay is based upon }
|
|
{ 1/bps * (start bit + data bits + parity bit + stop bits). }
|
|
|
|
GetComState(DCB);
|
|
BitsPerChar := DCB.ByteSize + 2; { Bits per Char + 1 start + 1 stop }
|
|
if (DCB.Parity <> 0) then
|
|
Inc(BitsPerChar);
|
|
if (DCB.StopBits <> 0) then
|
|
Inc(BitsPerChar);
|
|
BPS := ActualBaud(LastBaud);
|
|
MicroSecsPerBit := 10000000 div BPS;
|
|
MicroSecs := MicroSecsPerBit * BitsPerChar * 18;
|
|
if (MicroSecs < 10000) then
|
|
MicroSecs := MicroSecs + MicroSecs;
|
|
MilliSecs := Microsecs div 10000;
|
|
if ((Microsecs mod 10000) <> 0) then
|
|
Inc(MilliSecs);
|
|
Sleep(MilliSecs);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.WriteComSafe(ABuf: PAnsiChar; ASize: Integer): Integer;
|
|
begin
|
|
try
|
|
Result := WriteCom(ABuf, ASize);
|
|
except
|
|
on E: EAccessViolation do
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetLine(
|
|
Baud : Integer;
|
|
Parity : Cardinal;
|
|
DataBits : TDatabits;
|
|
StopBits : TStopbits) : Integer;
|
|
var
|
|
NewBaudRate : DWORD;
|
|
NewParity : Cardinal;
|
|
NewByteSize : TDatabits;
|
|
NewStopBits : Byte;
|
|
NewFlags : Integer; // SWB
|
|
{-Set or change the line parameters}
|
|
begin
|
|
Result := ecOK;
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Get current DCB parameters}
|
|
GetComState(DCB);
|
|
|
|
{Set critical default DCB options}
|
|
NewFlags := DCB.Flags; // SWB
|
|
NewFlags := NewFlags or dcb_Binary; // SWB
|
|
NewFlags := NewFlags and not dcb_Parity; // SWB
|
|
NewFlags := NewFlags and not dcb_DsrSensitivity; // SWB
|
|
NewFlags := NewFlags or dcb_TxContinueOnXoff; // SWB
|
|
NewFlags := NewFlags and not dcb_Null; // SWB
|
|
NewFlags := NewFlags and not dcb_Null; // SWB
|
|
|
|
{Validate stopbit range}
|
|
if StopBits <> DontChangeStopBits then
|
|
if StopBits < 1 then
|
|
StopBits := 1
|
|
else if StopBits > 2 then
|
|
StopBits := 2;
|
|
|
|
{Determine new line parameters}
|
|
if Baud <> DontChangeBaud then begin
|
|
NewBaudRate := Baud;
|
|
end else
|
|
NewBaudRate := DCB.BaudRate;
|
|
|
|
if Parity <> DontChangeParity then
|
|
NewParity := Parity
|
|
else
|
|
NewParity := DCB.Parity;
|
|
|
|
NewStopBits := DCB.StopBits;
|
|
|
|
if DataBits <> DontChangeDataBits then
|
|
begin
|
|
NewByteSize := DataBits;
|
|
if (DataBits = 5) then
|
|
NewStopBits := One5StopBits;
|
|
end else
|
|
NewByteSize := DCB.ByteSize;
|
|
|
|
if StopBits <> DontChangeStopBits then begin
|
|
NewStopBits := StopBitArray[StopBits];
|
|
if (NewByteSize = 5) then
|
|
NewStopBits := One5StopBits;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
|
|
if ((DCB.BaudRate = NewBaudRate) and
|
|
(DCB.Parity = NewParity) and
|
|
(DCB.ByteSize = NewByteSize) and
|
|
(DCB.StopBits = NewStopBits) and // SWB
|
|
(DCB.Flags = NewFlags)) then // SWB
|
|
Exit;
|
|
|
|
{ wait for the chars to be transmitted, don't want to change line }
|
|
{ settings while chars are pending }
|
|
WaitTxSent;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Get current DCB parameters}
|
|
GetComState(DCB);
|
|
|
|
{Change the parameters}
|
|
DCB.BaudRate := NewBaudRate;
|
|
DCB.Parity := NewParity;
|
|
DCB.ByteSize := NewByteSize;
|
|
DCB.StopBits := NewStopBits;
|
|
DCB.Flags := NewFlags; // SWB
|
|
|
|
{Set line parameters}
|
|
Result := SetCommStateFix(DCB);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.GetLine(
|
|
var Baud : Integer;
|
|
var Parity : Word;
|
|
var DataBits : TDatabits;
|
|
var StopBits : TStopbits);
|
|
{-Return line parameters}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Get current DCB parameters}
|
|
GetComState(DCB);
|
|
|
|
{Return the line parameters}
|
|
Baud := ActualBaud(DCB.Baudrate);
|
|
|
|
Parity := DCB.Parity;
|
|
DataBits := DCB.ByteSize;
|
|
if DCB.StopBits = OneStopBit then
|
|
StopBits := 1
|
|
else
|
|
StopBits := 2;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetModem(Dtr, Rts : Boolean) : Integer;
|
|
{-Set modem control lines, Dtr and Rts}
|
|
begin
|
|
Result := SetDtr(Dtr);
|
|
if Result = ecOK then
|
|
Result := SetRts(Rts); {!!.02}
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetDtr(OnOff : Boolean) : Integer;
|
|
{-Set DTR modem control line}
|
|
begin
|
|
if DtrAuto then begin
|
|
{ We can't change DTR if we're controlling it automatically }
|
|
Result := 1;
|
|
Exit;
|
|
end;
|
|
|
|
if (OnOff = True) then
|
|
Result := EscapeComFunction(Windows.SETDTR)
|
|
else
|
|
Result := EscapeComFunction(Windows.CLRDTR);
|
|
|
|
if (Result < ecOK) then
|
|
Result := ecBadArgument;
|
|
DTRState := OnOff;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetRts(OnOff : Boolean) : Integer;
|
|
{-Set RTS modem control line}
|
|
begin
|
|
if RtsAuto then begin
|
|
{ We can't change RTS if we're controlling it automatically }
|
|
Result := 1;
|
|
Exit;
|
|
end;
|
|
|
|
if (OnOff = True) then
|
|
Result := EscapeComFunction(Windows.SETRTS)
|
|
else
|
|
Result := EscapeComFunction(Windows.CLRRTS);
|
|
|
|
if (Result < ecOK) then
|
|
Result := ecBadArgument;
|
|
RTSState := OnOff;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetModemStatusPrim(ClearMask : Byte) : Byte;
|
|
{-Primitive to return the modem status and clear mask}
|
|
var
|
|
Data : DWORD;
|
|
begin
|
|
{Get the new absolute values}
|
|
// There is no reason for this to be inside the critical section // SWB
|
|
// and since this can be a very slow function when using mapped // SWB
|
|
// comm ports under Citrix or W2K3 I moved it out here. // SWB
|
|
GetCommModemStatus(CidEx, Data); // SWB
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
ModemStatus := (ModemStatus and $0F) or Byte(Data);
|
|
|
|
{Special case, transfer RI bit to TERI bit}
|
|
if RingFlag then begin
|
|
RingFlag := False;
|
|
ModemStatus := ModemStatus or $04;
|
|
end;
|
|
|
|
{Return the current ModemStatus value}
|
|
Result := Lo(ModemStatus);
|
|
|
|
{Clear specified delta bits}
|
|
ModemStatus := ModemStatus and Clearmask;
|
|
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetModemStatus : Byte;
|
|
{-Return the modem status byte and clear the delta bits}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDelta);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckCTS : Boolean;
|
|
{-Returns True if CTS is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaCTS) and CTSMask = CTSMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDSR : Boolean;
|
|
{-Returns True if DSR is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaDSR) and DSRMask = DSRMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckRI : Boolean;
|
|
{-Returns True if RI is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaRI) and RIMask = RIMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDCD : Boolean;
|
|
{-Returns True if DCD is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaDCD) and DCDMask = DCDMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDeltaCTS : Boolean;
|
|
{-Returns True if DeltaCTS is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaCTS) and DeltaCTSMask = DeltaCTSMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDeltaDSR : Boolean;
|
|
{-Returns True if DeltaDSR is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaDSR) and DeltaDSRMask = DeltaDSRMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDeltaRI : Boolean;
|
|
{-Returns True if DeltaRI is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaRI) and DeltaRIMask = DeltaRIMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckDeltaDCD : Boolean;
|
|
{-Returns True if DeltaDCD is high}
|
|
begin
|
|
Result := GetModemStatusPrim(ClearDeltaDCD) and DeltaDCDMask = DeltaDCDMask;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetLineError : Integer;
|
|
{-Return current line errors}
|
|
const
|
|
AllErrorMask = ce_RxOver +
|
|
ce_Overrun + ce_RxParity + ce_Frame;
|
|
var
|
|
GotError : Boolean;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
GotError := True;
|
|
if FlagIsSet(LastError, ce_RxOver) then
|
|
Result := leBuffer
|
|
else if FlagIsSet(LastError, ce_Overrun) then
|
|
Result := leOverrun
|
|
else if FlagIsSet(LastError, ce_RxParity) then
|
|
Result := leParity
|
|
else if FlagIsSet(LastError, ce_Frame) then
|
|
Result := leFraming
|
|
else if FlagIsSet(LastError, ce_Break) then
|
|
Result := leBreak
|
|
else begin
|
|
GotError := False;
|
|
Result := leNoError;
|
|
end;
|
|
|
|
{Clear all error flags}
|
|
if GotError then
|
|
LastError := LastError and not AllErrorMask;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckLineBreak : Boolean;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Result := FlagIsSet(LastError, ce_Break);
|
|
LastError := LastError and not ce_Break;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.SendBreak(Ticks : Cardinal; Yield : Boolean);
|
|
{Send a line break of Ticks ticks, with yields}
|
|
begin
|
|
{ raise RTS for RS485 mode }
|
|
if RS485Mode then {!!.01}
|
|
SetRTS(True); {!!.01}
|
|
SetCommBreak(CidEx);
|
|
DelayTicks(Ticks, Yield);
|
|
ClearCommBreak(CidEx);
|
|
{ lower RTS only if the output buffer is empty }
|
|
if RS485Mode and (OutBuffUsed = 0) then {!!.01}
|
|
SetRTS(False); {!!.01}
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.SetBreak(BreakOn: Boolean);
|
|
{Sets or clears line break condition}
|
|
begin
|
|
if BreakOn then begin {!!.01}
|
|
if RS485Mode then {!!.01}
|
|
SetRTS(True); {!!.01}
|
|
SetCommBreak(CidEx)
|
|
end else begin {!!.01}
|
|
ClearCommBreak(CidEx);
|
|
if RS485Mode and (OutBuffUsed = 0) then {!!.01}
|
|
SetRTS(False); {!!.01}
|
|
end; {!!.01}
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CharReady : Boolean;
|
|
{-Return True if at least one character is ready at the device driver}
|
|
var
|
|
NewTail : Cardinal;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
if InAvailMessage then begin
|
|
NewTail := DBufTail + GetCount;
|
|
if NewTail >= DispatchBufferSize then
|
|
Dec(NewTail, DispatchBufferSize);
|
|
Result := (DBufHead <> NewTail)
|
|
or (DispatchFull and (GetCount < DispatchBufferSize));
|
|
end else
|
|
Result := (DBufHead <> DBufTail) or DispatchFull;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PeekCharPrim(var C : AnsiChar; Count : Cardinal) : Integer;
|
|
{-Return the Count'th character but don't remove it from the buffer}
|
|
var
|
|
NewTail : Cardinal;
|
|
InCount : Cardinal;
|
|
begin
|
|
Result := ecOK;
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
if DBufHead > DBufTail then
|
|
InCount := DBufHead-DBufTail
|
|
else if DBufHead <> DBufTail then
|
|
InCount := ((DBufHead+DispatchBufferSize)-DBufTail)
|
|
else if DispatchFull then
|
|
InCount := DispatchBufferSize
|
|
else
|
|
InCount := 0;
|
|
|
|
if InCount >= Count then begin
|
|
{Calculate index of requested character}
|
|
NewTail := DBufTail + (Count - 1);
|
|
if NewTail >= DispatchBufferSize then
|
|
NewTail := (NewTail - DispatchBufferSize);
|
|
C := DBuffer^[NewTail];
|
|
end else
|
|
Result := ecBufferIsEmpty;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PeekChar(var C : AnsiChar; Count : Cardinal) : Integer;
|
|
{-Return the Count'th character but don't remove it from the buffer}
|
|
{-Account for GetCount}
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
if InAvailMessage then
|
|
Inc(Count, GetCount);
|
|
Result := PeekCharPrim(C, Count);
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetChar(var C : AnsiChar) : Integer;
|
|
{-Return next char and remove it from buffer}
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{If within an apw_TriggerAvail message then do not physically }
|
|
{extract the character. It will be removed by the dispatcher after }
|
|
{all trigger handlers have seen it. If not within an }
|
|
{apw_TriggerAvail message then physically extract the character }
|
|
|
|
if InAvailMessage then begin
|
|
Inc(GetCount);
|
|
Result := PeekCharPrim(C, GetCount);
|
|
if Result < ecOK then begin
|
|
Dec(GetCount);
|
|
Exit;
|
|
end;
|
|
end else begin
|
|
Result := PeekCharPrim(C, 1);
|
|
if Result >= ecOK then begin
|
|
{Increment the tail index}
|
|
Inc(DBufTail);
|
|
if DBufTail = DispatchBufferSize then
|
|
DBufTail := 0;
|
|
DispatchFull := False;
|
|
end;
|
|
end;
|
|
|
|
if TracingOn
|
|
and (Result >= ecOK) then
|
|
AddTraceEntry('R', C);
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PeekBlockPrim(Block : PAnsiChar;
|
|
Offset : Cardinal; Len : Cardinal; var NewTail : Cardinal) : Integer;
|
|
{-Return Block from ComPort, return new tail value}
|
|
var
|
|
Count : Cardinal;
|
|
EndCount : Cardinal;
|
|
BeginCount : Cardinal;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{Get count}
|
|
Count := BuffCount(DBufHead, DBufTail, DispatchFull);
|
|
|
|
{Set new tail value}
|
|
NewTail := DBufTail + Offset;
|
|
if NewTail >= DispatchBufferSize then
|
|
Dec(NewTail, DispatchBufferSize);
|
|
|
|
if Count >= Len then begin
|
|
{Set begin/end buffer counts}
|
|
if NewTail+Len < DispatchBufferSize then begin
|
|
EndCount := Len;
|
|
BeginCount := 0;
|
|
end else begin
|
|
EndCount := (DispatchBufferSize-NewTail);
|
|
BeginCount := Len-EndCount;
|
|
end;
|
|
|
|
if EndCount <> 0 then begin
|
|
{Move data from end of dispatch buffer}
|
|
Move(DBuffer^[NewTail], Pointer(Block)^, EndCount);
|
|
Inc(NewTail, EndCount);
|
|
end;
|
|
|
|
if BeginCount <> 0 then begin
|
|
{Move data from beginning of dispatch buffer}
|
|
Move(DBuffer^[0],
|
|
PByteBuffer(Block)^[EndCount+1],
|
|
BeginCount);
|
|
NewTail := BeginCount;
|
|
end;
|
|
|
|
{Wrap newtail}
|
|
if NewTail = DispatchBufferSize then
|
|
NewTail := 0;
|
|
|
|
Result := Len;
|
|
end else
|
|
Result := ecBufferIsEmpty;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PeekBlock(Block : PAnsiChar; Len : Cardinal) : Integer;
|
|
{-Return Block from ComPort but don't set new tail value}
|
|
var
|
|
Tail : Cardinal;
|
|
Offset : Cardinal;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{Get block}
|
|
if InAvailMessage then
|
|
Offset := GetCount
|
|
else
|
|
Offset := 0;
|
|
Result := PeekBlockPrim(Block, Offset, Len, Tail);
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetBlock(Block : PAnsiChar; Len : Cardinal) : Integer;
|
|
{-Get Block from ComPort and set new tail}
|
|
var
|
|
Tail : Cardinal;
|
|
I : Cardinal;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{ If within an apw_TriggerAvail message then do not physically }
|
|
{ extract the data. It will be removed by the dispatcher after }
|
|
{ all trigger handlers have seen it. If not within an }
|
|
{ apw_TriggerAvail message, then physically extract the data }
|
|
|
|
if InAvailMessage then begin
|
|
Result := PeekBlockPrim(Block, GetCount, Len, Tail);
|
|
if Result > 0 then
|
|
Inc(GetCount, Result);
|
|
end else begin
|
|
Result := PeekBlockPrim(Block, 0, Len, Tail);
|
|
if Result > 0 then begin
|
|
DBufTail := Tail;
|
|
DispatchFull := False;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if TracingOn and (Result > 0) then
|
|
for I := 0 to Result-1 do
|
|
AddTraceEntry('R', Block[I]);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PutChar(C : AnsiChar) : Integer;
|
|
{-Route through PutBlock to transmit a single character}
|
|
begin
|
|
Result := PutBlock(C, 1);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PutString(S : AnsiString) : Integer;
|
|
{-Send as a block}
|
|
begin
|
|
Result := PutBlock(S[1], Length(S));
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.AddStringToLog(S : Ansistring);
|
|
begin
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtUser, dstNone, 0, @S[1], length(S) * SizeOf(AnsiChar))
|
|
end;
|
|
|
|
function TApdBaseDispatcher.PutBlock(const Block; Len : Cardinal) : Integer;
|
|
{-Send Block to CommPort}
|
|
var
|
|
Avail : Cardinal;
|
|
I : Cardinal;
|
|
CharsOut : Integer; {Chars transmitted from last block}
|
|
begin
|
|
{Exit immediately if nothing to do}
|
|
Result := ecOK;
|
|
if Len = 0 then
|
|
Exit;
|
|
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
{ Is there enough free space in the outbuffer? }
|
|
{LastError := GetComError(ComStatus); // SWB
|
|
Avail := OutQue - ComStatus.cbOutQue;} // SWB
|
|
// The old method of determining available space in the output buffer // SWB
|
|
// was agonizingly slow when using mapped com ports under Citrix or // SWB
|
|
// Windows 2003. Replaced call to GetComError with a call that // SWB
|
|
// returns only the used buffer space. // SWB
|
|
Avail := OutQue - OutBufUsed; // SWB
|
|
if Avail < Len then begin
|
|
Result := ecOutputBufferTooSmall;
|
|
Exit;
|
|
end;
|
|
if Avail = Len then
|
|
OBufFull := True;
|
|
|
|
{ Raise RTS if in RS485 mode. In 32bit mode it will be lowered }
|
|
{ by the output thread. }
|
|
if Win32Platform <> VER_PLATFORM_WIN32_NT then
|
|
if RS485Mode then begin
|
|
if BaseAddress = 0 then begin
|
|
Result := ecBaseAddressNotSet;
|
|
Exit;
|
|
end;
|
|
SetRTS(True);
|
|
end;
|
|
|
|
{Send the data}
|
|
CharsOut := WriteCom(PAnsiChar(@Block), Len);
|
|
if CharsOut <= 0 then begin
|
|
CharsOut := Abs(CharsOut);
|
|
Result := ecPutBlockFail;
|
|
LastError := GetComError(ComStatus);
|
|
end;
|
|
|
|
{Flag output trigger}
|
|
OutSentPending := True;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if DLoggingOn then
|
|
if CharsOut = 0 then
|
|
AddDispatchEntry(dtDispatch, dstWriteCom, 0, nil, 0)
|
|
else
|
|
AddDispatchEntry(dtDispatch, dstWriteCom, CharsOut,
|
|
PAnsiChar(@Block), CharsOut);
|
|
|
|
if TracingOn and (CharsOut <> 0) then
|
|
for I := 0 to CharsOut-1 do
|
|
AddTraceEntry('T', PAnsiChar(@Block)[I]);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InBuffUsed : Cardinal;
|
|
{-Return number of bytes currently in input buffer}
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
if DBufHead = DBufTail then
|
|
if DispatchFull then
|
|
Result := DispatchBufferSize
|
|
else
|
|
Result := 0
|
|
else if DBufHead > DBufTail then
|
|
Result := DBufHead-DBufTail
|
|
else
|
|
Result := (DBufHead+DispatchBufferSize)-DBufTail;
|
|
|
|
if InAvailMessage then
|
|
{In apw_TriggerAvail message so reduce by retrieved chars}
|
|
Dec(Result, GetCount);
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InBuffFree : Cardinal;
|
|
{-Return number of bytes free in input buffer}
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
if DBufHead = DBufTail then
|
|
if DispatchFull then
|
|
Result := 0
|
|
else
|
|
Result := DispatchBufferSize
|
|
else if DBufHead > DBufTail then
|
|
Result := (DBufTail+DispatchBufferSize)-DBufHead
|
|
else
|
|
Result := DBufTail-DBufHead;
|
|
|
|
if InAvailMessage then
|
|
{In apw_TriggerAvail message so reduce by retrieved chars}
|
|
Inc(Result, GetCount);
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.OutBuffUsed : Cardinal;
|
|
{-Return number of bytes currently in output buffer}
|
|
begin
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
RefreshStatus;
|
|
Result := ComStatus.cbOutQue;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.OutBuffFree : Cardinal;
|
|
{-Return number of bytes free in output buffer}
|
|
begin
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
RefreshStatus;
|
|
Result := OutQue - ComStatus.cbOutQue;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.FlushOutBuffer : Integer;
|
|
{-Flush the output buffer}
|
|
begin
|
|
Result := FlushCom(0);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.FlushInBuffer : Integer;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{Flush COMM buffer}
|
|
Result := FlushCom(1);
|
|
|
|
{Flush the dispatcher's buffer}
|
|
if InAvailMessage then
|
|
MaxGetCount := BuffCount(DBufHead, DBufTail, DispatchFull)
|
|
else begin
|
|
DBufTail := DBufHead;
|
|
GetCount := 0;
|
|
end;
|
|
DispatchFull := False;
|
|
|
|
{Reset data triggers}
|
|
ResetDataTriggers;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.BufferSizes(var InSize, OutSize : Cardinal);
|
|
{-Return buffer sizes}
|
|
begin
|
|
InSize := InQue;
|
|
OutSize := OutQue;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.HWFlowOptions(
|
|
BufferFull, BufferResume : Cardinal;
|
|
Options : Cardinal) : Integer;
|
|
{-Turn on hardware flow control}
|
|
begin
|
|
{Validate the buffer points}
|
|
if (BufferResume > BufferFull) or
|
|
(BufferFull > InQue) then begin
|
|
Result := ecBadArgument;
|
|
Exit;
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
GetComState(DCB);
|
|
with DCB do begin
|
|
Flags := Flags and not (AllHdwFlow);
|
|
Flags := Flags and not (dcb_DTRBit1 or dcb_RTSBit1);
|
|
DtrAuto := False;
|
|
RtsAuto := False;
|
|
|
|
{Receive flow control, set requested signal(s)}
|
|
if FlagIsSet(Options, hfUseDtr) then begin
|
|
Flags := Flags or dcb_DTR_CONTROL_HANDSHAKE;
|
|
DtrAuto := True;
|
|
end else begin
|
|
{ If static DTR wanted }
|
|
if DTRState then
|
|
{ then assert DTR }
|
|
Flags := Flags or dcb_DTR_CONTROL_ENABLE;
|
|
end;
|
|
|
|
if FlagIsSet(Options, hfUseRts) then begin
|
|
Flags := Flags or dcb_RTS_CONTROL_HANDSHAKE;
|
|
RtsAuto := True;
|
|
end else begin
|
|
{ If static RTS wanted }
|
|
if RTSState then
|
|
{ then assert RTS }
|
|
Flags := Flags or dcb_RTS_CONTROL_ENABLE;
|
|
end;
|
|
|
|
if RS485Mode and (Win32Platform = VER_PLATFORM_WIN32_NT) then begin
|
|
Flags := Flags or dcb_RTS_CONTROL_TOGGLE;
|
|
RtsAuto := True;
|
|
end;
|
|
|
|
{Set receive flow buffer limits}
|
|
XoffLim := InQue - BufferFull;
|
|
XonLim := BufferResume;
|
|
|
|
{Transmit flow control, set requested signal(s)}
|
|
if FlagIsSet(Options, hfRequireDsr) then
|
|
Flags := Flags or dcb_OutxDsrFlow;
|
|
|
|
if FlagIsSet(Options, hfRequireCts) then
|
|
Flags := Flags or dcb_OutxCtsFlow;
|
|
|
|
{Set new DCB}
|
|
Result := SetCommStateFix(DCB);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.HWFlowState : Integer;
|
|
{-Returns state of flow control}
|
|
begin
|
|
with DCB do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if not FlagIsSet(Flags, AllHdwFlow) then begin
|
|
Result := fsOff;
|
|
Exit;
|
|
end else
|
|
Result := fsOn;
|
|
|
|
if Flags and InHdwFlow <> 0 then begin
|
|
{Get latest flow status}
|
|
RefreshStatus;
|
|
|
|
{Set appropriate flow state}
|
|
if (Flags and dcb_OutxDsrFlow <> 0) and
|
|
(fDsrHold in ComStatus.Flags) then
|
|
Result := fsDsrHold;
|
|
|
|
if (Flags and dcb_OutxCtsFlow <> 0) and
|
|
(fCtlHold in ComStatus.Flags) then
|
|
Result := fsCtsHold;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SWFlowEnable(
|
|
BufferFull, BufferResume : Cardinal;
|
|
Options : Cardinal) : Integer;
|
|
{-Turn on software flow control}
|
|
begin
|
|
{Validate the buffer points}
|
|
if (BufferResume > BufferFull) or
|
|
(BufferFull > InQue) then begin
|
|
Result := ecBadArgument;
|
|
Exit;
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{ Make sure we have an up-to-date DCB }
|
|
GetComState(DCB);
|
|
with DCB do begin
|
|
if FlagIsSet(Options, sfReceiveFlow) then begin
|
|
{Receive flow control}
|
|
Flags := Flags or dcb_InX;
|
|
|
|
{Set receive flow buffer limits}
|
|
XoffLim := InQue - BufferFull;
|
|
XonLim := BufferResume;
|
|
|
|
{Set flow control characters}
|
|
XOnChar := cXon;
|
|
XOffChar := cXoff;
|
|
end;
|
|
|
|
if FlagIsSet(Options, sfTransmitFlow) then begin
|
|
{Transmit flow control}
|
|
Flags := Flags or dcb_OutX;
|
|
|
|
{Set flow control characters}
|
|
XOnChar := cXon;
|
|
XOffChar := cXoff;
|
|
end;
|
|
|
|
{Set new DCB}
|
|
Result := SetCommStateFix(DCB);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SWFlowDisable : Integer;
|
|
{-Turn off all software flow control}
|
|
begin
|
|
with DCB do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{ Make sure we have an up-to-date DCB }
|
|
GetComState(DCB);
|
|
Flags := Flags and not AllSfwFlow;
|
|
Result := SetCommStateFix(DCB);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SWFlowState : Integer;
|
|
{-Returns state of flow control}
|
|
begin
|
|
with DCB do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if FlagIsSet(Flags, dcb_InX) or FlagIsSet(Flags, dcb_OutX) then
|
|
Result := fsOn
|
|
else begin
|
|
Result := fsOff;
|
|
Exit;
|
|
end;
|
|
|
|
{Get latest flow status}
|
|
RefreshStatus;
|
|
|
|
{Set appropriate flow state}
|
|
if (fXoffHold in ComStatus.Flags) then
|
|
if (fXoffSent in ComStatus.Flags) then
|
|
Result := fsXBothHold
|
|
else
|
|
Result := fsXOutHold
|
|
else if (fXoffSent in ComStatus.Flags) then
|
|
Result := fsXInHold;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SWFlowChars(OnChar, OffChar : AnsiChar) : Integer;
|
|
{-Set on/off chars for software flow control}
|
|
begin
|
|
with DCB do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{ Make sure we have an up-to-date DCB }
|
|
GetComState(DCB);
|
|
|
|
{Set flow control characters}
|
|
XOnChar := OnChar;
|
|
XOffChar := OffChar;
|
|
Result := SetCommStateFix(DCB);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SendNotify(Msg, Trigger, Data: Cardinal) : Boolean;
|
|
{-Send trigger messages, return False to stop checking triggers}
|
|
var
|
|
lParam : DWORD;
|
|
Res : DWORD;
|
|
i : Integer;
|
|
begin
|
|
Result := True;
|
|
|
|
if not HandlerServiceNeeded then Exit;
|
|
|
|
{Don't let dispatcher change anything while sending messages}
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
fEventBusy := True;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
|
|
try
|
|
MaxGetCount := 0;
|
|
|
|
{Flag apw_TriggerAvail messages}
|
|
InAvailMessage := (Msg = apw_TriggerAvail) or (Msg = apw_TriggerData);
|
|
|
|
{Clear trigger handle modification flags}
|
|
lParam := (DWORD(fHandle) shl 16) + Data;
|
|
|
|
for i := 0 to pred(EventTriggerHandlers.Count) do
|
|
with PEventTriggerHandler(EventTriggerHandlers[i])^ do begin
|
|
GetCount := 0;
|
|
|
|
if not thDeleted then
|
|
if thSync then
|
|
DispThread.SyncNotify(Msg,Trigger,lParam,thNotify)
|
|
else
|
|
thNotify(Msg, Trigger, lParam);
|
|
|
|
if ClosePending then begin
|
|
{Port was closed by event handler, bail out}
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
|
|
{Note deepest look at input buffer}
|
|
if GetCount > MaxGetCount then
|
|
MaxGetCount := GetCount;
|
|
end;
|
|
|
|
for i := 0 to pred(ProcTriggerHandlers.Count) do
|
|
with PProcTriggerHandler(ProcTriggerHandlers[i])^ do begin
|
|
GetCount := 0;
|
|
|
|
if not thDeleted and (@thNotify <> nil) then
|
|
thNotify(Msg, Trigger, lParam);
|
|
|
|
if ClosePending then begin
|
|
{Port was closed by event handler, bail out}
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
|
|
{Note deepest look at input buffer}
|
|
if GetCount > MaxGetCount then
|
|
MaxGetCount := GetCount;
|
|
end;
|
|
|
|
if (WndTriggerHandlers.Count > 1) or PortHandlerInstalled then
|
|
for i := 0 to pred(WndTriggerHandlers.Count) do
|
|
with PWndTriggerHandler(WndTriggerHandlers[i])^ do begin
|
|
GetCount := 0;
|
|
|
|
if not thDeleted then
|
|
SendMessageTimeout(thWnd, Msg, Trigger, lParam,
|
|
SMTO_BLOCK, 3000, @Res);
|
|
|
|
if ClosePending then begin
|
|
{Port was closed by event handler, bail out}
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
|
|
{Note deepest look at input buffer}
|
|
if GetCount > MaxGetCount then
|
|
MaxGetCount := GetCount;
|
|
end;
|
|
|
|
{ If in apw_TriggerAvail message remove the data now }
|
|
if InAvailMessage then begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
InAvailMessage := False;
|
|
Inc(DBufTail, MaxGetCount);
|
|
if DBufTail >= DispatchBufferSize then
|
|
Dec(DBufTail, DispatchBufferSize);
|
|
if MaxGetCount <> 0 then
|
|
DispatchFull := False;
|
|
|
|
{Force CheckTriggers to exit if another avail msg is pending}
|
|
{Note: for avail msgs, trigger is really the byte count}
|
|
if (Msg = apw_TriggerAvail) and (MaxGetCount <> Trigger) then
|
|
Result := False;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
finally
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
fEventBusy := False;
|
|
|
|
if DeletePending then begin
|
|
|
|
for i := pred(WndTriggerHandlers.Count) downto 0 do
|
|
if PWndTriggerHandler(WndTriggerHandlers[i])^.thDeleted then begin
|
|
Dispose(PWndTriggerHandler(WndTriggerHandlers[i]));
|
|
WndTriggerHandlers.Delete(i);
|
|
end;
|
|
|
|
for i := pred(ProcTriggerHandlers.Count) downto 0 do
|
|
if PProcTriggerHandler(ProcTriggerHandlers[i])^.thDeleted then begin
|
|
Dispose(PProcTriggerHandler(ProcTriggerHandlers[i]));
|
|
ProcTriggerHandlers.Delete(i);
|
|
end;
|
|
|
|
for i := pred(EventTriggerHandlers.Count) downto 0 do
|
|
if PEventTriggerHandler(EventTriggerHandlers[i])^.thDeleted then begin
|
|
Dispose(PEventTriggerHandler(EventTriggerHandlers[i]));
|
|
EventTriggerHandlers.Delete(i);
|
|
end;
|
|
|
|
DeletePending := False;
|
|
UpdateHandlerFlags(fuKeepPort);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
GetCount := 0;
|
|
end;
|
|
|
|
function MatchString(var Indexes : TCheckIndex; const C : AnsiChar; Len : Cardinal;
|
|
P : PAnsiChar; IgnoreCase : Boolean) : Boolean;
|
|
{-Checks for string P on consecutive calls, returns True when found}
|
|
var
|
|
I : Cardinal;
|
|
Check : Boolean;
|
|
GotFirst : Boolean;
|
|
begin
|
|
Result := False;
|
|
|
|
if IgnoreCase then
|
|
AnsiUpperBuff(@C, 1);
|
|
|
|
GotFirst := False;
|
|
Check := True;
|
|
for I := 0 to Len-1 do begin
|
|
{Check another index?}
|
|
if Check then begin
|
|
{Compare this index...}
|
|
if C = P[Indexes[I]] then
|
|
{Got match, was it complete?}
|
|
if Indexes[I] = Len-1 then begin
|
|
Indexes[I] := 0;
|
|
Result := True;
|
|
|
|
{Clear all inprogress matches}
|
|
FillChar(Indexes, SizeOf(Indexes), 0);
|
|
end else
|
|
Inc(Indexes[I])
|
|
else
|
|
{No match, reset index}
|
|
if C = P[0] then begin
|
|
GotFirst := True;
|
|
Indexes[I] := 1
|
|
end else
|
|
Indexes[I] := 0;
|
|
end;
|
|
|
|
{See if last match was on first char}
|
|
if Indexes[I] = 1 then
|
|
GotFirst := True;
|
|
|
|
{See if we should check the next index}
|
|
if I <> Len-1 then
|
|
if GotFirst then
|
|
{Got a previous restart, don't allow more restarts}
|
|
Check := Indexes[I+1] <> 0
|
|
else
|
|
{Not a restart, check next index if in progress or on first char}
|
|
Check := (Indexes[I+1] <> 0) or (C = P[0])
|
|
else
|
|
Check := False;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckStatusTriggers : Boolean;
|
|
{-Check status triggers for H, send notification messages as required}
|
|
{-Return True if more checks remain}
|
|
var
|
|
J : Integer;
|
|
Hit : Cardinal;
|
|
StatusLen : Cardinal;
|
|
Res : Byte;
|
|
BufCnt : Cardinal;
|
|
begin
|
|
{Check status triggers}
|
|
for J := 0 to pred(StatusTriggers.Count) do begin
|
|
with PStatusTrigger(StatusTriggers[J])^ do begin
|
|
if tSActive and not StatusHit then begin
|
|
Hit := stNotActive;
|
|
StatusLen := 0;
|
|
case tSType of
|
|
stLine :
|
|
if LastError and tValue <> 0 then begin
|
|
Hit := stLine;
|
|
tValue := LastError;
|
|
end;
|
|
stModem :
|
|
begin
|
|
{Check for changed bits}
|
|
Res := Lo(tValue) xor ModemStatus;
|
|
|
|
{Skip bits not in our mask}
|
|
Res := Res and Hi(tValue);
|
|
|
|
{If anything is still set, it's a hit}
|
|
if Res <> 0 then begin
|
|
Hit := stModem;
|
|
end;
|
|
end;
|
|
stOutBuffFree :
|
|
begin
|
|
BufCnt := OutBuffFree;
|
|
if BufCnt >= tValue then begin
|
|
StatusLen := BufCnt;
|
|
Hit := stOutBuffFree;
|
|
end;
|
|
end;
|
|
stOutBuffUsed :
|
|
begin
|
|
BufCnt := OutBuffUsed;
|
|
if BufCnt <= tValue then begin
|
|
StatusLen := BufCnt;
|
|
Hit := stOutBuffUsed;
|
|
end;
|
|
end;
|
|
stOutSent :
|
|
if OutSentPending then begin
|
|
OutSentPending := False;
|
|
StatusLen := 0;
|
|
Hit := stOutSent;
|
|
end;
|
|
end;
|
|
if Hit <> stNotActive then begin
|
|
{Clear the trigger and send the notification message}
|
|
tSActive := False;
|
|
|
|
{Prevent status trigger re-entrancy issues}
|
|
GlobalStatHit := True;
|
|
StatusHit := True;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTrigger, dstStatus, tHandle, nil, 0);
|
|
|
|
Result :=
|
|
SendNotify(apw_TriggerStatus, tHandle, StatusLen);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
if J >= StatusTriggers.Count then break;
|
|
end;
|
|
{No more checks required}
|
|
Result := False;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckReceiveTriggers : Boolean;
|
|
{-Check all receive triggers for H, send notification messages as required}
|
|
{-Return True if more checks remain}
|
|
type
|
|
LH = record L,H : Byte; end;
|
|
var
|
|
I : Cardinal;
|
|
J : Integer;
|
|
BufCnt : Cardinal;
|
|
MatchSize : Cardinal;
|
|
CC : Cardinal;
|
|
AnyMatch : Boolean;
|
|
C : AnsiChar;
|
|
|
|
function CharCount(CurTail, Adjust : Cardinal) : Cardinal;
|
|
{-Return the number of characters available between CurTail }
|
|
{ and DBufTail that haven't already been extracted. CurTail }
|
|
{ is first adjusted downward by Adjust, the size of the }
|
|
{ current match string }
|
|
begin
|
|
if Adjust <= CurTail then
|
|
Dec(CurTail, Adjust)
|
|
else
|
|
CurTail := (CurTail + DispatchBufferSize) - Adjust;
|
|
Result := BuffCount(CurTail, DBufTail, DispatchFull) + 1;
|
|
if InAvailMessage then
|
|
Dec(Result, GetCount);
|
|
end;
|
|
|
|
begin
|
|
{Assume triggers need to be re-checked}
|
|
Result := True;
|
|
|
|
I := LastTailData;
|
|
{Check data triggers}
|
|
if LastTailData <> DBufHead then begin
|
|
{Prepare}
|
|
|
|
{Loop through new data in dispatch buffer}
|
|
while I <> DBufHead do begin
|
|
C := DBuffer^[I];
|
|
|
|
{Check each trigger for a match on this character}
|
|
AnyMatch := False;
|
|
MatchSize := 0;
|
|
for J := 0 to pred(DataTriggers.Count) do
|
|
with PDataTrigger(DataTriggers[J])^ do
|
|
if tLen <> 0 then begin
|
|
tMatched := tMatched or
|
|
MatchString(tChkIndex, C, tLen, tData, tIgnoreCase);
|
|
if tMatched and (tLen > MatchSize) then
|
|
MatchSize := tLen;
|
|
if not AnyMatch then
|
|
AnyMatch := tMatched;
|
|
end;
|
|
|
|
{Send len message if we have any matches}
|
|
if AnyMatch then begin
|
|
{Send len message up to first matching char}
|
|
if (LenTrigger <> 0) and
|
|
(NotifyTail <> I) and
|
|
(Integer(CharCount(I, 0))-
|
|
Integer(MatchSize) >= Integer(LenTrigger))
|
|
then begin
|
|
|
|
{Generate len message for preceding data}
|
|
CC := CharCount(I, MatchSize);
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTrigger, dstAvail, CC, nil, 0);
|
|
Result := SendNotify(apw_TriggerAvail, CC, 0);
|
|
LastTailData := I;
|
|
NotifyTail := I;
|
|
end;
|
|
|
|
{Process the matches}
|
|
for J := pred(DataTriggers.Count) downto 0 do begin
|
|
with PDataTrigger(DataTriggers[J])^ do
|
|
if tMatched then begin
|
|
{No preceding data or msg pending, send data msg}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTrigger, dstData, tHandle, nil, 0);
|
|
|
|
tMatched := False;
|
|
Result :=
|
|
SendNotify(apw_TriggerData, tHandle, tLen);
|
|
end;
|
|
if J >= DataTriggers.Count then break;
|
|
end;
|
|
|
|
{Exit after all data triggers that matched on this char}
|
|
if I = DispatchBufferSize-1 then
|
|
LastTailData := 0
|
|
else
|
|
LastTailData := I+1;
|
|
Exit;
|
|
end;
|
|
|
|
{Next index for buffer}
|
|
if I = DispatchBufferSize-1 then
|
|
I := 0
|
|
else
|
|
inc(I);
|
|
end;
|
|
|
|
{Update last tail for data triggers}
|
|
LastTailData := I;
|
|
end;
|
|
|
|
{Check for length trigger}
|
|
|
|
BufCnt := InBuffUsed;
|
|
|
|
if (LenTrigger <> 0) and
|
|
(NotifyTail <> I) and
|
|
(BufCnt >= LenTrigger) then begin
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTrigger, dstAvail, BufCnt, nil, 0);
|
|
|
|
Result :=
|
|
SendNotify(apw_TriggerAvail, BufCnt, 0);
|
|
NotifyTail := I;
|
|
Exit;
|
|
end;
|
|
|
|
{No more checks required}
|
|
Result := False;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckTimerTriggers : Boolean;
|
|
{-Check timer triggers for H, send notification messages as required}
|
|
{-Return True if more checks remain}
|
|
var
|
|
J : Integer;
|
|
begin
|
|
{Check for timer triggers}
|
|
for J := 0 to pred(TimerTriggers.Count) do begin
|
|
with PTimerTrigger(TimerTriggers[J])^ do
|
|
if tActive and TimerExpired(tET) then begin
|
|
tActive := False;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTrigger, dstTimer, tHandle, nil, 0);
|
|
|
|
Result := SendNotify(apw_TriggerTimer, tHandle, 0);
|
|
Exit;
|
|
end;
|
|
if J >= TimerTriggers.Count then break;
|
|
end;
|
|
{No more checks required}
|
|
Result := False;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.ExtractData : Boolean;
|
|
{-Move data from communications driver to dispatch buffer}
|
|
{-Return True if data available, false otherwise}
|
|
var
|
|
BytesToRead : Cardinal;
|
|
FreeSpace : Cardinal;
|
|
BeginFree : Cardinal;
|
|
EndFree : Cardinal;
|
|
Len : Integer;
|
|
begin
|
|
EnterCriticalSection(DispSection);
|
|
try
|
|
{Nothing to do if dispatch buffer is already full}
|
|
if DispatchFull then begin
|
|
if (DLoggingOn) then // SWB
|
|
AddDispatchEntry(dtDispatch, // SWB
|
|
dstStatus, // SWB
|
|
0, // SWB
|
|
PAnsiChar('Dispatch buffer full.'), // SWB
|
|
21); // SWB
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
ComStatus.cbInQue := InQueueUsed; // SWB
|
|
if ComStatus.cbInQue > 0 then begin
|
|
Result := True;
|
|
|
|
if DBufHead = DBufTail then begin
|
|
{Buffer is completely empty}
|
|
FreeSpace := DispatchBufferSize;
|
|
EndFree := DispatchBufferSize-DBufHead;
|
|
end else if DBufHead > DBufTail then begin
|
|
{Buffer not wrapped}
|
|
FreeSpace := (DBufTail+DispatchBufferSize)-DBufHead;
|
|
EndFree := DispatchBufferSize-DBufHead;
|
|
end else begin
|
|
{Buffer is wrapped}
|
|
FreeSpace := DBufTail-DBufHead;
|
|
EndFree := DBufTail-DBufHead;
|
|
end;
|
|
|
|
{Figure out how much data to read}
|
|
if ComStatus.cbInQue > FreeSpace then begin
|
|
BytesToRead := FreeSpace;
|
|
end else begin
|
|
BytesToRead := ComStatus.cbInQue;
|
|
end;
|
|
|
|
{Figure where data fits (end and/or beginning of buffer)}
|
|
if BytesToRead > EndFree then
|
|
BeginFree := BytesToRead-EndFree
|
|
else
|
|
BeginFree := 0;
|
|
|
|
{Move data to end of dispatch buffer}
|
|
if EndFree <> 0 then begin
|
|
Len := ReadCom(PAnsiChar(@DBuffer^[DBufHead]), EndFree);
|
|
|
|
{Restore data count on errors}
|
|
if Len < 0 then begin
|
|
Len := 0;
|
|
GetComEventMask(-1);
|
|
end;
|
|
|
|
if DLoggingOn then
|
|
if Len = 0 then
|
|
AddDispatchEntry(dtDispatch, dstReadCom, Len, nil, 0)
|
|
else
|
|
AddDispatchEntry(dtDispatch, dstReadCom, Len,
|
|
@DBuffer^[DBufHead], Len);
|
|
|
|
{Increment buffer head}
|
|
Inc(DBufHead, Len);
|
|
|
|
if Cardinal(Len) < EndFree then
|
|
BeginFree := 0;
|
|
|
|
end else
|
|
Len := 0;
|
|
|
|
{Handle buffer wrap}
|
|
if DBufHead = DispatchBufferSize then
|
|
DBufHead := 0;
|
|
|
|
{Check for a full dispatch buffer}
|
|
if Len <> 0 then
|
|
DispatchFull := DBufHead = DBufTail;
|
|
|
|
{Move data to beginning of dispatch buffer}
|
|
if BeginFree <> 0 then begin
|
|
Len := ReadCom(PAnsiChar(@DBuffer^[DBufHead]), BeginFree);
|
|
|
|
{Restore data count on errors}
|
|
if Len < 0 then begin
|
|
Len := Abs(Len);
|
|
GetComEventMask(-1);
|
|
end;
|
|
|
|
if DLoggingOn then
|
|
if Len = 0 then
|
|
AddDispatchEntry(dtDispatch, dstReadCom, Len, nil, 0)
|
|
else
|
|
AddDispatchEntry(dtDispatch, dstReadCom, Len,
|
|
@DBuffer^[DBufHead], Len);
|
|
|
|
{Increment buffer head}
|
|
Inc(DBufHead, Len);
|
|
|
|
{Check for a full dispatch buffer}
|
|
DispatchFull := DBufHead = DBufTail;
|
|
|
|
end;
|
|
end else
|
|
Result := False;
|
|
finally
|
|
LeaveCriticalSection(DispSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.CheckTriggers : Boolean;
|
|
{-Check all triggers for H, send notification messages as required}
|
|
{-Return True if more checks remain}
|
|
{-Only used by the Winsock dispatcher}
|
|
begin
|
|
Result := True;
|
|
|
|
{Check timers, exit true if any hit}
|
|
if CheckTimerTriggers then
|
|
Exit;
|
|
|
|
{Check status triggers, exit true if any hit}
|
|
if CheckStatusTriggers then
|
|
Exit;
|
|
|
|
{Check receive data triggers, exit true if any hit}
|
|
if CheckReceiveTriggers then
|
|
Exit;
|
|
|
|
{No trigger hits, exit false}
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.CreateDispatcherWindow;
|
|
{-Create dispatcher window element}
|
|
{-Only used by the Winsock dispatcher}
|
|
begin
|
|
fDispatcherWindow :=
|
|
CreateWindow(DispatcherClassName, {window class name}
|
|
'', {caption}
|
|
ws_Overlapped, {window style}
|
|
0, {X}
|
|
0, {Y}
|
|
10, {width}
|
|
10, {height}
|
|
0, {parent}
|
|
0, {menu}
|
|
HInstance, {instance}
|
|
nil); {parameter}
|
|
|
|
ShowWindow(fDispatcherWindow, sw_Hide);
|
|
end;
|
|
|
|
{Trigger functions}
|
|
|
|
procedure TApdBaseDispatcher.RegisterWndTriggerHandler(HW : TApdHwnd);
|
|
var
|
|
TH : PWndTriggerHandler;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Allocate memory for TriggerHandler node}
|
|
New(TH);
|
|
|
|
{Fill in data}
|
|
with TH^ do begin
|
|
thWnd := HW;
|
|
thDeleted := False;
|
|
end;
|
|
|
|
WndTriggerHandlers.Add(TH);
|
|
HandlerServiceNeeded := True;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerAlloc,dstWndHandler,HW,nil,0);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.RegisterProcTriggerHandler(NP : TApdNotifyProc);
|
|
var
|
|
TH : PProcTriggerHandler;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Allocate memory for TriggerHandler node}
|
|
New(TH);
|
|
|
|
{Fill in data}
|
|
with TH^ do begin
|
|
thnotify := NP;
|
|
thDeleted := False;
|
|
end;
|
|
|
|
ProcTriggerHandlers.Add(TH);
|
|
HandlerServiceNeeded := True;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerAlloc,dstProcHandler,0,nil,0);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.RegisterSyncEventTriggerHandler(NP : TApdNotifyEvent);
|
|
var
|
|
TH : PEventTriggerHandler;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Allocate memory for TriggerHandler node}
|
|
New(TH);
|
|
|
|
{Fill in data}
|
|
with TH^ do begin
|
|
thNotify := NP;
|
|
thSync := True;
|
|
thDeleted := False;
|
|
end;
|
|
|
|
EventTriggerHandlers.Add(TH);
|
|
HandlerServiceNeeded := True;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerAlloc,dstEventHandler,1,nil,0);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.RegisterEventTriggerHandler(NP : TApdNotifyEvent);
|
|
var
|
|
TH : PEventTriggerHandler;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Allocate memory for TriggerHandler node}
|
|
New(TH);
|
|
|
|
{Fill in data}
|
|
with TH^ do begin
|
|
thNotify := NP;
|
|
thSync := False;
|
|
thDeleted := False;
|
|
end;
|
|
|
|
EventTriggerHandlers.Add(TH);
|
|
HandlerServiceNeeded := True;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerAlloc,dstEventHandler,0,nil,0);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.DeregisterWndTriggerHandler(HW : TApdHwnd);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
for i := 0 to pred(WndTriggerHandlers.Count) do
|
|
with PWndTriggerHandler(WndTriggerHandlers[i])^ do
|
|
if thWnd = HW then begin
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerDispose,dstWndHandler,HW,nil,0);
|
|
if fEventBusy then begin
|
|
thDeleted := True;
|
|
DeletePending := True;
|
|
end else begin
|
|
Dispose(PWndTriggerHandler(WndTriggerHandlers[i]));
|
|
WndTriggerHandlers.Delete(i);
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
UpdateHandlerFlags(fuKeepPort);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.DeregisterProcTriggerHandler(NP : TApdNotifyProc);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
for i := 0 to pred(ProcTriggerHandlers.Count) do
|
|
with PProcTriggerHandler(ProcTriggerHandlers[i])^ do
|
|
if @thNotify = @NP then begin
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerDispose,dstProcHandler,0,nil,0);
|
|
if fEventBusy then begin
|
|
thDeleted := True;
|
|
DeletePending := True;
|
|
end else begin
|
|
Dispose(PProcTriggerHandler(ProcTriggerHandlers[i]));
|
|
ProcTriggerHandlers.Delete(i);
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
UpdateHandlerFlags(fuKeepPort);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.DeregisterEventTriggerHandler(NP : TApdNotifyEvent);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
for i := 0 to pred(EventTriggerHandlers.Count) do
|
|
with PEventTriggerHandler(EventTriggerHandlers[i])^ do
|
|
if @thNotify = @NP then begin
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerHandlerDispose,dstEventHandler,0,nil,0);
|
|
if fEventBusy then begin
|
|
thDeleted := True;
|
|
DeletePending := True;
|
|
end else begin
|
|
Dispose(PEventTriggerHandler(EventTriggerHandlers[i]));
|
|
EventTriggerHandlers.Delete(i);
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
UpdateHandlerFlags(fuKeepPort);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetTriggerHandle : Cardinal;
|
|
{-Find, allocate and return the first free trigger handle}
|
|
var
|
|
I : Integer;
|
|
Good : Boolean;
|
|
begin
|
|
{ Allocate a trigger handle. If we can, within the size of the handle's }
|
|
{ datatype, we just increment TriggerCounter to get a new handle. If not, }
|
|
{ we need to check the existing handles to find a unique one. }
|
|
if TriggerCounter < MaxTriggerHandle then begin
|
|
Result := TriggerCounter shl 3; {low three bits reserved for trigger specific information}
|
|
inc(TriggerCounter);
|
|
end else begin
|
|
Result := FirstTriggerCounter shl 3; {lowest possible handle value}
|
|
repeat
|
|
Good := True; {Assume success}
|
|
for i := 0 to pred(TimerTriggers.Count) do
|
|
with PTimerTrigger(TimerTriggers[i])^ do
|
|
if tHandle = Result then begin
|
|
Good := False;
|
|
break;
|
|
end;
|
|
if Good then for i := 0 to pred(StatusTriggers.Count) do
|
|
with PStatusTrigger(StatusTriggers[i])^ do
|
|
if (tHandle and not 7)= Result then begin
|
|
Good := False;
|
|
break;
|
|
end;
|
|
if Good then for i := 0 to pred(DataTriggers.Count) do
|
|
with PDataTrigger(DataTriggers[i])^ do
|
|
if tHandle = Result then begin
|
|
Good := False;
|
|
break;
|
|
end;
|
|
if not Good then
|
|
inc(Result,(1 shl 3));
|
|
until Good;
|
|
if Result > MaxTriggerHandle then
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.FindTriggerFromHandle(TriggerHandle : Cardinal; Delete : Boolean;
|
|
var T : TTriggerType; var Trigger : Pointer) : Integer;
|
|
{-Find the trigger index}
|
|
var
|
|
i : Integer;
|
|
b : Byte;
|
|
begin
|
|
T := ttNone;
|
|
Result := ecOk;
|
|
if (TriggerHandle > 1) then begin
|
|
for i := 0 to pred(TimerTriggers.Count) do begin
|
|
Trigger := TimerTriggers[i];
|
|
with PTimerTrigger(Trigger)^ do
|
|
if tHandle = TriggerHandle then begin
|
|
T := ttTimer;
|
|
if Delete then begin
|
|
TimerTriggers.Delete(i);
|
|
Dispose(PTimerTrigger(Trigger));
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerDispose,dstTimer,TriggerHandle,nil,0);
|
|
Trigger := nil;
|
|
end;
|
|
exit;
|
|
end;
|
|
end;
|
|
for i := 0 to pred(StatusTriggers.Count) do begin
|
|
Trigger := StatusTriggers[i];
|
|
with PStatusTrigger(Trigger)^ do
|
|
if tHandle = TriggerHandle then begin
|
|
T := ttStatus;
|
|
if Delete then begin
|
|
StatusTriggers.Delete(i);
|
|
Dispose(PStatusTrigger(Trigger));
|
|
if DLoggingOn then begin
|
|
b := lo(TriggerHandle and (StatusTypeMask));
|
|
AddDispatchEntry(dtTriggerDispose,dstStatusTrigger,TriggerHandle,@b,1);
|
|
end;
|
|
Trigger := nil;
|
|
end;
|
|
exit;
|
|
end;
|
|
end;
|
|
for i := 0 to pred(DataTriggers.Count) do begin
|
|
Trigger := DataTriggers[i];
|
|
with PDataTrigger(Trigger)^ do
|
|
if Cardinal(tHandle and not 7) = TriggerHandle then begin {!!.01}
|
|
T := ttData;
|
|
if Delete then begin
|
|
DataTriggers.Delete(i);
|
|
Dispose(PDataTrigger(Trigger));
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerDispose,dstData,TriggerHandle,nil,0);
|
|
Trigger := nil;
|
|
end;
|
|
exit;
|
|
end;
|
|
end;
|
|
end else begin
|
|
T := ttNone;
|
|
Trigger := nil;
|
|
end;
|
|
if T = ttNone then
|
|
Result := ecBadTriggerHandle;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.ChangeLengthTrigger(Length : Cardinal);
|
|
{-Change the length trigger to Length}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
LenTrigger := Length;
|
|
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerDataChange,dstAvailTrigger,Length,nil,0);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AddTimerTrigger : Integer;
|
|
{-Add a timer trigger}
|
|
var
|
|
NewTimerTrigger : PTimerTrigger;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
NewTimerTrigger := AllocMem(sizeof(TTimerTrigger));
|
|
with NewTimerTrigger^ do begin
|
|
tHandle := GetTriggerHandle;
|
|
tTicks := 0;
|
|
tActive := False;
|
|
tValid := True;
|
|
Result := tHandle;
|
|
end;
|
|
if Result > 0 then begin
|
|
TimerTriggers.Add(NewTimerTrigger);
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerAlloc,dstTimerTrigger,Result,nil,0);
|
|
end else
|
|
Result := ecNoMoreTriggers;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AddDataTriggerLen(Data : PAnsiChar;
|
|
IgnoreCase : Boolean; Len : Cardinal) : Integer;
|
|
{-Add a data trigger, data is any ASCIIZ string so no embedded zeros}
|
|
var
|
|
NewDataTrigger : PDataTrigger;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if Len <= MaxTrigData then begin
|
|
NewDataTrigger := AllocMem(sizeof(TDataTrigger));
|
|
with NewDataTrigger^ do begin
|
|
tHandle := GetTriggerHandle;
|
|
tLen := Len;
|
|
FillChar(tChkIndex, SizeOf(TCheckIndex), 0);
|
|
tMatched := False;
|
|
tIgnoreCase := IgnoreCase;
|
|
Move(Data^, tData, Len);
|
|
if IgnoreCase and (Len <> 0) then
|
|
AnsiUpperBuff(@tData, Len);
|
|
Result := tHandle;
|
|
end;
|
|
if Result > 0 then begin
|
|
DataTriggers.Add(NewDataTrigger);
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerAlloc,dstDataTrigger,Result,Data,Len);
|
|
end else
|
|
Result := ecNoMoreTriggers;
|
|
|
|
end else
|
|
Result := ecTriggerTooLong;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AddDataTrigger(Data : PAnsiChar;
|
|
IgnoreCase : Boolean) : Integer;
|
|
{-Add a data trigger, data is any ASCIIZ string so no embedded nulls}
|
|
begin
|
|
Result := AddDataTriggerLen(Data, IgnoreCase, AnsiStrings.StrLen(Data));
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AddStatusTrigger(SType : Cardinal) : Integer;
|
|
{-Add a status trigger of type SType}
|
|
var
|
|
NewStatusTrigger : PStatusTrigger;
|
|
begin
|
|
if (SType > stOutSent) then begin
|
|
Result := ecBadArgument;
|
|
Exit;
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
NewStatusTrigger := AllocMem(sizeof(TStatusTrigger));
|
|
with NewStatusTrigger^ do begin
|
|
tHandle := GetTriggerHandle or SType;
|
|
tSType := SType;
|
|
tSActive := False;
|
|
Result := tHandle;
|
|
end;
|
|
if (Result and not 7) > 0 then begin
|
|
StatusTriggers.Add(NewStatusTrigger);
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerAlloc, dstStatusTrigger,
|
|
Result, @SType, 1);
|
|
end else
|
|
Result := ecNoMoreTriggers;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.RemoveTrigger(TriggerHandle : Cardinal) : Integer;
|
|
{-Remove the trigger for Index}
|
|
var
|
|
Trigger : Pointer;
|
|
T : TTriggerType;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if TriggerHandle = 1 then
|
|
{Length trigger}
|
|
begin
|
|
LenTrigger := 0;
|
|
Result := ecOk;
|
|
end
|
|
else
|
|
{Other trigger}
|
|
Result := FindTriggerFromHandle(TriggerHandle, True, T, Trigger);
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetTimerTrigger(TriggerHandle : Cardinal;
|
|
Ticks : Integer; Activate : Boolean) : Integer;
|
|
const
|
|
DeactivateStr : Ansistring = 'Deactivated';
|
|
var
|
|
Trigger : PTimerTrigger;
|
|
T : TTriggerType;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
FindTriggerFromHandle(TriggerHandle, False, T, Pointer(Trigger));
|
|
if (Trigger <> nil) and (T = ttTimer) then
|
|
with Trigger^ do begin
|
|
if Activate then begin
|
|
if Ticks <> 0 then
|
|
tTicks := Ticks;
|
|
NewTimer(tET, tTicks);
|
|
end;
|
|
if DLoggingOn then
|
|
if Activate then
|
|
AddDispatchEntry(dtTriggerDataChange, dstTimerTrigger,
|
|
TriggerHandle,@Ticks,sizeof(Ticks))
|
|
else
|
|
AddDispatchEntry(dtTriggerDataChange, dstTimerTrigger,
|
|
TriggerHandle,@DeactivateStr[1],Length(DeactivateStr));
|
|
tActive := Activate;
|
|
Result := ecOk;
|
|
end
|
|
else
|
|
Result := ecBadTriggerHandle;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.ExtendTimer(TriggerHandle : Cardinal;
|
|
Ticks : Integer) : Integer;
|
|
var
|
|
Trigger : PTimerTrigger;
|
|
T : TTriggerType;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
FindTriggerFromHandle(TriggerHandle, False, T, Pointer(Trigger));
|
|
if (Trigger <> nil) and (T = ttTimer) then
|
|
with Trigger^ do begin
|
|
Inc(tET.ExpireTicks, Ticks);
|
|
Result := ecOk;
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerDataChange, dstTimerTrigger,
|
|
TriggerHandle, @Ticks,sizeof(Ticks));
|
|
end
|
|
else
|
|
Result := ecBadTriggerHandle;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.TimerTicksRemaining(TriggerHandle : Cardinal;
|
|
var TicksRemaining : Integer) : Integer;
|
|
var
|
|
Trigger : PTimerTrigger;
|
|
T : TTriggerType;
|
|
begin
|
|
TicksRemaining := 0;
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
FindTriggerFromHandle(TriggerHandle, False, T, Pointer(Trigger));
|
|
if (Trigger <> nil) and (T = ttTimer) then
|
|
with Trigger^ do begin
|
|
TicksRemaining := RemainingTime(tET);
|
|
Result := ecOk;
|
|
end
|
|
else
|
|
Result := ecBadTriggerHandle;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.UpdateHandlerFlags(FlagUpdate : TApHandlerFlagUpdate);
|
|
var
|
|
HandlersInstalled : Boolean;
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
HandlersInstalled := (WndTriggerHandlers.Count > 1) or
|
|
(ProcTriggerHandlers.Count > 0) or (EventTriggerHandlers.Count > 0);
|
|
|
|
case FlagUpdate of
|
|
fuKeepPort :
|
|
HandlerServiceNeeded := (HandlersInstalled or PortHandlerInstalled);
|
|
|
|
fuEnablePort :
|
|
begin
|
|
PortHandlerInstalled := True;
|
|
HandlerServiceNeeded := True;
|
|
end;
|
|
|
|
fuDisablePort :
|
|
begin
|
|
PortHandlerInstalled := False;
|
|
HandlerServiceNeeded := HandlersInstalled;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetStatusTrigger(TriggerHandle : Cardinal;
|
|
Value : Cardinal; Activate : Boolean) : Integer;
|
|
type
|
|
LH = record L,H : Byte; end;
|
|
var
|
|
Trigger : PStatusTrigger;
|
|
T : TTriggerType;
|
|
|
|
function SetLineBits(Value : Cardinal) : Cardinal;
|
|
{-Return mask that can be checked against LastError later}
|
|
begin
|
|
Result := 0;
|
|
if FlagIsSet(Value, lsOverrun) then
|
|
Result := ce_Overrun;
|
|
if FlagIsSet(Value, lsParity) then
|
|
Result := Result or ce_RxParity;
|
|
if FlagIsSet(Value, lsFraming) then
|
|
Result := Result or ce_Frame;
|
|
if FlagIsSet(Value, lsBreak) then
|
|
Result := Result or ce_Break;
|
|
end;
|
|
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
FindTriggerFromHandle(TriggerHandle, False, T, Pointer(Trigger));
|
|
if (Trigger <> nil) and (T = ttStatus) then
|
|
with Trigger^ do begin
|
|
if Activate then begin
|
|
case tSType of
|
|
stLine :
|
|
tValue := SetLineBits(Value);
|
|
stModem :
|
|
begin
|
|
{Hi tValue is delta mask, Lo is current modem status}
|
|
LH(tValue).H := Value;
|
|
LH(tValue).L := Value and ModemStatus;
|
|
end;
|
|
stOutBuffFree,
|
|
stOutBuffUsed :
|
|
tValue := Value;
|
|
end;
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtTriggerDataChange, dstStatusTrigger,
|
|
TriggerHandle, @tValue, sizeof(Cardinal));
|
|
end;
|
|
tSActive := Activate;
|
|
Result := ecOK;
|
|
end
|
|
else
|
|
Result := ecBadTriggerHandle;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
class procedure TApdBaseDispatcher.ClearSaveBuffers(var Save : TTriggerSave);
|
|
begin
|
|
with Save do begin
|
|
if tsTimerTriggers <> nil then begin
|
|
while tsTimerTriggers.Count > 0 do begin
|
|
Dispose(PTimerTrigger(tsTimerTriggers[0]));
|
|
tsTimerTriggers.Delete(0);
|
|
end;
|
|
tsTimerTriggers.Free;
|
|
tsTimerTriggers := nil;
|
|
end;
|
|
if tsDataTriggers <> nil then begin
|
|
while tsDataTriggers.Count > 0 do begin
|
|
Dispose(PDataTrigger(tsDataTriggers[0]));
|
|
tsDataTriggers.Delete(0);
|
|
end;
|
|
tsDataTriggers.Free;
|
|
tsDataTriggers := nil;
|
|
end;
|
|
if tsStatusTriggers <> nil then begin
|
|
while tsStatusTriggers.Count > 0 do begin
|
|
Dispose(PStatusTrigger(tsStatusTriggers[0]));
|
|
tsStatusTriggers.Delete(0);
|
|
end;
|
|
tsStatusTriggers.Free;
|
|
tsStatusTriggers := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.SaveTriggers(var Save : TTriggerSave);
|
|
{-Saves all current triggers to Save}
|
|
var
|
|
i : Integer;
|
|
NewTimerTrigger : PTimerTrigger;
|
|
NewDataTrigger : PDataTrigger;
|
|
NewStatusTrigger : PStatusTrigger;
|
|
begin
|
|
with Save do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
ClearSaveBuffers(Save);
|
|
|
|
tsLenTrigger := LenTrigger;
|
|
tsTimerTriggers := TList.Create;
|
|
for i := 0 to pred(TimerTriggers.Count) do begin
|
|
NewTimerTrigger := AllocMem(sizeof(TTimerTrigger));
|
|
move(PTimerTrigger(TimerTriggers[i])^, NewTimerTrigger^,
|
|
sizeof(TTimerTrigger));
|
|
tsTimerTriggers.Add(NewTimerTrigger);
|
|
end;
|
|
tsDataTriggers := TList.Create;
|
|
for i := 0 to pred(DataTriggers.Count) do begin
|
|
NewDataTrigger := AllocMem(sizeof(TDataTrigger));
|
|
move(PDataTrigger(DataTriggers[i])^, NewDataTrigger^,
|
|
sizeof(TDataTrigger));
|
|
tsDataTriggers.Add(NewDataTrigger);
|
|
end;
|
|
tsStatusTriggers := TList.Create;
|
|
for i := 0 to pred(StatusTriggers.Count) do begin
|
|
NewStatusTrigger := AllocMem(sizeof(TStatusTrigger));
|
|
move(PStatusTrigger(StatusTriggers[i])^, NewStatusTrigger^,
|
|
sizeof(TStatusTrigger));
|
|
tsStatusTriggers.Add(NewStatusTrigger);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.RestoreTriggers(var Save : TTriggerSave);
|
|
{-Restores previously saved triggers}
|
|
var
|
|
i : Integer;
|
|
NewTimerTrigger : PTimerTrigger;
|
|
NewDataTrigger : PDataTrigger;
|
|
NewStatusTrigger : PStatusTrigger;
|
|
begin
|
|
with Save do begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
LenTrigger := tsLenTrigger;
|
|
while TimerTriggers.Count > 0 do begin
|
|
Dispose(PTimerTrigger(TimerTriggers[0]));
|
|
TimerTriggers.Delete(0);
|
|
end;
|
|
while DataTriggers.Count > 0 do begin
|
|
Dispose(PDataTrigger(DataTriggers[0]));
|
|
DataTriggers.Delete(0);
|
|
end;
|
|
while StatusTriggers.Count > 0 do begin
|
|
Dispose(PStatusTrigger(StatusTriggers[0]));
|
|
StatusTriggers.Delete(0);
|
|
end;
|
|
if tsTimerTriggers <> nil then
|
|
for i := 0 to pred(tsTimerTriggers.Count) do begin
|
|
NewTimerTrigger := AllocMem(sizeof(TTimerTrigger));
|
|
move(PTimerTrigger(tsTimerTriggers[i])^, NewTimerTrigger^,
|
|
sizeof(TTimerTrigger));
|
|
TimerTriggers.Add(NewTimerTrigger);
|
|
end;
|
|
if tsDataTriggers <> nil then
|
|
for i := 0 to pred(tsDataTriggers.Count) do begin
|
|
NewDataTrigger := AllocMem(sizeof(TDataTrigger));
|
|
move(PDataTrigger(tsDataTriggers[i])^, NewDataTrigger^,
|
|
sizeof(TDataTrigger));
|
|
DataTriggers.Add(NewDataTrigger);
|
|
end;
|
|
if tsStatusTriggers <> nil then
|
|
for i := 0 to pred(tsStatusTriggers.Count) do begin
|
|
NewStatusTrigger := AllocMem(sizeof(TStatusTrigger));
|
|
move(PStatusTrigger(tsStatusTriggers[i])^, NewStatusTrigger^,
|
|
sizeof(TStatusTrigger));
|
|
StatusTriggers.Add(NewStatusTrigger);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.ChangeBaud(NewBaud : Integer) : Integer;
|
|
{-Change the baud rate of port H to NewBaud}
|
|
begin
|
|
Result := SetLine(NewBaud, DontChangeParity, DontChangeDatabits,
|
|
DontChangeStopbits);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.SetDataPointer(P : Pointer; Index : Cardinal) : Integer;
|
|
{-Set a data pointer}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if (Index >= 1) and (Index <= MaxDataPointers) then begin
|
|
DataPointers[Index] := P;
|
|
Result := ecOK;
|
|
end else
|
|
Result := ecBadArgument;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetDataPointer(var P : Pointer;
|
|
Index : Cardinal) : Integer;
|
|
{-Return a data pointer}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if (Index >= 1) and (Index <= MaxDataPointers) then begin
|
|
P := DataPointers[Index];
|
|
Result := ecOK;
|
|
end else
|
|
Result := ecBadArgument;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetFlowOptions(var HWOpts, SWOpts, BufferFull,
|
|
BufferResume : Cardinal; var OnChar, OffChar : AnsiChar) : Integer;
|
|
begin
|
|
HWOpts := 0;
|
|
SWOpts := 0;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Result := GetComState(DCB);
|
|
|
|
if (DCB.Flags and dcb_DTR_CONTROL_HANDSHAKE) <> 0 then
|
|
HWOpts := HWOpts or hfUseDtr;
|
|
|
|
if (DCB.Flags and dcb_RTS_CONTROL_HANDSHAKE) <> 0 then
|
|
HWOpts := HWOpts or hfUseRts;
|
|
|
|
if (DCB.Flags and dcb_OutxDsrFlow) <> 0 then
|
|
HWOpts := HWOpts or hfRequireDsr;
|
|
|
|
if (DCB.Flags and dcb_OutxCtsFlow) <> 0 then
|
|
HWOpts := HWOpts or hfRequireCts;
|
|
|
|
if (DCB.Flags and dcb_InX) <> 0 then
|
|
SWOpts := SWOpts or sfReceiveFlow;
|
|
|
|
if (DCB.Flags and dcb_OutX) <> 0 then
|
|
SWOpts := SWOpts or sfTransmitFlow;
|
|
|
|
OnChar := DCB.XOnChar;
|
|
OffChar := DCB.XOffChar;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.OptionsOn(Options : Cardinal);
|
|
{-Enable the port options in Options}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Flags := Flags or Options;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.OptionsOff(Options : Cardinal);
|
|
{-Disable the port options in Options}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Flags := Flags and not Options;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.OptionsAreOn(Options : Cardinal) : Boolean;
|
|
{-Return True if the specified options are on}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Result := (Flags and Options) = Options;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.ClearTracing : Integer;
|
|
{-Clears the trace buffer}
|
|
begin
|
|
Result := ecOK;
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
TraceIndex := 0;
|
|
TraceWrapped := False;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.AbortTracing;
|
|
{-Stops tracing and destroys the tracebuffer}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
TracingOn := False;
|
|
if TraceQueue <> nil then begin
|
|
FreeMem(TraceQueue, TraceMax*2);
|
|
TraceQueue := nil;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.InitTracing(NumEntries : Cardinal) : Integer;
|
|
{-Prepare a circular tracing queue}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if TraceQueue <> nil then
|
|
{Just clear buffer if already on}
|
|
ClearTracing
|
|
else begin
|
|
{Limit check size of trace buffer}
|
|
if NumEntries > HighestTrace then begin
|
|
Result := ecBadArgument;
|
|
exit;
|
|
end;
|
|
|
|
{Allocate trace buffer and start tracing}
|
|
TraceMax := NumEntries;
|
|
TraceIndex := 0;
|
|
TraceWrapped := False;
|
|
TraceQueue := AllocMem(NumEntries*2);
|
|
end;
|
|
TracingOn := True;
|
|
Result := ecOK;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.AddTraceEntry(CurEntry : AnsiChar; CurCh : AnsiChar);
|
|
{-Add a trace event to the global TraceQueue}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if TraceQueue <> nil then begin
|
|
TraceQueue^[TraceIndex].EventType := CurEntry;
|
|
TraceQueue^[TraceIndex].C := CurCh;
|
|
Inc(TraceIndex);
|
|
if TraceIndex = TraceMax then begin
|
|
TraceIndex := 0;
|
|
TraceWrapped := True;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.DumpTracePrim(FName : string;
|
|
AppendFile, InHex, AllHex : Boolean) : Integer;
|
|
{-Write the TraceQueue to FName}
|
|
const
|
|
Digits : array[0..$F] of AnsiChar = '0123456789ABCDEF';
|
|
LowChar : array[Boolean] of Byte = (32, 33);
|
|
var
|
|
Start, Len : Cardinal;
|
|
TraceFile : Text;
|
|
TraceFileBuffer : array[1..512] of AnsiChar;
|
|
LastEventType : AnsiChar;
|
|
First : Boolean;
|
|
Col : Cardinal;
|
|
I : Cardinal;
|
|
Res : Cardinal;
|
|
|
|
procedure CheckCol(N : Cardinal);
|
|
{-Wrap if N bytes would exceed column limit}
|
|
begin
|
|
Inc(Col, N);
|
|
if Col > MaxTraceCol then begin
|
|
WriteLn(TraceFile);
|
|
Col := N;
|
|
end;
|
|
end;
|
|
|
|
function HexB(B : Byte) : AnsiString;
|
|
{-Return hex string for byte}
|
|
begin
|
|
SetLength(Result, 2);
|
|
HexB[1] := Digits[B shr 4];
|
|
HexB[2] := Digits[B and $F];
|
|
end;
|
|
|
|
begin
|
|
Result := ecOK;
|
|
|
|
{Make sure we have something to do}
|
|
if TraceQueue = nil then
|
|
Exit;
|
|
|
|
{Turn tracing off now}
|
|
// TracingOn := False; // SWB
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
{Set the Start and Len markers}
|
|
Len := TraceIndex;
|
|
if TraceWrapped then
|
|
Start := TraceIndex
|
|
else if TraceIndex <> 0 then
|
|
Start := 0
|
|
else begin
|
|
{No events, just exit}
|
|
// AbortTracing; // SWB
|
|
Exit;
|
|
end;
|
|
|
|
Assign(TraceFile, FName);
|
|
SetTextBuf(TraceFile, TraceFileBuffer, SizeOf(TraceFileBuffer));
|
|
if AppendFile and ExistFileZ(FName) then begin
|
|
{Open an existing file}
|
|
Append(TraceFile);
|
|
Res := IoResult;
|
|
end else begin
|
|
{Open new file}
|
|
ReWrite(TraceFile);
|
|
Res := IoResult;
|
|
end;
|
|
if Res <> ecOK then begin
|
|
Result := -Res;
|
|
AbortTracing;
|
|
Exit;
|
|
end;
|
|
|
|
try
|
|
{Write the trace queue}
|
|
LastEventType := #0;
|
|
First := True;
|
|
Col := 0;
|
|
repeat
|
|
{Some formattting}
|
|
with TraceQueue^[Start] do begin
|
|
if EventType <> LastEventType then begin
|
|
if not First then begin
|
|
WriteLn(TraceFile,^M^J);
|
|
Col := 0;
|
|
end;
|
|
{First := False;}
|
|
case EventType of
|
|
'T' : WriteLn(TraceFile, 'Transmit: ');
|
|
'R' : WriteLn(TraceFile, 'Receive: ');
|
|
else WriteLn(TraceFile, 'Special-'+EventType+': ');
|
|
end;
|
|
LastEventType := EventType;
|
|
end;
|
|
|
|
{Write the current char}
|
|
if AllHex then begin
|
|
CheckCol(4);
|
|
Write(TraceFile, '[',HexB(Ord(C)),']');
|
|
end else
|
|
if (Ord(C) < LowChar[InHex]) or (Ord(C) > 126) then begin
|
|
if InHex then begin
|
|
CheckCol(4);
|
|
Write(TraceFile, '[',HexB(Ord(C)),']')
|
|
end else begin
|
|
if Ord(C) > 99 then
|
|
I := 5
|
|
else if Ord(C) > 9 then
|
|
I := 4
|
|
else
|
|
I := 3;
|
|
CheckCol(I);
|
|
Write(TraceFile, '[',Ord(C),']')
|
|
end;
|
|
end else begin
|
|
CheckCol(1);
|
|
Write(TraceFile, C);
|
|
end;
|
|
|
|
{Get the next char}
|
|
Inc(Start);
|
|
if Start = TraceMax then
|
|
Start := 0;
|
|
end;
|
|
First := False;
|
|
until Start = Len;
|
|
|
|
finally
|
|
Close(TraceFile);
|
|
Result := -IoResult;
|
|
// AbortTracing; // SWB
|
|
InitTracing(TraceMax); // SWB
|
|
end;
|
|
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.DumpTrace(FName : string;
|
|
InHex, AllHex : Boolean) : Integer;
|
|
{-Write the TraceQueue to FName}
|
|
begin
|
|
Result := DumpTracePrim(FName, False, InHex, AllHex);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AppendTrace(FName : string;
|
|
InHex, AllHex : Boolean) : Integer;
|
|
{-Append the TraceQueue to FName}
|
|
begin
|
|
Result := DumpTracePrim(FName, True, InHex, AllHex);
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.StartTracing;
|
|
{-Restarts tracing after a StopTracing}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
if TraceQueue <> nil then
|
|
TracingOn := True;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.StopTracing;
|
|
{-Stops tracing temporarily}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
TracingOn := False;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.ClearDispatchLogging;
|
|
{-Clear the dispatch log}
|
|
begin
|
|
DLoggingQueue.Clear; // SWB
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.AbortDispatchLogging;
|
|
{-Abort dispatch logging}
|
|
begin
|
|
DLoggingOn := False;
|
|
DLoggingQueue.Clear; // SWB
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.StartDispatchLogging;
|
|
{-Restarts logging after a pause}
|
|
begin
|
|
DLoggingOn := True;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.StopDispatchLogging;
|
|
{-Pause dispatch logging}
|
|
begin
|
|
DLoggingOn := False;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.InitDispatchLogging(QueueSize : Cardinal);
|
|
{-Enable dispatch logging}
|
|
begin
|
|
ClearDispatchLogging;
|
|
DLoggingMax := QueueSize;
|
|
DLoggingOn := True;
|
|
end;
|
|
|
|
{apro.str offsets used for logging strings:}
|
|
const
|
|
drTypeBase = 15001;
|
|
drSubTypeBase = 15100;
|
|
Header1 = 15501;
|
|
Header2 = 15502;
|
|
MaxTelnetTag = 42;
|
|
TelnetBase = 15700;
|
|
MSTagBase = 15601;
|
|
|
|
function GetDTStr(drType : TDispatchType) : string;
|
|
begin
|
|
Result := AproLoadStr(drTypeBase + ord(drType));
|
|
end;
|
|
|
|
function GetDSTStr(drsType : TDispatchSubType) : string;
|
|
begin
|
|
if drsType = dstNone then
|
|
Result := ''
|
|
else
|
|
Result := AproLoadStr(drSubTypeBase + ord(drsType));
|
|
end;
|
|
|
|
function GetTimeStr(drTime : DWORD) : string;
|
|
begin
|
|
Result := Format('%07.7d', [drTime]);
|
|
Insert('.', Result, Length(Result) - 2); {!!.04}
|
|
end;
|
|
|
|
function TApdBaseDispatcher.DumpDispatchLogPrim(FName : string;
|
|
AppendFile, InHex, AllHex : Boolean) : Integer;
|
|
|
|
{-Dump the dispatch log}
|
|
const
|
|
StartColumn = 45;
|
|
Digits : array[0..$F] of AnsiChar = '0123456789ABCDEF';
|
|
LowChar : array[Boolean] of Byte = (32, 33);
|
|
var
|
|
I, J : Cardinal;
|
|
Col : Cardinal;
|
|
Res : Integer;
|
|
DumpFile : Text;
|
|
C : AnsiChar;
|
|
LogFileBuffer : array[1..512] of AnsiChar;
|
|
S : string[80];
|
|
logBfr : TLogBuffer; // SWB
|
|
|
|
function GetOSVersion : string;
|
|
var
|
|
OSVersion : TOSVersionInfo;
|
|
SerPack : string; {!!.04}
|
|
begin
|
|
OSVersion.dwOSVersionInfoSize := SizeOf(OSVersion);
|
|
GetVersionEx(OSVersion);
|
|
SerPack := ''; {!!.04}
|
|
|
|
case OSVersion.dwPlatformID of
|
|
VER_PLATFORM_WIN32s : begin {!!.04}
|
|
SerPack := StrPas(OSVersion.szCSDVersion); {!!.04}
|
|
Result := 'Win32s on Windows ';
|
|
end; {!!.04}
|
|
VER_PLATFORM_WIN32_WINDOWS : begin {!!.04}
|
|
case OsVersion.dwMinorVersion of {!!.04}
|
|
0 : if Trim(OsVersion.szCSDVersion[1]) = 'B' then {!!.04}
|
|
Result := 'Win32 on Windows 95 OSR 2 ' {!!.04}
|
|
else {!!.04}
|
|
Result := 'Win32 on Windows 95 OSR 1 '; {!!.04}
|
|
10 : if Trim(OsVersion.szCSDVersion[1]) = 'A' then {!!.04}
|
|
Result := 'Win32 on Windows 98 OSR 2 ' {!!.04}
|
|
else {!!.04}
|
|
Result := 'Win32 on Windows 98 OSR 1 '; {!!.04}
|
|
90 : if (OsVersion.dwBuildNumber = 73010104) then {!!.04}
|
|
Result := 'Win32 on Windows ME '; {!!.04}
|
|
else Result := 'Win32 on Windows 9x'; {!!.04}
|
|
end; {!!.04}
|
|
end; {!!.04}
|
|
VER_PLATFORM_WIN32_NT : begin {!!.04}
|
|
SerPack := StrPas(OSVersion.szCSDVersion); {!!.04}
|
|
case OSVersion.dwMajorVersion of {!!.04}
|
|
2 : if OsVersion.dwMinorVersion = 6 then // --sm
|
|
Result := 'Window CE '; // --sm
|
|
3 : Result := 'Windows NT 3.5 '; {!!.04}
|
|
4 : Result := 'Windows NT 4 '; {!!.04}
|
|
5 : case OSVersion.dwMinorVersion of {!!.04}
|
|
0 : Result := 'Windows 2000 '; {!!.04}
|
|
1 : Result := 'Windows XP '; {!!.04}
|
|
2 : Result := 'Windows 2003 '; // --sm
|
|
end;
|
|
6 : case OSVersion.dwMinorVersion of // --sm
|
|
0 : Result := 'Windows Vista '; // --sm
|
|
1 : Result := 'Windows 7 '; // --sm
|
|
end; {!!.04}
|
|
else Result := 'WinNT '; {!!.04}
|
|
end; {!!.04}
|
|
end; {!!.04}
|
|
else Result := 'Unknown';
|
|
end;
|
|
Result := Result + IntToStr(OSVersion.dwMajorVersion) + '.' +
|
|
IntToStr(OSVersion.dwMinorVersion) + ' ' + SerPack; {!!.04}
|
|
end;
|
|
|
|
procedure CheckCol(N : Cardinal);
|
|
{-Wrap if N bytes would exceed column limit}
|
|
begin
|
|
Inc(Col, N);
|
|
if Col > MaxTraceCol then begin
|
|
WriteLn(DumpFile);
|
|
Write(DumpFile, '':StartColumn-1);
|
|
Col := StartColumn+N;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := ecOK;
|
|
|
|
{Make sure we have something to do}
|
|
if ((DLoggingQueue = nil) or // SWB
|
|
(DLoggingQueue.Count = 0)) then begin // SWB
|
|
// AbortDispatchLogging; // SWB
|
|
Exit;
|
|
end;
|
|
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
Assign(DumpFile, FName);
|
|
SetTextBuf(DumpFile, LogFileBuffer, SizeOf(LogFileBuffer));
|
|
if AppendFile and ExistFileZ(FName) then begin
|
|
{Append to existing file}
|
|
Append(DumpFile);
|
|
Res := IoResult;
|
|
end else begin
|
|
{Create new file}
|
|
Rewrite(DumpFile);
|
|
Res := IoResult;
|
|
end;
|
|
if Res <> 0 then begin
|
|
Result := -Res;
|
|
Close(DumpFile);
|
|
if IoResult <> 0 then ;
|
|
Exit;
|
|
end;
|
|
|
|
{Write heading just once}
|
|
{$IFDEF APAX}
|
|
WriteLn(DumpFile, 'APAX', ApaxVersionStr);
|
|
{$ELSE}
|
|
WriteLn(DumpFile, 'APRO ', ApVersionStr);
|
|
{write compiler version to log}
|
|
S := 'RAD Studio XEn';
|
|
|
|
WriteLn(DumpFile, 'Compiler : ', S);
|
|
{$ENDIF}
|
|
|
|
{write operating system to log}
|
|
S := ShortString(GetOSVersion());
|
|
WriteLn(DumpFile, 'Operating System : ', S);
|
|
|
|
WriteLn(DumpFile, 'Device: ', DeviceName);
|
|
|
|
S := ShortString(FormatDateTime('dd/mm/yy, hh:mm:ss', Now)); {!!.02}
|
|
WriteLn(DumpFile, 'Date/time: ', S); {!!.02}
|
|
|
|
WriteLn(DumpFile, AproLoadStr(Header1));
|
|
WriteLn(DumpFile, AproLoadStr(Header2));
|
|
|
|
{Loop through all entries}
|
|
repeat
|
|
{Get the next entry and remove from queue}
|
|
logBfr := TLogBuffer(DLoggingQueue.Pop); // SWB
|
|
{Write a report line}
|
|
if (Assigned(logBfr)) then begin // SWB
|
|
with logBfr do begin
|
|
Write(DumpFile, format('%8s %-8s %-12s %08.8x ',
|
|
[GetTimeStr(drTime),GetDTStr(drType),GetDSTStr(drSubType),drData]));
|
|
if drMoreData = 0 then begin
|
|
|
|
{Add telnet tags if necessary}
|
|
if drType = dtTelnet then begin
|
|
S := ' [';
|
|
if drData <= MaxTelnetTag then
|
|
S := S + ShortString(AproLoadStr(TelnetBase + ord(drData)));
|
|
Write(DumpFile, trim(string(S)),']');
|
|
end;
|
|
|
|
WriteLn(DumpFile)
|
|
end else begin
|
|
if (drSubType = dstStatusTrigger)
|
|
and ((drType = dtTriggerAlloc)
|
|
or (drType = dtTriggerDispose))
|
|
then begin
|
|
case Byte(drBuffer^) of // SWB
|
|
0 : Write(DumpFile, '(Not active)');
|
|
1 : Write(DumpFile, '(Modem status)');
|
|
2 : Write(DumpFile, '(Line status)');
|
|
3 : Write(DumpFile, '(Output buffer free)');
|
|
4 : Write(DumpFile, '(Output buffer used)');
|
|
5 : Write(DumpFile, '(Output sent)');
|
|
end;
|
|
end else begin
|
|
Col := StartColumn;
|
|
for I := 0 to (drMoreData - 1) do begin // SWB
|
|
C := (drBuffer + I)^; // SWB
|
|
if AllHex then begin
|
|
if drType = dtUser then begin
|
|
CheckCol(1);
|
|
Write(DumpFile, C);
|
|
end else begin
|
|
CheckCol(4);
|
|
Write(DumpFile, '[',IntToHex(Ord(C), 2),']');
|
|
end;
|
|
end else
|
|
if (Ord(C) < LowChar[InHex]) or (Ord(C) > 126) then begin
|
|
if InHex then begin
|
|
CheckCol(4);
|
|
Write(DumpFile, '[',IntToHex(Ord(C),2),']')
|
|
end else begin
|
|
if Ord(C) > 99 then
|
|
J := 5
|
|
else if Ord(C) > 9 then
|
|
J := 4
|
|
else
|
|
J := 3;
|
|
CheckCol(J);
|
|
Write(DumpFile, '[',Ord(C),']')
|
|
end;
|
|
end else begin
|
|
CheckCol(1);
|
|
Write(DumpFile, C);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{Add modem status tags}
|
|
if drSubType = dstModemStatus then begin
|
|
S := ' (';
|
|
for I := 0 to 7 do
|
|
if Odd(drData shr I) then
|
|
S := S + ShortString(AproLoadStr(MSTagBase + I));
|
|
Write(DumpFile, trim(string(S)),')');
|
|
end;
|
|
|
|
WriteLn(DumpFile);
|
|
|
|
end;
|
|
end;
|
|
logBfr.Free; // SWB
|
|
end;
|
|
until (not Assigned(logBfr)); // SWB
|
|
|
|
Close(DumpFile);
|
|
Result := -IoResult;
|
|
// AbortDispatchLogging; // SWB
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.DumpDispatchLog(
|
|
FName : string;
|
|
InHex, AllHex : Boolean) : Integer;
|
|
|
|
{-Dump the dispatch log}
|
|
begin
|
|
Result := DumpDispatchLogPrim(FName, False, InHex, AllHex);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.AppendDispatchLog(
|
|
FName : string;
|
|
InHex, AllHex : Boolean) : Integer;
|
|
{-Append the dispatch log}
|
|
begin
|
|
Result := DumpDispatchLogPrim(FName, True, InHex, AllHex);
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetDispatchTime : DWORD;
|
|
{-Return elapsed time}
|
|
begin
|
|
Result := (AdTimeGetTime - TimeBase);
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.AddDispatchEntry(
|
|
DT : TDispatchType;
|
|
DST : TDispatchSubType;
|
|
Data : Cardinal;
|
|
Buffer : Pointer;
|
|
BufferLen : Cardinal);
|
|
var
|
|
logBuf : TLogBuffer; // SWB
|
|
begin
|
|
if DLoggingOn then {!!.02}
|
|
begin // SWB
|
|
// If there is a limit to the log queue size and we have // SWB
|
|
// exceeded it, pop the oldest entries from the queue until we // SWB
|
|
// are under the limit again. // SWB
|
|
while ((DLoggingMax > 0) and // SWB
|
|
(Cardinal(DLoggingQueue.BytesQueued) > DLoggingMax)) do // SWB
|
|
begin // SWB
|
|
logBuf := TLogBuffer(DLoggingQueue.Pop); // SWB
|
|
logBuf.Free; // SWB
|
|
end; // SWB
|
|
// Add the new entry to the queue // SWB
|
|
logBuf := TLogBuffer.Create(DT, // SWB
|
|
DST, // SWB
|
|
GetDispatchTime, // SWB
|
|
Data, // SWB
|
|
PAnsiChar(Buffer), // SWB
|
|
BufferLen); // SWB
|
|
DLoggingQueue.Push(logBuf); // SWB
|
|
end; // SWB
|
|
end;
|
|
|
|
function TApdBaseDispatcher.ClassifyStatusTrigger(
|
|
TriggerHandle : Cardinal) : Cardinal;
|
|
{-Return the type for TriggerHandle}
|
|
begin
|
|
Result := TriggerHandle and StatusTypeMask;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.SetEventBusy(
|
|
var WasOn : Boolean;
|
|
SetOn : Boolean);
|
|
{-Set/Clear the event busy flag}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
WasOn := fEventBusy;
|
|
fEventBusy := SetOn;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function PortIn(Address: Word): Byte;
|
|
{-Use this instead of Port since it works in both 16 and 32-bit mode}
|
|
asm
|
|
mov dx,ax
|
|
in al,dx
|
|
end;
|
|
|
|
|
|
procedure TApdBaseDispatcher.SetRS485Mode(OnOff : Boolean);
|
|
{-Set/reset the RS485 flag}
|
|
var
|
|
LocalBaseAddress : Word;
|
|
|
|
procedure GetLocalBaseAddress;
|
|
{Undocumented function returns the base address in edx}
|
|
{$ifndef CPUX64}
|
|
asm
|
|
mov eax,CidEX
|
|
push eax
|
|
push 10
|
|
call EscapeCommFunction // (CidEx, 10);
|
|
mov LocalBaseAddress, dx
|
|
end;
|
|
{$else}
|
|
asm
|
|
mov ecx, CidEX
|
|
mov rdx,10
|
|
call EscapeCommFunction // (CidEx, 10);
|
|
mov LocalBaseAddress, dx
|
|
end;
|
|
{$endif}
|
|
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
RS485Mode := OnOff;
|
|
|
|
if RS485Mode then begin
|
|
{Handle entering RS485 mode}
|
|
if Assigned(OutThread) then
|
|
OutThread.Priority :=
|
|
TThreadPriority(Ord(tpHigher) + ThreadBoost);
|
|
if Win32Platform <> VER_PLATFORM_WIN32_NT then begin
|
|
GetLocalBaseAddress;
|
|
BaseAddress := LocalBaseAddress;
|
|
end;
|
|
end else begin
|
|
if Assigned(OutThread) then
|
|
OutThread.Priority :=
|
|
TThreadPriority(Ord(tpNormal) + ThreadBoost);
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TApdBaseDispatcher.SetBaseAddress(NewBaseAddress : Word);
|
|
{-Set the base address}
|
|
begin
|
|
EnterCriticalSection(DataSection);
|
|
try
|
|
BaseAddress := NewBaseAddress;
|
|
finally
|
|
LeaveCriticalSection(DataSection);
|
|
end;
|
|
end;
|
|
|
|
function TApdBaseDispatcher.GetBaseAddress : Word;
|
|
{-Get the base address}
|
|
begin
|
|
Result := BaseAddress;
|
|
end;
|
|
|
|
constructor TApdDispatcherThread.Create(Disp : TApdBaseDispatcher);
|
|
begin
|
|
H := Disp;
|
|
inherited Create(False);
|
|
FreeOnTerminate := True;
|
|
end;
|
|
|
|
procedure TApdDispatcherThread.SyncEvent;
|
|
begin
|
|
pTriggerEvent(pMsg,pTrigger,plParam);
|
|
end;
|
|
|
|
procedure TApdDispatcherThread.SyncNotify(Msg, Trigger : Cardinal;
|
|
lParam : Integer; Event : TApdNotifyEvent);
|
|
begin
|
|
pMsg := Msg;
|
|
pTrigger := Trigger;
|
|
plParam := lParam;
|
|
pTriggerEvent := Event;
|
|
Synchronize(SyncEvent);
|
|
end;
|
|
|
|
procedure TApdDispatcherThread.Sync(Method: TThreadMethod);
|
|
{- public version of Synchronize}
|
|
begin
|
|
Synchronize(Method);
|
|
end;
|
|
|
|
{Output event thread}
|
|
procedure TOutThread.Execute;
|
|
{-Wait for and process output events}
|
|
var
|
|
Res : Integer;
|
|
OutOL : TOverlapped; {For output event waiting}
|
|
|
|
function DataInBuffer : Boolean;
|
|
{indicate whether the output buffer has data to be sent}
|
|
begin
|
|
with H do begin
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
DataInBuffer := OBufFull or (OBufHead <> OBufTail);
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure ProcessOutputEvent(H : TApdBaseDispatcher);
|
|
var
|
|
NumToWrite : Integer;
|
|
NumWritten : DWORD;
|
|
Ok : Boolean;
|
|
TempBuff : POBuffer;
|
|
begin
|
|
while DataInBuffer do begin
|
|
with H do begin
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
{Check for buffer wrap-around. If wrap around has occurred,
|
|
use a temp buffer to shuffle around the buffer contents to make the
|
|
data in the buffer reside at contiguous locations. This is done to
|
|
prevent scheduling delays in the OS from causing us to emit data with
|
|
potentially large gaps in the output stream of bytes when buffer wrap-
|
|
around occurs.}
|
|
if OBufTail < OBufHead then
|
|
NumToWrite := OBufHead - OBufTail
|
|
else begin
|
|
if (OBufHead = 0) then
|
|
NumToWrite := OutQue - OBufTail
|
|
else begin
|
|
GetMem(TempBuff, OBufHead);
|
|
Move(OBuffer^, TempBuff^, OBufHead);
|
|
Move(OBuffer^[OBufTail], OBuffer^, OutQue - OBufTail);
|
|
Move(TempBuff^, OBuffer^[OutQue - OBufTail], OBufHead);
|
|
FreeMem(TempBuff);
|
|
Inc(OBufHead, OutQue - OBufTail);
|
|
NumToWrite := OBufHead;
|
|
OBufTail := 0;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
Ok := WriteFile(CidEx,
|
|
OBuffer^[OBufTail],
|
|
NumToWrite,
|
|
NumWritten,
|
|
@OutOL);
|
|
if not Ok then begin
|
|
if GetLastError = ERROR_IO_PENDING then begin
|
|
{expected -- write is pending}
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(OutSleep));
|
|
{$ENDIF}
|
|
Res := WaitForMultipleObjects(2,
|
|
@OutWaitObjects2,
|
|
False,
|
|
INFINITE);
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(OutWake));
|
|
{$ENDIF}
|
|
case Res of
|
|
WAIT_OBJECT_0 :
|
|
begin
|
|
{overlapped i/o completed}
|
|
if GetOverLappedResult(CidEx, OutOL, NumWritten, False) then begin
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
Inc(OBufTail, NumWritten);
|
|
if(OBufTail = OutQue) then
|
|
OBufTail := 0;
|
|
{ If nothing left in the buffer, reset the }
|
|
{ queue to avoid buffer wrap-arounds. }
|
|
if(OBufTail = OBufHead) then begin
|
|
OBufTail := 0;
|
|
OBufHead := 0;
|
|
end;
|
|
OBufFull := False;
|
|
ResetEvent(OutOL.hEvent);
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end else begin
|
|
{GetOverLappedResult failed.}
|
|
end;
|
|
end;
|
|
WAIT_OBJECT_0 + 1 :
|
|
begin
|
|
{flush buffer requested, acknowledge and exit}
|
|
SetEvent(GeneralEvent);
|
|
Exit;
|
|
end;
|
|
WAIT_TIMEOUT :
|
|
{couldn't send all data}
|
|
else
|
|
{an unexpected error occurred with WaitForMultipleObjects}
|
|
end;
|
|
end else begin
|
|
{WriteFile failed, but not because of delayed write}
|
|
{ Give up on sending this block, update the queue
|
|
pointers, and continue. We get here if we lose
|
|
carrier during a transmit, and if we continue to
|
|
try to resend the data, we'll loop forever.}
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
inc(OBufTail, NumToWrite);
|
|
if (OBufTail = OutQue) then
|
|
OBufTail := 0;
|
|
{ If nothing left in the buffer, reset the queue }
|
|
{ to avoid buffer wrap-arounds }
|
|
if (OBufTail = OBufHead) then begin
|
|
OBufTail := 0;
|
|
OBufHead := 0;
|
|
end;
|
|
OBufFull := False;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end;
|
|
end else begin
|
|
{ WriteFile completed immediately -- update buffer pointer }
|
|
EnterCriticalSection(OutputSection);
|
|
try
|
|
Inc(OBufTail, NumWritten);
|
|
if (OBufTail = OutQue) then
|
|
OBufTail := 0;
|
|
{ If nothing left in the buffer, reset the queue to }
|
|
{ avoid buffer wrap-arounds }
|
|
if (OBufTail = OBufHead) then begin
|
|
OBufTail := 0;
|
|
OBufHead := 0;
|
|
end;
|
|
OBufFull := False;
|
|
finally
|
|
LeaveCriticalSection(OutputSection);
|
|
end;
|
|
end;
|
|
{No more data in buffer, if in RS485 mode wait for TE}
|
|
if Win32Platform <> VER_PLATFORM_WIN32_NT then
|
|
if RS485Mode then begin
|
|
repeat
|
|
until (PortIn(BaseAddress+5) and $40) <> 0;
|
|
SetRTS(False);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
InterLockedIncrement(H.ActiveThreads);
|
|
try
|
|
FillChar(OutOL, SizeOf(OutOL), #0);
|
|
with H do begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadStart, 3, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{set the event used for overlapped i/o to signal completion}
|
|
OutOL.hEvent := SentEvent;
|
|
|
|
{Ready to go, set the general event}
|
|
SetEvent(GeneralEvent);
|
|
|
|
{Repeat until port is closed}
|
|
repeat
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadSleep, 3, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{Wait for either an output event or a flush event}
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(OutSleep));
|
|
{$ENDIF}
|
|
Res := WaitForMultipleObjects(2,
|
|
@OutWaitObjects1,
|
|
False,
|
|
INFINITE);
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(OutWake));
|
|
{$ENDIF}
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadWake, 3, nil, 0);
|
|
{$ENDIF}
|
|
|
|
case Res of
|
|
WAIT_OBJECT_0 :
|
|
begin
|
|
{output event}
|
|
{Exit immediately if thread was killed while waiting}
|
|
if KillThreads then begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 3, nil, 0);
|
|
{$ENDIF}
|
|
{Finished here, okay to close the port}
|
|
H.ThreadGone(Self);
|
|
Exit;
|
|
end;
|
|
|
|
{We have data to send, so process it...}
|
|
ProcessOutputEvent(H);
|
|
end;
|
|
WAIT_OBJECT_0 + 1 :
|
|
begin
|
|
{flush buffer requested, acknowledge and continue}
|
|
SetEvent(GeneralEvent);
|
|
end;
|
|
else
|
|
{unexpected problem with WaitFor}
|
|
end;
|
|
until KillThreads or ClosePending;
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 3, nil, 0);
|
|
{$ENDIF}
|
|
end;
|
|
H.ThreadGone(Self);
|
|
except
|
|
if Assigned(GShowExceptionHandler) then
|
|
GShowExceptionHandler(ExceptObject, ExceptAddr)
|
|
else
|
|
ShowException(ExceptObject, ExceptAddr);
|
|
end;
|
|
end;
|
|
|
|
{Communications event thread}
|
|
procedure TComThread.Execute;
|
|
{-Wait for and process communications events}
|
|
var
|
|
Junk : DWORD;
|
|
LastMask : Integer;
|
|
Timeouts : TCommTimeouts;
|
|
ComOL : TOverlapped; {For com event waiting}
|
|
begin
|
|
InterLockedIncrement(H.ActiveThreads);
|
|
try
|
|
FillChar(ComOL, SizeOf(ComOL), #0);
|
|
with H do begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadStart, 1, nil, 0);
|
|
{$ENDIF}
|
|
|
|
ComOL.hEvent := CreateEvent(nil, True, False, nil);
|
|
|
|
{Set our standard win32 events}
|
|
|
|
{ Note, NuMega's BoundsChecker will flag a bogus error on the }
|
|
{ following statement because we use the undocumented ring_te flag }
|
|
|
|
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
|
LastMask := DefEventMask and not ev_RingTe
|
|
else
|
|
LastMask := DefEventMask;
|
|
SetCommMask(CidEx, LastMask);
|
|
|
|
FillChar(Timeouts, SizeOf(TCommTimeouts), 0);
|
|
Timeouts.ReadIntervalTimeout := MaxDWord;
|
|
SetCommTimeouts(CidEx, Timeouts);
|
|
|
|
{Ready to go, set the general event}
|
|
SetEvent(GeneralEvent);
|
|
|
|
{Repeat until port is closed}
|
|
repeat
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadSleep, 1, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(ComSleep));
|
|
{$ENDIF}
|
|
|
|
{Release time slice until we get a communications event}
|
|
if not WaitComEvent(CurrentEvent, @ComOL) then begin
|
|
if GetLastError = ERROR_IO_PENDING then begin
|
|
if GetOverLappedResult(CidEx,
|
|
ComOL,
|
|
Junk,
|
|
True) then begin
|
|
|
|
{WIN32 bug workaround: Apro gets the modem status bits
|
|
with a call (later) to GetCommModemStatus. Unfortunately,
|
|
that routine never seems to return either RI or TERI.
|
|
So, we note either EV_RING or EV_RINGTE here and later
|
|
manually merge the TERI bit into ModemStatus.}
|
|
if ((CurrentEvent and EV_RINGTE) <> 0) or
|
|
((CurrentEvent and EV_RING) <> 0) then
|
|
RingFlag := True;
|
|
|
|
{Read complete, reset event}
|
|
ResetEvent(ComOL.hEvent);
|
|
end else begin
|
|
{Port closed or other fatal condition, just exit the thread}
|
|
SetEvent(GeneralEvent);
|
|
CloseHandle(ComOL.hEvent);
|
|
H.ThreadGone(Self);
|
|
Exit;
|
|
end;
|
|
end else begin
|
|
{ If we get an ERROR_INVALID_PARAMETER, we assume it's our }
|
|
{ use of ev_RingTe -- clear the flag and try again }
|
|
if (GetLastError = ERROR_INVALID_PARAMETER) and
|
|
(LastMask and EV_RINGTE <> 0) then begin
|
|
LastMask := DefEventMask and not EV_RINGTE;
|
|
SetCommMask(CidEx, LastMask);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{Exit immediately if thread was killed while waiting}
|
|
if KillThreads then begin
|
|
SetEvent(GeneralEvent);
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 1, nil, 0);
|
|
{$ENDIF}
|
|
CloseHandle(ComOL.hEvent);
|
|
H.ThreadGone(Self);
|
|
Exit;
|
|
end;
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(ComWake));
|
|
{$ENDIF}
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadWake, 1, @CurrentEvent, 2);
|
|
{$ENDIF}
|
|
|
|
{Signal com event}
|
|
SetEvent(ComEvent);
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(ComSleep));
|
|
{$ENDIF}
|
|
|
|
{Wait for the dispatcher thread to complete}
|
|
WaitForSingleObject(ReadyEvent, INFINITE);
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(ComWake));
|
|
{$ENDIF}
|
|
|
|
until KillThreads;
|
|
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 1, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{Finished here, okay to close the port}
|
|
SetEvent(GeneralEvent);
|
|
end;
|
|
CloseHandle(ComOL.hEvent);
|
|
H.ThreadGone(Self);
|
|
except
|
|
if Assigned(GShowExceptionHandler) then
|
|
GShowExceptionHandler(ExceptObject, ExceptAddr)
|
|
else
|
|
ShowException(ExceptObject, ExceptAddr);
|
|
end;
|
|
end;
|
|
|
|
procedure TDispThread.Execute;
|
|
{-Wait for and process communications events}
|
|
procedure ProcessComEvent(H : TApdBaseDispatcher);
|
|
{$IFNDEF UseAwWin32} // SWB
|
|
var // SWB
|
|
bfr : TIOBuffer; // SWB
|
|
{$ENDIF} // SWB
|
|
begin
|
|
with H do begin
|
|
{$IFNDEF UseAwWin32} // SWB
|
|
// Read the first status packet from the queue & copy its contents // SWB
|
|
// to CurrentEvent so that the status event handlers can process it.// SWB
|
|
bfr := FQueue.Peek; // SWB
|
|
if (Assigned(bfr)) then // SWB
|
|
begin // SWB
|
|
if (bfr is TStatusBuffer) then // SWB
|
|
begin // SWB
|
|
CurrentEvent := TStatusBuffer(bfr).Status; // SWB
|
|
FQueue.Pop; // SWB
|
|
TStatusBuffer(bfr).Free; // KGM
|
|
end else // SWB
|
|
begin // SWB
|
|
bfr.InUse := False; // SWB
|
|
CurrentEvent := 0; // SWB
|
|
end; // SWB
|
|
end else // SWB
|
|
CurrentEvent := 0; // SWB
|
|
{WIN32 bug workaround: Apro gets the modem status bits // SWB
|
|
with a call (later) to GetCommModemStatus. Unfortunately, // SWB
|
|
that routine never seems to return either RI or TERI. // SWB
|
|
So, we note either EV_RING or EV_RINGTE here and later // SWB
|
|
manually merge the TERI bit into ModemStatus.} // SWB
|
|
if ((CurrentEvent and (EV_RINGTE or EV_RING)) <> 0) then // SWB
|
|
RingFlag := True; // SWB
|
|
{$ENDIF} // SWB
|
|
{Check for modem events}
|
|
if CurrentEvent and ModemEvent <> 0 then begin
|
|
|
|
{A modem status event...}
|
|
MapEventsToMS(CurrentEvent);
|
|
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtDispatch, dstModemStatus,
|
|
ModemStatus, @CurrentEvent, 2);
|
|
{$ENDIF}
|
|
|
|
{Check for status triggers}
|
|
if not fEventBusy then begin
|
|
while CheckStatusTriggers do
|
|
if ClosePending then
|
|
Exit;
|
|
|
|
{Allow status triggers to hit again}
|
|
if GlobalStatHit then
|
|
ResetStatusHits;
|
|
end;
|
|
end;
|
|
|
|
{Check for line events}
|
|
if CurrentEvent and LineEvent <> 0 then begin
|
|
{A line status/error event}
|
|
RefreshStatus;
|
|
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtDispatch, dstLineStatus,
|
|
0, @CurrentEvent, 2);
|
|
{$ENDIF}
|
|
|
|
{Check for status triggers}
|
|
if not fEventBusy then begin
|
|
while CheckStatusTriggers do
|
|
if ClosePending then
|
|
Exit;
|
|
|
|
{Allow status triggers to hit again}
|
|
if GlobalStatHit then
|
|
ResetStatusHits;
|
|
end;
|
|
end;
|
|
|
|
{ Get any available data }
|
|
ExtractData;
|
|
|
|
{Check for received status & data triggers}
|
|
if not fEventBusy then begin
|
|
ModemStatus := GetModemStatus; {!!.06}
|
|
while CheckStatusTriggers do
|
|
if ClosePending then
|
|
Exit;
|
|
while CheckReceiveTriggers do
|
|
if ClosePending then
|
|
Exit;
|
|
end;
|
|
if GlobalStatHit then
|
|
ResetStatusHits;
|
|
|
|
{Let the com thread continue...}
|
|
SetEvent(ReadyEvent);
|
|
end;
|
|
end;
|
|
|
|
procedure ProcessTimer(H : TApdBaseDispatcher);
|
|
begin
|
|
with H do begin
|
|
if ClosePending then
|
|
Exit;
|
|
|
|
if not fEventBusy then begin
|
|
GlobalStatHit := False;
|
|
|
|
{Issue all status and timer triggers}
|
|
|
|
while (CheckStatusTriggers or CheckTimerTriggers) and not ClosePending do
|
|
;
|
|
{Allow status triggers to hit again}
|
|
if GlobalStatHit then
|
|
ResetStatusHits;
|
|
end else begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtError, dstNone, 0, nil, 0);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
InterLockedIncrement(H.ActiveThreads);
|
|
try
|
|
with H do begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadStart, 2, nil, 0);
|
|
{$ENDIF}
|
|
|
|
try
|
|
{Ready to go, set the general event}
|
|
SetEvent(GeneralEvent);
|
|
|
|
{Repeat until port is closed}
|
|
repeat
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadSleep, 2, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(DispSleep));
|
|
{$ENDIF}
|
|
|
|
{Wait for either a com event or a timeout}
|
|
FQueue.WaitForBuffer(50); // SWB
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(DispWake));
|
|
{$ENDIF}
|
|
|
|
{Exit immediately if thread was killed while waiting}
|
|
if KillThreads then begin
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 2, nil, 0);
|
|
{$ENDIF}
|
|
{Finished here, okay to close the port}
|
|
Exit;
|
|
end;
|
|
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadWake, 2, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{Process it...}
|
|
ProcessComEvent(H);
|
|
ProcessTimer(H);
|
|
|
|
until KillThreads or ClosePending;
|
|
|
|
{$IFDEF DebugThreads}
|
|
if DLoggingOn then
|
|
AddDispatchEntry(dtThread, dstThreadExit, 2, nil, 0);
|
|
{$ENDIF}
|
|
|
|
{Finished here, okay to close the port}
|
|
SetEvent(GeneralEvent);
|
|
|
|
finally
|
|
{ Make sure DonePortPrim gets called }
|
|
DoDonePortPrim := (ClosePending or KillThreads);
|
|
{$IFDEF DebugThreadConsole}
|
|
Writeln(ThreadStatus(DispKill));
|
|
{$ENDIF}
|
|
H.ThreadGone(Self);
|
|
end;
|
|
end;
|
|
except
|
|
if Assigned(GShowExceptionHandler) then
|
|
GShowExceptionHandler(ExceptObject, ExceptAddr)
|
|
else
|
|
ShowException(ExceptObject, ExceptAddr);
|
|
end;
|
|
end;
|
|
|
|
procedure LockPortList;
|
|
begin
|
|
EnterCriticalSection(PortListSection);
|
|
end;
|
|
|
|
procedure UnlockPortList;
|
|
begin
|
|
LeaveCriticalSection(PortListSection);
|
|
end;
|
|
|
|
procedure FinalizeUnit; far;
|
|
begin
|
|
PortList.Free;
|
|
PortList := nil;
|
|
end;
|
|
|
|
procedure InitializeUnit;
|
|
begin
|
|
PortList := TList.Create;
|
|
|
|
FillChar(PortListSection, SizeOf(PortListSection), 0);
|
|
InitializeCriticalSection(PortListSection);
|
|
end;
|
|
|
|
initialization // SZ FIXME loader lock
|
|
InitializeUnit;
|
|
|
|
finalization
|
|
FinalizeUnit;
|
|
DeleteCriticalSection(PortListSection);
|
|
|
|
end.
|