// 7 Dec 2007 - angus - magenta systems - added public ComPortName instead of ComNumber // only code change is within function MakeComName and public ComPortName // 14 July 2014 - fixed memory leak, ignore ComNumber if ComPortName specified (***** 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): * * ***** END LICENSE BLOCK ***** *) {*********************************************************} {* ADPORT.PAS 4.06 *} {*********************************************************} {* TApdComPort component *} {*********************************************************} { This unit defines the TApdCustomComPort and TApdComPort components. Both of these are interfaces to the dispatcher, which is what does the actual port communication. The base dispatcher is defined in AwUser.pas, serial port dispatcher (Win32) is in AwWin32.pas, Winsock dispatcher is in AwWnSock.pas The term dispatcher is used for the code that interfaces with the device. } {Global defines potentially affecting this unit} {$I AWDEFINE.INC} {Options required for this unit} {$G+,X+,F+. $J+} {$C MOVEABLE,DEMANDLOAD,DISCARDABLE} {!!.02} { removed Win16 references } unit AdPort; {-Delphi serial port component} interface uses WinTypes, WinProcs, SysUtils, Classes, Messages, Controls, Forms, OoMisc, AwUser, AwWin32, AdExcept, AdSelCom; type {Parity type} TParity = (pNone, pOdd, pEven, pMark, pSpace); {Activation procedure type} TActivationProcedure = function(Owner : TObject) : TApdBaseDispatcher; {Device layer types} TDeviceLayer = (dlWin32, dlWinsock); TDeviceLayers = set of TDeviceLayer; {Baud type} TBaudRate = LongInt; {Tapi modes} TTapiMode = (tmNone, tmAuto, tmOn, tmOff); {Port state} TPortState = (psClosed, psShuttingDown, psOpen); {Hardware flow control types} THWFlowOptions = ( hwfUseDTR, {Use DTR for receive flow control} hwfUseRTS, {Use RTS for receive flow control} hwfRequireDSR, {Require DSR before transmitting} hwfRequireCTS); {Require CTS before transmitting} THWFlowOptionSet = set of THWFlowOptions; {Software flow control types} TSWFlowOptions = (swfNone, swfReceive, swfTransmit, swfBoth); {For reporting flow states, note: no rcv hardware flow status is provided} TFlowControlState = (fcOff, {No flow control is in use} fcOn, {Transmit blocked} fcDsrHold, {Transmit blocked by low DSR} fcCtsHold, {Transmit blocked by low CTS} fcDcdHold, {Transmit blocked by low DCD} fcXOutHold, {Transmit blocked by Xoff} fcXInHold, {Receive blocked by Xoff} fcXBothHold); {Both are blocked by Xoff} {Tracing/logging states} TTraceLogState = (tlOff, tlOn, tlDump, tlAppend, tlClear, tlPause); {General trigger event handler} TTriggerEvent = procedure(CP : TObject; Msg, TriggerHandle, Data : Word) of object; {Specific trigger event handlers} TTriggerAvailEvent = procedure(CP : TObject; Count : Word) of object; TTriggerDataEvent = procedure(CP : TObject; TriggerHandle : Word) of object; TTriggerStatusEvent = procedure(CP : TObject; TriggerHandle : Word) of object; TTriggerTimerEvent = procedure(CP : TObject; TriggerHandle : Word) of object; {Status event handlers} TTriggerLineErrorEvent = procedure(CP : TObject; Error : Word; LineBreak : Boolean) of object; {WaitChar event handler} TWaitCharEvent = procedure(CP : TObject; C : Char) of object; {Port open/close callbacks} TPortCallback = procedure(CP : TObject; Opening : Boolean) of object; {Extended port open/closing/close callbacks} {!!.03} TApdCallbackType = (ctOpen, ctClosing, ctClosed); TPortCallbackEx = procedure(CP : TObject; CallbackType : TApdCallbackType) of object; {For keeping track of port users} PUserListEntry = ^TUserListEntry; TUserListEntry = record Handle : THandle; OpenClose : TPortCallback; OpenCloseEx: TPortCallbackEx; {!!.03} IsEx : Boolean; {!!.03} end; TApThreadBoost = (tbNone, tbPlusOne, tbPlusTwo); const {Parity strings} ParityName : array[TParity] of string[5] = ('None', 'Odd', 'Even', 'Mark', 'Space'); {Property defaults} adpoDefDeviceLayer = dlWin32; adpoDefPromptForPort = True; adpoDefComNumber = 0; adpoDefBaudRt = 19200; adpoDefParity = pNone; adpoDefDatabits = 8; adpoDefStopbits = 1; adpoDefInSize = 4096; adpoDefOutSize = 4096; adpoDefOpen = False; adpoDefAutoOpen = True; adpoDefBaseAddress = 0; adpoDefTapiMode = tmAuto; adpoDefDTR = True; adpoDefRTS = True; adpoDefTracing = tlOff; adpoDefTraceSize = 10000; adpoDefTraceName = 'APRO.TRC'; adpoDefTraceHex = True; adpoDefTraceAllHex = False; adpoDefLogging = tlOff; adpoDefLogSize = 10000; adpoDefLogName = 'APRO.LOG'; adpoDefLogHex = True; adpoDefLogAllHex = False; adpoDefUseMSRShadow = True; adpoDefUseEventWord = True; adpoDefSWFlowOptions = swfNone; adpoDefXonChar = #17; adpoDefXoffChar = #19; adpoDefBufferFull = 0; adpoDefBufferResume = 0; adpoDefTriggerLength = 1; adpoDefCommNotificationLevel = 10; adpoDefRS485Mode = False; type {Port component} TApdCustomComPort = class(TApdBaseComponent) private protected {private} {.Z+} {Internal stuff} Force : Boolean; {True to force property setting} PortState : TPortState; {State of the physical port/dispatcher} OpenPending : Boolean; {True if Open := True while shutting down} ForceOpen : Boolean; {Force open after loading} UserList : TList; {List of comport users} CopyTriggers : Boolean; {Copy triggers on open} SaveTriggerBuffer: TTriggerSave; {Triggers to copy} BusyBeforeWait : Boolean; {True if EventBusy before Wait} WaitPrepped : Boolean; {True if PrepareWait called} fComWindow : THandle; {Hidden window handle} fCustomDispatcher: TActivationProcedure;{Custom device layer activation} FMasterTerminal : TWinControl; {The terminal that replies to requests} {Port info} FDeviceLayer : TDeviceLayer; {Device layer for this port} FDeviceLayers : TDeviceLayers; FDispatcher : TApdBaseDispatcher; {Handle to comm object} FComNumber : Word; {Com1 - ComWhatever} FBaud : LongInt; {Baud rate} FParity : TParity; {Parity} FDatabits : Word; {Data bits} FStopbits : Word; {Stop bits} FInSize : Word; {Input buffer size} FOutSize : Word; {Output buffer size} FOpen : Boolean; {True if the port is open} FPromptForPort : Boolean; {True to display the com port selection dialog if no port is selected} FAutoOpen : Boolean; {True to do implicit opens} FCommNotificationLevel : Word; {Comm notify level} FTapiCid : Word; {Cid from TAPI} FTapiMode : TTapiMode; {True if using TAPI} FRS485Mode : Boolean; {True if in RS485 mode} FThreadBoost : TApThreadBoost; {Boost for dispatcher threads} {Modem control/status} FDTR : Boolean; {DTR control state} FRTS : Boolean; {RTS control state} {Flow control} FBufferFull : Word; {Flow control cutoff} FBufferResume : Word; {Flow control resume} FHWFlowOptions : THWFlowOptionSet; {Hardware flow control} FSWFlowOptions : TSWFlowOptions; {Software flow control} FXOnChar : Char; {Xon character} FXOffChar : Char; {Xoff character} {Debugging} FTracing : TTraceLogState; {Controls Tracing state} FTraceSize : Cardinal; {Number of tracing entries} FTraceName : TPassString; {Name of trace file} FTraceHex : Boolean; {True to dump trace non-printables in hex} FTraceAllHex : Boolean; {True to dump all trace chars in hex} FLogging : TTraceLogState; {Controls DispatchLogging state} FLogSize : Cardinal; {Size, in bytes, of log buffer} FLogName : TPassString; {Name of log file} FLogHex : Boolean; {True to dump log non-printables in hex} FLogAllHex : Boolean; {True to dump all log chars in hex} {Options} FUseMSRShadow : Boolean; {True to use MSR shadow reg} FUseEventWord : Boolean; {True to use the EventWord} {Triggers} FTriggerLength : Word; {Number of bytes for avail trigger} FOnTrigger : TTriggerEvent; {All-encompassing event handler} FOnTriggerAvail : TTriggerAvailEvent; {APW_TRIGGERAVAIL events} FOnTriggerData : TTriggerDataEvent; {APW_TRIGGERDATA events} FOnTriggerStatus : TTriggerStatusEvent; {APW_TRIGGERSTATUS events} FOnTriggerTimer : TTriggerTimerEvent; {APW_TRIGGERTIMER events} FOnTriggerLineError : TTriggerLineErrorEvent; {Got line error} FOnTriggerModemStatus : TNotifyEvent; {Got modem status change} FOnTriggerOutbuffFree : TNotifyEvent; {Outbuff free above mark} FOnTriggerOutbuffUsed : TNotifyEvent; {Outbuff used above mark} FOnTriggerOutSent : TNotifyEvent; {Data was transmitted} FOnPortOpen : TNotifyEvent; {Port just opened} FOnPortClose : TNotifyEvent; {Port just closed} FOnWaitChar : TWaitCharEvent; {Received char during wait} {Property read/write methods} procedure SetDeviceLayer(const NewDevice : TDeviceLayer); procedure SetComNumber(const NewNumber : Word); procedure SetBaud(const NewBaud : Longint); procedure SetParity(const NewParity : TParity); procedure SetDatabits(const NewBits : Word); procedure SetStopbits(const NewBits : Word); procedure SetInSize(const NewSize : Word); procedure SetOutSize(const NewSize : Word); procedure SetTracing(const NewState : TTraceLogState); procedure SetTraceSize(const NewSize : Cardinal); procedure SetLogging(const NewState : TTraceLogState); procedure SetLogSize(const NewSize : Cardinal); procedure SetOpen(const Enable : Boolean); procedure SetHWFlowOptions(const NewOpts : THWFlowOptionSet); function GetFlowState : TFlowControlState; procedure SetSWFlowOptions(const NewOpts : TSWFlowOptions); procedure SetXonChar(const NewChar : Char); procedure SetXoffChar(const NewChar : Char); procedure SetBufferFull(const NewFull : Word); procedure SetBufferResume(const NewResume : Word); procedure SetTriggerLength(const NewLength : Word); procedure SetDTR(const NewDTR : Boolean); procedure SetRTS(const NewRTS : Boolean); {Trigger write methods} procedure SetOnTrigger(const Value : TTriggerEvent); procedure SetOnTriggerAvail(const Value : TTriggerAvailEvent); procedure SetOnTriggerData(const Value : TTriggerDataEvent); procedure SetOnTriggerStatus(const Value : TTriggerStatusEvent); procedure SetOnTriggerTimer(const Value : TTriggerTimerEvent); procedure SetOnTriggerLineError(const Value : TTriggerLineErrorEvent); procedure SetOnTriggerModemStatus(const Value : TNotifyEvent); procedure SetOnTriggerOutbuffFree(const Value : TNotifyEvent); procedure SetOnTriggerOutbuffUsed(const Value : TNotifyEvent); procedure SetOnTriggerOutSent(const Value : TNotifyEvent); function GetBaseAddress : Word; function GetDispatcher : TApdBaseDispatcher; function GetModemStatus : Byte; function GetDSR : Boolean; function GetCTS : Boolean; function GetRI : Boolean; function GetDCD : Boolean; function GetDeltaDSR : Boolean; function GetDeltaCTS : Boolean; function GetDeltaRI : Boolean; function GetDeltaDCD : Boolean; function GetLineError : Word; function GetLineBreak : Boolean; function GetInBuffUsed : Word; function GetInBuffFree : Word; function GetOutBuffUsed : Word; function GetOutBuffFree : Word; procedure SetUseEventWord(NewUse : Boolean); procedure SetCommNotificationLevel(NewLevel : Word); procedure SetRS485Mode(NewMode : Boolean); procedure SetBaseAddress(NewBaseAddress : Word); procedure SetThreadBoost(NewBoost : TApThreadBoost); protected {Misc} function ActivateDeviceLayer : TApdBaseDispatcher; virtual; procedure DeviceLayerChanged; virtual; function InitializePort : integer; virtual; procedure Loaded; override; procedure RegisterComPort(Enabling : Boolean); virtual; procedure ValidateComport; virtual; procedure SetUseMSRShadow(NewUse : Boolean); virtual; {Trigger event methods} procedure Trigger(Msg, TriggerHandle, Data : Word); virtual; procedure TriggerAvail(Count : Word); virtual; procedure TriggerData(TriggerHandle : Word); virtual; procedure TriggerStatus(TriggerHandle : Word); virtual; procedure TriggerTimer(TriggerHandle : Word); virtual; procedure UpdateHandlerFlag; virtual; {Port open/close/change event methods} procedure PortOpen; dynamic; procedure PortClose; dynamic; procedure PortClosing; dynamic; {!!.03} {Status trigger methods} procedure TriggerLineError(const Error : Word; const LineBreak : Boolean); virtual; procedure TriggerModemStatus; virtual; procedure TriggerOutbuffFree; virtual; procedure TriggerOutbuffUsed; virtual; procedure TriggerOutSent; virtual; {Wait trigger method} procedure WaitChar(C : Char); virtual; {Tracing} procedure InitTracing(const NumEntries : Cardinal); procedure DumpTrace(const FName : ShortString; const InHex : Boolean); procedure AppendTrace(const FName : ShortString; const InHex : Boolean); procedure ClearTracing; procedure AbortTracing; procedure StartTracing; procedure StopTracing; {DispatchLogging} procedure InitLogging(const Size : Cardinal); procedure DumpLog(const FName : ShortString; const InHex : Boolean); procedure AppendLog(const FName : ShortString; const InHex : Boolean); procedure ClearLogging; procedure AbortLogging; procedure StartLogging; procedure StopLogging; public OverrideLine : Boolean; {True to override line parms} ComPortName : String ; // Angus 7 Dec 2007, ie COMA33 or COM1 {Creation/destruction} constructor Create(AOwner : TComponent); override; {-Create a TApdComPort component} destructor Destroy; override; {-Destroy a TApdComPort component} {General} procedure InitPort; dynamic; {-Physically open the serial port} procedure DonePort; virtual; {-Physically close the serial port} procedure Assign(Source: TPersistent); override; {-Assign fields from TApdComPort object specified by Source} procedure ForcePortOpen; {-Force the port open after it is loaded} procedure SendBreak(Ticks : Word; Yield : Boolean); {-Send a line break of ticks duration} procedure SetBreak(BreakOn : Boolean); {-Sets or clears line break condition} {.Z-} procedure RegisterUser(const H : THandle); {-Register a TApdComPort user to receive PortOpen/PortClose events} procedure RegisterUserEx(const H : THandle); {!!.03} {-Register a TApdComPort user to receive open/closing/close events} procedure RegisterUserCallback(CallBack : TPortCallback); {-Register a TApdComPort user to receive callbacks} procedure RegisterUserCallbackEx(CallBackEx : TPortCallbackEx); {!!.03} {-Register a TApdComPort user to receive extended callbacks} procedure DeregisterUser(const H : THandle); {-Deregister a TApdComPort user from receiving PortOpen/PortClose events} procedure DeregisterUserCallback(CallBack : TPortCallback); {-Deregister a TApdComPort user callback} procedure DeregisterUserCallbackEx(CallBackEx : TPortCallbackEx); {!!.03} {-Deregister a TApdComPort user callback} procedure ProcessCommunications; virtual; {-Call the internal dispatcher} procedure FlushInBuffer; {-Discard the contents of the input buffer} procedure FlushOutBuffer; {-Discard the contents of the output buffer} {Trigger managment} function AddDataTrigger(const Data : ShortString; const IgnoreCase : Boolean) : Word; {-Add a data trigger} function AddTimerTrigger : Word; {-Add a timer trigger} function AddStatusTrigger(const SType : Word) : Word; {-Add a status trigger} procedure RemoveTrigger(const Handle : Word); {-Remove a trigger} procedure RemoveAllTriggers; {-Remove all triggers} procedure SetTimerTrigger(const Handle : Word; const Ticks : LongInt; const Activate : Boolean); {-Activate or deactivate a timer trigger} procedure SetStatusTrigger(const Handle : Word; const Value : Word; const Activate : Boolean); {-Activate or deactivate a status trigger} {I/O} function CharReady : Boolean; {-Return True if at least one character is in the input buffer} function PeekChar(const Count : Word) : Char; {-Return a received character other than the next one} function GetChar : Char; {-Return the next received character} procedure PeekBlock(var Block; const Len : Word); {-Return a block of data other than the next block} procedure GetBlock(var Block; const Len : Word); {-Return the next block of data} procedure PutChar(const C : Char); {-Add C to the output buffer} procedure PutString(const S : String); {-Add S to the output buffer} function PutBlock(const Block; const Len : Word) : Integer; {-Add Block to the output buffer} {Waits} function CheckForString(var Index : Byte; C : Char; const S : String; IgnoreCase : Boolean) : Boolean; {-Compare C against a sequence of chars, looking for S} function WaitForString(const S : String; const Timeout : LongInt; const Yield, IgnoreCase : Boolean) : Boolean; {-Wait for S} function WaitForMultiString(const S : String; const Timeout : LongInt; const Yield, IgnoreCase : Boolean; const SepChar : Char) : Integer; {-Wait for S, which contains several substrings separated by ^} procedure PrepareWait; {-Set EventBusy true to prevent triggers} property ComNumber : Word read FComNumber write SetComNumber default adpoDefComNumber; property CustomDispatcher : TActivationProcedure read fCustomDispatcher write fCustomDispatcher; property DeviceLayer : TDeviceLayer read FDeviceLayer write SetDeviceLayer default adpoDefDeviceLayer; property ComWindow : THandle read fComWindow; property Baud : LongInt read FBaud write SetBaud default adpoDefBaudRt; property Parity : TParity read FParity write SetParity default adpoDefParity; property PromptForPort : Boolean read FPromptForPort write FPromptForPort default adpoDefPromptForPort; property DataBits : Word read FDatabits write SetDatabits default adpoDefDatabits; property StopBits : Word read FStopbits write SetStopbits default adpoDefStopbits; {Miscellaneous port properties} property InSize : Word read FInSize write SetInSize default adpoDefInSize; property OutSize : Word read FOutSize write SetOutSize default adpoDefOutSize; property Open : Boolean read FOpen write SetOpen default adpoDefOpen; property AutoOpen : Boolean read FAutoOpen write FAutoOpen default adpoDefAutoOpen; property CommNotificationLevel : Word read FCommNotificationLevel write SetCommNotificationLevel default adpoDefCommNotificationLevel; property TapiMode : TTapiMode read FTapiMode write FTapiMode default adpoDefTapiMode; property TapiCid : Word read FTapiCid write FTapiCid; property RS485Mode : Boolean read FRS485Mode write SetRS485Mode default adpoDefRS485Mode; property BaseAddress : Word read GetBaseAddress write SetBaseAddress default adpoDefBaseAddress; property ThreadBoost : TApThreadBoost read FThreadBoost write SetThreadBoost; property MasterTerminal : TWinControl read FMasterTerminal write FMasterTerminal; {Modem control/status} property DTR : Boolean read FDTR write SetDTR default adpoDefDTR; property RTS : Boolean read FRTS write SetRTS default adpoDefRTS; {Flow control properties} property HWFlowOptions : THWFlowOptionSet read FHWFlowOptions write SetHWFlowOptions default []; property FlowState : TFlowControlState read GetFlowState; property SWFlowOptions : TSWFlowOptions read FSWFlowOptions write SetSWFlowOptions default adpoDefSWFlowOptions; property XOnChar : Char read FXonChar write SetXonChar default adpoDefXOnChar; property XOffChar : Char read FXOffChar write SetXoffChar default adpoDefXOffChar; property BufferFull : Word read FBufferFull write SetBufferFull default adpoDefBufferFull; property BufferResume : Word read FBufferResume write SetBufferResume default adpoDefBufferResume; {Debugging} property Tracing : TTraceLogState read FTracing write SetTracing default adpoDefTracing; property TraceSize : Cardinal read FTraceSize write SetTraceSize default adpoDefTraceSize; property TraceName : TPassString read FTraceName write FTraceName; property TraceHex : Boolean read FTraceHex write FTraceHex default adpoDefTraceHex; property TraceAllHex : Boolean read FTraceAllHex write FTraceAllHex default adpoDefTraceAllHex; property Logging : TTraceLogState read FLogging write SetLogging default adpoDefLogging; property LogSize : Cardinal read FLogSize write SetLogSize default adpoDefLogSize; property LogName : TPassString read FLogName write FLogName; property LogHex : Boolean read FLogHex write FLogHex default adpoDefLogHex; property LogAllHex : Boolean read FLogAllHex write FLogAllHex default adpoDefLogAllHex; {Options} property UseMSRShadow : Boolean read FUseMSRShadow write SetUseMSRShadow default adpoDefUseMSRShadow; property UseEventWord : Boolean read FUseEventWord write SetUseEventWord default adpoDefUseEventWord; {Tracing} procedure AddTraceEntry(const CurEntry, CurCh : Char); {-Add an entry to the trace buffer} procedure AddStringToLog(S : string); {-Add a string to the current LOG file} {Trigger events} property TriggerLength : Word read FTriggerLength write SetTriggerLength default adpoDefTriggerLength; property OnTrigger : TTriggerEvent read FOnTrigger write SetOnTrigger; property OnTriggerAvail : TTriggerAvailEvent read FOnTriggerAvail write SetOnTriggerAvail; property OnTriggerData : TTriggerDataEvent read FOnTriggerData write SetOnTriggerData; property OnTriggerStatus : TTriggerStatusEvent read FOnTriggerStatus write SetOnTriggerStatus; property OnTriggerTimer : TTriggerTimerEvent read FOnTriggerTimer write SetOnTriggerTimer; {Port open/close/change events} property OnPortOpen : TNotifyEvent read FOnPortOpen write FOnPortOpen; property OnPortClose : TNotifyEvent read FOnPortClose write FOnPortClose; {Status events} property OnTriggerLineError : TTriggerLineErrorEvent read FOnTriggerLineError write SetOnTriggerLineError; property OnTriggerModemStatus : TNotifyEvent read FOnTriggerModemStatus write SetOnTriggerModemStatus; property OnTriggerOutbuffFree : TNotifyEvent read FOnTriggerOutbuffFree write SetOnTriggerOutbuffFree; property OnTriggerOutbuffUsed : TNotifyEvent read FOnTriggerOutbuffUsed write SetOnTriggerOutbuffUsed; property OnTriggerOutSent : TNotifyEvent read FOnTriggerOutSent write SetOnTriggerOutSent; {WaitChar event} property OnWaitChar : TWaitCharEvent read FOnWaitchar write FOnWaitChar; {I/O properties} property Output : String write PutString; {TComHandle, read only} property Dispatcher : TApdBaseDispatcher read GetDispatcher; function ValidDispatcher : TApdBaseDispatcher; {Modem status, read only} property ModemStatus : Byte read GetModemStatus; property DSR : Boolean read GetDSR; property CTS : Boolean read GetCTS; property RI : Boolean read GetRI; property DCD : Boolean read GetDCD; property DeltaDSR : Boolean read GetDeltaDSR; property DeltaCTS : Boolean read GetDeltaCTS; property DeltaRI : Boolean read GetDeltaRI; property DeltaDCD : Boolean read GetDeltaDCD; {Line errors} property LineError : Word read GetLineError; property LineBreak : Boolean read GetLineBreak; {Buffer info, readonly} property InBuffUsed : Word read GetInBuffUsed; property InBuffFree : Word read GetInBuffFree; property OutBuffUsed : Word read GetOutBuffUsed; property OutBuffFree : Word read GetOutBuffFree; end; {Port component} TApdComPort = class(TApdCustomComPort) published property DeviceLayer; property ComNumber; property Baud; property PromptForPort; property Parity; property DataBits; property StopBits; property InSize; property OutSize; property AutoOpen; property Open; property DTR; property RTS; property HWFlowOptions; property SWFlowOptions; property XOnChar; property XOffChar; property BufferFull; property BufferResume; property Tracing; property TraceSize; property TraceName; property TraceHex; property TraceAllHex; property Logging; property LogSize; property LogName; property LogHex; property LogAllHex; property UseMSRShadow; property UseEventWord; property CommNotificationLevel; property TapiMode; property RS485Mode; property OnPortClose; property OnPortOpen; property OnTrigger; property OnTriggerAvail; property OnTriggerData; property OnTriggerStatus; property OnTriggerTimer; property OnTriggerLineError; property OnTriggerModemStatus; property OnTriggerOutbuffFree; property OnTriggerOutbuffUsed; property OnTriggerOutSent; property Tag; end; function ComName(const ComNumber : Word) : ShortString; function SearchComPort(const C : TComponent) : TApdCustomComPort; implementation const ComWindowClass = 'awComWindow'; {Main trigger handler} function ComWindowProc(hWindow : TApdHwnd; Msg, wParam : Word; lParam : Longint) : Longint; stdcall; export; {-Receives all triggers, dispatches to event handlers} type lParamCast = record Data : Word; Dispatcher : Word; end; var LP : lParamCast absolute lParam; TrigHandle : Word absolute wParam; Count : Word absolute wParam; CP : TApdCustomComPort; D : Pointer; begin case Msg of APW_CLOSEPENDING, APW_TRIGGERAVAIL, APW_TRIGGERDATA, APW_TRIGGERSTATUS, APW_TRIGGERTIMER : ; else ComWindowProc := DefWindowProc(hWindow, Msg, wParam, lParam); exit; end; LockPortList; try ComWindowProc := ecOK; if (PortList <> nil) and (LP.Dispatcher < PortList.Count) then begin D := PortList[LP.Dispatcher]; if D <> nil then CP := TApdCustomComPort(TApdBaseDispatcher(D).Owner) else CP := nil; if Assigned(CP) then with CP do begin try if Msg = APW_TRIGGERAVAIL then Trigger(Msg, TrigHandle, Count) else Trigger(Msg, TrigHandle, LP.Data); case Msg of APW_CLOSEPENDING : begin if FDispatcher.Active then begin PostMessage(FComWindow,APW_CLOSEPENDING,0,lparam); end else begin {Get rid of the trigger handler} RegisterComPort(False); FDispatcher.Free; FDispatcher := nil; PortState := psClosed; FOpen := False; {!!.02} if OpenPending then begin InitPort; OpenPending := False; end; end; end; APW_TRIGGERAVAIL : TriggerAvail(Count); APW_TRIGGERDATA : TriggerData(TrigHandle); APW_TRIGGERSTATUS : begin TriggerStatus(TrigHandle); case Dispatcher.ClassifyStatusTrigger(TrigHandle) of stModem : TriggerModemStatus; stLine : TriggerLineError(LineError, LineBreak); stOutBuffFree : TriggerOutbuffFree; stOutBuffUsed : TriggerOutbuffUsed; stOutSent : TriggerOutSent; end; end; APW_TRIGGERTIMER : TriggerTimer(TrigHandle); end; except if GetCurrentThreadID = MainThreadID then Application.HandleException(nil); end; end; end; finally UnlockPortList; end; end; {Misc} procedure RegisterComWindow; {-Make sure the comwindow class is registered} const Registered : Boolean = False; var XClass: TWndClass; begin if Registered then Exit; Registered := True; with XClass do begin Style := 0; lpfnWndProc := @ComWindowProc; cbClsExtra := 0; cbWndExtra := SizeOf(Pointer); if ModuleIsLib and not ModuleIsPackage then { we're in a DLL, not a package } hInstance := SysInit.hInstance else { we're a package or exe } hInstance := System.MainInstance; hIcon := 0; hCursor := 0; hbrBackground := 0; lpszMenuName := nil; lpszClassName := ComWindowClass; end; WinProcs.RegisterClass(XClass); end; function TApdCustomComPort.ValidDispatcher : TApdBaseDispatcher; {- return the current dispatcher object. Raise an exception if NIL } begin if Dispatcher = nil then CheckException(Self,ecCommNotOpen); Result := Dispatcher; end; procedure TApdCustomComPort.SetDeviceLayer(const NewDevice : TDeviceLayer); {-Set a new device layer, ignore if port is open} begin if (NewDevice <> FDeviceLayer) and (PortState = psClosed) then if NewDevice in FDeviceLayers then begin FDeviceLayer := NewDevice; DeviceLayerChanged; end; end; procedure TApdCustomComPort.SetComNumber(const NewNumber : Word); {-Set a new comnumber, close the old port if open} var WasOpen : Boolean; OldTracing : TTraceLogState; OldLogging : TTraceLogState; begin if FComNumber <> NewNumber then begin WasOpen := (PortState = psOpen); OldTracing := tlOff; OldLogging := tlOff; if (PortState = psOpen) then begin Dispatcher.SaveTriggers(SaveTriggerBuffer); OldTracing := Tracing; OldLogging := Logging; Open := False; end; FComNumber := NewNumber; if WasOpen then begin Tracing := OldTracing; Logging := OldLogging; Open := True; Dispatcher.RestoreTriggers(SaveTriggerBuffer); end; end; end; procedure TApdCustomComPort.SetBaud(const NewBaud : Longint); {-Set a new baud rate} begin if NewBaud <> FBaud then begin FBaud := NewBaud; if (PortState = psOpen) then CheckException(Self, Dispatcher.SetLine(NewBaud, Ord(Parity), Databits, Stopbits)); end; end; procedure TApdCustomComPort.SetParity(const NewParity : TParity); {-Set new parity} begin if NewParity <> FParity then begin FParity := NewParity; if (PortState = psOpen) then CheckException(Self, Dispatcher.SetLine(Baud, Ord(FParity), Databits, Stopbits)); end; end; procedure TApdCustomComPort.SetDatabits(const NewBits : Word); {-Set new databits} begin if NewBits <> FDatabits then begin FDatabits := NewBits; if (PortState = psOpen) then CheckException(Self, Dispatcher.SetLine(Baud, Ord(Parity), FDatabits, Stopbits)); end; end; procedure TApdCustomComPort.SetStopbits(const NewBits : Word); {-Set new stop bits} begin if NewBits <> FStopbits then begin FStopbits := NewBits; if (PortState = psOpen) then CheckException(Self, Dispatcher.SetLine(Baud, Ord(Parity), Databits, FStopbits)); end; end; procedure TApdCustomComPort.SetInSize(const NewSize : Word); {-Set new insize, requires re-opening port if port was open} begin if NewSize <> FInSize then begin FInSize := NewSize; if (PortState = psOpen) then Dispatcher.SetCommBuffers(NewSize, OutSize); end; end; procedure TApdCustomComPort.SetOutSize(const NewSize : Word); {-Set new outsize, requires re-opening port if port was open} begin if NewSize <> FOutSize then begin FOutSize := NewSize; if (PortState = psOpen) then Dispatcher.SetCommBuffers(InSize, NewSize); end; end; procedure TApdCustomComPort.SetTracing(const NewState : TTraceLogState); {-Set Tracing state, FTracing is modified by called methods} begin if (FTracing <> NewState) or Force then begin if (PortState = psOpen) then begin {Port is open -- do it} case NewState of tlOff : if (FTracing = tlOn) or (FTracing = tlPause) then AbortTracing; tlOn : if FTracing = tlPause then StartTracing else InitTracing(FTraceSize); tlDump : if (FTracing = tlOn) or (FTracing = tlPause) then begin StartTracing; DumpTrace(FTraceName, FTraceHex); end; tlAppend : if (FTracing = tlOn) or (FTracing = tlPause) then begin StartTracing; AppendTrace(FTraceName, FTraceHex); end; tlPause : if (FTracing = tlOn) then StopTracing; tlClear : if (FTracing = tlOn) or (FTracing = tlPause) then ClearTracing; end; end else begin {Port is closed, only acceptable values are tlOff and tlOn} case NewState of tlOff, tlOn : FTracing := NewState; else FTracing := tlOff; end; end; end; end; procedure TApdCustomComPort.SetTraceSize(const NewSize : Cardinal); {-Set trace size} var OldState : TTraceLogState; begin if NewSize <> FTraceSize then begin if NewSize > HighestTrace then FTraceSize := HighestTrace else FTraceSize := NewSize; if (PortState = psOpen) and ((FTracing = tlOn) or (FTracing = tlPause)) then begin {Trace file is open: abort, then restart to get new size} OldState := Tracing; AbortTracing; Tracing := OldState; end; end; end; procedure TApdCustomComPort.SetLogging(const NewState : TTraceLogState); {-Set Logging state, FLogging is modified by called methods} begin if (FLogging <> NewState) or Force then begin if (PortState = psOpen) then begin case NewState of tlOff : if (FLogging = tlOn) or (FLogging = tlPause) then AbortLogging; tlOn : if FLogging = tlPause then StartLogging else InitLogging(FLogSize); tlDump : if (FLogging = tlOn) or (FLogging = tlPause) then begin StartLogging; DumpLog(FLogName, FLogHex); end; tlAppend : if (FLogging = tlOn) or (FLogging = tlPause) then begin StartLogging; AppendLog(FLogName, FLogHex); end; tlPause : if (FLogging = tlOn) then StopLogging; tlClear : if (FLogging = tlOn) or (FLogging = tlPause) then ClearLogging; end; end else begin {Port is closed, only acceptable values are tlOff and tlOn} case NewState of tlOff, tlOn : FLogging := NewState; else FLogging := tlOff; end; end; end; end; procedure TApdCustomComPort.SetLogSize(const NewSize : Cardinal); {-Set log size} var OldState : TTraceLogState; begin if NewSize <> FLogSize then begin if NewSize > MaxDLogQueueSize then FLogSize := MaxDLogQueueSize else FLogSize := NewSize; if (PortState = psOpen) and ((FLogging = tlOn) or (FLogging = tlPause)) then begin {Log file is open: abort, then restart to get new size} OldState := FLogging; AbortLogging; Logging := OldState; end; end; end; procedure TApdCustomComPort.SetOpen(const Enable : Boolean); {-Open/close the port} begin if FOpen <> Enable then begin if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin if Enable then begin if (PortState = psClosed) then { open the port } InitPort else { wait until we're closed } OpenPending := True; end else { close the port } DonePort; end else begin { we're loading or designing, just set a flag } FOpen := Enable; if Enable then ForceOpen := True; end; end; end; procedure TApdCustomComPort.SetHWFlowOptions(const NewOpts : THWFlowOptionSet); {-Set hardware flow options} const UseDTR : array[Boolean] of Word = (0, hfUseDTR); UseRTS : array[Boolean] of Word = (0, hfUseRTS); RequireDSR : array[Boolean] of Word = (0, hfRequireDSR); RequireCTS : array[Boolean] of Word = (0, hfRequireCTS); var Opts : Word; begin if (FHWFlowOptions <> NewOpts) or Force then begin Opts := UseDTR[hwfUseDTR in NewOpts] + UseRTS[hwfUseRTS in NewOpts] + RequireDSR[hwfRequireDSR in NewOpts] + RequireCTS[hwfRequireCTS in NewOpts]; {Validate bufferfull and bufferresume if opts not zero} if Opts <> 0 then begin if (BufferFull = 0) or (BufferFull > InSize) then FBufferFull := Trunc(InSize * 0.9); if (BufferResume = 0) or (BufferResume > BufferFull) then FBufferResume := Trunc(InSize * 0.1); end; if (PortState = psOpen) then begin CheckException(Self, Dispatcher.HWFlowOptions(FBufferFull, FBufferResume, Opts)) end; FHWFlowOptions := NewOpts; {Force RS485 mode off if using RTS/CTS flow control} if (hwfUseRTS in NewOpts) or (hwfRequireCTS in NewOpts) then RS485Mode := False; end; end; function TApdCustomComPort.GetFlowState : TFlowControlState; {-Return the current state of flow control} begin if (PortState <> psShuttingDown) then begin Result := TFlowControlState(Pred(CheckException(Self, ValidDispatcher.HWFlowState))); if Result = fcOff then Result := TFlowControlState(Pred(CheckException(Self, Dispatcher.SWFlowState))); end else begin Result := fcOff; end; end; procedure TApdCustomComPort.SetSWFlowOptions(const NewOpts : TSWFlowOptions); var Opts : Word; begin if (FSWFlowOptions <> NewOpts) or Force then begin if NewOpts = swfBoth then Opts := sfTransmitFlow + sfReceiveFlow else if NewOpts = swfTransmit then Opts := sfTransmitFlow else if NewOpts = swfReceive then Opts := sfReceiveFlow else Opts := 0; {Validate bufferfull and bufferresume if opts not zero} if Opts <> 0 then begin if (BufferFull = 0) or (BufferFull > InSize) then FBufferFull := Trunc(InSize * 0.75); if (BufferResume = 0) or (BufferResume > BufferFull) then FBufferResume := Trunc(InSize * 0.25); end; if (PortState = psOpen) then begin if Opts <> 0 then CheckException(Self, Dispatcher.SWFlowEnable(FBufferFull, FBufferResume, Opts)) else CheckException(Self, Dispatcher.SWFlowDisable); end; FSWFlowOptions := NewOpts; end; end; procedure TApdCustomComPort.SetXonChar(const NewChar : Char); {-Set new xon character} begin if (NewChar <> FXOnChar) or Force then begin FXOnChar := NewChar; if (PortState = psOpen) then CheckException(Self, Dispatcher.SWFlowChars(FXOnChar, FXOffChar)); end; end; procedure TApdCustomComPort.SetXoffChar(const NewChar : Char); {-Set new xoff character} begin if (NewChar <> FXOffChar) or Force then begin FXOffChar := NewChar; if (PortState = psOpen) then CheckException(Self, Dispatcher.SWFlowChars(FXOnChar, FXOffChar)); end; end; procedure TApdCustomComPort.SetBufferFull(const NewFull : Word); {-Set buffer full mark} var SaveForce : Boolean; begin if (NewFull <> FBufferFull) or Force then begin if NewFull <= InSize then FBufferFull := NewFull else FBufferFull := Trunc(NewFull * 0.9); SaveForce := Force; Force := True; SetHWFlowOptions(HWFlowOptions); SetSWFlowOptions(SWFlowOptions); Force := SaveForce; end; end; procedure TApdCustomComPort.SetBufferResume(const NewResume : Word); {-Set buffer resume mark} var SaveForce : Boolean; begin if (NewResume <> FBufferResume) or Force then begin if NewResume > FBufferFull then FBufferResume := Trunc(FBufferFull * 0.1) else FBufferResume := NewResume; SaveForce := Force; Force := True; SetHWFlowOptions(HWFlowOptions); SetSWFlowOptions(SWFlowOptions); Force := SaveForce; end; end; procedure TApdCustomComPort.SetDTR(const NewDTR : Boolean); {-Set a new DTR value} begin if (NewDTR <> FDTR) or Force then begin if (PortState = psOpen) then begin if CheckException(Self, Dispatcher.SetDTR(NewDTR)) = ecOK then FDTR := NewDTR; end else begin FDTR := NewDTR; end; end; end; procedure TApdCustomComPort.SetRTS(const NewRTS : Boolean); {-Set new RTS value} begin if (NewRTS <> FRTS) or Force then begin if (PortState = psOpen) then begin if CheckException(Self, Dispatcher.SetRTS(NewRTS)) = ecOK then FRTS := NewRTS; end else begin FRTS := NewRTS; end; end; end; procedure TApdCustomComPort.SetOnTrigger(const Value : TTriggerEvent); begin FOnTrigger := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerAvail(const Value : TTriggerAvailEvent); begin FOnTriggerAvail := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerData(const Value : TTriggerDataEvent); begin FOnTriggerData := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerStatus(const Value : TTriggerStatusEvent); begin FOnTriggerStatus := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerTimer(const Value : TTriggerTimerEvent); begin FOnTriggerTimer := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerLineError(const Value : TTriggerLineErrorEvent); begin FOnTriggerLineError := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerModemStatus(const Value : TNotifyEvent); begin FOnTriggerModemStatus := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerOutbuffFree(const Value : TNotifyEvent); begin FOnTriggerOutbuffFree := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerOutbuffUsed(const Value : TNotifyEvent); begin FOnTriggerOutbuffUsed := Value; UpdateHandlerFlag; end; procedure TApdCustomComPort.SetOnTriggerOutSent(const Value : TNotifyEvent); begin FOnTriggerOutSent := Value; UpdateHandlerFlag; end; function TApdCustomComPort.GetDispatcher : TApdBaseDispatcher; {-Return the current Dispatcher, opening the port if necessary} begin if FDispatcher = nil then if not (csDesigning in ComponentState) then begin if (PortState <> psOpen) and (not (csLoading in ComponentState)) and AutoOpen then Open := True; end; Result := FDispatcher; end; function TApdCustomComPort.GetModemStatus : Byte; {-Return the current modem status register value} begin if (PortState = psShuttingDown) then Result := 0 else Result := ValidDispatcher.GetModemStatus; end; function TApdCustomComPort.GetDSR : Boolean; {-Return the DSR bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDSR else Result := False; end; function TApdCustomComPort.GetCTS : Boolean; {-Return CTS bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckCTS else Result := False; end; function TApdCustomComPort.GetRI : Boolean; {-Return RI bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckRI else Result := False; end; function TApdCustomComPort.GetDCD : Boolean; {-Return DCD bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDCD else Result := False; end; function TApdCustomComPort.GetDeltaDSR : Boolean; {-Return delta DSR bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDeltaDSR else Result := False; end; function TApdCustomComPort.GetDeltaCTS : Boolean; {-Return delta CTS bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDeltaCTS else Result := False; end; function TApdCustomComPort.GetDeltaRI : Boolean; {-Return delta RI bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDeltaRI else Result := False; end; function TApdCustomComPort.GetDeltaDCD : Boolean; {-Return delta DCD bit state} begin if (PortState = psOpen) then Result := Dispatcher.CheckDeltaDCD else Result := False; end; function TApdCustomComPort.GetLineError : Word; {-Return most severe current line error} begin if (PortState = psOpen) then Result := Word(CheckException(Self, Word(Dispatcher.GetLineError))) else Result := leNoError; end; function TApdCustomComPort.GetLineBreak : Boolean; {-Return True if break received} begin if (PortState = psOpen) then Result := Dispatcher.CheckLineBreak else Result := False; end; procedure TApdCustomComPort.SetTriggerLength(const NewLength : Word); {-Change the length trigger} begin if (FTriggerLength <> NewLength) or Force then begin FTriggerLength := NewLength; if (PortState = psOpen) then Dispatcher.ChangeLengthTrigger(NewLength); end; end; function TApdCustomComPort.GetInBuffUsed : Word; {-Return the number of used bytes in the input buffer} begin if (PortState = psOpen) then Result := Dispatcher.InBuffUsed else Result := 0; end; function TApdCustomComPort.GetInBuffFree : Word; {-Return amount of freespace in inbuf} begin if (PortState = psOpen) then Result := Dispatcher.InBuffFree else Result := DispatchBufferSize; end; function TApdCustomComPort.GetOutBuffUsed : Word; {-Return number of used bytes in output buffer} begin if (PortState = psOpen) then Result := Dispatcher.OutBuffUsed else Result := 0; end; function TApdCustomComPort.GetOutBuffFree : Word; {-Return amount of free space in outbuff} begin if (PortState = psOpen) then Result := Dispatcher.OutBuffFree else Result := FOutSize; end; procedure TApdCustomComPort.SetUseMSRShadow(NewUse : Boolean); {-Set the MSR shadow option} begin { UseMSRShadow is only applicable to 16-bit, ignore it } end; procedure TApdCustomComPort.SetUseEventWord(NewUse : Boolean); {-Set the UseEventWord option} begin if (FUseEventWord <> NewUse) or Force then begin FUseEventWord := NewUse; if (PortState = psOpen) then if FUseEventWord then Dispatcher.OptionsOn(poUseEventWord) else Dispatcher.OptionsOff(poUseEventWord); end; end; procedure TApdCustomComPort.SetCommNotificationLevel(NewLevel : Word); {-Set the comm notification level} begin { 16-bit } if (FCommNotificationLevel <> NewLevel) or Force then begin FCommNotificationLevel := NewLevel; end; end; procedure TApdCustomComPort.SetRS485Mode(NewMode : Boolean); {-Set the RS485 mode} var NewFlowOpts : THWFlowOptionSet; begin if (FRS485Mode <> NewMode) or Force then begin FRS485Mode := NewMode; if (PortState = psOpen) then Dispatcher.SetRS485Mode(NewMode); if NewMode then begin {Force rts/cts flow control off} NewFlowOpts := FHWFlowOptions; Exclude(NewFlowOpts, hwfUseRTS); Exclude(NewFlowOpts, hwfRequireCTS); SetHWFlowOptions(NewFlowOpts); {Force RTS off} RTS := False; end; end; end; procedure TApdCustomComPort.SetBaseAddress(NewBaseAddress : Word); {-Set the base address} begin if (BaseAddress <> NewBaseAddress) or Force then begin if (PortState = psOpen) then Dispatcher.SetBaseAddress(NewBaseAddress); end; end; procedure TApdCustomComPort.SetThreadBoost(NewBoost : TApThreadBoost); begin if (FThreadBoost <> NewBoost) or Force then begin FThreadBoost := NewBoost; if (PortState = psOpen) then Dispatcher.SetThreadBoost(Ord(NewBoost)); end; end; function TApdCustomComPort.GetBaseAddress : Word; {-Get the base address} begin if (PortState = psOpen) then Result := Dispatcher.GetBaseAddress else Result := 0; end; {TApdComPort protected} function TApdCustomComPort.ActivateDeviceLayer : TApdBaseDispatcher; begin if Assigned(fCustomDispatcher) then Result := CustomDispatcher(Self) else case DeviceLayer of dlWin32 : if TapiMode = tmOn then Result := TApdTAPI32Dispatcher.Create(Self,FTapiCID) else Result := TApdWin32Dispatcher.Create(Self); else raise ENullAPI.Create(ecNullAPI, False); end; end; procedure TApdCustomComPort.DeviceLayerChanged; {-Notification that device layer has changed} begin { Do nothing at this level } end; function TApdCustomComPort.InitializePort : Integer; var Temp : array[0..32] of Char; // angus was 12 FlowFlags : DWORD; function MakeComName(const ComNum : Word) : PChar; {-Return a string like 'COMXX'} begin if TapiMode <> tmOn then begin if (ComPortName <> '') then // angus allow names COM ports to be opened StrLFmt(Temp, 32, '\\.\%s', [ComPortName]) // angus July 2014 removed memory leak else StrFmt(Temp, '\\.\COM%d', [ComNum]); Result := Temp; end else Result := nil; end; begin { Set up initial flow control info } FlowFlags := 0; { Manual settings } if FDTR then FlowFlags := (FlowFlags or ipAssertDTR); if FRTS then FlowFlags := (FlowFlags or ipAssertRTS); if (hwfUseDTR in FHWFlowOptions) then FlowFlags := (FlowFlags or ipAutoDTR); if (hwfUseRTS in FHWFlowOptions) then FlowFlags := (FlowFlags or ipAutoRTS); Result := Dispatcher.InitPort(MakeComName(FComNumber), FBaud, Ord(FParity), FDatabits, FStopbits, FInSize, FOutSize, FlowFlags); end; procedure TApdCustomComPort.Loaded; {-Physically open the port if FOpen is True} begin inherited Loaded; if not (csDesigning in ComponentState) then begin if ForceOpen then FOpen := True; if FOpen then begin ForceOpen := False; try InitPort; except FOpen := False; Application.HandleException(nil); end; end; end; end; procedure TApdCustomComPort.Trigger(Msg, TriggerHandle, Data : Word); {-For internal processing of all triggers} begin if Assigned(FOnTrigger) then FOnTrigger(Self, Msg, TriggerHandle, Data); end; procedure TApdCustomComPort.TriggerAvail(Count : Word); {-For internal triggeravail processing} begin if Assigned(FOnTriggerAvail) then FOnTriggerAvail(Self, Count); end; procedure TApdCustomComPort.TriggerData(TriggerHandle : Word); {-For internal triggerdata processing} begin if Assigned(FOnTriggerData) then FOnTriggerData(Self, TriggerHandle); end; procedure TApdCustomComPort.TriggerStatus(TriggerHandle : Word); {-For internal triggerstatus processing} begin if Assigned(FOnTriggerStatus) then FOnTriggerStatus(Self, TriggerHandle); end; procedure TApdCustomComPort.TriggerTimer(TriggerHandle : Word); {-For internal triggertimer processing} begin if Assigned(FOnTriggerTimer) then FOnTriggerTimer(Self, TriggerHandle); end; procedure TApdCustomComPort.UpdateHandlerFlag; begin if (PortState <> psOpen) then Exit; if Assigned(FOnTrigger) or Assigned(FOnTriggerAvail) or Assigned(FOnTriggerData) or Assigned(FOnTriggerStatus) or Assigned(FOnTriggerTimer) or Assigned(FOnTriggerLineError) or Assigned(FOnTriggerModemStatus) or Assigned(FOnTriggerOutbuffFree) or Assigned(FOnTriggerOutbuffUsed) or Assigned(FOnTriggerOutSent) then FDispatcher.UpdateHandlerFlags(fuEnablePort) else FDispatcher.UpdateHandlerFlags(fuDisablePort); end; procedure TApdCustomComPort.PortOpen; {-Port open processing} var I : Word; UL : PUserListEntry; begin {Tell all comport users that the port is now open} if UserList.Count > 0 then begin for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; with UL^ do begin if Handle <> 0 then SendMessage(Handle, APW_PORTOPEN, 0, 0) else begin {!!.03} if IsEx then {!!.03} UL^.OpenCloseEx(Self, ctOpen) {!!.03} else {!!.03} UL^.OpenClose(Self, True); end; {!!.03} end; end; end; if Assigned(FOnPortOpen) then FOnPortOpen(Self); end; procedure TApdCustomComPort.PortClose; {-Port close processing} var I : Word; UL : PUserListEntry; begin {Tell all comport users that the port is now closed} if UserList.Count > 0 then begin for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; with UL^ do begin if Handle <> 0 then SendMessage(Handle, APW_PORTCLOSE, 0, 0) else begin {!!.03} if IsEx then {!!.03} UL^.OpenCloseEx(Self, ctClosed) {!!.03} else {!!.03} UL^.OpenClose(Self, False); end; {!!.03} end; end; end; if Assigned(FOnPortClose) then FOnPortClose(Self); end; procedure TApdCustomComPort.PortClosing; {!!.03} {-Port closing processing, sent to other controls to notify that the port } { is starting to close for cleanup } var I : Word; UL : PUserListEntry; begin { tell all users that the port is now being closed } if UserList.Count > 0 then begin for I := pred(UserList.Count) downto 0 do begin UL := UserList.Items[I]; { only notify if they are registered as extended } if UL^.IsEx then with UL^ do begin if Handle <> 0 then SendMessage(Handle, APW_CLOSEPENDING, 0, 0) else UL^.OpenCloseEx(Self, ctClosing); end; end; end; end; procedure TApdCustomComPort.TriggerLineError(const Error : Word; const LineBreak : Boolean); {-Received a line error} begin if Assigned(FOnTriggerLineError) then FOnTriggerLineError(Self, Error, LineBreak); end; procedure TApdCustomComPort.TriggerModemStatus; {-Received a modem status change} begin if Assigned(FOnTriggerModemStatus) then FOnTriggerModemStatus(Self); end; procedure TApdCustomComPort.TriggerOutbuffFree; {-Received and outbuff free trigger} begin if Assigned(FOnTriggerOutbuffFree) then FOnTriggerOutbuffFree(Self); end; procedure TApdCustomComPort.TriggerOutbuffUsed; {-Received and outbuff used trigger} begin if Assigned(FOnTriggerOutbuffUsed) then FOnTriggerOutbuffUsed(Self); end; procedure TApdCustomComPort.TriggerOutSent; {-Received an outsent trigger} begin if Assigned(FOnTriggerOutSent) then FOnTriggerOutSent(Self); end; procedure TApdCustomComPort.WaitChar(C : Char); {-Received a character in WaitForString or WaitForMultiString} begin if Assigned(FOnWaitChar) then FOnWaitChar(Self, C); end; procedure TApdCustomComPort.RegisterComPort(Enabling : Boolean); {-Use a hidden window to get triggers} var Instance : THandle; begin if Enabling then begin {Make sure the window is registered} RegisterComWindow; if ModuleIsLib and not ModuleIsPackage then { we're a DLL, not a package } Instance := SysInit.hInstance else {we're an exe or package } Instance := System.MainInstance; {Create a window} fComWindow := CreateWindow(ComWindowClass, {class name} '', {caption} ws_Overlapped, {window style} 0, {X} 0, {Y} 0, {width} 0, {height} 0, {parent} 0, {menu} Instance, {instance} nil); {parameter} {Register it} FDispatcher.RegisterWndTriggerHandler(ComWindow); end else begin {Deregister it} FDispatcher.DeregisterWndTriggerHandler(ComWindow); DestroyWindow(ComWindow); end; end; procedure TApdCustomComPort.ValidateComport; var ComSelDlg : TComSelectForm; begin if (FComNumber = 0) then if (not FPromptForPort) then raise ENoPortSelected.Create(ecNoPortSelected, False) else begin ComSelDlg := TComSelectForm.Create(Application); try if (ComSelDlg.ShowModal = mrOk) then ComNumber := ComSelDlg.SelectedComNum else raise ENoPortSelected.Create(ecNoPortSelected, False); finally ComSelDlg.Free; end; end; end; constructor TApdCustomComPort.Create(AOwner : TComponent); {-Create the object instance} begin {Create the registration list before notification events are sent} UserList := TList.Create; {No override by default} OverrideLine := False; {This causes notification events for all other components} inherited Create(AOwner); {Private inits} Force := False; PortState := psClosed; ForceOpen := False; CopyTriggers := False; BusyBeforeWait := False; WaitPrepped := False; fComWindow := 0; {Data inits} FDeviceLayers := [dlWin32]; FPromptForPort := adpoDefPromptForPort; FDeviceLayer := adpoDefDeviceLayer; FDispatcher := nil; FComNumber := adpoDefComNumber; FOpen := adpoDefOpen; FAutoOpen := adpoDefAutoOpen; FDTR := adpoDefDTR; FRTS := adpoDefRTS; FSWFlowOptions := adpoDefSWFlowOptions; FXonChar := adpoDefXOnChar; FXOffChar := adpoDefXOffChar; FBufferFull := adpoDefBufferFull; FBufferResume := adpoDefBufferResume; FTriggerLength := adpoDefTriggerLength; FTracing := adpoDefTracing; FTraceSize := adpoDefTraceSize; FTraceName := adpoDefTraceName; FTraceHex := adpoDefTraceHex; TraceAllHex:= adpoDefTraceAllHex; FLogging := adpoDefLogging; FLogSize := adpoDefLogSize; FLogName := adpoDefLogName; FLogHex := adpoDefLogHex; LogAllHex := adpoDefLogAllHex; FUseMSRShadow := adpoDefUseMSRShadow; FUseEventWord := adpoDefUseEventWord; FCommNotificationLevel := adpoDefCommNotificationLevel; FTapiMode := adpoDefTapiMode; if not OverrideLine then begin FBaud := adpoDefBaudRt; FParity := adpoDefParity; FDatabits := adpoDefDatabits; FStopbits := adpoDefStopbits; FInSize := adpoDefInSize; FOutSize := adpoDefOutSize; FHWFlowOptions := []; end; {Event inits} FOnTrigger := nil; FOnTriggerAvail := nil; FOnTriggerData := nil; FOnTriggerStatus := nil; FOnTriggerTimer := nil; FOnTriggerLineError := nil; FOnTriggerModemStatus := nil; FOnTriggerOutbuffFree := nil; FOnTriggerOutbuffUsed := nil; FOnTriggerOutSent := nil; FOnPortOpen := nil; FOnPortClose := nil; FOnWaitChar := nil; end; destructor TApdCustomComPort.Destroy; {-Destroy the object instance} var I : Word; UL : PUserListEntry; begin {Close the port} if (PortState = psOpen) then begin DonePort; end; {Get rid of the user list} if Assigned(UserList) and (UserList.Count > 0) then begin {!!.02} for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; UserList.Remove(UL); Dispose(UL); end; end; UserList.Free; TApdBaseDispatcher.ClearSaveBuffers(SaveTriggerBuffer); inherited Destroy; end; procedure TApdCustomComPort.InitPort; {-Physically open the comport} var Res : Integer; nBaud : LongInt; nParity : Word; nDataBits : TDatabits; nStopBits : TStopbits; nHWOpts, nSWOpts, nBufferFull, nBufferResume : Cardinal; nOnChar, nOffChar : Char; begin { Validate the comport -- not needed for Tapi } if TapiMode <> tmOn then ValidateComport; { Activate the specified device layer } FDispatcher := ActivateDeviceLayer; FDispatcher.DeviceName := Format('COM%d', [ComNumber]); try { Get line parameters that Tapi set } if TapiMode = tmOn then begin if ValidDispatcher.ComHandle = 0 then CheckException(Self, ecNotOpenedByTapi); FDispatcher.GetLine(nBaud, nParity, nDataBits, nStopBits); FDispatcher.GetFlowOptions(nHWOpts, nSWOpts, nBufferFull, nBufferResume, nOnChar, nOffChar); { Sync our properties with those set by Tapi } FBaud := nBaud; FParity := TParity(nParity); FDataBits := Ord(nDataBits); FStopBits := Ord(nStopBits); FHWFlowOptions := []; if (nHWOpts and hfUseDTR) <> 0 then Include(FHWFlowOptions, hwfUseDTR); if (nHWOpts and hfUseRTS) <> 0 then Include(FHWFlowOptions, hwfUseRTS); if (nHWOpts and hfRequireDSR) <> 0 then Include(FHWFlowOptions, hwfRequireDSR); if (nHWOpts and hfRequireCTS) <> 0 then Include(FHWFlowOptions, hwfRequireCTS); FSWFlowOptions := TSWFlowOptions(nSWOpts); FXOnChar := nOnChar; FXOffChar := nOffChar; end; Res := InitializePort; {Remap access denied and file not found errors} if Res = ecAccessDenied then Res := ecAlreadyOpen else if (Res = ecFileNotFound) or (Res = ecPathNotFound) then Res := ecBadId; if (Res = ecOk) then begin {Handle preset properties} PortState := psOpen; UpdateHandlerFlag; Force := True; SetTracing(Tracing); SetLogging(Logging); SetHWFlowOptions(HWFlowOptions); SetSWFlowOptions(SWFlowOptions); SetXOnChar(FXonChar); SetXOffChar(FXoffChar); SetTriggerLength(FTriggerLength); SetDTR(FDTR); SetRTS(FRTS); {SetUseMSRShadow(FUseMSRShadow);} {16-bit} {!!.02} SetUseEventWord(FUseEventWord); {SetCommNotificationLevel(FCommNotificationLevel);} {16-bit} {!!.02} SetRS485Mode(FRS485Mode); SetThreadBoost(FThreadBoost); Force := False; FOpen := True; {Prepare for triggers} RegisterComPort(True); {Add pending triggers} if CopyTriggers then begin CopyTriggers := False; FDispatcher.RestoreTriggers(SaveTriggerBuffer); end; {Send OnPortEvent} PortOpen; end else CheckException(Self, Res); except FOpen := False; PortState := psClosed; FDispatcher.Free; FDispatcher := nil; raise; end; end; procedure TApdCustomComPort.DonePort; {-Physically close the comport} begin {FOpen := False;} {!!.02} if (PortState = psOpen) then begin { Force trace/log dumps if they were on } Tracing := tlDump; Logging := tlDump; { Port is shutting down } PortState := psShuttingDown; { Send OnPortClose event } {PortClose;} {!!.02} PortClosing; {!!.03} { Save triggers in case this port is reopened } Dispatcher.SaveTriggers(SaveTriggerBuffer); CopyTriggers := True; { Close the port and clear ComTable } Dispatcher.DonePort; if Dispatcher.EventBusy then begin PostMessage(fComWindow, apw_ClosePending, 0, Dispatcher.Handle shl 16); SafeYield; end else begin { Get rid of the trigger handler } RegisterComPort(False); FDispatcher.Free; FDispatcher := nil; PortState := psClosed; FOpen := False; {!!.02} end; { Send OnPortClose event } PortClose; {!!.02} end; end; procedure TApdCustomComPort.Assign(Source: TPersistent); {-Assign values of Source to self} var SourcePort : TApdCustomComPort absolute Source; I : Word; UL : PUserListEntry; begin if Source is TApdCustomComPort then begin {Discard existing userlist} if UserList.Count > 0 then for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; UserList.Remove(UL); Dispose(UL); end; UserList.Free; {Copy Source's userlist} UserList := TList.Create; if SourcePort.UserList.Count > 0 then for I := 0 to SourcePort.UserList.Count-1 do begin New(UL); Move(SourcePort.UserList.Items[I]^, UL^, SizeOf(TUserListEntry)); UserList.Add(UL); end; {Copy triggers from Source} if (SourcePort.PortState = psOpen) then begin SourcePort.Dispatcher.SaveTriggers(SaveTriggerBuffer); CopyTriggers := True; end; {Copy all other fields} Force := SourcePort.Force; FDeviceLayer := SourcePort.FDeviceLayer; FComNumber := SourcePort.FComNumber; FBaud := SourcePort.FBaud; FParity := SourcePort.FParity; FDatabits := SourcePort.FDatabits; FStopbits := SourcePort.FStopbits; FInSize := SourcePort.FInSize; FOutSize := SourcePort.FOutSize; FOpen := False; FAutoOpen := SourcePort.FAutoOpen; FPromptForPort := SourcePort.FPromptForPort; FRS485Mode := SourcePort.FRS485Mode; FThreadBoost := SourcePort.FThreadBoost; FDTR := SourcePort.FDTR; FRTS := SourcePort.FRTS; FBufferFull := SourcePort.FBufferFull; FBufferResume := SourcePort.FBufferResume; FHWFlowOptions := SourcePort.FHWFlowOptions; FSWFlowOptions := SourcePort.FSWFlowOptions; FXOnChar := SourcePort.FXOnChar; FXOffChar := SourcePort.FXOffChar; FTracing := SourcePort.FTracing; FTraceSize := SourcePort.FTraceSize; FTraceName := SourcePort.FTraceName; FTraceHex := SourcePort.FTraceHex; FTraceAllHex := SourcePort.FTraceAllHex; FLogging := SourcePort.FLogging; FLogSize := SourcePort.FLogSize; FLogName := SourcePort.FLogName; FLogHex := SourcePort.FLogHex; FLogAllHex := SourcePort.FLogAllHex; FTriggerLength := SourcePort.FTriggerLength; {Must go through write method to ensure flag gets updated} OnTrigger := SourcePort.FOnTrigger; OnTriggerAvail := SourcePort.FOnTriggerAvail; OnTriggerData := SourcePort.FOnTriggerData; OnTriggerStatus := SourcePort.FOnTriggerStatus; OnTriggerTimer := SourcePort.FOnTriggerTimer; FOnPortOpen := SourcePort.FOnPortOpen; FOnPortClose := SourcePort.FOnPortClose; FTapiMode := SourcePort.FTapiMode; end; end; procedure TApdCustomComPort.RegisterUser(const H : THandle); {-Register a user of this comport} var UL : PUserListEntry; begin New(UL); with UL^ do begin Handle := H; OpenClose := nil; OpenCloseEx := nil; {!!.03} IsEx := False; {!!.03} end; UserList.Add(UL); end; procedure TApdCustomComPort.RegisterUserEx(const H : THandle);{!!.03} {-Register a TApdComPort user to receive open/closing/close events} var UL : PUserListEntry; begin New(UL); with UL^ do begin Handle := H; OpenClose := nil; OpenCloseEx := nil; IsEx := True; end; UserList.Add(UL); end; procedure TApdCustomComPort.RegisterUserCallback(CallBack : TPortCallback); {-Register a user of this comport} var UL : PUserListEntry; begin New(UL); with UL^ do begin Handle := 0; OpenClose := Callback; OpenCloseEx := nil; {!!.03} IsEx := False; {!!.03} end; UserList.Add(UL); end; procedure TApdCustomComPort.RegisterUserCallbackEx( {!!.03} CallBackEx : TPortCallbackEx); {-Register a TApdComPort user to receive extended callbacks} var UL : PUserListEntry; begin New(UL); with UL^ do begin Handle := 0; OpenClose := nil; OpenCloseEx := CallbackEx; IsEx := True; end; UserList.Add(UL); end; procedure TApdCustomComPort.DeregisterUser(const H : THandle); {-Deregister a user of this comport} var UL : PUserListEntry; I : Word; begin if csDestroying in ComponentState then Exit; {!!.05} if Assigned(UserList) and (UserList.Count > 0) then begin {!!.02} for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; with UL^ do begin if Handle = H then begin UserList.Remove(UL); Dispose(UL); end; end; end; end; end; procedure TApdCustomComPort.DeregisterUserCallback(CallBack : TPortCallback); {-Deregister a user of this comport} var UL : PUserListEntry; I : Word; begin if csDestroying in ComponentState then Exit; {!!.05} if Assigned(UserList) and (UserList.Count > 0) then begin {!!.02} for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; with UL^ do begin if @CallBack = @OpenClose then begin UserList.Remove(UL); Dispose(UL); end; end; end; end; end; procedure TApdCustomComPort.DeregisterUserCallbackEx( {!!.03} CallBackEx : TPortCallbackEx); {-Deregister a TApdComPort user callback} var UL : PUserListEntry; I : Word; begin if csDestroying in ComponentState then Exit; {!!.05} if Assigned(UserList) and (UserList.Count > 0) then begin for I := UserList.Count-1 downto 0 do begin UL := UserList.Items[I]; with UL^ do begin if @CallBackEx = @OpenCloseEx then begin UserList.Remove(UL); Dispose(UL); end; end; end; end; end; procedure TApdCustomComPort.ProcessCommunications; {-Process communications receive events, but not triggers} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.ProcessCommunications); end; procedure TApdCustomComPort.FlushInBuffer; {-Flush the input buffer} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.FlushInBuffer); end; procedure TApdCustomComPort.FlushOutBuffer; {-Flush the output buffer} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.FlushOutBuffer); end; procedure TApdCustomComPort.InitTracing(const NumEntries : Cardinal); {-Start tracing} begin if (PortState = psShuttingDown) then Exit; if NumEntries <> 0 then FTraceSize := NumEntries; CheckException(Self, Dispatcher.InitTracing(NumEntries)); FTracing := tlOn; end; procedure TApdCustomComPort.DumpTrace(const FName : ShortString; const InHex : Boolean); {-Dump the trace file} var Dest : array[0..255] of Char; begin if (PortState = psShuttingDown) then Exit; CheckException(Self, Dispatcher.DumpTrace(StrPCopy(Dest, FName), InHex, TraceAllHex)); FTracing := tlOff; end; procedure TApdCustomComPort.AppendTrace(const FName : ShortString; const InHex : Boolean); {-Append the trace file} var Dest : array[0..255] of Char; begin if (PortState = psShuttingDown) then Exit; CheckException(Self, Dispatcher.AppendTrace(StrPCopy(Dest, FName), InHex, TraceAllHex)); FTracing := tlOff; end; procedure TApdCustomComPort.ClearTracing; {-Clear the trace buffer but keep tracing} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, Dispatcher.ClearTracing); end; procedure TApdCustomComPort.AbortTracing; {-Abort tracing without dumping the trace file} begin if (PortState = psShuttingDown) then Exit; Dispatcher.AbortTracing; FTracing := tlOff; end; procedure TApdCustomComPort.AddTraceEntry(const CurEntry, CurCh : Char); {-Add a trace entry} begin if (PortState = psShuttingDown) then Exit; Dispatcher.AddTraceEntry(CurEntry, CurCh); end; procedure TApdCustomComPort.AddStringToLog(S : string); begin if (PortState = psShuttingDown) then Exit; ValidDispatcher.AddStringToLog(S); end; procedure TApdCustomComPort.StartTracing; {-Resume tracing after StopTracing} begin if (PortState = psShuttingDown) then Exit; Dispatcher.StartTracing; FTracing := tlOn; end; procedure TApdCustomComPort.StopTracing; {-Temporarily stop tracing} begin if (PortState = psShuttingDown) then Exit; Dispatcher.StopTracing; FTracing := tlPause; end; procedure TApdCustomComPort.ForcePortOpen; {-Ensure port is opened after loading} begin if AutoOpen then ForceOpen := True; end; procedure TApdCustomComPort.SendBreak(Ticks : Word; Yield : Boolean); {-Send a line break of ticks duration} begin if (PortState = psShuttingDown) then Exit; ValidDispatcher.SendBreak(Ticks, Yield); end; procedure TApdCustomComPort.SetBreak(BreakOn: Boolean); {-Sets or clears line break condition} begin if (PortState = psShuttingDown) then Exit; ValidDispatcher.SetBreak(BreakOn); end; procedure TApdCustomComPort.InitLogging(const Size : Cardinal); {-Start dispatch logging} begin if (PortState = psShuttingDown) then Exit; if Size <> 0 then FLogSize := Size; Dispatcher.InitDispatchLogging(FLogSize); FLogging := tlOn; end; procedure TApdCustomComPort.DumpLog(const FName : ShortString; const InHex : Boolean); {-Dump the dispatch log} var Dest : array[0..255] of Char; begin if (PortState = psShuttingDown) then Exit; CheckException(Self, Dispatcher.DumpDispatchLog(StrPCopy(Dest, FName), InHex, LogAllHex)); FLogging := tlOff; end; procedure TApdCustomComPort.AppendLog(const FName : ShortString; const InHex : Boolean); {-Dump the dispatch log} var Dest : array[0..255] of Char; begin if (PortState = psShuttingDown) then Exit; CheckException(Self, Dispatcher.AppendDispatchLog(StrPCopy(Dest, FName), InHex, LogAllHex)); FLogging := tlOff; end; procedure TApdCustomComPort.ClearLogging; {-Clear the log but keep logging} begin if (PortState = psShuttingDown) then Exit; Dispatcher.ClearDispatchLogging; end; procedure TApdCustomComPort.AbortLogging; {-Abort logging without dumping the log} begin if (PortState = psShuttingDown) then Exit; Dispatcher.AbortDispatchLogging; FLogging := tlOff; end; procedure TApdCustomComPort.StartLogging; {-Resume logging after stopping} begin if (PortState = psShuttingDown) then Exit; Dispatcher.StartDispatchLogging; FLogging := tlOn; end; procedure TApdCustomComPort.StopLogging; {-Temporarily stop logging} begin if (PortState = psShuttingDown) then Exit; Dispatcher.StopDispatchLogging; FLogging := tlPause; end; function TApdCustomComPort.AddDataTrigger(const Data : ShortString; const IgnoreCase : Boolean) : Word; {-Add a ShortString data trigger} var Len : Word; P : array[0..255] of Char; begin if (PortState = psShuttingDown) then begin Result := 0; Exit; end; Len := Length(Data); Move(Data[1], P, Len); Result := Word(CheckException(Self, ValidDispatcher.AddDataTriggerLen(P, IgnoreCase, Len))); end; function TApdCustomComPort.AddTimerTrigger : Word; {-Add a timer trigger} begin if (PortState = psShuttingDown) then Result := 0 else Result := Word(CheckException(Self, ValidDispatcher.AddTimerTrigger)); end; function TApdCustomComPort.AddStatusTrigger(const SType : Word) : Word; {-Add a status trigger of type SType} begin if (PortState = psShuttingDown) then Result := 0 else Result := Word(CheckException(Self, ValidDispatcher.AddStatusTrigger(SType))); end; procedure TApdCustomComPort.RemoveTrigger(const Handle : Word); {-Remove trigger with index Index} begin if (PortState = psOpen) then CheckException(Self, Dispatcher.RemoveTrigger(Handle)); end; procedure TApdCustomComPort.RemoveAllTriggers; {-Remove all triggers} begin if (PortState = psOpen) then begin Dispatcher.RemoveAllTriggers; FTriggerLength := 0; end; end; procedure TApdCustomComPort.SetTimerTrigger(const Handle : Word; const Ticks : LongInt; const Activate : Boolean); {-Set the timer for trigger Index} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.SetTimerTrigger(Handle, Ticks, Activate)); end; procedure TApdCustomComPort.SetStatusTrigger(const Handle : Word; const Value : Word; const Activate : Boolean); {-Set status trigger} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.SetStatusTrigger(Handle, Value, Activate)); end; {I/O} function TApdCustomComPort.CharReady : Boolean; {-Return the next character in the receive buffer} begin if (PortState = psShuttingDown) then Result := False else Result := ValidDispatcher.CharReady; end; function TApdCustomComPort.PeekChar(const Count : Word) : Char; {-Peek at the Count'th character in the buffer (1=next)} var Res : Integer; C : Char; begin if (PortState = psShuttingDown) then begin Res := ecOk; C := #0; end else Res := ValidDispatcher.PeekChar(C, Count); if Res = ecOK then Result := C else begin CheckException(Self, Res); Result := #0; end; end; function TApdCustomComPort.GetChar : Char; {-Retrieve the next character from the input queue} var Res : Integer; C : Char; begin if (PortState = psShuttingDown) then begin Res := ecOk; C := #0; end else Res := ValidDispatcher.GetChar(C); if Res = ecOK then Result := C else begin CheckException(Self, Res); Result := #0; end; end; procedure TApdCustomComPort.PeekBlock(var Block; const Len : Word); {-Peek at the next Len characters, but don't remove from buffer} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.PeekBlock(PChar(@Block), Len)); end; procedure TApdCustomComPort.GetBlock(var Block; const Len : Word); {-Return the next Len characters from the buffer} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.GetBlock(PChar(@Block), Len)); end; procedure TApdCustomComPort.PutChar(const C : Char); {-Add C to the output buffer} begin if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.PutChar(C)); end; procedure TApdCustomComPort.PutString(const S : String); {-Add S to the output buffer} begin if (PortState = psShuttingDown) then Exit; {$IFOPT H+} CheckException(Self, ValidDispatcher.PutBlock(Pointer(S)^, Length(S))); {$ELSE} CheckException(Self, ValidDispatcher.PutString(S)); {$ENDIF} end; function TApdCustomComPort.PutBlock(const Block; const Len : Word) : Integer; {-Add Block to the output buffer} begin PutBlock := 0; if (PortState = psShuttingDown) then Exit; CheckException(Self, ValidDispatcher.PutBlock(PChar(Block), Len)); end; {Waits} function TApdCustomComPort.CheckForString(var Index : Byte; C : Char; const S : String; IgnoreCase : Boolean) : Boolean; {-Compare C against a sequence of chars, looking for S} var CurChar : Char; begin CheckForString := False; if (PortState = psShuttingDown) then Exit; Inc(Index); {Upcase both data if ignoring case} if IgnoreCase then begin C := Upcase(C); CurChar := Upcase(S[Index]); end else CurChar := S[Index]; {Compare...} if C = CurChar then {Got match, was it complete?} if Index = Length(S) then begin Index := 0; CheckForString := True; end else else {No match, reset Index} if (IgnoreCase and (C = Upcase(S[1]))) or (C = S[1]) then Index := 1 else Index := 0; end; function TApdCustomComPort.WaitForString(const S : String; const Timeout : LongInt; const Yield, IgnoreCase : Boolean) : Boolean; {-Wait for data, generate ETimeout exception if not found} var ET : EventTimer; C : Char; CurChar : Char; StartChar : Char; Index : Byte; Finished : Boolean; WasBusy : Boolean; Len : Word; begin Result := True; {Exit immediately if nothing to do} if (S = '') or (PortState = psShuttingDown) then Exit; {Set busy flag} ValidDispatcher.SetEventBusy(WasBusy, True); {Note the length of the string} Len := Length(S); {Prepare...} NewTimer(ET, Timeout); Index := 0; Finished := False; StartChar := S[1]; if IgnoreCase then StartChar := Upcase(StartChar); {Wait for data...} repeat if CharReady then begin {Char is ready, go get it} C := GetChar; Inc(Index); CurChar := S[Index]; {Report the character} WaitChar(C); {If ignoring case then upcase both} if IgnoreCase then begin C := Upcase(C); CurChar := Upcase(CurChar); end; {Compare current character} if C = CurChar then begin if Index = Len then Finished := True; end else begin {No match, reset...} if C = StartChar then Index := 1 else Index := 0; end; end; {Check for timeout if we're not otherwise finished} if not Finished then begin Finished := TimerExpired(ET); {Yield} if Yield then Application.ProcessMessages; end; until Finished or Application.Terminated; {Indicate timeout if we timed out} if not Application.Terminated then Result := not TimerExpired(ET); {Restore busy flag} if WaitPrepped and not BusyBeforeWait then Dispatcher.SetEventBusy(WasBusy, False) else if not WasBusy then Dispatcher.SetEventBusy(WasBusy, False); WaitPrepped := False; BusyBeforeWait := False; end; function TApdCustomComPort.WaitForMultiString(const S : String; const Timeout : LongInt; const Yield : Boolean; const IgnoreCase : Boolean; const SepChar : Char) : Integer; {-Wait for S, which contains several substrings separated by ^} const MaxSubs = 127; var ET : EventTimer; I, Total : Word; C : Char; CurChar : Char; Finished : Boolean; WasBusy : Boolean; StartChar : array[1..MaxSubs] of Char; StartIndex : array[1..MaxSubs] of Byte; EndIndex : array[1..MaxSubs] of Byte; Index : array[1..MaxSubs] of Byte; Len : Word; begin Result := 0; {Exit immediately if nothing to do} if (S = '') or (PortState = psShuttingDown) then Exit; {Note the length of the string} Len := Length(S); {Set busy flag} ValidDispatcher.SetEventBusy(WasBusy, True); {Prepare to parse for substrings} Total := 1; I := 1; StartIndex[Total] := I; Index[Total] := I; StartChar[Total] := S[I]; if IgnoreCase then StartChar[Total] := Upcase(StartChar[Total]); {Loop through S, noting start positions of each substring} while (I <= Len) and (Total < MaxSubs) do begin if S[I] = SepChar then begin EndIndex[Total] := I-1; Inc(I); Inc(Total); StartIndex[Total] := I; Index[Total] := I; StartChar[Total] := S[I]; If IgnoreCase then StartChar[Total] := Upcase(StartChar[Total]); end else Inc(I); end; {Handle last string} if S[Len] <> SepChar then EndIndex[Total] := Len else Dec(Total); {Prepare to wait} NewTimer(ET, Timeout); Finished := False; {Wait for data...} repeat if CharReady then begin {Char is ready, go get it} C := GetChar; {Report the character} WaitChar(C); {Handle case} if IgnoreCase then C := Upcase(C); {Compare against all substrings} for I := 1 to Total do begin CurChar := S[Index[I]]; if IgnoreCase then CurChar := Upcase(CurChar); {Compare current character} if C = CurChar then begin if Index[I] = EndIndex[I] then begin Result := I; Finished := True; break; end; Inc(Index[I]); end else begin {No match, reset...} if C = StartChar[I] then Index[I] := StartIndex[I]+1 else Index[I] := StartIndex[I]; end; end; end; {Check for timeout if we're not otherwise finished} if not Finished then begin Finished := TimerExpired(ET); {Yield} if Yield then Application.ProcessMessages; end; until Finished or Application.Terminated; {Restore busy flag} if WaitPrepped and not BusyBeforeWait then Dispatcher.SetEventBusy(WasBusy, False) else if not WasBusy then Dispatcher.SetEventBusy(WasBusy, False); WaitPrepped := False; BusyBeforeWait := False; end; procedure TApdCustomComPort.PrepareWait; {-Set EventBusy true to prevent triggers} begin if (PortState = psShuttingDown) then Exit; WaitPrepped := True; ValidDispatcher.SetEventBusy(BusyBeforeWait, True); end; {Miscellaneous procedures} function SearchComPort(const C : TComponent) : TApdCustomComPort; {-Search for a comport in the same form as TComponent} function FindComPort(const C : TComponent) : TApdCustomComPort; var I : Integer; begin Result := nil; if not Assigned(C) then Exit; {Look through all of the owned components} for I := 0 to C.ComponentCount-1 do begin if C.Components[I] is TApdCustomComPort then begin Result := TApdCustomComPort(C.Components[I]); Exit; end; {If this isn't one, see if it owns other components} Result := FindComPort(C.Components[I]); end; end; begin {Search the entire form} Result := FindComPort(C); end; function ComName(const ComNumber : Word) : ShortString; {-Return a comname ShortString for ComNumber} begin Result := 'COM' + IntToStr(ComNumber); end; end.