diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4da76bc --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +AssettoCorsa/source/__history +AssettoCorsa/*.dproj.local +AssettoCorsa/bin +AssettoCorsa/lib \ No newline at end of file diff --git a/AssettoCorsa/AssettoCorsaSF.dpr b/AssettoCorsa/AssettoCorsaSF.dpr new file mode 100644 index 0000000..5ebe640 --- /dev/null +++ b/AssettoCorsa/AssettoCorsaSF.dpr @@ -0,0 +1,19 @@ +program AssettoCorsaSF; + +uses + Vcl.Forms, + MainFrm in 'source\MainFrm.pas' {MainForm}, + AssettoCorsa.SharedMemory in 'source\AssettoCorsa.SharedMemory.pas', + CPort in 'source\CPort.pas'; + +{$R *.res} + +var + MainForm: TMainForm; + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TMainForm, MainForm); + Application.Run; +end. diff --git a/AssettoCorsa/AssettoCorsaSF.dproj b/AssettoCorsa/AssettoCorsaSF.dproj new file mode 100644 index 0000000..bc94af9 --- /dev/null +++ b/AssettoCorsa/AssettoCorsaSF.dproj @@ -0,0 +1,155 @@ + + + {3CBA51E1-33C8-4599-8659-3A1F26AA5E70} + 13.4 + VCL + AssettoCorsaSF.dpr + True + Debug + Win32 + 1 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + None + 1043 + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICON.ico + bindcompfmx;fmx;rtl;dbrtl;IndySystem;DbxClientDriver;bindcomp;inetdb;DBXInterBaseDriver;DataSnapCommon;DataSnapClient;DataSnapServer;DataSnapProviderClient;xmlrtl;DbxCommonDriver;IndyProtocols;DBXMySQLDriver;dbxcds;soaprtl;FMXTee;bindengine;DBXOracleDriver;CustomIPTransport;dsnap;DBXInformixDriver;IndyCore;FmxTeeUI;DBXFirebirdDriver;inet;inetdbxpress;DBXSybaseASADriver;IPIndyImpl;dbexpress;DataSnapIndy10ServerTransport;$(DCC_UsePackage) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + DBXOdbcDriver;DBXSybaseASEDriver;vclimg;vclactnband;vcldb;bindcompvcl;vcldsnap;vclie;vcltouch;DBXDb2Driver;websnap;VclSmp;vcl;DBXMSSQLDriver;dsnapcon;vclx;webdsnap;$(DCC_UsePackage) + + + .\bin\x86 + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + madBasic_;vcldbx;TeeDB;vclib;inetdbbde;Tee;DBXOdbcDriver;madDisAsm_;svnui;ibxpress;DBXSybaseASEDriver;vclimg;vclactnband;vcldb;TeeUI;bindcompvcl;vcldsnap;vclie;madExcept_;vcltouch;DBXDb2Driver;websnap;VclSmp;vcl;DataSnapConnectors;CloudService;DBXMSSQLDriver;dsnapcon;vclx;webdsnap;svn;bdertl;VirtualTreesR;$(DCC_UsePackage) + .\lib\x86 + 1033 + $(BDS)\bin\default_app.manifest + + + DEBUG;$(DCC_Define) + false + true + true + true + + + true + 1033 + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + +
MainForm
+ dfm + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + AssettoCorsaSF.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1043 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + False + True + + + 12 + + + + diff --git a/AssettoCorsa/AssettoCorsaSF.res b/AssettoCorsa/AssettoCorsaSF.res new file mode 100644 index 0000000..c287ee9 Binary files /dev/null and b/AssettoCorsa/AssettoCorsaSF.res differ diff --git a/AssettoCorsa/source/AssettoCorsa.SharedMemory.pas b/AssettoCorsa/source/AssettoCorsa.SharedMemory.pas new file mode 100644 index 0000000..bfa6424 --- /dev/null +++ b/AssettoCorsa/source/AssettoCorsa.SharedMemory.pas @@ -0,0 +1,333 @@ +unit AssettoCorsa.SharedMemory; + +interface +type + AC_STATUS = Integer; + TACStatus = AC_STATUS; + + +const + { AC_STATUS } + AC_OFF = 0; + AC_REPLAY = 1; + AC_LIVE = 2; + AC_PAUSE = 3; + + +type + AC_SESSION_TYPE = Integer; + TACSessionType = AC_SESSION_TYPE; + +const + { AC_SESSION_TYPE } + AC_UNKNOWN = -1; + AC_PRACTICE = 0; + AC_QUALIFY = 1; + AC_RACE = 2; + AC_HOTLAP = 3; + AC_TIME_ATTACK = 4; + AC_DRIFT = 5; + AC_DRAG = 6; + + +type + AC_FLAG_TYPE = Integer; + TACFlagType = AC_FLAG_TYPE; + +const + { AC_FLAG_TYPE } + AC_NO_FLAG = 0; + AC_BLUE_FLAG = 1; + AC_YELLOW_FLAG = 2; + AC_BLACK_FLAG = 3; + AC_WHITE_FLAG = 4; + AC_CHECKERED_FLAG = 5; + AC_PENALTY_FLAG = 6; + + +type + TACSMPhysics = packed record + packetId: Integer; + gas: Single; + brake: Single; + fuel: Single; + gear: Integer; + rpms: Integer; + steerAngle: Single; + speedKmh: Single; + velocity: array[0..2] of Single; + accG: array[0..2] of Single; + wheelSlip: array[0..3] of Single; + wheelLoad: array[0..3] of Single; + wheelsPressure: array[0..3] of Single; + wheelAngularSpeed: array[0..3] of Single; + tyreWear: array[0..3] of Single; + tyreDirtyLevel: array[0..3] of Single; + tyreCoreTemperature: array[0..3] of Single; + camberRAD: array[0..3] of Single; + suspensionTravel: array[0..3] of Single; + drs: Single; + tc: Single; + heading: Single; + pitch: Single; + roll: Single; + cgHeight: Single; + carDamage: array[0..4] of Single; + umberOfTyresOut: Integer; + pitLimiterOn: Integer; + abs: Single; + kersCharge: Single; + kersInput: Single; + autoShifterOn: Integer; + rideHeigh: Single; + turboBoost: Single; + ballast: Single; + airDensity: Single; + airTemp: Single; + roadTemp: Single; + localAngularVelocity: array[0..2] of Single; + finalFF: Single; + performanceMeter: Single; + + engineBrake: Integer; + ersRecoveryLevel: Integer; + ersPowerLevel: Integer; + ersHeatCharging: Integer; + ersIsCharging: Integer; + kersCurrentKJ: Single; + + drsAvailable: Integer; + drsEnabled: Integer; + + brakeTemp: array[0..3] of Single; + clutch: Single; + + tyreTempI: array[0..3] of Single; + tyreTempM: array[0..3] of Single; + tyreTempO: array[0..3] of Single; + + isAIControlled: Integer; + + tyreContactPoint: array[0..3, 0..2] of Single; + tyreContactNormal: array[0..3, 0..2] of Single; + tyreContactHeading: array[0..3, 0..2] of Single; + + brakeBias: Single; + end; + PACSMPhysics = ^TACSMPhysics; + + + TACSMGraphic = packed record + packetId: Integer; + status: TACStatus; + session: TACSessionType; + currentTime: array[0..14] of WideChar; + lastTime: array[0..14] of WideChar; + bestTime: array[0..14] of WideChar; + split: array[0..14] of WideChar; + completedLaps: Integer; + position: Integer; + iCurrentTime: Integer; + iLastTime: Integer; + iBestTime: Integer; + sessionTimeLeft: Single; + distanceTraveled: Single; + isInPit: Integer; + currentSectorIndex: Integer; + lastSectorTime: Integer; + numberOfLaps: Integer; + tyreCompound: array[0..32] of WideChar; + + replayTimeMultiplier: Single; + normalizedCarPosition: Single; + carCoordinates: array[0..2] of Single; + penaltyTime: Single; + flag: TACFlagType; + idealLineOn: Integer; + isInPitLane: Integer; + + surfaceGrip: Single; + end; + PACSMGraphic = ^TACSMGraphic; + + + TACSMStatic = packed record + smVersion: array[0..14] of WideChar; + acVersion: array[0..14] of WideChar; + + // Session static info + numberOfSessions: Integer; + numCars: Integer; + carModel: array[0..32] of WideChar; + track: array[0..32] of WideChar; + playerName: array[0..32] of WideChar; + playerSurname: array[0..32] of WideChar; + playerNick: array[0..32] of WideChar; + sectorCount: Integer; + + // Car static info + maxTorque: Single; + maxPower: Single; + maxRpm: Integer; + maxFuel: Single; + suspensionMaxTravel: array[0..3] of Single; + tyreRadius: array[0..3] of Single; + maxTurboBoost: Single; + + deprecated_1: Single; + deprecated_2: Single; + + penaltiesEnabled: Integer; + + aidFuelRate: Single; + aidTireRate: Single; + aidMechanicalDamage: Single; + aidAllowTyreBlankets: Integer; + aidStability: Single; + aidAutoClutch: Integer; + aidAutoBlip: Integer; + + hasDRS: Integer; + hasERS: Integer; + hasKERS: Integer; + kersMaxJ: Single; + engineBrakeSettingsCount: Integer; + ersPowerControllerCount: Integer; + trackSPlineLength: Single; + trackConfiguration: array[0..32] of WideChar; + ersMaxJ: Single; + end; + PACSMStatic = ^TACSMStatic; + + +const + ACSM_PHYSICS = 'Local\acpmf_physics'; + ACSM_GRAPHICS = 'Local\acpmf_graphics'; + ACSM_STATIC = 'Local\acpmf_static'; + + +type + IAssettoCorsaSharedMemory = interface + ['{D7C0E678-CB11-4C34-81EB-4AAD5737C44F}'] + function GetPhysics(out APhysics: TACSMPhysics): Boolean; + function GetGraphic(out AGraphic: TACSMGraphic): Boolean; + function GetStatic(out AStatic: TACSMStatic): Boolean; + end; + + + function GetAssettoCorsaSharedMemory(): IAssettoCorsaSharedMemory; + + +implementation +uses + WinApi.Windows, System.SysUtils, System.Classes; + + +type + TACSMMapping = record + Handle: THandle; + Buffer: Pointer; + end; + + + TAssettoCorsaSharedMemory = class(TInterfacedObject, IAssettoCorsaSharedMemory) + private + FPhysicsMapping: TACSMMapping; + FGraphicMapping: TACSMMapping; + FStaticMapping: TACSMMapping; + protected + function OpenMapping(const AName: string; var AMapping: TACSMMapping; ASize: Integer): Boolean; + procedure CloseMapping(var AMapping: TACSMMapping); + public + destructor Destroy; override; + + { IACSM } + function GetPhysics(out APhysics: TACSMPhysics): Boolean; + function GetGraphic(out AGraphic: TACSMGraphic): Boolean; + function GetStatic(out AStatic: TACSMStatic): Boolean; + end; + + + +function GetAssettoCorsaSharedMemory(): IAssettoCorsaSharedMemory; +begin + Result := TAssettoCorsaSharedMemory.Create; +end; + + +{ TACSM } +destructor TAssettoCorsaSharedMemory.Destroy; +begin + CloseMapping(FPhysicsMapping); + CloseMapping(FGraphicMapping); + CloseMapping(FStaticMapping); + + inherited; +end; + + +function TAssettoCorsaSharedMemory.GetPhysics(out APhysics: TACSMPhysics): Boolean; +begin + Result := OpenMapping(ACSM_PHYSICS, FPhysicsMapping, SizeOf(TACSMPhysics)); + if Result then + APhysics := PACSMPhysics(FPhysicsMapping.Buffer)^; +end; + + +function TAssettoCorsaSharedMemory.GetGraphic(out AGraphic: TACSMGraphic): Boolean; +begin + Result := OpenMapping(ACSM_GRAPHICS, FGraphicMapping, SizeOf(TACSMGraphic)); + if Result then + AGraphic := PACSMGraphic(FGraphicMapping.Buffer)^; +end; + + +function TAssettoCorsaSharedMemory.GetStatic(out AStatic: TACSMStatic): Boolean; +begin + Result := OpenMapping(ACSM_STATIC, FStaticMapping, SizeOf(TACSMStatic)); + if Result then + AStatic := PACSMStatic(FStaticMapping.Buffer)^; +end; + + +function TAssettoCorsaSharedMemory.OpenMapping(const AName: string; var AMapping: TACSMMapping; ASize: Integer): Boolean; +var + handle: THandle; + buffer: Pointer; + +begin + if AMapping.Handle <> 0 then + begin + Result := True; + exit; + end; + + Result := False; + handle := OpenFileMapping(FILE_MAP_READ, False, PChar(AName)); + if handle = 0 then + Exit; + + buffer := MapViewOfFile(handle, FILE_MAP_READ, 0, 0, ASize); + if Assigned(buffer) then + begin + AMapping.Handle := handle; + AMapping.Buffer := buffer; + Result := True; + end else + begin + CloseHandle(handle); + RaiseLastOSError; + end; +end; + + +procedure TAssettoCorsaSharedMemory.CloseMapping(var AMapping: TACSMMapping); +begin + if AMapping.Handle <> 0 then + begin + UnmapViewOfFile(AMapping.Buffer); + CloseHandle(AMapping.Handle); + end; +end; + +end. diff --git a/AssettoCorsa/source/CPort.inc b/AssettoCorsa/source/CPort.inc new file mode 100644 index 0000000..2c3e31f --- /dev/null +++ b/AssettoCorsa/source/CPort.inc @@ -0,0 +1,227 @@ +{ ComPort Library global definitions } + +{ Fixed up for Delphi 2009 by W.Postma. } + +{$B-} +{$X+} +{$H+} + +{$IFDEF VER110} { C++ Builder 3 } + {$ObjExportAll On} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER120} { Delphi 4 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_4} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER125} { C++ Builder 4 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_4} + {$ObjExportAll On} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER130} { Delphi 5 and C++ Builder 5 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_5} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER140} { Delphi 6 and C++ Builder 6} + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_6} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER150} { Delphi 7 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_7} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER160} { Delphi 8 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_8} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER170} { Delphi 9 (2005) } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2005} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER180} { Delphi 10 (2006) } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2006} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + +{$IFDEF VER185} { Delphi 11 - 2007 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2007_OR_HIGHER} + {$DEFINE DELPHI_2007} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$IFDEF BCB} + {$DEFINE BCB11} + {$ObjExportAll On} + {$ENDIF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + + +{$IFDEF VER190} { Delphi 12 2008 } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2007_OR_HIGHER} + {$DEFINE DELPHI_2008_OR_HIGHER} + {$DEFINE DELPHI_2008} + {$DEFINE DELPHI_UNICODE} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + + + +{$IFDEF VER200} { Delphi 14 2009 UNICODE } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2007_OR_HIGHER} + {$DEFINE DELPHI_2008_OR_HIGHER} + {$DEFINE DELPHI_2009_OR_HIGHER} + {$DEFINE DELPHI_2009} + {$DEFINE DELPHI_UNICODE} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + + + + +{$IFDEF VER210} { Delphi 15 XE 2010 UNICODE } + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2007_OR_HIGHER} + {$DEFINE DELPHI_2008_OR_HIGHER} + {$DEFINE DELPHI_2009_OR_HIGHER} + {$DEFINE DELPHI_2010_OR_HIGHER} + {$DEFINE DELPHI_2010} + {$DEFINE DELPHI_UNICODE} + {$IFDEF BCBNOTDELPHI} + {$ObjExportAll On} + {$ENDIF} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} + {$DEFINE VER_RECOGNIZED} +{$ENDIF} + + +{... Lets try to make it work, for Delphi 2011 and later, right now...} +{$IFNDEF VER_RECOGNIZED} + {$DEFINE DELPHI_4_OR_HIGHER} + {$DEFINE DELPHI_5_OR_HIGHER} + {$DEFINE DELPHI_6_OR_HIGHER} + {$DEFINE DELPHI_7_OR_HIGHER} + {$DEFINE DELPHI_8_OR_HIGHER} + {$DEFINE DELPHI_2005_OR_HIGHER} + {$DEFINE DELPHI_2006_OR_HIGHER} + {$DEFINE DELPHI_2007_OR_HIGHER} + {$DEFINE DELPHI_2009_OR_HIGHER} + {$DEFINE DELPHI_2010_OR_HIGHER} + {$DEFINE DELPHI_UNICODE} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CODE OFF} + {$WARN UNSAFE_CAST OFF} +{$ENDIF} + + +{$UNDEF VER_RECOGNIZED} + diff --git a/AssettoCorsa/source/CPort.pas b/AssettoCorsa/source/CPort.pas new file mode 100644 index 0000000..dbc9482 --- /dev/null +++ b/AssettoCorsa/source/CPort.pas @@ -0,0 +1,3652 @@ +(****************************************************** + * ComPort Library ver. 4.11 * + * for Delphi 5, 6, 7, 2007-2010,XE and * + * C++ Builder 3, 4, 5, 6 * + * written by Dejan Crnila, 1998 - 2002 * + * maintained by Lars B. Dybdahl, 2003 * + * Homepage: http://comport.sf.net/ * + * * + * Brian Gochnauer Oct 2010 * + * Removed ansi references for backward compat * + * Made unicode ready * + *****************************************************) + + +unit CPort; +{$Warnings OFF} +{$I CPort.inc} +{$DEFINE No_Dialogs} //removes forms setup/config code +interface + +uses + Windows, Messages, Classes, SysUtils, IniFiles, Registry; + +type + TComExceptions = ( CE_OpenFailed , CE_WriteFailed , + CE_ReadFailed , CE_InvalidAsync , + CE_PurgeFailed , CE_AsyncCheck , + CE_SetStateFailed , CE_TimeoutsFailed , + CE_SetupComFailed , CE_ClearComFailed , + CE_ModemStatFailed , CE_EscapeComFailed , + CE_TransmitFailed , CE_ConnChangeProp , + CE_EnumPortsFailed , CE_StoreFailed , + CE_LoadFailed , CE_RegFailed , + CE_LedStateFailed , CE_ThreadCreated , + CE_WaitFailed , CE_HasLink , + CE_RegError , CEPortNotOpen ); + + + + + // various types + TPort = string; + TBaudRate = (brCustom, br110, br300, br600, br1200, br2400, br4800, br9600, br14400, + br19200, br38400, br56000, br57600, br115200, br128000, br256000); + TStopBits = (sbOneStopBit, sbOne5StopBits, sbTwoStopBits); + TDataBits = (dbFive, dbSix, dbSeven, dbEight); + TParityBits = (prNone, prOdd, prEven, prMark, prSpace); + TDTRFlowControl = (dtrDisable, dtrEnable, dtrHandshake); + TRTSFlowControl = (rtsDisable, rtsEnable, rtsHandshake, rtsToggle); + TFlowControl = (fcHardware, fcSoftware, fcNone, fcCustom); + TComEvent = (evRxChar, evTxEmpty, evRxFlag, evRing, evBreak, evCTS, evDSR, evError, evRLSD, evRx80Full); + TComEvents = set of TComEvent; + TComSignal = (csCTS, csDSR, csRing, csRLSD); + TComSignals = set of TComSignal; + TComError = (ceFrame, ceRxParity, ceOverrun, ceBreak, ceIO, ceMode, ceRxOver, ceTxFull); + TComErrors = set of TComError; + TSyncMethod = (smThreadSync, smWindowSync, smNone); + TStoreType = (stRegistry, stIniFile); + TStoredProp = (spBasic, spFlowControl, spBuffer, spTimeouts, spParity, spOthers); + TStoredProps = set of TStoredProp; + TComLinkEvent = (leConn, leCTS, leDSR, leRLSD, leRing, leRx, leTx, leTxEmpty, leRxFlag); + TRxCharEvent = procedure(Sender: TObject; Count: Integer) of object; + TRxBufEvent = procedure(Sender: TObject; const Buffer; Count: Integer) of object; + TComErrorEvent = procedure(Sender: TObject; Errors: TComErrors) of object; + TComSignalEvent = procedure(Sender: TObject; OnOff: Boolean) of object; + TComExceptionEvent = procedure(Sender:TObject; + TComException:TComExceptions; ComportMessage:String; + WinError:Int64; WinMessage:String) of object; + + // types for asynchronous calls + TOperationKind = (okWrite, okRead); + TAsync = record + Overlapped: TOverlapped; + Kind: TOperationKind; + Data: Pointer; + Size: Integer; + end; + PAsync = ^TAsync; + + {$IFNDEF Unicode} + UnicodeString = Widestring; + {$ENDIF} + + // TComPort component and asistant classes + TCustomComPort = class; // forward declaration + + // class that links TCustomComPort events to other components + TComLink = class + private + FOnConn: TComSignalEvent; + FOnRxBuf: TRxBufEvent; + FOnTxBuf: TRxBufEvent; + FOnTxEmpty: TNotifyEvent; + FOnRxFlag: TNotifyEvent; + FOnCTSChange: TComSignalEvent; + FOnDSRChange: TComSignalEvent; + FOnRLSDChange: TComSignalEvent; + FOnRing: TNotifyEvent; + FOnTx: TComSignalEvent; + FOnRx: TComSignalEvent; + public + property OnConn: TComSignalEvent read FOnConn write FOnConn; + property OnRxBuf: TRxBufEvent read FOnRxBuf write FOnRxBuf; + property OnTxBuf: TRxBufEvent read FOnTxBuf write FOnTxBuf; + property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty; + property OnRxFlag: TNotifyEvent read FOnRxFlag write FOnRxFlag; + property OnCTSChange: TComSignalEvent read FOnCTSChange write FOnCTSChange; + property OnDSRChange: TComSignalEvent read FOnDSRChange write FOnDSRChange; + property OnRLSDChange: TComSignalEvent read FOnRLSDChange write FOnRLSDChange; + property OnRing: TNotifyEvent read FOnRing write FOnRing; + property OnTx: TComSignalEvent read FOnTx write FOnTx; + property OnRx: TComSignalEvent read FOnRx write FOnRx; + end; + + // thread for background monitoring of port events + TComThread = class(TThread) + private + FComPort: TCustomComPort; + FStopEvent: THandle; + FEvents: TComEvents; + protected + procedure DispatchComMsg; + procedure DoEvents; + procedure Execute; override; + procedure SendEvents; + procedure Stop; + public + constructor Create(AComPort: TCustomComPort); + destructor Destroy; override; + end; + + // timoeout properties for read/write operations + TComTimeouts = class(TPersistent) + private + FComPort: TCustomComPort; + FReadInterval: Integer; + FReadTotalM: Integer; + FReadTotalC: Integer; + FWriteTotalM: Integer; + FWriteTotalC: Integer; + procedure SetComPort(const AComPort: TCustomComPort); + procedure SetReadInterval(const Value: Integer); + procedure SetReadTotalM(const Value: Integer); + procedure SetReadTotalC(const Value: Integer); + procedure SetWriteTotalM(const Value: Integer); + procedure SetWriteTotalC(const Value: Integer); + protected + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create; + property ComPort: TCustomComPort read FComPort; + published + property ReadInterval: Integer read FReadInterval write SetReadInterval default -1; + property ReadTotalMultiplier: Integer read FReadTotalM write SetReadTotalM default 0; + property ReadTotalConstant: Integer read FReadTotalC write SetReadTotalC default 0; + property WriteTotalMultiplier: Integer + read FWriteTotalM write SetWriteTotalM default 100; + property WriteTotalConstant: Integer + read FWriteTotalC write SetWriteTotalC default 1000; + end; + + // flow control settings + TComFlowControl = class(TPersistent) + private + FComPort: TCustomComPort; + FOutCTSFlow: Boolean; + FOutDSRFlow: Boolean; + FControlDTR: TDTRFlowControl; + FControlRTS: TRTSFlowControl; + FXonXoffOut: Boolean; + FXonXoffIn: Boolean; + FDSRSensitivity: Boolean; + FTxContinueOnXoff: Boolean; + FXonChar: Char; + FXoffChar: Char; + procedure SetComPort(const AComPort: TCustomComPort); + procedure SetOutCTSFlow(const Value: Boolean); + procedure SetOutDSRFlow(const Value: Boolean); + procedure SetControlDTR(const Value: TDTRFlowControl); + procedure SetControlRTS(const Value: TRTSFlowControl); + procedure SetXonXoffOut(const Value: Boolean); + procedure SetXonXoffIn(const Value: Boolean); + procedure SetDSRSensitivity(const Value: Boolean); + procedure SetTxContinueOnXoff(const Value: Boolean); + procedure SetXonChar(const Value: Char); + procedure SetXoffChar(const Value: Char); + procedure SetFlowControl(const Value: TFlowControl); + function GetFlowControl: TFlowControl; + protected + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create; + property ComPort: TCustomComPort read FComPort; + published + property FlowControl: TFlowControl read GetFlowControl write SetFlowControl stored False; + property OutCTSFlow: Boolean read FOutCTSFlow write SetOutCTSFlow; + property OutDSRFlow: Boolean read FOutDSRFlow write SetOutDSRFlow; + property ControlDTR: TDTRFlowControl read FControlDTR write SetControlDTR; + property ControlRTS: TRTSFlowControl read FControlRTS write SetControlRTS; + property XonXoffOut: Boolean read FXonXoffOut write SetXonXoffOut; + property XonXoffIn: Boolean read FXonXoffIn write SetXonXoffIn; + property DSRSensitivity: Boolean + read FDSRSensitivity write SetDSRSensitivity default False; + property TxContinueOnXoff: Boolean + read FTxContinueOnXoff write SetTxContinueOnXoff default False; + property XonChar: Char read FXonChar write SetXonChar default #17; + property XoffChar: Char read FXoffChar write SetXoffChar default #19; + end; + + // parity settings + TComParity = class(TPersistent) + private + FComPort: TCustomComPort; + FBits: TParityBits; + FCheck: Boolean; + FReplace: Boolean; + FReplaceChar: Char; + procedure SetComPort(const AComPort: TCustomComPort); + procedure SetBits(const Value: TParityBits); + procedure SetCheck(const Value: Boolean); + procedure SetReplace(const Value: Boolean); + procedure SetReplaceChar(const Value: Char); + protected + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create; + property ComPort: TCustomComPort read FComPort; + published + property Bits: TParityBits read FBits write SetBits; + property Check: Boolean read FCheck write SetCheck default False; + property Replace: Boolean read FReplace write SetReplace default False; + property ReplaceChar: Char read FReplaceChar write SetReplaceChar default #0; + end; + + // buffer size settings + TComBuffer = class(TPersistent) + private + FComPort: TCustomComPort; + FInputSize: Integer; + FOutputSize: Integer; + procedure SetComPort(const AComPort: TCustomComPort); + procedure SetInputSize(const Value: Integer); + procedure SetOutputSize(const Value: Integer); + protected + procedure AssignTo(Dest: TPersistent); override; + public + constructor Create; + property ComPort: TCustomComPort read FComPort; + published + property InputSize: Integer read FInputSize write SetInputSize default 1024; + property OutputSize: Integer read FOutputSize write SetOutputSize default 1024; + end; + + // main component + TCustomComPort = class(TComponent) + private + FEventThread: TComThread; + FThreadCreated: Boolean; + FHandle: THandle; + FWindow: THandle; + FUpdateCount: Integer; + FLinks: TList; + FTriggersOnRxChar: Boolean; + FEventThreadPriority: TThreadPriority; + FHasLink: Boolean; + FConnected: Boolean; + FBaudRate: TBaudRate; + FCustomBaudRate: Integer; + FPort: TPort; + FStopBits: TStopBits; + FDataBits: TDataBits; + FDiscardNull: Boolean; + FEventChar: Char; + FEvents: TComEvents; + FBuffer: TComBuffer; + FParity: TComParity; + FTimeouts: TComTimeouts; + FFlowControl: TComFlowControl; + FSyncMethod: TSyncMethod; + FStoredProps: TStoredProps; + FOnRxChar: TRxCharEvent; + FOnRxBuf: TRxBufEvent; + FOnTxEmpty: TNotifyEvent; + FOnBreak: TNotifyEvent; + FOnRing: TNotifyEvent; + FOnCTSChange: TComSignalEvent; + FOnDSRChange: TComSignalEvent; + FOnRLSDChange: TComSignalEvent; + FOnError: TComErrorEvent; + FOnRxFlag: TNotifyEvent; + FOnAfterOpen: TNotifyEvent; + FOnAfterClose: TNotifyEvent; + FOnBeforeOpen: TNotifyEvent; + FOnBeforeClose: TNotifyEvent; + FOnRx80Full : TNotifyEvent; + FOnException :TComExceptionEvent; + FCodePage : Cardinal; + function GetTriggersOnRxChar: Boolean; + procedure SetTriggersOnRxChar(const Value: Boolean); + procedure SetConnected(const Value: Boolean); + procedure SetBaudRate(const Value: TBaudRate); + procedure SetCustomBaudRate(const Value: Integer); + procedure SetPort(const Value: TPort); + procedure SetStopBits(const Value: TStopBits); + procedure SetDataBits(const Value: TDataBits); + procedure SetDiscardNull(const Value: Boolean); + procedure SetEventChar(const Value: Char); + procedure SetSyncMethod(const Value: TSyncMethod); + procedure SetEventThreadPriority(const Value: TThreadPriority); + procedure SetParity(const Value: TComParity); + procedure SetTimeouts(const Value: TComTimeouts); + procedure SetBuffer(const Value: TComBuffer); + procedure SetFlowControl(const Value: TComFlowControl); + function HasLink: Boolean; + procedure TxNotifyLink(const Buffer; Count: Integer); + procedure NotifyLink(FLinkEvent: TComLinkEvent); + procedure SendSignalToLink(Signal: TComLinkEvent; OnOff: Boolean); + procedure CheckSignals(Open: Boolean); + procedure WindowMethod(var Message: TMessage); + procedure CallAfterOpen; + procedure CallAfterClose; + procedure CallBeforeOpen; + procedure CallBeforeClose; + procedure CallRxChar; + procedure CallTxEmpty; + procedure CallBreak; + procedure CallRing; + procedure CallRxFlag; + procedure CallCTSChange; + procedure CallDSRChange; + procedure CallError; + procedure CallRLSDChange; + procedure CallRx80Full; + procedure CallException(AnException: Word; const WinError: Int64 =0); + protected + procedure Loaded; override; + procedure DoAfterClose; dynamic; + procedure DoAfterOpen; dynamic; + procedure DoBeforeClose; dynamic; + procedure DoBeforeOpen; dynamic; + procedure DoRxChar(Count: Integer); dynamic; + procedure DoRxBuf(const Buffer; Count: Integer); dynamic; + procedure DoTxEmpty; dynamic; + procedure DoBreak; dynamic; + procedure DoRing; dynamic; + procedure DoRxFlag; dynamic; + procedure DoCTSChange(OnOff: Boolean); dynamic; + procedure DoDSRChange(OnOff: Boolean); dynamic; + procedure DoError(Errors: TComErrors); dynamic; + procedure DoRLSDChange(OnOff: Boolean); dynamic; + procedure DoRx80Full; dynamic; + procedure StoreRegistry(Reg: TRegistry); virtual; + procedure StoreIniFile(IniFile: TIniFile); virtual; + procedure LoadRegistry(Reg: TRegistry); virtual; + procedure LoadIniFile(IniFile: TIniFile); virtual; + procedure CreateHandle; virtual; + procedure DestroyHandle; virtual; + procedure ApplyDCB; dynamic; + procedure ApplyTimeouts; dynamic; + procedure ApplyBuffer; dynamic; + procedure SetupComPort; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure BeginUpdate; + procedure EndUpdate; + procedure StoreSettings(StoreType: TStoreType; StoreTo: string); + procedure LoadSettings(StoreType: TStoreType; LoadFrom: string); + procedure Open; + procedure Close; + {$IFNDEF No_Dialogs}procedure ShowSetupDialog;{$ENDIF} + function InputCount: Integer; + function OutputCount: Integer; + function Signals: TComSignals; + function StateFlags: TComStateFlags; + procedure SetDTR(OnOff: Boolean); + procedure SetRTS(OnOff: Boolean); + procedure SetXonXoff(OnOff: Boolean); + procedure SetBreak(OnOff: Boolean); + procedure ClearBuffer(Input, Output: Boolean); + function LastErrors: TComErrors; + + function Write(const Buffer; Count: Integer): Integer; + function WriteStr( Str: string): Integer; + function Read(var Buffer; Count: Integer): Integer; + function ReadStr(var Str: string; Count: Integer): Integer; + function WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; + function WriteStrAsync(var Str: string; var AsyncPtr: PAsync): Integer; + function ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; + function ReadStrAsync(var Str: Ansistring; Count: Integer; var AsyncPtr: PAsync): Integer; + function WriteUnicodeString(const Str: Unicodestring): Integer; + function ReadUnicodeString(var Str: UnicodeString; Count: Integer): Integer; + + function WaitForAsync(var AsyncPtr: PAsync): Integer; + function IsAsyncCompleted(AsyncPtr: PAsync): Boolean; + procedure WaitForEvent(var Events: TComEvents; StopEvent: THandle; Timeout: Integer); + procedure AbortAllAsync; + procedure TransmitChar(Ch: Char); + procedure RegisterLink(AComLink: TComLink); + procedure UnRegisterLink(AComLink: TComLink); + property Handle: THandle read FHandle; + property TriggersOnRxChar: Boolean read GetTriggersOnRxChar write SetTriggersOnRxChar; + property EventThreadPriority: TThreadPriority read FEventThreadPriority write SetEventThreadPriority; + property StoredProps: TStoredProps read FStoredProps write FStoredProps; + property Connected: Boolean read FConnected write SetConnected default False; + property BaudRate: TBaudRate read FBaudRate write SetBaudRate; + property CustomBaudRate: Integer read FCustomBaudRate write SetCustomBaudRate; + property Port: TPort read FPort write SetPort; + property Parity: TComParity read FParity write SetParity; + property StopBits: TStopBits read FStopBits write SetStopBits; + property DataBits: TDataBits read FDataBits write SetDataBits; + property DiscardNull: Boolean read FDiscardNull write SetDiscardNull default False; + property EventChar: Char read FEventChar write SetEventChar default #0; + property Events: TComEvents read FEvents write FEvents; + property Buffer: TComBuffer read FBuffer write SetBuffer; + property FlowControl: TComFlowControl read FFlowControl write SetFlowControl; + property Timeouts: TComTimeouts read FTimeouts write SetTimeouts; + property SyncMethod: TSyncMethod read FSyncMethod write SetSyncMethod default smThreadSync; + property OnAfterOpen: TNotifyEvent read FOnAfterOpen write FOnAfterOpen; + property OnAfterClose: TNotifyEvent read FOnAfterClose write FOnAfterClose; + property OnBeforeOpen: TNotifyEvent read FOnBeforeOpen write FOnBeforeOpen; + property OnBeforeClose: TNotifyEvent read FOnBeforeClose write FOnBeforeClose; + property OnRxChar: TRxCharEvent read FOnRxChar write FOnRxChar; + property OnRxBuf: TRxBufEvent read FOnRxBuf write FOnRxBuf; + property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty; + property OnBreak: TNotifyEvent read FOnBreak write FOnBreak; + property OnRing: TNotifyEvent read FOnRing write FOnRing; + property OnCTSChange: TComSignalEvent read FOnCTSChange write FOnCTSChange; + property OnDSRChange: TComSignalEvent read FOnDSRChange write FOnDSRChange; + property OnRLSDChange: TComSignalEvent read FOnRLSDChange write FOnRLSDChange; + property OnRxFlag: TNotifyEvent read FOnRxFlag write FOnRxFlag; + property OnError: TComErrorEvent read FOnError write FOnError; + property OnRx80Full: TNotifyEvent read FOnRx80Full write FOnRx80Full; + property OnException: TComExceptionEvent read FOnException write FOnException; + // Translate strings between ANSI charsets + property CodePage: Cardinal read FCodePage write FCodePage default 0; + end; + + // publish the properties + TComPort = class(TCustomComPort) + property Connected; + property BaudRate; + property Port; + property Parity; + property StopBits; + property DataBits; + property DiscardNull; + property EventChar; + property Events; + property Buffer; + property FlowControl; + property Timeouts; + property StoredProps; + property TriggersOnRxChar; + property SyncMethod; + property OnAfterOpen; + property OnAfterClose; + property OnBeforeOpen; + property OnBeforeClose; + property OnRxChar; + property OnRxBuf; + property OnTxEmpty; + property OnBreak; + property OnRing; + property OnCTSChange; + property OnDSRChange; + property OnRLSDChange; + property OnRxFlag; + property OnError; + property OnRx80Full; + property OnException; + property CodePage; + end; + + TComStrEvent = procedure(Sender: TObject; const Str: string) of object; + TCustPacketEvent = procedure(Sender: TObject; const Str: string; + var Pos: Integer) of object; + + // component for reading data in packets + TComDataPacket = class(TComponent) + private + FComLink: TComLink; + FComPort: TCustomComPort; + FStartString: string; + FStopString: string; + FMaxBufferSize: Integer; + FSize: Integer; + FIncludeStrings: Boolean; + FCaseInsensitive: Boolean; + FInPacket: Boolean; + FBuffer: string; + FOnPacket: TComStrEvent; + FOnDiscard: TComStrEvent; + FOnCustomStart: TCustPacketEvent; + FOnCustomStop: TCustPacketEvent; + procedure SetComPort(const Value: TCustomComPort); + procedure SetCaseInsensitive(const Value: Boolean); + procedure SetSize(const Value: Integer); + procedure SetStartString(const Value: string); + procedure SetStopString(const Value: string); + procedure RxBuf(Sender: TObject; const Buffer; Count: Integer); + procedure CheckIncludeStrings(var Str: string); + function Upper(const Str: string): string; + procedure EmptyBuffer; + function ValidStop: Boolean; + protected + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure DoDiscard(const Str: string); dynamic; + procedure DoPacket(const Str: string); dynamic; + procedure DoCustomStart(const Str: string; var Pos: Integer); dynamic; + procedure DoCustomStop(const Str: string; var Pos: Integer); dynamic; + procedure HandleBuffer; virtual; + property Buffer: string read FBuffer write FBuffer; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure AddData(const Str: string); + published + procedure ResetBuffer; + property ComPort: TCustomComPort read FComPort write SetComPort; + property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive default False; + property IncludeStrings: Boolean read FIncludeStrings write FIncludeStrings default False; + property MaxBufferSize: Integer read FMaxBufferSize write FMaxBufferSize default 1024; + property StartString: string read FStartString write SetStartString; + property StopString: string read FStopString write SetStopString; + property Size: Integer read FSize write SetSize default 0; + property OnDiscard: TComStrEvent read FOnDiscard write FOnDiscard; + property OnPacket: TComStrEvent read FOnPacket write FOnPacket; + property OnCustomStart: TCustPacketEvent read FOnCustomStart write FOnCustomStart; + property OnCustomStop: TCustPacketEvent read FOnCustomStop write FOnCustomStop; + end; + + // com port stream + TComStream = class(TStream) + private + FComPort: TCustomComPort; + public + constructor Create(AComPort: TCustomComPort); + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + end; + + // exception class for ComPort Library errors + EComPort = class(Exception) + private + FWinCode: Integer; + FCode: Integer; + public + constructor Create(ACode: Integer; AWinCode: Integer); + constructor CreateNoWinCode(ACode: Integer); + property WinCode: Integer read FWinCode write FWinCode; + property Code: Integer read FCode write FCode; + end; + +// aditional procedures +procedure InitAsync(var AsyncPtr: PAsync); +procedure DoneAsync(var AsyncPtr: PAsync); +procedure EnumComPorts(Ports: TStrings); + +// conversion functions +function StrToBaudRate(Str: string): TBaudRate; +function StrToStopBits(Str: string): TStopBits; +function StrToDataBits(Str: string): TDataBits; +function StrToParity(Str: string): TParityBits; +function StrToFlowControl(Str: string): TFlowControl; +function BaudRateToStr(BaudRate: TBaudRate): string; +function StopBitsToStr(StopBits: TStopBits): string; +function DataBitsToStr(DataBits: TDataBits): string; +function ParityToStr(Parity: TParityBits): string; +function FlowControlToStr(FlowControl: TFlowControl): string; +function ComErrorsToStr(Errors:TComErrors):String; + +const + // infinite wait + WaitInfinite = Integer(INFINITE); + + // error codes + CError_OpenFailed = 1; + CError_WriteFailed = 2; + CError_ReadFailed = 3; + CError_InvalidAsync = 4; + CError_PurgeFailed = 5; + CError_AsyncCheck = 6; + CError_SetStateFailed = 7; + CError_TimeoutsFailed = 8; + CError_SetupComFailed = 9; + CError_ClearComFailed = 10; + CError_ModemStatFailed = 11; + CError_EscapeComFailed = 12; + CError_TransmitFailed = 13; + CError_ConnChangeProp = 14; + CError_EnumPortsFailed = 15; + CError_StoreFailed = 16; + CError_LoadFailed = 17; + CError_RegFailed = 18; + CError_LedStateFailed = 19; + CError_ThreadCreated = 20; + CError_WaitFailed = 21; + CError_HasLink = 22; + CError_RegError = 23; + CError_PortNotOpen = 24; + +implementation + +uses + {$IFNDEF No_Dialogs} CPortSetup, {$ENDIF} + Controls, Forms, WinSpool; + +var + // error messages + ComErrorMessages: array[1..24] of widestring; + +const + // auxilary constants used not defined in windows.pas + dcb_Binary = $00000001; + dcb_Parity = $00000002; + dcb_OutxCTSFlow = $00000004; + dcb_OutxDSRFlow = $00000008; + dcb_DTRControl = $00000030; + dcb_DSRSensivity = $00000040; + dcb_TxContinueOnXoff = $00000080; + dcb_OutX = $00000100; + dcb_InX = $00000200; + dcb_ErrorChar = $00000400; + dcb_Null = $00000800; + dcb_RTSControl = $00003000; + dcb_AbortOnError = $00004000; + + // com port window message + CM_COMPORT = WM_USER + 1; + +(***************************************** + * auxilary functions and procedures * + *****************************************) +function ComErrorsToStr(Errors:TComErrors):String; + procedure e(msg:String); + begin + if result='' then + result := msg + else + result := result+','+msg; + end; +begin + result := ''; + if ceFrame in Errors then e('Frame'); + if ceRxParity in Errors then e('Parity'); + if ceOverrun in Errors then e('Overrun'); + if ceBreak in Errors then e('Break'); + if ceIO in Errors then e('IO'); + if ceMode in Errors then e('Mode'); + if ceRxOver in Errors then e('RxOver'); + if ceTxFull in Errors then e('TxFull'); + if result = '' then + result := '' + else + result := ''; +end; + +// converts TComEvents type to Integer +function EventsToInt(const Events: TComEvents): Integer; +begin + Result := 0; + if evRxChar in Events then + Result := Result or EV_RXCHAR; + if evRxFlag in Events then + Result := Result or EV_RXFLAG; + if evTxEmpty in Events then + Result := Result or EV_TXEMPTY; + if evRing in Events then + Result := Result or EV_RING; + if evCTS in Events then + Result := Result or EV_CTS; + if evDSR in Events then + Result := Result or EV_DSR; + if evRLSD in Events then + Result := Result or EV_RLSD; + if evError in Events then + Result := Result or EV_ERR; + if evBreak in Events then + Result := Result or EV_BREAK; + if evRx80Full in Events then + Result := Result or EV_RX80FULL; +end; + +function IntToEvents(Mask: Integer): TComEvents; +begin + Result := []; + if (EV_RXCHAR and Mask) <> 0 then + Result := Result + [evRxChar]; + if (EV_TXEMPTY and Mask) <> 0 then + Result := Result + [evTxEmpty]; + if (EV_BREAK and Mask) <> 0 then + Result := Result + [evBreak]; + if (EV_RING and Mask) <> 0 then + Result := Result + [evRing]; + if (EV_CTS and Mask) <> 0 then + Result := Result + [evCTS]; + if (EV_DSR and Mask) <> 0 then + Result := Result + [evDSR]; + if (EV_RXFLAG and Mask) <> 0 then + Result := Result + [evRxFlag]; + if (EV_RLSD and Mask) <> 0 then + Result := Result + [evRLSD]; + if (EV_ERR and Mask) <> 0 then + Result := Result + [evError]; + if (EV_RX80FULL and Mask) <> 0 then + Result := Result + [evRx80Full]; +end; + +(***************************************** + * TComThread class * + *****************************************) + +// create thread +constructor TComThread.Create(AComPort: TCustomComPort); +begin + inherited Create(false); + FStopEvent := CreateEvent(nil, True, False, nil); + FComPort := AComPort; + // set thread priority + Priority := FComPort.EventThreadPriority; + // select which events are monitored + SetCommMask(FComPort.Handle, EventsToInt(FComPort.Events)); + // execute thread + //{$IFDEF Unicode}Start; {$ELSE} Resume; {$ENDIF} +end; + +// destroy thread +destructor TComThread.Destroy; +begin + Stop; + inherited Destroy; +end; + +// thread action +procedure TComThread.Execute; +var + EventHandles: array[0..1] of THandle; + Overlapped: TOverlapped; + Signaled, BytesTrans, Mask: DWORD; +begin + FillChar(Overlapped, SizeOf(Overlapped), 0); + Overlapped.hEvent := CreateEvent(nil, True, True, nil); + EventHandles[0] := FStopEvent; + EventHandles[1] := Overlapped.hEvent; + repeat + // wait for event to occur on serial port + WaitCommEvent(FComPort.Handle, Mask, @Overlapped); + Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE); + // if event occurs, dispatch it + if (Signaled = WAIT_OBJECT_0 + 1) + and GetOverlappedResult(FComPort.Handle, Overlapped, BytesTrans, False) + then + begin + FEvents := IntToEvents(Mask); + DispatchComMsg; + end; + until Signaled <> (WAIT_OBJECT_0 + 1); + // clear buffers + SetCommMask(FComPort.Handle, 0); + PurgeComm(FComPort.Handle, PURGE_TXCLEAR or PURGE_RXCLEAR); + CloseHandle(Overlapped.hEvent); + CloseHandle(FStopEvent); +end; + +// stop thread +procedure TComThread.Stop; +begin + SetEvent(FStopEvent); + Sleep(0); +end; + +// dispatch events +procedure TComThread.DispatchComMsg; +begin + case FComPort.SyncMethod of + smThreadSync: Synchronize(DoEvents); // call events in main thread + smWindowSync: SendEvents; // call events in thread that opened the port + smNone: DoEvents; // call events inside monitoring thread + end; +end; + +// send events to TCustomComPort component using window message +procedure TComThread.SendEvents; +begin + if evError in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_ERR, 0); + if evRxChar in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXCHAR, 0); + if evTxEmpty in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_TXEMPTY, 0); + if evBreak in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_BREAK, 0); + if evRing in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_RING, 0); + if evCTS in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_CTS, 0); + if evDSR in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_DSR, 0); + if evRxFlag in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_RXFLAG, 0); + if evRing in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_RLSD, 0); + if evRx80Full in FEvents then + SendMessage(FComPort.FWindow, CM_COMPORT, EV_RX80FULL, 0); +end; + +// call events +procedure TComThread.DoEvents; +begin + if evError in FEvents then + FComPort.CallError; + if evRxChar in FEvents then + FComPort.CallRxChar; + if evTxEmpty in FEvents then + FComPort.CallTxEmpty; + if evBreak in FEvents then + FComPort.CallBreak; + if evRing in FEvents then + FComPort.CallRing; + if evCTS in FEvents then + FComPort.CallCTSChange; + if evDSR in FEvents then + FComPort.CallDSRChange; + if evRxFlag in FEvents then + FComPort.CallRxFlag; + if evRLSD in FEvents then + FComPort.CallRLSDChange; + if evRx80Full in FEvents then + FComPort.CallRx80Full; +end; + +(***************************************** + * TComTimeouts class * + *****************************************) + +// create class +constructor TComTimeouts.Create; +begin + inherited Create; + FReadInterval := -1; + FWriteTotalM := 100; + FWriteTotalC := 1000; +end; + +// copy properties to other class +procedure TComTimeouts.AssignTo(Dest: TPersistent); +begin + if Dest is TComTimeouts then + begin + with TComTimeouts(Dest) do + begin + FReadInterval := Self.ReadInterval; + FReadTotalM := Self.ReadTotalMultiplier; + FReadTotalC := Self.ReadTotalConstant; + FWriteTotalM := Self.WriteTotalMultiplier; + FWriteTotalC := Self.WriteTotalConstant; + end + end + else + inherited AssignTo(Dest); +end; + +// select TCustomComPort to own this class +procedure TComTimeouts.SetComPort(const AComPort: TCustomComPort); +begin + FComPort := AComPort; +end; + +// set read interval +procedure TComTimeouts.SetReadInterval(const Value: Integer); +begin + if Value <> FReadInterval then + begin + FReadInterval := Value; + // if possible, apply the changes + if FComPort <> nil then + FComPort.ApplyTimeouts; + end; +end; + +// set read total constant +procedure TComTimeouts.SetReadTotalC(const Value: Integer); +begin + if Value <> FReadTotalC then + begin + FReadTotalC := Value; + if FComPort <> nil then + FComPort.ApplyTimeouts; + end; +end; + +// set read total multiplier +procedure TComTimeouts.SetReadTotalM(const Value: Integer); +begin + if Value <> FReadTotalM then + begin + FReadTotalM := Value; + if FComPort <> nil then + FComPort.ApplyTimeouts; + end; +end; + +// set write total constant +procedure TComTimeouts.SetWriteTotalC(const Value: Integer); +begin + if Value <> FWriteTotalC then + begin + FWriteTotalC := Value; + if FComPort <> nil then + FComPort.ApplyTimeouts; + end; +end; + +// set write total multiplier +procedure TComTimeouts.SetWriteTotalM(const Value: Integer); +begin + if Value <> FWriteTotalM then + begin + FWriteTotalM := Value; + if FComPort <> nil then + FComPort.ApplyTimeouts; + end; +end; + +(***************************************** + * TComFlowControl class * + *****************************************) + +// create class +constructor TComFlowControl.Create; +begin + inherited Create; + FXonChar := #17; + FXoffChar := #19; +end; + +// copy properties to other class +procedure TComFlowControl.AssignTo(Dest: TPersistent); +begin + if Dest is TComFlowControl then + begin + with TComFlowControl(Dest) do + begin + FOutCTSFlow := Self.OutCTSFlow; + FOutDSRFlow := Self.OutDSRFlow; + FControlDTR := Self.ControlDTR; + FControlRTS := Self.ControlRTS; + FXonXoffOut := Self.XonXoffOut; + FXonXoffIn := Self.XonXoffIn; + FTxContinueOnXoff := Self.TxContinueOnXoff; + FDSRSensitivity := Self.DSRSensitivity; + FXonChar := Self.XonChar; + FXoffChar := Self.XoffChar; + end + end + else + inherited AssignTo(Dest); +end; + +// select TCustomComPort to own this class +procedure TComFlowControl.SetComPort(const AComPort: TCustomComPort); +begin + FComPort := AComPort; +end; + +// set input flow control for DTR (data-terminal-ready) +procedure TComFlowControl.SetControlDTR(const Value: TDTRFlowControl); +begin + if Value <> FControlDTR then + begin + FControlDTR := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set input flow control for RTS (request-to-send) +procedure TComFlowControl.SetControlRTS(const Value: TRTSFlowControl); +begin + if Value <> FControlRTS then + begin + FControlRTS := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set ouput flow control for CTS (clear-to-send) +procedure TComFlowControl.SetOutCTSFlow(const Value: Boolean); +begin + if Value <> FOutCTSFlow then + begin + FOutCTSFlow := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set output flow control for DSR (data-set-ready) +procedure TComFlowControl.SetOutDSRFlow(const Value: Boolean); +begin + if Value <> FOutDSRFlow then + begin + FOutDSRFlow := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set software input flow control +procedure TComFlowControl.SetXonXoffIn(const Value: Boolean); +begin + if Value <> FXonXoffIn then + begin + FXonXoffIn := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set software ouput flow control +procedure TComFlowControl.SetXonXoffOut(const Value: Boolean); +begin + if Value <> FXonXoffOut then + begin + FXonXoffOut := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set DSR sensitivity +procedure TComFlowControl.SetDSRSensitivity(const Value: Boolean); +begin + if Value <> FDSRSensitivity then + begin + FDSRSensitivity := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set transfer continue when Xoff is sent +procedure TComFlowControl.SetTxContinueOnXoff(const Value: Boolean); +begin + if Value <> FTxContinueOnXoff then + begin + FTxContinueOnXoff := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set Xon char +procedure TComFlowControl.SetXonChar(const Value: Char); +begin + if Value <> FXonChar then + begin + FXonChar := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set Xoff char +procedure TComFlowControl.SetXoffChar(const Value: Char); +begin + if Value <> FXoffChar then + begin + FXoffChar := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// get common flow control +function TComFlowControl.GetFlowControl: TFlowControl; +begin + if (FControlRTS = rtsHandshake) and (FOutCTSFlow) + and (not FXonXoffIn) and (not FXonXoffOut) + then + Result := fcHardware + else + if (FControlRTS = rtsDisable) and (not FOutCTSFlow) + and (FXonXoffIn) and (FXonXoffOut) + then + Result := fcSoftware + else + if (FControlRTS = rtsDisable) and (not FOutCTSFlow) + and (not FXonXoffIn) and (not FXonXoffOut) + then + Result := fcNone + else + Result := fcCustom; +end; + +// set common flow control +procedure TComFlowControl.SetFlowControl(const Value: TFlowControl); +begin + if Value <> fcCustom then + begin + FControlRTS := rtsDisable; + FOutCTSFlow := False; + FXonXoffIn := False; + FXonXoffOut := False; + case Value of + fcHardware: + begin + FControlRTS := rtsHandshake; + FOutCTSFlow := True; + end; + fcSoftware: + begin + FXonXoffIn := True; + FXonXoffOut := True; + end; + end; + end; + if FComPort <> nil then + FComPort.ApplyDCB; +end; + +(***************************************** + * TComParity class * + *****************************************) + +// create class +constructor TComParity.Create; +begin + inherited Create; + FBits := prNone; +end; + +// copy properties to other class +procedure TComParity.AssignTo(Dest: TPersistent); +begin + if Dest is TComParity then + begin + with TComParity(Dest) do + begin + FBits := Self.Bits; + FCheck := Self.Check; + FReplace := Self.Replace; + FReplaceChar := Self.ReplaceChar; + end + end + else + inherited AssignTo(Dest); +end; + +// select TCustomComPort to own this class +procedure TComParity.SetComPort(const AComPort: TCustomComPort); +begin + FComPort := AComPort; +end; + +// set parity bits +procedure TComParity.SetBits(const Value: TParityBits); +begin + if Value <> FBits then + begin + FBits := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set check parity +procedure TComParity.SetCheck(const Value: Boolean); +begin + if Value <> FCheck then + begin + FCheck := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set replace on parity error +procedure TComParity.SetReplace(const Value: Boolean); +begin + if Value <> FReplace then + begin + FReplace := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +// set replace char +procedure TComParity.SetReplaceChar(const Value: Char); +begin + if Value <> FReplaceChar then + begin + FReplaceChar := Value; + if FComPort <> nil then + FComPort.ApplyDCB; + end; +end; + +(***************************************** + * TComBuffer class * + *****************************************) + +// create class +constructor TComBuffer.Create; +begin + inherited Create; + FInputSize := 1024; + FOutputSize := 1024; +end; + +// copy properties to other class +procedure TComBuffer.AssignTo(Dest: TPersistent); +begin + if Dest is TComBuffer then + begin + with TComBuffer(Dest) do + begin + FOutputSize := Self.OutputSize; + FInputSize := Self.InputSize; + end + end + else + inherited AssignTo(Dest); +end; + +// select TCustomComPort to own this class +procedure TComBuffer.SetComPort(const AComPort: TCustomComPort); +begin + FComPort := AComPort; +end; + +// set input size +procedure TComBuffer.SetInputSize(const Value: Integer); +begin + if Value <> FInputSize then + begin + FInputSize := Value; + if (FInputSize mod 2) = 1 then + Dec(FInputSize); + if FComPort <> nil then + FComPort.ApplyBuffer; + end; +end; + +// set ouput size +procedure TComBuffer.SetOutputSize(const Value: Integer); +begin + if Value <> FOutputSize then + begin + FOutputSize := Value; + if (FOutputSize mod 2) = 1 then + Dec(FOutputSize); + if FComPort <> nil then + FComPort.ApplyBuffer; + end; +end; + +(***************************************** + * TCustomComPort component * + *****************************************) + +// create component +constructor TCustomComPort.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + // component cannot reside on inheritable forms + FComponentStyle := FComponentStyle - [csInheritable]; + FLinks := TList.Create; + FTriggersOnRxChar := True; + FEventThreadPriority := tpNormal; + FBaudRate := br9600; + FCustomBaudRate := 9600; + FPort := 'COM1'; + FStopBits := sbOneStopBit; + FDataBits := dbEight; + FEvents := [evRxChar, evTxEmpty, evRxFlag, evRing, evBreak, + evCTS, evDSR, evError, evRLSD, evRx80Full]; + FHandle := INVALID_HANDLE_VALUE; + FStoredProps := [spBasic]; + FParity := TComParity.Create; + FParity.SetComPort(Self); + FFlowControl := TComFlowControl.Create; + FFlowControl.SetComPort(Self); + FTimeouts := TComTimeouts.Create; + FTimeouts.SetComPort(Self); + FBuffer := TComBuffer.Create; + FBuffer.SetComPort(Self); + FCodePage := CP_ACP;//0; // uses default system codepage +end; + +// destroy component +destructor TCustomComPort.Destroy; +begin + Close; + FBuffer.Free; + FFlowControl.Free; + FTimeouts.Free; + FParity.Free; + inherited Destroy; + FLinks.Free; +end; + +//Handle Exceptions +procedure TCustomComPort.CallException(AnException:Word; const WinError:Int64 =0); +var winmessage:string; +begin + if Assigned(FOnException) then + begin + if WinError > 0 then //get windows error string + try Win32Check(winerror = 0); except on E:Exception do WinMessage:=e.message; end; + FOnException(self,TComExceptions(AnException),ComErrorMessages[AnException],WinError, WinMessage); + end + else + if WinError > 0 then raise EComPort.Create(AnException, WinError) + else raise EComPort.CreateNoWinCode(AnException); + +end; +// create handle to serial port +procedure TCustomComPort.CreateHandle; +begin + FHandle := CreateFile( + PChar('\\.\' + FPort), + GENERIC_READ or GENERIC_WRITE, + 0, + nil, + OPEN_EXISTING, + FILE_FLAG_OVERLAPPED, + 0); + + if FHandle = INVALID_HANDLE_VALUE then + //raise EComPort.Create + CallException(CError_OpenFailed, GetLastError); +end; + +// destroy serial port handle +procedure TCustomComPort.DestroyHandle; +begin + if FHandle <> INVALID_HANDLE_VALUE then + begin + if CloseHandle(FHandle) then + FHandle := INVALID_HANDLE_VALUE; + end; +end; + +procedure TCustomComPort.Loaded; +begin + inherited Loaded; + // open port if Connected is True at design-time + if FConnected and not (csDesigning in ComponentState) then + begin + FConnected := False; + try + Open; + except + Application.HandleException(Self); + end; + end; +end; + +// call events which have been dispatch using window message +procedure TCustomComPort.WindowMethod(var Message: TMessage); +begin + with Message do + if Msg = CM_COMPORT then + try + if InSendMessage then + ReplyMessage(0); + if FConnected then + case wParam of + EV_RXCHAR: CallRxChar; + EV_TXEMPTY: CallTxEmpty; + EV_BREAK: CallBreak; + EV_RING: CallRing; + EV_CTS: CallCTSChange; + EV_DSR: CallDSRChange; + EV_RXFLAG: CallRxFlag; + EV_RLSD: CallRLSDChange; + EV_ERR: CallError; + EV_RX80FULL: CallRx80Full; + end + except + Application.HandleException(Self); + end + else + Result := DefWindowProc(FWindow, Msg, wParam, lParam); +end; + +// prevent from applying changes at runtime +procedure TCustomComPort.BeginUpdate; +begin + FUpdateCount := FUpdateCount + 1; +end; + +// apply the changes made since BeginUpdate call +procedure TCustomComPort.EndUpdate; +begin + if FUpdateCount > 0 then + begin + FUpdateCount := FUpdateCount - 1; + if FUpdateCount = 0 then + SetupComPort; + end; +end; + +// open port +procedure TCustomComPort.Open; +begin + // if already connected, do nothing + if not FConnected and not (csDesigning in ComponentState) then + begin + CallBeforeOpen; + // open port + CreateHandle; + FConnected := True; + try + // initialize port + SetupComPort; + except + // error occured during initialization, destroy handle + DestroyHandle; + FConnected := False; + raise; + end; + // if at least one event is set, create special thread to monitor port + if (FEvents = []) then + FThreadCreated := False + else + begin + if (FSyncMethod = smWindowSync) then +{$IFDEF DELPHI_6_OR_HIGHER} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + FWindow := AllocateHWnd(WindowMethod); +{$IFDEF DELPHI_6_OR_HIGHER} + {$WARN SYMBOL_DEPRECATED ON} +{$ENDIF} + FEventThread := TComThread.Create(Self); + FThreadCreated := True; + end; + // port is succesfully opened, do any additional initialization + CallAfterOpen; + end; +end; + +// close port +procedure TCustomComPort.Close; +begin + // if already closed, do nothing + if FConnected and not (csDesigning in ComponentState) then + begin + CallBeforeClose; + // abort all pending operations + AbortAllAsync; + // stop monitoring for events + if FThreadCreated then + begin + FEventThread.Free; + FThreadCreated := False; + if FSyncMethod = smWindowSync then +{$IFDEF DELPHI_6_OR_HIGHER} + {$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} + DeallocateHWnd(FWindow); +{$IFDEF DELPHI_6_OR_HIGHER} + {$WARN SYMBOL_DEPRECATED ON} +{$ENDIF} + end; + // close port + DestroyHandle; + FConnected := False; + // port is closed, do any additional finalization + CallAfterClose; + end; +end; + +// apply port properties +procedure TCustomComPort.ApplyDCB; +const + CParityBits: array[TParityBits] of Integer = + (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY); + CStopBits: array[TStopBits] of Integer = + (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS); + CBaudRate: array[TBaudRate] of Integer = + (0, CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, + CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, + CBR_128000, CBR_256000); + CDataBits: array[TDataBits] of Integer = (5, 6, 7, 8); + CControlRTS: array[TRTSFlowControl] of Integer = + (RTS_CONTROL_DISABLE shl 12, + RTS_CONTROL_ENABLE shl 12, + RTS_CONTROL_HANDSHAKE shl 12, + RTS_CONTROL_TOGGLE shl 12); + CControlDTR: array[TDTRFlowControl] of Integer = + (DTR_CONTROL_DISABLE shl 4, + DTR_CONTROL_ENABLE shl 4, + DTR_CONTROL_HANDSHAKE shl 4); + +var + DCB: TDCB; + +begin + // if not connected or inside BeginUpdate/EndUpdate block, do nothing + if FConnected and (FUpdateCount = 0) and + not ((csDesigning in ComponentState) or (csLoading in ComponentState)) then + begin + DCB.DCBlength := SizeOf(TDCB); + DCB.XonLim := FBuffer.InputSize div 4; + DCB.XoffLim := DCB.XonLim; + DCB.EvtChar := AnsiChar(FEventChar); + + DCB.Flags := dcb_Binary; + if FDiscardNull then + DCB.Flags := DCB.Flags or dcb_Null; + + with FFlowControl do + begin + DCB.XonChar := AnsiChar(XonChar); + DCB.XoffChar := AnsiChar(XoffChar); + if OutCTSFlow then + DCB.Flags := DCB.Flags or dcb_OutxCTSFlow; + if OutDSRFlow then + DCB.Flags := DCB.Flags or dcb_OutxDSRFlow; + DCB.Flags := DCB.Flags or CControlDTR[ControlDTR] + or CControlRTS[ControlRTS]; + if XonXoffOut then + DCB.Flags := DCB.Flags or dcb_OutX; + if XonXoffIn then + DCB.Flags := DCB.Flags or dcb_InX; + if DSRSensitivity then + DCB.Flags := DCB.Flags or dcb_DSRSensivity; + if TxContinueOnXoff then + DCB.Flags := DCB.Flags or dcb_TxContinueOnXoff; + end; + + DCB.Parity := CParityBits[FParity.Bits]; + DCB.StopBits := CStopBits[FStopBits]; + if FBaudRate <> brCustom then + DCB.BaudRate := CBaudRate[FBaudRate] + else + DCB.BaudRate := FCustomBaudRate; + DCB.ByteSize := CDataBits[FDataBits]; + + if FParity.Check then + begin + DCB.Flags := DCB.Flags or dcb_Parity; + if FParity.Replace then + begin + DCB.Flags := DCB.Flags or dcb_ErrorChar; + DCB.ErrorChar := AnsiChar(FParity.ReplaceChar); + end; + end; + + // apply settings + if not SetCommState(FHandle, DCB) then + //raise EComPort.Create + CallException(CError_SetStateFailed, GetLastError); + end; +end; + +// apply timeout properties +procedure TCustomComPort.ApplyTimeouts; +var + Timeouts: TCommTimeouts; + + function GetTOValue(const Value: Integer): DWORD; + begin + if Value = -1 then + Result := MAXDWORD + else + Result := Value; + end; + +begin + // if not connected or inside BeginUpdate/EndUpdate block, do nothing + if FConnected and (FUpdateCount = 0) and + not ((csDesigning in ComponentState) or (csLoading in ComponentState)) then + begin + Timeouts.ReadIntervalTimeout := GetTOValue(FTimeouts.ReadInterval); + Timeouts.ReadTotalTimeoutMultiplier := GetTOValue(FTimeouts.ReadTotalMultiplier); + Timeouts.ReadTotalTimeoutConstant := GetTOValue(FTimeouts.ReadTotalConstant); + Timeouts.WriteTotalTimeoutMultiplier := GetTOValue(FTimeouts.WriteTotalMultiplier); + Timeouts.WriteTotalTimeoutConstant := GetTOValue(FTimeouts.WriteTotalConstant); + + // apply settings + if not SetCommTimeouts(FHandle, Timeouts) then + //raise EComPort.Create + CallException(CError_TimeoutsFailed, GetLastError); + end; +end; + +// apply buffers +procedure TCustomComPort.ApplyBuffer; +begin + // if not connected or inside BeginUpdate/EndUpdate block, do nothing + if FConnected and (FUpdateCount = 0) and + not ((csDesigning in ComponentState) or (csLoading in ComponentState)) + then + //apply settings + if not SetupComm(FHandle, FBuffer.InputSize, FBuffer.OutputSize) then + //raise EComPort.Create + CallException(CError_SetupComFailed, GetLastError); +end; + +// initialize port +procedure TCustomComPort.SetupComPort; +begin + ApplyBuffer; + ApplyDCB; + ApplyTimeouts; +end; + +// get number of bytes in input buffer +function TCustomComPort.InputCount: Integer; +var + Errors: DWORD; + ComStat: TComStat; +begin + if not ClearCommError(FHandle, Errors, @ComStat) then + //raise EComPort.Create + CallException(CError_ClearComFailed, GetLastError); + Result := ComStat.cbInQue; +end; + +// get number of bytes in output buffer +function TCustomComPort.OutputCount: Integer; +var + Errors: DWORD; + ComStat: TComStat; +begin + if not ClearCommError(FHandle, Errors, @ComStat) then + //raise EComPort.Create + CallException(CError_ClearComFailed, GetLastError); + Result := ComStat.cbOutQue; +end; + +// get signals which are in high state +function TCustomComPort.Signals: TComSignals; +var + Status: DWORD; +begin + if not GetCommModemStatus(FHandle, Status) then + //raise EComPort.Create + CallException(CError_ModemStatFailed, GetLastError); + Result := []; + + if (MS_CTS_ON and Status) <> 0 then + Result := Result + [csCTS]; + if (MS_DSR_ON and Status) <> 0 then + Result := Result + [csDSR]; + if (MS_RING_ON and Status) <> 0 then + Result := Result + [csRing]; + if (MS_RLSD_ON and Status) <> 0 then + Result := Result + [csRLSD]; +end; + +// get port state flags +function TCustomComPort.StateFlags: TComStateFlags; +var + Errors: DWORD; + ComStat: TComStat; +begin + if not ClearCommError(FHandle, Errors, @ComStat) then + //raise EComPort.Create + CallException(CError_ClearComFailed, GetLastError); + Result := ComStat.Flags; +end; + +// set hardware line break +procedure TCustomComPort.SetBreak(OnOff: Boolean); +var + Act: Integer; +begin + if OnOff then + Act := Windows.SETBREAK + else + Act := Windows.CLRBREAK; + + if not EscapeCommFunction(FHandle, Act) then + //raise EComPort.Create + CallException(CError_EscapeComFailed, GetLastError); +end; + +// set DTR signal +procedure TCustomComPort.SetDTR(OnOff: Boolean); +var + Act: DWORD; +begin + if OnOff then + Act := Windows.SETDTR + else + Act := Windows.CLRDTR; + + if not EscapeCommFunction(FHandle, Act) then + //raise EComPort.Create + CallException(CError_EscapeComFailed, GetLastError); +end; + +// set RTS signals +procedure TCustomComPort.SetRTS(OnOff: Boolean); +var + Act: DWORD; +begin + if OnOff then + Act := Windows.SETRTS + else + Act := Windows.CLRRTS; + + if not EscapeCommFunction(FHandle, Act) then + //raise EComPort.Create + CallException(CError_EscapeComFailed, GetLastError); +end; + +// set XonXoff state +procedure TCustomComPort.SetXonXoff(OnOff: Boolean); +var + Act: DWORD; +begin + if OnOff then + Act := Windows.SETXON + else + Act := Windows.SETXOFF; + + if not EscapeCommFunction(FHandle, Act) then + //raise EComPort.Create + CallException(CError_EscapeComFailed, GetLastError); +end; + +// clear input and/or output buffer +procedure TCustomComPort.ClearBuffer(Input, Output: Boolean); +var + Flag: DWORD; +begin + Flag := 0; + if Input then + Flag := PURGE_RXCLEAR; + if Output then + Flag := Flag or PURGE_TXCLEAR; + + if not PurgeComm(FHandle, Flag) then + //raise EComPort.Create + CallException(CError_PurgeFailed, GetLastError); +end; + +// return last errors on port +function TCustomComPort.LastErrors: TComErrors; +var + Errors: DWORD; + ComStat: TComStat; +begin + if not ClearCommError(FHandle, Errors, @ComStat) then + //raise EComPort.Create + CallException(CError_ClearComFailed, GetLastError); + Result := []; + + if (CE_FRAME and Errors) <> 0 then + Result := Result + [ceFrame]; + if ((CE_RXPARITY and Errors) <> 0) and FParity.Check then // get around a bug + Result := Result + [ceRxParity]; + if (CE_OVERRUN and Errors) <> 0 then + Result := Result + [ceOverrun]; + if (CE_RXOVER and Errors) <> 0 then + Result := Result + [ceRxOver]; + if (CE_TXFULL and Errors) <> 0 then + Result := Result + [ceTxFull]; + if (CE_BREAK and Errors) <> 0 then + Result := Result + [ceBreak]; + if (CE_IOE and Errors) <> 0 then + Result := Result + [ceIO]; + if (CE_MODE and Errors) <> 0 then + Result := Result + [ceMode]; +end; + +// prepare PAsync variable for read/write operation +procedure PrepareAsync(AKind: TOperationKind; const Buffer; Count: Integer; AsyncPtr: PAsync); +begin + with AsyncPtr^ do + begin + Kind := AKind; + if Data <> nil then + FreeMem(Data); + GetMem(Data, Count); + Move(Buffer, Data^, Count); + Size := Count; + end; +end; + +// perform asynchronous write operation +function TCustomComPort.WriteAsync(const Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; +var + Success: Boolean; + BytesTrans: DWORD; +begin + if AsyncPtr = nil then + //raise EComPort.CreateNoWinCode + CallException(CError_InvalidAsync); + if FHandle = INVALID_HANDLE_VALUE then + //raise EComPort.Create + CallException(CError_PortNotOpen, -24); + PrepareAsync(okWrite, Buffer, Count, AsyncPtr); + + Success := WriteFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped) + or (GetLastError = ERROR_IO_PENDING); + + if not Success then + //raise EComPort.Create + CallException(CError_WriteFailed, GetLastError); + + SendSignalToLink(leTx, True); + Result := BytesTrans; +end; + +// perform synchronous write operation +function TCustomComPort.Write(const Buffer; Count: Integer): Integer; +var + AsyncPtr: PAsync; +begin + InitAsync(AsyncPtr); + try + WriteAsync(Buffer, Count, AsyncPtr); + Result := WaitForAsync(AsyncPtr); + finally + DoneAsync(AsyncPtr); + end; +end; + +// perform asynchronous write operation +function TCustomComPort.WriteStrAsync(var Str: string; var AsyncPtr: PAsync): Integer; +var sa : Ansistring; var i:integer; +begin + if Length(Str) > 0 then + begin + setlength(sa,length(str)); + {$IFDEF Unicode} + if length(sa)>0 then + begin + for i := 1 to length(str) do sa[i] := ansichar(byte(str[i])); + move(sa[1],str[1],length(sa)); + end; + {$ENDIF} + Result := WriteAsync(Str[1], Length(Str), AsyncPtr) + end + else + Result := 0; +end; +// perform synchronous write operation +function TCustomComPort.WriteStr(Str: string): Integer; +var + AsyncPtr: PAsync; +begin + InitAsync(AsyncPtr); + try + WriteStrAsync(Str, AsyncPtr); + Result := WaitForAsync(AsyncPtr); + finally + DoneAsync(AsyncPtr); + end; +end; +//Pierre Yager - includes codepage converstion of strings being sent +function TCustomComPort.WriteUnicodeString(const Str: Unicodestring): Integer; +var + l: Integer; + rb: AnsiString; +begin + l := WideCharToMultiByte(FCodePage, 0, PWideChar(Str), Length(Str), nil, 0, nil, nil); + SetLength(rb, l); + WideCharToMultiByte(FCodePage, 0, PWideChar(Str), Length(Str), PAnsiChar(rb), l, nil, nil); + Result := WriteStr(string(rb)); +end; + +//Pierre Yager - includes codepage converstion of strings received +function TCustomComPort.ReadUnicodeString(var Str: UnicodeString; Count: Integer): Integer; +var + rb: AnsiString; + l: Integer; + AsyncPtr: PAsync; +begin + InitAsync(AsyncPtr); + try + setLength(rb,count); + Result := ReadAsync(rb[1], Count, AsyncPtr); // ReadStr(s, Count); + //{$IFDEF Unicode}rb := UTF8Encode(s);{$ELSE} rb := s; {$ENDIF} + l := MultiByteToWideChar(FCodePage, 0, PAnsiChar(rb), Length(rb), nil, 0); + SetLength(Str, l); + Result := MultiByteToWideChar(FCodePage, 0, PAnsiChar(rb), Length(rb), PWideChar(Str), l); + finally + DoneAsync(AsyncPtr); + end; +end; + +// perform asynchronous read operation +function TCustomComPort.ReadAsync(var Buffer; Count: Integer; var AsyncPtr: PAsync): Integer; +var + Success: Boolean; + BytesTrans: DWORD; +begin + if AsyncPtr = nil then + //raise EComPort.CreateNoWinCode + CallException(CError_InvalidAsync); + AsyncPtr^.Kind := okRead; + if FHandle = INVALID_HANDLE_VALUE then + //raise EComPort.Create + CallException(CError_PortNotOpen, -24); + + Success := ReadFile(FHandle, Buffer, Count, BytesTrans, @AsyncPtr^.Overlapped) + or (GetLastError = ERROR_IO_PENDING); + + if not Success then + //raise EComPort.Create + CallException(CError_ReadFailed, GetLastError); + + Result := BytesTrans; +end; + +// perform synchronous read operation +function TCustomComPort.Read(var Buffer; Count: Integer): Integer; +var + AsyncPtr: PAsync; +begin + InitAsync(AsyncPtr); + try + ReadAsync(Buffer, Count, AsyncPtr); + Result := WaitForAsync(AsyncPtr); + finally + DoneAsync(AsyncPtr); + end; +end; + +// perform asynchronous read operation +function TCustomComPort.ReadStrAsync(var Str: Ansistring; Count: Integer; var AsyncPtr: PAsync): Integer; +begin + setlength(str,count); + if Count > 0 then + Result := ReadAsync(str[1], Count, AsyncPtr) + else + Result := 0; +end; + +// perform synchronous read operation +function TCustomComPort.ReadStr(var Str: string; Count: Integer): Integer; +var + AsyncPtr: PAsync; + sa :ansistring; + i : integer; +begin + InitAsync(AsyncPtr); + try + ReadStrAsync(sa, Count, AsyncPtr); + Result := WaitForAsync(AsyncPtr); + SetLength(sa, Result); + SetLength(str, Result); + {$IFDEF Unicode} + if length(sa)>0 then + for i := 1 to length(sa) do str[i] := char(byte(sa[i])) + {$ELSE} + str := sa; + {$ENDIF} + finally + DoneAsync(AsyncPtr); + end; +end; + +function ErrorCode(AsyncPtr: PAsync): Integer; +begin + Result := 0; + case AsyncPtr^.Kind of + okWrite: Result := CError_WriteFailed; + okRead: Result := CError_ReadFailed; + end; +end; + +// wait for asynchronous operation to end +function TCustomComPort.WaitForAsync(var AsyncPtr: PAsync): Integer; +var + BytesTrans, Signaled: DWORD; + Success: Boolean; +begin + if AsyncPtr = nil then + //raise EComPort.CreateNoWinCode + CallException(CError_InvalidAsync); + + Signaled := WaitForSingleObject(AsyncPtr^.Overlapped.hEvent, INFINITE); + Success := (Signaled = WAIT_OBJECT_0) and + (GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False)); + + if not Success then + //raise EComPort.Create + CallException(ErrorCode(AsyncPtr), GetLastError); + + if (AsyncPtr^.Kind = okRead) and (InputCount = 0) then + SendSignalToLink(leRx, False) + else + if AsyncPtr^.Data <> nil then + TxNotifyLink(AsyncPtr^.Data^, AsyncPtr^.Size); + + Result := BytesTrans; +end; + +// abort all asynchronous operations +procedure TCustomComPort.AbortAllAsync; +begin + if not PurgeComm(FHandle, PURGE_TXABORT or PURGE_RXABORT) then + //raise EComPort.Create + CallException(CError_PurgeFailed, GetLastError); +end; + +// detect whether asynchronous operation is completed +function TCustomComPort.IsAsyncCompleted(AsyncPtr: PAsync): Boolean; +var + BytesTrans: DWORD; +begin + if AsyncPtr = nil then + //raise EComPort.CreateNoWinCode + CallException(CError_InvalidAsync); + + Result := GetOverlappedResult(FHandle, AsyncPtr^.Overlapped, BytesTrans, False); + if not Result then + if (GetLastError <> ERROR_IO_PENDING) and (GetLastError <> ERROR_IO_INCOMPLETE) then + //raise EComPort.Create + CallException(CError_AsyncCheck, GetLastError); +end; + +// waits for event to occur on serial port +procedure TCustomComPort.WaitForEvent(var Events: TComEvents; + StopEvent: THandle; Timeout: Integer); +var + Overlapped: TOverlapped; + Mask: DWORD; + Success: Boolean; + Signaled, EventHandleCount: Integer; + EventHandles: array[0..1] of THandle; +begin + // cannot call method if event thread is running + if FThreadCreated then + //raise EComPort.CreateNoWinCode + CallException(CError_ThreadCreated); + + FillChar(Overlapped, SizeOf(TOverlapped), 0); + Overlapped.hEvent := CreateEvent(nil, True, False, nil); + EventHandles[0] := Overlapped.hEvent; + if StopEvent <> 0 then + begin + EventHandles[1] := StopEvent; + EventHandleCount := 2; + end + else + EventHandleCount := 1; + + try + SetCommMask(FHandle, EventsToInt(Events)); + // let's wait for event or timeout + Success := WaitCommEvent(FHandle, Mask, @Overlapped); + + if (Success) or (GetLastError = ERROR_IO_PENDING) then + begin + Signaled := WaitForMultipleObjects(EventHandleCount, @EventHandles, + False, Timeout); + Success := (Signaled = WAIT_OBJECT_0) + or (Signaled = WAIT_OBJECT_0 + 1) or (Signaled = WAIT_TIMEOUT); + SetCommMask(FHandle, 0); + end; + + if not Success then + //raise EComPort.Create + CallException(CError_WaitFailed, GetLastError); + + Events := IntToEvents(Mask); + finally + CloseHandle(Overlapped.hEvent); + end; +end; + +// transmit char ahead of any pending data in ouput buffer +procedure TCustomComPort.TransmitChar(Ch: Char); +begin + if not TransmitCommChar(FHandle, AnsiChar(Ch)) then + //raise EComPort.Create + CallException(CError_TransmitFailed, GetLastError); +end; + +// show port setup dialog +{$IFNDEF No_Dialogs} +procedure TCustomComPort.ShowSetupDialog; +begin + EditComPort(Self); +end; +{$ENDIF} + +// some conversion routines +function BoolToStr(const Value: Boolean): string; +begin + if Value then + Result := 'Yes' + else + Result := 'No'; +end; + +function StrToBool(const Value: string): Boolean; +begin + if UpperCase(Value) = 'YES' then + Result := True + else + Result := False; +end; + +function DTRToStr(DTRFlowControl: TDTRFlowControl): string; +const + DTRStrings: array[TDTRFlowControl] of string = ('Disable', 'Enable', + 'Handshake'); +begin + Result := DTRStrings[DTRFlowControl]; +end; + +function RTSToStr(RTSFlowControl: TRTSFlowControl): string; +const + RTSStrings: array[TRTSFlowControl] of string = ('Disable', 'Enable', + 'Handshake', 'Toggle'); +begin + Result := RTSStrings[RTSFlowControl]; +end; + +function StrToRTS(Str: string): TRTSFlowControl; +var + I: TRTSFlowControl; +begin + I := Low(TRTSFlowControl); + while (I <= High(TRTSFlowControl)) do + begin + if UpperCase(Str) = UpperCase(RTSToStr(I)) then + Break; + I := Succ(I); + end; + if I > High(TRTSFlowControl) then + Result := rtsDisable + else + Result := I; +end; + +function StrToDTR(Str: string): TDTRFlowControl; +var + I: TDTRFlowControl; +begin + I := Low(TDTRFlowControl); + while (I <= High(TDTRFlowControl)) do + begin + if UpperCase(Str) = UpperCase(DTRToStr(I)) then + Break; + I := Succ(I); + end; + if I > High(TDTRFlowControl) then + Result := dtrDisable + else + Result := I; +end; + +function StrToChar(Str: string): Char; +var + A: Integer; +begin + if Length(Str) > 0 then + begin + if (Str[1] = '#') and (Length(Str) > 1) then + begin + try + A := StrToInt(Copy(Str, 2, Length(Str) - 1)); + except + A := 0; + end; + Result := Chr(Byte(A)); + end + else + Result := Str[1]; + end + else + Result := #0; +end; + +function CharToStr(Ch: Char): string; +begin + {$IFDEF Unicode} + if CharInSet(ch,[#33..#127]) then + {$ELSE} + if Ch in [#33..#127] then {$ENDIF} + Result := Ch + else + Result := '#' + IntToStr(Ord(Ch)); +end; + +// store settings to ini file +procedure TCustomComPort.StoreIniFile(IniFile: TIniFile); +begin + if spBasic in FStoredProps then + begin + IniFile.WriteString(Name, 'Port', Port); + IniFile.WriteString(Name, 'BaudRate', BaudRateToStr(BaudRate)); + if BaudRate = brCustom then + IniFile.WriteInteger(Name, 'CustomBaudRate', CustomBaudRate); + IniFile.WriteString(Name, 'StopBits', StopBitsToStr(StopBits)); + IniFile.WriteString(Name, 'DataBits', DataBitsToStr(DataBits)); + IniFile.WriteString(Name, 'Parity', ParityToStr(Parity.Bits)); + IniFile.WriteString(Name, 'FlowControl', FlowControlToStr(FlowControl.FlowControl)); + end; + if spOthers in FStoredProps then + begin + IniFile.WriteString(Name, 'EventChar', CharToStr(EventChar)); + IniFile.WriteString(Name, 'DiscardNull', BoolToStr(DiscardNull)); + end; + if spParity in FStoredProps then + begin + IniFile.WriteString(Name, 'Parity.Check', BoolToStr(Parity.Check)); + IniFile.WriteString(Name, 'Parity.Replace', BoolToStr(Parity.Replace)); + IniFile.WriteString(Name, 'Parity.ReplaceChar', CharToStr(Parity.ReplaceChar)); + end; + if spBuffer in FStoredProps then + begin + IniFile.WriteInteger(Name, 'Buffer.OutputSize', Buffer.OutputSize); + IniFile.WriteInteger(Name, 'Buffer.InputSize', Buffer.InputSize); + end; + if spTimeouts in FStoredProps then + begin + IniFile.WriteInteger(Name, 'Timeouts.ReadInterval', Timeouts.ReadInterval); + IniFile.WriteInteger(Name, 'Timeouts.ReadTotalConstant', Timeouts.ReadTotalConstant); + IniFile.WriteInteger(Name, 'Timeouts.ReadTotalMultiplier', Timeouts.ReadTotalMultiplier); + IniFile.WriteInteger(Name, 'Timeouts.WriteTotalConstant', Timeouts.WriteTotalConstant); + IniFile.WriteInteger(Name, 'Timeouts.WriteTotalMultiplier', Timeouts.WriteTotalMultiplier); + end; + if spFlowControl in FStoredProps then + begin + IniFile.WriteString(Name, 'FlowControl.ControlRTS', RTSToStr(FlowControl.ControlRTS)); + IniFile.WriteString(Name, 'FlowControl.ControlDTR', DTRToStr(FlowControl.ControlDTR)); + IniFile.WriteString(Name, 'FlowControl.DSRSensitivity', BoolToStr(FlowControl.DSRSensitivity)); + IniFile.WriteString(Name, 'FlowControl.OutCTSFlow', BoolToStr(FlowControl.OutCTSFlow)); + IniFile.WriteString(Name, 'FlowControl.OutDSRFlow', BoolToStr(FlowControl.OutDSRFlow)); + IniFile.WriteString(Name, 'FlowControl.TxContinueOnXoff', BoolToStr(FlowControl.TxContinueOnXoff)); + IniFile.WriteString(Name, 'FlowControl.XonXoffIn', BoolToStr(FlowControl.XonXoffIn)); + IniFile.WriteString(Name, 'FlowControl.XonXoffOut', BoolToStr(FlowControl.XonXoffOut)); + IniFile.WriteString(Name, 'FlowControl.XoffChar', CharToStr(FlowControl.XoffChar)); + IniFile.WriteString(Name, 'FlowControl.XonChar', CharToStr(FlowControl.XonChar)); + end; +end; + +// store settings to registry +procedure TCustomComPort.StoreRegistry(Reg: TRegistry); +begin + if spBasic in FStoredProps then + begin + Reg.WriteString('Port', Port); + Reg.WriteString('BaudRate', BaudRateToStr(BaudRate)); + if BaudRate = brCustom then + Reg.WriteInteger('CustomBaudRate', CustomBaudRate); + Reg.WriteString('StopBits', StopBitsToStr(StopBits)); + Reg.WriteString('DataBits', DataBitsToStr(DataBits)); + Reg.WriteString('Parity', ParityToStr(Parity.Bits)); + Reg.WriteString('FlowControl', FlowControlToStr(FlowControl.FlowControl)); + end; + if spOthers in FStoredProps then + begin + Reg.WriteString('EventChar', CharToStr(EventChar)); + Reg.WriteString('DiscardNull', BoolToStr(DiscardNull)); + end; + if spParity in FStoredProps then + begin + Reg.WriteString('Parity.Check', BoolToStr(Parity.Check)); + Reg.WriteString('Parity.Replace', BoolToStr(Parity.Replace)); + Reg.WriteString('Parity.ReplaceChar', CharToStr(Parity.ReplaceChar)); + end; + if spBuffer in FStoredProps then + begin + Reg.WriteInteger('Buffer.OutputSize', Buffer.OutputSize); + Reg.WriteInteger('Buffer.InputSize', Buffer.InputSize); + end; + if spTimeouts in FStoredProps then + begin + Reg.WriteInteger('Timeouts.ReadInterval', Timeouts.ReadInterval); + Reg.WriteInteger('Timeouts.ReadTotalConstant', Timeouts.ReadTotalConstant); + Reg.WriteInteger('Timeouts.ReadTotalMultiplier', Timeouts.ReadTotalMultiplier); + Reg.WriteInteger('Timeouts.WriteTotalConstant', Timeouts.WriteTotalConstant); + Reg.WriteInteger('Timeouts.WriteTotalMultiplier', Timeouts.WriteTotalMultiplier); + end; + if spFlowControl in FStoredProps then + begin + Reg.WriteString('FlowControl.ControlRTS', RTSToStr(FlowControl.ControlRTS)); + Reg.WriteString('FlowControl.ControlDTR', DTRToStr(FlowControl.ControlDTR)); + Reg.WriteString('FlowControl.DSRSensitivity', BoolToStr(FlowControl.DSRSensitivity)); + Reg.WriteString('FlowControl.OutCTSFlow', BoolToStr(FlowControl.OutCTSFlow)); + Reg.WriteString('FlowControl.OutDSRFlow', BoolToStr(FlowControl.OutDSRFlow)); + Reg.WriteString('FlowControl.TxContinueOnXoff', BoolToStr(FlowControl.TxContinueOnXoff)); + Reg.WriteString('FlowControl.XonXoffIn', BoolToStr(FlowControl.XonXoffIn)); + Reg.WriteString('FlowControl.XonXoffOut', BoolToStr(FlowControl.XonXoffOut)); + Reg.WriteString('FlowControl.XoffChar', CharToStr(FlowControl.XoffChar)); + Reg.WriteString('FlowControl.XonChar', CharToStr(FlowControl.XonChar)); + end; +end; + +// load settings from ini file +procedure TCustomComPort.LoadIniFile(IniFile: TIniFile); +begin + if spBasic in FStoredProps then + begin + Port := IniFile.ReadString(Name, 'Port', Port); + BaudRate := StrToBaudRate(IniFile.ReadString(Name, 'BaudRate', BaudRateToStr(BaudRate))); + if BaudRate = brCustom then + CustomBaudRate := IniFile.ReadInteger(Name, 'CustomBaudRate', 9600); + StopBits := StrToStopBits(IniFile.ReadString(Name, 'StopBits', StopBitsToStr(StopBits))); + DataBits := StrToDataBits(IniFile.ReadString(Name, 'DataBits', DataBitsToStr(DataBits))); + Parity.Bits := StrToParity(IniFile.ReadString(Name, 'Parity', ParityToStr(Parity.Bits))); + FlowControl.FlowControl := StrToFlowControl( + IniFile.ReadString(Name, 'FlowControl', FlowControlToStr(FlowControl.FlowControl))); + end; + if spOthers in FStoredProps then + begin + EventChar := StrToChar(IniFile.ReadString(Name, 'EventChar', CharToStr(EventChar))); + DiscardNull := StrToBool(IniFile.ReadString(Name, 'DiscardNull', BoolToStr(DiscardNull))); + end; + if spParity in FStoredProps then + begin + Parity.Check := StrToBool(IniFile.ReadString(Name, 'Parity.Check', BoolToStr(Parity.Check))); + Parity.Replace := StrToBool(IniFile.ReadString(Name, 'Parity.Replace', BoolToStr(Parity.Replace))); + Parity.ReplaceChar := StrToChar(IniFile.ReadString(Name, 'Parity.ReplaceChar', CharToStr(Parity.ReplaceChar))); + end; + if spBuffer in FStoredProps then + begin + Buffer.OutputSize := IniFile.ReadInteger(Name, 'Buffer.OutputSize', Buffer.OutputSize); + Buffer.InputSize := IniFile.ReadInteger(Name, 'Buffer.InputSize', Buffer.InputSize); + end; + if spTimeouts in FStoredProps then + begin + Timeouts.ReadInterval := IniFile.ReadInteger(Name, 'Timeouts.ReadInterval', Timeouts.ReadInterval); + Timeouts.ReadTotalConstant := IniFile.ReadInteger(Name, 'Timeouts.ReadTotalConstant', Timeouts.ReadTotalConstant); + Timeouts.ReadTotalMultiplier := IniFile.ReadInteger(Name, 'Timeouts.ReadTotalMultiplier', Timeouts.ReadTotalMultiplier); + Timeouts.WriteTotalConstant := IniFile.ReadInteger(Name, 'Timeouts.WriteTotalConstant', Timeouts.WriteTotalConstant); + Timeouts.WriteTotalMultiplier := IniFile.ReadInteger(Name, 'Timeouts.WriteTotalMultiplier', Timeouts.WriteTotalMultiplier); + end; + if spFlowControl in FStoredProps then + begin + FlowControl.ControlRTS := StrToRTS(IniFile.ReadString(Name, 'FlowControl.ControlRTS', RTSToStr(FlowControl.ControlRTS))); + FlowControl.ControlDTR := StrToDTR(IniFile.ReadString(Name, 'FlowControl.ControlDTR', DTRToStr(FlowControl.ControlDTR))); + FlowControl.DSRSensitivity := StrToBool(IniFile.ReadString(Name, 'FlowControl.DSRSensitivity', BoolToStr(FlowControl.DSRSensitivity))); + FlowControl.OutCTSFlow := StrToBool(IniFile.ReadString(Name, 'FlowControl.OutCTSFlow', BoolToStr(FlowControl.OutCTSFlow))); + FlowControl.OutDSRFlow := StrToBool(IniFile.ReadString(Name, 'FlowControl.OutDSRFlow', BoolToStr(FlowControl.OutCTSFlow))); + FlowControl.TxContinueOnXoff := StrToBool(IniFile.ReadString(Name, 'FlowControl.TxContinueOnXoff', BoolToStr(FlowControl.TxContinueOnXoff))); + FlowControl.XonXoffIn := StrToBool(IniFile.ReadString(Name, 'FlowControl.XonXoffIn', BoolToStr(FlowControl.XonXoffIn))); + FlowControl.XonXoffOut := StrToBool(IniFile.ReadString(Name, 'FlowControl.XonXoffOut', BoolToStr(FlowControl.XonXoffOut))); + FlowControl.XoffChar := StrToChar(IniFile.ReadString(Name, 'FlowControl.XoffChar', CharToStr(FlowControl.XoffChar))); + FlowControl.XonChar := StrToChar(IniFile.ReadString(Name, 'FlowControl.XonChar', CharToStr(FlowControl.XonChar))); + end; +end; + +// load settings from registry +procedure TCustomComPort.LoadRegistry(Reg: TRegistry); +begin + if spBasic in FStoredProps then + begin + Port := Reg.ReadString('Port'); + BaudRate := StrToBaudRate(Reg.ReadString('BaudRate')); + if BaudRate = brCustom then + CustomBaudRate := Reg.ReadInteger('CustomBaudRate'); + StopBits := StrToStopBits(Reg.ReadString('StopBits')); + DataBits := StrToDataBits(Reg.ReadString('DataBits')); + Parity.Bits := StrToParity(Reg.ReadString('Parity')); + FlowControl.FlowControl := StrToFlowControl(Reg.ReadString('FlowControl')); + end; + if spOthers in FStoredProps then + begin + EventChar := StrToChar(Reg.ReadString('EventChar')); + DiscardNull := StrToBool(Reg.ReadString('DiscardNull')); + end; + if spParity in FStoredProps then + begin + Parity.Check := StrToBool(Reg.ReadString('Parity.Check')); + Parity.Replace := StrToBool(Reg.ReadString('Parity.Replace')); + Parity.ReplaceChar := StrToChar(Reg.ReadString('Parity.ReplaceChar')); + end; + if spBuffer in FStoredProps then + begin + Buffer.OutputSize := Reg.ReadInteger('Buffer.OutputSize'); + Buffer.InputSize := Reg.ReadInteger('Buffer.InputSize'); + end; + if spTimeouts in FStoredProps then + begin + Timeouts.ReadInterval := Reg.ReadInteger('Timeouts.ReadInterval'); + Timeouts.ReadTotalConstant := Reg.ReadInteger('Timeouts.ReadTotalConstant'); + Timeouts.ReadTotalMultiplier := Reg.ReadInteger('Timeouts.ReadTotalMultiplier'); + Timeouts.WriteTotalConstant := Reg.ReadInteger('Timeouts.WriteTotalConstant'); + Timeouts.WriteTotalMultiplier := Reg.ReadInteger('Timeouts.WriteTotalMultiplier'); + end; + if spFlowControl in FStoredProps then + begin + FlowControl.ControlRTS := StrToRTS(Reg.ReadString('FlowControl.ControlRTS')); + FlowControl.ControlDTR := StrToDTR(Reg.ReadString('FlowControl.ControlDTR')); + FlowControl.DSRSensitivity := StrToBool(Reg.ReadString('FlowControl.DSRSensitivity')); + FlowControl.OutCTSFlow := StrToBool(Reg.ReadString('FlowControl.OutCTSFlow')); + FlowControl.OutDSRFlow := StrToBool(Reg.ReadString('FlowControl.OutDSRFlow')); + FlowControl.TxContinueOnXoff := StrToBool(Reg.ReadString('FlowControl.TxContinueOnXoff')); + FlowControl.XonXoffIn := StrToBool(Reg.ReadString('FlowControl.XonXoffIn')); + FlowControl.XonXoffOut := StrToBool(Reg.ReadString('FlowControl.XonXoffOut')); + FlowControl.XoffChar := StrToChar(Reg.ReadString('FlowControl.XoffChar')); + FlowControl.XonChar := StrToChar(Reg.ReadString('FlowControl.XonChar')); + end; +end; + +// initialize registry +procedure SetRegistry(Reg: TRegistry; Key: string; Name: string); +var + I: Integer; + Temp: string; +begin + I := Pos('\', Key); + if I > 0 then + begin + Temp := Copy(Key, 1, I - 1); + if UpperCase(Temp) = 'HKEY_LOCAL_MACHINE' then + Reg.RootKey := HKEY_LOCAL_MACHINE + else + if UpperCase(Temp) = 'HKEY_CURRENT_USER' then + Reg.RootKey := HKEY_CURRENT_USER; + Key := Copy(Key, I + 1, Length(Key) - I); + if Key[Length(Key)] <> '\' then + Key := Key + '\'; + Key := Key + Name; + Reg.OpenKey(Key, True); + end; +end; + +// store settings +procedure TCustomComPort.StoreSettings(StoreType: TStoreType; StoreTo: string); +var + IniFile: TIniFile; + Reg: TRegistry; +begin + try + if StoreType = stRegistry then + begin + Reg := TRegistry.Create; + try + SetRegistry(Reg, StoreTo, Name); + StoreRegistry(Reg); + finally + Reg.Free; + end + end else + begin + IniFile := TIniFile.Create(StoreTo); + try + StoreIniFile(IniFile); + finally + IniFile.Free; + end + end; + except + //raise EComPort.CreateNoWinCode + CallException(CError_StoreFailed); + end; +end; + +// load settings +procedure TCustomComPort.LoadSettings(StoreType: TStoreType; LoadFrom: string); +var + IniFile: TIniFile; + Reg: TRegistry; +begin + BeginUpdate; + try + try + if StoreType = stRegistry then + begin + Reg := TRegistry.Create; + try + SetRegistry(Reg, LoadFrom, Name); + LoadRegistry(Reg); + finally + Reg.Free; + end + end else + begin + IniFile := TIniFile.Create(LoadFrom); + try + LoadIniFile(IniFile); + finally + IniFile.Free; + end + end; + finally + EndUpdate; + end; + except + //raise EComPort.CreateNoWinCode + CallException(CError_LoadFailed); + end; +end; + +// register link from other component to TCustomComPort +procedure TCustomComPort.RegisterLink(AComLink: TComLink); +begin + if FLinks.IndexOf(Pointer(AComLink)) > -1 then + //raise EComPort.CreateNoWinCode + CallException(CError_RegFailed) + else + FLinks.Add(Pointer(AComLink)); + FHasLink := HasLink; +end; + +// unregister link from other component to TCustomComPort +procedure TCustomComPort.UnRegisterLink(AComLink: TComLink); +begin + if FLinks.IndexOf(Pointer(AComLink)) = -1 then + //raise EComPort.CreateNoWinCode + CallException(CError_RegFailed) + else + FLinks.Remove(Pointer(AComLink)); + FHasLink := HasLink; +end; + +// default actions on port events + +procedure TCustomComPort.DoBeforeClose; +begin + if Assigned(FOnBeforeClose) then + FOnBeforeClose(Self); +end; + +procedure TCustomComPort.DoBeforeOpen; +begin + if Assigned(FOnBeforeOpen) then + FOnBeforeOpen(Self); +end; + +procedure TCustomComPort.DoAfterOpen; +begin + if Assigned(FOnAfterOpen) then + FOnAfterOpen(Self); +end; + +procedure TCustomComPort.DoAfterClose; +begin + if Assigned(FOnAfterClose) then + FOnAfterClose(Self); +end; + +procedure TCustomComPort.DoRxChar(Count: Integer); +begin + if Assigned(FOnRxChar) then + FOnRxChar(Self, Count); +end; + +procedure TCustomComPort.DoRxBuf(const Buffer; Count: Integer); +begin + if Assigned(FOnRxBuf) then + FOnRxBuf(Self, Buffer, Count); +end; + +procedure TCustomComPort.DoBreak; +begin + if Assigned(FOnBreak) then + FOnBreak(Self); +end; + +procedure TCustomComPort.DoTxEmpty; +begin + if Assigned(FOnTxEmpty) + then FOnTxEmpty(Self); +end; + +procedure TCustomComPort.DoRing; +begin + if Assigned(FOnRing) then + FOnRing(Self); +end; + +procedure TCustomComPort.DoCTSChange(OnOff: Boolean); +begin + if Assigned(FOnCTSChange) then + FOnCTSChange(Self, OnOff); +end; + +procedure TCustomComPort.DoDSRChange(OnOff: Boolean); +begin + if Assigned(FOnDSRChange) then + FOnDSRChange(Self, OnOff); +end; + +procedure TCustomComPort.DoRLSDChange(OnOff: Boolean); +begin + if Assigned(FOnRLSDChange) then + FOnRLSDChange(Self, OnOff); +end; + +procedure TCustomComPort.DoError(Errors: TComErrors); +begin + if Assigned(FOnError) then + FOnError(Self, Errors); +end; + +procedure TCustomComPort.DoRxFlag; +begin + if Assigned(FOnRxFlag) then + FOnRxFlag(Self); +end; + +procedure TCustomComPort.DoRx80Full; +begin + if Assigned(FOnRx80Full) then + FOnRx80Full(Self); +end; + +// set signals to false on close, and to proper value on open, +// because OnXChange events are not called automatically +procedure TCustomComPort.CheckSignals(Open: Boolean); +begin + if Open then + begin + CallCTSChange; + CallDSRChange; + CallRLSDChange; + end else + begin + SendSignalToLink(leCTS, False); + SendSignalToLink(leDSR, False); + SendSignalToLink(leRLSD, False); + DoCTSChange(False); + DoDSRChange(False); + DoRLSDChange(False); + end; +end; + +// called in response to EV_X events, except CallXClose, CallXOpen + +procedure TCustomComPort.CallAfterClose; +begin + SendSignalToLink(leConn, False); + DoAfterClose; +end; + +procedure TCustomComPort.CallAfterOpen; +begin + SendSignalToLink(leConn, True); + DoAfterOpen; + CheckSignals(True); +end; + +procedure TCustomComPort.CallBeforeClose; +begin + // shutdown com signals manually + CheckSignals(False); + DoBeforeClose; +end; + +procedure TCustomComPort.CallBeforeOpen; +begin + DoBeforeOpen; +end; + +procedure TCustomComPort.CallBreak; +begin + DoBreak; +end; + +procedure TCustomComPort.CallCTSChange; +var + OnOff: Boolean; +begin + OnOff := csCTS in Signals; + // check for linked components + SendSignalToLink(leCTS, OnOff); + DoCTSChange(OnOff); +end; + +procedure TCustomComPort.CallDSRChange; +var + OnOff: Boolean; +begin + OnOff := csDSR in Signals; + // check for linked components + SendSignalToLink(leDSR, OnOff); + DoDSRChange(OnOff); +end; + +procedure TCustomComPort.CallRLSDChange; +var + OnOff: Boolean; +begin + OnOff := csRLSD in Signals; + // check for linked components + SendSignalToLink(leRLSD, OnOff); + DoRLSDChange(OnOff); +end; + +procedure TCustomComPort.CallError; +var + Errors: TComErrors; +begin + Errors := LastErrors; + if Errors <> [] then + DoError(Errors); +end; + +procedure TCustomComPort.CallRing; +begin + NotifyLink(leRing); + DoRing; +end; + +procedure TCustomComPort.CallRx80Full; +begin + DoRx80Full; +end; + +procedure TCustomComPort.CallRxChar; +var + Count: Integer; + + // read from input buffer + procedure PerformRead(var P: Pointer); + begin + GetMem(P, Count); + Read(P^, Count); + // call OnRxBuf event + DoRxBuf(P^, Count); + end; + + // check if any component is linked, to OnRxChar event + procedure CheckLinks; + {$WARNINGS OFF} + var + I: Integer; + P: Pointer; + ComLink: TComLink; + ReadFromBuffer: Boolean; + begin + // examine links + if (Count > 0) and (not TriggersOnRxChar) then + begin + ReadFromBuffer := False; + try + // cycle through links + for I := 0 to FLinks.Count - 1 do + begin + ComLink := TComLink(FLinks[I]); + if Assigned(ComLink.OnRxBuf) then + begin + // link to OnRxChar event found + if not ReadFromBuffer then + begin + // TCustomComPort must read from comport, so OnRxChar event is + // not triggered + ReadFromBuffer := True; + PerformRead(P); + end; + // send data to linked component + ComLink.OnRxBuf(Self, P^, Count); + end + end; + if (not ReadFromBuffer) and (not FTriggersOnRxChar) then + begin + ReadFromBuffer := True; + PerformRead(P); + end; + finally + if ReadFromBuffer then + begin + FreeMem(P); + // data is already out of buffer, prevent from OnRxChar event to occur + Count := 0; + end; + end; + end; + end; + +begin + Count := InputCount; + if Count > 0 then + SendSignalToLink(leRx, True); + CheckLinks; + if Count > 0 then + DoRxChar(Count); +end; + +procedure TCustomComPort.CallRxFlag; +begin + NotifyLink(leRxFlag); + DoRxFlag; +end; + +procedure TCustomComPort.CallTxEmpty; +begin + SendSignalToLink(leTx, False); + NotifyLink(leTxEmpty); + DoTxEmpty; +end; + +// returns true if it has least one component linked to OnRxBuf event +function TCustomComPort.HasLink: Boolean; +var + I: Integer; + ComLink: TComLink; +begin + Result := False; + // examine links + if FLinks.Count > 0 then + for I := 0 to FLinks.Count - 1 do + begin + ComLink := TComLink(FLinks[I]); + if Assigned(ComLink.OnRxBuf) then + Result := True; + end; +end; + +// send TxBuf notify to link +procedure TCustomComPort.TxNotifyLink(const Buffer; Count: Integer); +var + I: Integer; + ComLink: TComLink; +begin + if (FLinks.Count > 0) then + for I := 0 to FLinks.Count - 1 do + begin + ComLink := TComLink(FLinks[I]); + if Assigned(ComLink.OnTxBuf) then + ComLink.OnTxBuf(Self, Buffer, Count); + end; +end; + +// send event notification to link +procedure TCustomComPort.NotifyLink(FLinkEvent: TComLinkEvent); +var + I: Integer; + ComLink: TComLink; + Event: TNotifyEvent; +begin + if (FLinks.Count > 0) then + for I := 0 to FLinks.Count - 1 do + begin + ComLink := TComLink(FLinks[I]); + Event := nil; + case FLinkEvent of + leRing: Event := ComLink.OnRing; + leTxEmpty: Event := ComLink.OnTxEmpty; + leRxFlag: Event := ComLink.OnRxFlag; + end; + if Assigned(Event) then + Event(Self); + end; +end; + +// send signal to linked components +procedure TCustomComPort.SendSignalToLink(Signal: TComLinkEvent; OnOff: Boolean); +var + I: Integer; + ComLink: TComLink; + SignalEvent: TComSignalEvent; +begin + if (FLinks.Count > 0) then + // cycle through links + for I := 0 to FLinks.Count - 1 do + begin + ComLink := TComLink(FLinks[I]); + SignalEvent := nil; + case Signal of + leCTS: SignalEvent := ComLink.OnCTSChange; + leDSR: SignalEvent := ComLink.OnDSRChange; + leRLSD: SignalEvent := ComLink.OnRLSDChange; + leTx: SignalEvent := ComLink.OnTx; + leRx: SignalEvent := ComLink.OnRx; + leConn: SignalEvent := ComLink.OnConn; + end; + // if linked, trigger event + if Assigned(SignalEvent) then + SignalEvent(Self, OnOff); + end; +end; + +// set connected property, same as Open/Close methods +procedure TCustomComPort.SetConnected(const Value: Boolean); +begin + if not ((csDesigning in ComponentState) or (csLoading in ComponentState)) then + begin + if Value <> FConnected then + if Value then + Open + else + Close; + end + else + FConnected := Value; +end; + +// set baud rate +procedure TCustomComPort.SetBaudRate(const Value: TBaudRate); +begin + if Value <> FBaudRate then + begin + FBaudRate := Value; + // if possible, apply settings + ApplyDCB; + end; +end; + +// set custom baud rate +procedure TCustomComPort.SetCustomBaudRate(const Value: Integer); +begin + if Value <> FCustomBaudRate then + begin + FCustomBaudRate := Value; + ApplyDCB; + end; +end; + +// set data bits +procedure TCustomComPort.SetDataBits(const Value: TDataBits); +begin + if Value <> FDataBits then + begin + FDataBits := Value; + ApplyDCB; + end; +end; + +// set discard null characters +procedure TCustomComPort.SetDiscardNull(const Value: Boolean); +begin + if Value <> FDiscardNull then + begin + FDiscardNull := Value; + ApplyDCB; + end; +end; + +// set event characters +procedure TCustomComPort.SetEventChar(const Value: Char); +begin + if Value <> FEventChar then + begin + FEventChar := Value; + ApplyDCB; + end; +end; + +// set port +procedure TCustomComPort.SetPort(const Value: TPort); +begin + // 11.1.2001 Ch. Kaufmann; removed function ComString, because there can be com ports + // with names other than COMn. + if Value <> FPort then + begin + FPort := Value; + if FConnected and not ((csDesigning in ComponentState) or + (csLoading in ComponentState)) then + begin + Close; + Open; + end; + end; +end; + +// set stop bits +procedure TCustomComPort.SetStopBits(const Value: TStopBits); +begin + if Value <> FStopBits then + begin + FStopBits := Value; + ApplyDCB; + end; +end; + +// set event synchronization method +procedure TCustomComPort.SetSyncMethod(const Value: TSyncMethod); +begin + if Value <> FSyncMethod then + begin + if FConnected and not ((csDesigning in ComponentState) or + (csLoading in ComponentState)) + then + //raise EComPort.CreateNoWinCode + CallException(CError_ConnChangeProp) + else + FSyncMethod := Value; + end; +end; + +// sets RxChar triggering +procedure TCustomComPort.SetTriggersOnRxChar(const Value: Boolean); +begin + if FHasLink then + //raise EComPort.CreateNoWinCode + CallException(CError_HasLink); + FTriggersOnRxChar := Value; +end; + +// sets event thread priority +procedure TCustomComPort.SetEventThreadPriority(const Value: TThreadPriority); +begin + if Value <> FEventThreadPriority then + begin + if FConnected and not ((csDesigning in ComponentState) or + (csLoading in ComponentState)) + then + //raise EComPort.CreateNoWinCode + CallException(CError_ConnChangeProp) + else + FEventThreadPriority := Value; + end; +end; + +// returns true if RxChar is triggered when data arrives input buffer +function TCustomComPort.GetTriggersOnRxChar: Boolean; +begin + Result := FTriggersOnRxChar and (not FHasLink); +end; + +// set flow control +procedure TCustomComPort.SetFlowControl(const Value: TComFlowControl); +begin + FFlowControl.Assign(Value); + ApplyDCB; +end; + +// set parity +procedure TCustomComPort.SetParity(const Value: TComParity); +begin + FParity.Assign(Value); + ApplyDCB; +end; + +// set timeouts +procedure TCustomComPort.SetTimeouts(const Value: TComTimeouts); +begin + FTimeouts.Assign(Value); + ApplyTimeouts; +end; + +// set buffer +procedure TCustomComPort.SetBuffer(const Value: TComBuffer); +begin + FBuffer.Assign(Value); + ApplyBuffer; +end; + +(***************************************** + * TComDataPacket component * + *****************************************) + +// create component +constructor TComDataPacket.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FComLink := TComLink.Create; + FComLink.OnRxBuf := RxBuf; + FMaxBufferSize := 1024; +end; + +// destroy component +destructor TComDataPacket.Destroy; +begin + ComPort := nil; + FComLink.Free; + inherited Destroy; +end; + +// add custom data to packet buffer +procedure TComDataPacket.AddData(const Str: string); +begin + if ValidStop then + begin + Buffer := Buffer + Str; + HandleBuffer; + end + else + DoPacket(Str); +end; + +// remove ComPort property if being destroyed +procedure TComDataPacket.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited Notification(AComponent, Operation); + if (AComponent = FComPort) and (Operation = opRemove) then + ComPort := nil; +end; + +// call OnDiscard +procedure TComDataPacket.DoDiscard(const Str: string); +begin + if Assigned(FOnDiscard) then + FOnDiscard(Self, Str); +end; + +// call OnPacket +procedure TComDataPacket.DoPacket(const Str: string); +begin + if Assigned(FOnPacket) then + FOnPacket(Self, Str); +end; + +// call OnCustomStart +procedure TComDataPacket.DoCustomStart(const Str: string; + var Pos: Integer); +begin + if Assigned(FOnCustomStart) then + FOnCustomStart(Self, Str, Pos); +end; + +// call OnCustomStop +procedure TComDataPacket.DoCustomStop(const Str: string; var Pos: Integer); +begin + if Assigned(FOnCustomStop) then + FOnCustomStop(Self, Str, Pos); +end; + +// discard start and stop strings +procedure TComDataPacket.CheckIncludeStrings(var Str: string); +var + LenStart, LenStop: Integer; +begin + if FIncludeStrings then + Exit; + LenStart := Length(FStartString); + LenStop := Length(FStopString); + // remove start string + if Pos(Upper(FStartString), Upper(Str)) = 1 then + Str := Copy(Str, LenStart + 1, Length(Str) - LenStart); + // remove stop string + if Pos(Upper(FStopString), Upper(Str)) = (Length(Str) - LenStop + 1) then + Str := Copy(Str, 1, Length(Str) - LenStop); +end; + +// upper case +function TComDataPacket.Upper(const Str: string): string; +begin + if FCaseInsensitive then + Result := UpperCase(Str) + else + Result := Str; +end; + +// split buffer in packets +procedure TComDataPacket.HandleBuffer; + + procedure DiscardPacketToPos(Pos: Integer); + var + Str: string; + begin + FInPacket := True; + if Pos > 1 then + begin + Str := Copy(Buffer, 1, Pos - 1); // some discarded data + Buffer := Copy(Buffer, Pos, Length(Buffer) - Pos + 1); + DoDiscard(Str); + end; + end; + + procedure FormPacket(CutSize: Integer); + var + Str: string; + begin + Str := Copy(Buffer, 1, CutSize); + Buffer := Copy(Buffer, CutSize + 1, Length(Buffer) - CutSize); + CheckIncludeStrings(Str); + DoPacket(Str); + end; + + procedure StartPacket; + var + Found: Integer; + begin + // check for custom start condition + Found := -1; + DoCustomStart(Buffer, Found); + if Found > 0 then + DiscardPacketToPos(Found); + if Found = -1 then + begin + if Length(FStartString) > 0 then // start string valid + begin + Found := Pos(Upper(FStartString), Upper(Buffer)); + if Found > 0 then + DiscardPacketToPos(Found); + end + else + FInPacket := True; + end; + end; + + procedure EndPacket; + var + Found, CutSize, Len: Integer; + begin + // check for custom stop condition + Found := -1; + DoCustomStop(Buffer, Found); + if Found > 0 then + begin + // custom stop condition detected + CutSize := Found; + FInPacket := False; + end + else + if Found = -1 then + begin + Len := Length(Buffer); + if (FSize > 0) and (Len >= FSize) then + begin + // size stop condition detected + FInPacket := False; + CutSize := FSize; + end + else + begin + Len := Length(FStartString); + Found := Pos(Upper(FStopString), + Upper(Copy(Buffer, Len + 1, Length(Buffer) - Len))); + if Found > 0 then + begin + // stop string stop condition detected + CutSize := Found + Length(FStopString) + Len - 1; + FInPacket := False; + end; + end; + end; + if not FInPacket then + FormPacket(CutSize); // create packet + end; + + function IsBufferTooLarge: Boolean; + begin + Result := (Length(Buffer) >= FMaxBufferSize) and (FMaxBufferSize > 0); + end; + +begin + try + if not FInPacket then + StartPacket; + if FInPacket then + begin + EndPacket; + if not FInPacket then + HandleBuffer; + end; + finally + if IsBufferTooLarge then + EmptyBuffer; + end; +end; + +// is stop condition valid? +function TComDataPacket.ValidStop: Boolean; +begin + Result := (FSize > 0) or (Length(FStopString) > 0) + or (Assigned(FOnCustomStop)); +end; + +// receive data +procedure TComDataPacket.ResetBuffer; +begin + EmptyBuffer; +end; + +procedure TComDataPacket.RxBuf(Sender: TObject; const Buffer; Count: Integer); +var sa:AnsiString; Str: string; + i:integer; +begin + SetLength(Str, Count); + SetLength(Sa, Count); + Move(Buffer, Sa[1], Count); + {$IFDEF Unicode} + if length(sa)>0 then + for i := 1 to length(sa) do str[i] := char(byte(sa[i])); + {$ELSE} str := sa; {$ENDIF} + AddData(Str); +end; + +// empty buffer +procedure TComDataPacket.EmptyBuffer; +begin + if Buffer <> '' then + begin + try + DoDiscard(Buffer); + finally + Buffer := ''; + FInPacket := False; + end; + end; +end; + +// set com port +procedure TComDataPacket.SetComPort(const Value: TCustomComPort); +begin + if Value <> FComPort then + begin + if FComPort <> nil then + FComPort.UnRegisterLink(FComLink); + FComPort := Value; + if FComPort <> nil then + begin + FComPort.FreeNotification(Self); + FComPort.RegisterLink(FComLink); + end; + end; +end; + +// set case sensitivity +procedure TComDataPacket.SetCaseInsensitive(const Value: Boolean); +begin + if FCaseInsensitive <> Value then + begin + FCaseInsensitive := Value; + if not (csLoading in ComponentState) then + EmptyBuffer; + end; +end; + +// set packet size +procedure TComDataPacket.SetSize(const Value: Integer); +begin + if FSize <> Value then + begin + FSize := Value; + if not (csLoading in ComponentState) then + EmptyBuffer; + end; +end; + +// set start string +procedure TComDataPacket.SetStartString(const Value: string); +begin + if FStartString <> Value then + begin + FStartString := Value; + if not (csLoading in ComponentState) then + EmptyBuffer; + end; +end; + +// set stop string +procedure TComDataPacket.SetStopString(const Value: string); +begin + if FStopString <> Value then + begin + FStopString := Value; + if not (csLoading in ComponentState) then + EmptyBuffer; + end; +end; + +(***************************************** + * EComPort exception * + *****************************************) + +// create stream +constructor TComStream.Create(AComPort: TCustomComPort); +begin + inherited Create; + FComPort := AComPort; +end; + +// read from stream +function TComStream.Read(var Buffer; Count: Integer): Longint; +begin + FComPort.Read(Buffer, Count); +end; + +// write to stream +function TComStream.Write(const Buffer; Count: Integer): Longint; +begin + FComPort.Write(Buffer, Count); +end; + +// seek always to 0 +function TComStream.Seek(Offset: Integer; Origin: Word): Longint; +begin + Result := 0; +end; + +(***************************************** + * EComPort exception * + *****************************************) + +// create exception with windows error code +constructor EComPort.Create(ACode: Integer; AWinCode: Integer); +begin + FWinCode := AWinCode; + FCode := ACode; + inherited CreateFmt(ComErrorMessages[ACode] + ' (Error: %d)', [AWinCode]); +end; + +// create exception +constructor EComPort.CreateNoWinCode(ACode: Integer); +begin + FWinCode := -1; + FCode := ACode; + inherited Create(ComErrorMessages[ACode]); +end; + +(***************************************** + * other procedures/functions * + *****************************************) + +// initialization of PAsync variables used in asynchronous calls +procedure InitAsync(var AsyncPtr: PAsync); +begin + New(AsyncPtr); + with AsyncPtr^ do + begin + FillChar(Overlapped, SizeOf(TOverlapped), 0); + Overlapped.hEvent := CreateEvent(nil, True, True, nil); + Data := nil; + Size := 0; + end; +end; + +// clean-up of PAsync variable +procedure DoneAsync(var AsyncPtr: PAsync); +begin + with AsyncPtr^ do + begin + CloseHandle(Overlapped.hEvent); + if Data <> nil then + FreeMem(Data); + end; + Dispose(AsyncPtr); + AsyncPtr := nil; +end; + +procedure EnumComPorts(Ports: TStrings); +var + KeyHandle: HKEY; + ErrCode, Index: Integer; + ValueName, Data: string; + ValueLen, DataLen, ValueType: DWORD; + TmpPorts: TStringList; +begin + ErrCode := RegOpenKeyEx( + HKEY_LOCAL_MACHINE, + 'HARDWARE\DEVICEMAP\SERIALCOMM', + 0, + KEY_READ, + KeyHandle); + + if ErrCode <> ERROR_SUCCESS then + begin + //raise EComPort.Create(CError_RegError, ErrCode); + exit; + end; + + TmpPorts := TStringList.Create; + try + Index := 0; + repeat + ValueLen := 256; + DataLen := 256; + SetLength(ValueName, ValueLen); + SetLength(Data, DataLen); + ErrCode := RegEnumValue( + KeyHandle, + Index, + PChar(ValueName), + {$IFDEF DELPHI_4_OR_HIGHER} + Cardinal(ValueLen), + {$ELSE} + ValueLen, + {$ENDIF} + nil, + @ValueType, + PByte(PChar(Data)), + @DataLen); + + if ErrCode = ERROR_SUCCESS then + begin + SetLength(Data, DataLen - 1); + TmpPorts.Add(Data); + Inc(Index); + end + else + if ErrCode <> ERROR_NO_MORE_ITEMS then break; + //raise EComPort.Create(CError_RegError, ErrCode); + + until (ErrCode <> ERROR_SUCCESS) ; + + TmpPorts.Sort; + Ports.Assign(TmpPorts); + finally + RegCloseKey(KeyHandle); + TmpPorts.Free; + end; + +end; + +// string to baud rate +function StrToBaudRate(Str: string): TBaudRate; +var + I: TBaudRate; +begin + I := Low(TBaudRate); + while (I <= High(TBaudRate)) do + begin + if UpperCase(Str) = UpperCase(BaudRateToStr(TBaudRate(I))) then + Break; + I := Succ(I); + end; + if I > High(TBaudRate) then + Result := br9600 + else + Result := I; +end; + +// string to stop bits +function StrToStopBits(Str: string): TStopBits; +var + I: TStopBits; +begin + I := Low(TStopBits); + while (I <= High(TStopBits)) do + begin + if UpperCase(Str) = UpperCase(StopBitsToStr(TStopBits(I))) then + Break; + I := Succ(I); + end; + if I > High(TStopBits) then + Result := sbOneStopBit + else + Result := I; +end; + +// string to data bits +function StrToDataBits(Str: string): TDataBits; +var + I: TDataBits; +begin + I := Low(TDataBits); + while (I <= High(TDataBits)) do + begin + if UpperCase(Str) = UpperCase(DataBitsToStr(I)) then + Break; + I := Succ(I); + end; + if I > High(TDataBits) then + Result := dbEight + else + Result := I; +end; + +// string to parity +function StrToParity(Str: string): TParityBits; +var + I: TParityBits; +begin + I := Low(TParityBits); + while (I <= High(TParityBits)) do + begin + if UpperCase(Str) = UpperCase(ParityToStr(I)) then + Break; + I := Succ(I); + end; + if I > High(TParityBits) then + Result := prNone + else + Result := I; +end; + +// string to flow control +function StrToFlowControl(Str: string): TFlowControl; +var + I: TFlowControl; +begin + I := Low(TFlowControl); + while (I <= High(TFlowControl)) do + begin + if UpperCase(Str) = UpperCase(FlowControlToStr(I)) then + Break; + I := Succ(I); + end; + if I > High(TFlowControl) then + Result := fcCustom + else + Result := I; +end; + +// baud rate to string +function BaudRateToStr(BaudRate: TBaudRate): string; +const + BaudRateStrings: array[TBaudRate] of string = ('Custom', '110', '300', '600', + '1200', '2400', '4800', '9600', '14400', '19200', '38400', '56000', '57600', + '115200', '128000', '256000'); +begin + Result := BaudRateStrings[BaudRate]; +end; + +// stop bits to string +function StopBitsToStr(StopBits: TStopBits): string; +const + StopBitsStrings: array[TStopBits] of string = ('1', '1.5', '2'); +begin + Result := StopBitsStrings[StopBits]; +end; + +// data bits to string +function DataBitsToStr(DataBits: TDataBits): string; +const + DataBitsStrings: array[TDataBits] of string = ('5', '6', '7', '8'); +begin + Result := DataBitsStrings[DataBits]; +end; + +// parity to string +function ParityToStr(Parity: TParityBits): string; +const + ParityBitsStrings: array[TParityBits] of string = ('None', 'Odd', 'Even', + 'Mark', 'Space'); +begin + Result := ParityBitsStrings[Parity]; +end; + +// flow control to string +function FlowControlToStr(FlowControl: TFlowControl): string; +const + FlowControlStrings: array[TFlowControl] of string = ('Hardware', + 'Software', 'None', 'Custom'); +begin + Result := FlowControlStrings[FlowControl]; +end; + +initialization + ComErrorMessages[1]:='Unable to open com port'; + ComErrorMessages[2]:='WriteFile function failed'; + ComErrorMessages[3]:='ReadFile function failed'; + ComErrorMessages[4]:='Invalid Async parameter'; + ComErrorMessages[5]:='PurgeComm function failed'; + ComErrorMessages[6]:='Unable to get async status'; + ComErrorMessages[7]:='SetCommState function failed'; + ComErrorMessages[8]:='SetCommTimeouts failed'; + ComErrorMessages[9]:='SetupComm function failed'; + ComErrorMessages[10]:='ClearCommError function failed'; + ComErrorMessages[11]:='GetCommModemStatus function failed'; + ComErrorMessages[12]:='EscapeCommFunction function failed'; + ComErrorMessages[13]:='TransmitCommChar function failed'; + ComErrorMessages[14]:='Cannot set property while connected'; + ComErrorMessages[15]:='EnumPorts function failed'; + ComErrorMessages[16]:='Failed to store settings'; + ComErrorMessages[17]:='Failed to load settings'; + ComErrorMessages[18]:='Link (un)registration failed'; + ComErrorMessages[19]:='Cannot change led state if ComPort is selected'; + ComErrorMessages[20]:='Cannot wait for event if event thread is created'; + ComErrorMessages[21]:='WaitForEvent method failed'; + ComErrorMessages[22]:='A component is linked to OnRxBuf event'; + ComErrorMessages[23]:='Registry error'; + ComErrorMessages[24]:='Port Not Open';// CError_PortNotOpen + + +end. diff --git a/AssettoCorsa/source/MainFrm.dfm b/AssettoCorsa/source/MainFrm.dfm new file mode 100644 index 0000000..79701d3 --- /dev/null +++ b/AssettoCorsa/source/MainFrm.dfm @@ -0,0 +1,90 @@ +object MainForm: TMainForm + Left = 0 + Top = 0 + BorderIcons = [biSystemMenu, biMinimize] + BorderStyle = bsSingle + Caption = 'SimulatorFans - Assetto Corsa' + ClientHeight = 309 + ClientWidth = 645 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object PortComboBox: TComboBox + Left = 24 + Top = 24 + Width = 201 + Height = 21 + Style = csDropDownList + TabOrder = 0 + end + object RefreshPortsButton: TButton + Left = 231 + Top = 23 + Width = 75 + Height = 23 + Caption = 'Refresh' + TabOrder = 1 + OnClick = RefreshPortsButtonClick + end + object Button1: TButton + Left = 192 + Top = 176 + Width = 75 + Height = 25 + Caption = 'Connect' + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 288 + Top = 176 + Width = 75 + Height = 25 + Caption = 'Fan 1 full' + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 384 + Top = 176 + Width = 75 + Height = 25 + Caption = 'Fan 2 full' + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 480 + Top = 176 + Width = 75 + Height = 25 + Caption = 'Off' + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 288 + Top = 207 + Width = 75 + Height = 25 + Caption = 'Fan 1 half' + TabOrder = 6 + OnClick = Button5Click + end + object Button6: TButton + Left = 384 + Top = 207 + Width = 75 + Height = 25 + Caption = 'Fan 2 half' + TabOrder = 7 + OnClick = Button6Click + end +end diff --git a/AssettoCorsa/source/MainFrm.pas b/AssettoCorsa/source/MainFrm.pas new file mode 100644 index 0000000..0b164be --- /dev/null +++ b/AssettoCorsa/source/MainFrm.pas @@ -0,0 +1,187 @@ +unit MainFrm; + +interface +uses + System.Classes, + System.SysUtils, + Vcl.Controls, + Vcl.ExtCtrls, + Vcl.Forms, + Vcl.StdCtrls, + + CPort; + + +type + TMainForm = class(TForm) + PortComboBox: TComboBox; + RefreshPortsButton: TButton; + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + Button6: TButton; + + procedure FormCreate(Sender: TObject); + procedure RefreshPortsButtonClick(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button6Click(Sender: TObject); + private + FComPort: TComPort; + FReceived: string; + FOnResponse: TProc; + + procedure OnReceiveChar(Sender: TObject; Count: Integer); + + procedure RefreshPorts; + procedure SendCommand(const ACommand: string; AOnResponse: TProc); + + property ComPort: TComPort read FComPort; + end; + + +implementation + +uses + System.RegularExpressions, Vcl.Dialogs; + +{$R *.dfm} + +procedure TMainForm.Button1Click(Sender: TObject); +begin + SendCommand('>Info', + procedure(Response: string) + var + match: TMatch; + + begin + match := TRegEx.Match(Response, 'SetFans:255,0', + procedure(Response: string) + begin + if Response <> 'SetFans:0,255', + procedure(Response: string) + begin + if Response <> 'SetFans:0,0', + procedure(Response: string) + begin + if Response <> 'SetFans:128,0', + procedure(Response: string) + begin + if Response <> 'SetFans:0,128', + procedure(Response: string) + begin + if Response <> ' -1 then + currentPort := PortComboBox.Items[PortComboBox.ItemIndex]; + + EnumComPorts(PortComboBox.Items); + + if Length(currentPort) > 0 then + PortComboBox.ItemIndex := PortComboBox.Items.IndexOf(currentPort); +end; + + +procedure TMainForm.OnReceiveChar(Sender: TObject; Count: Integer); +var + data: string; + terminatorPos: Integer; + +begin + (Sender as TComPort).ReadStr(data, Count); + FReceived := FReceived + data; + + terminatorPos := AnsiPos(#10, FReceived); + if terminatorPos > 0 then + begin + // Since the protocol is quite synchronous, this is good enough for now + SetLength(FReceived, terminatorPos - 1); + if Assigned(FOnResponse) then + FOnResponse(FReceived); + + FReceived := ''; + FOnResponse := nil; + end; +end; + + +procedure TMainForm.SendCommand(const ACommand: string; AOnResponse: TProc); +begin + if not Assigned(FComPort) then + begin + FComPort := TComPort.Create(Self); + FComPort.Port := PortComboBox.Items[PortComboBox.ItemIndex]; + FComPort.BaudRate := br19200; + FComPort.OnRxChar := OnReceiveChar; + FComPort.Open; + end; + + FOnResponse := AOnResponse; + ComPort.WriteStr(ACommand + #10); +end; + +end.