├── icons ├── readme.txt ├── TDataPortCom.png ├── TDataPortFile.bmp ├── TDataPortFile.png ├── TDataPortFtdi.bmp ├── TDataPortFtdi.png ├── TDataPortHttp.bmp ├── TDataPortHttp.png ├── TDataPortTcp.bmp ├── TDataPortTcp.png ├── TDataPortUdp.bmp ├── TDataPortUdp.png ├── TDataPortPipes.bmp ├── TDataPortPipes.png ├── TDataPortSerial.bmp ├── TDataPortSerial.png ├── makeres.bat └── DataPort.rc ├── DataPortD7.res ├── DataPortIcons.bcr ├── demo ├── DataPortDemo.res ├── DataPortDemo.lpr ├── DataPortDemo.lpi ├── mainform.lfm └── mainform.pas ├── dataportlasarus_reg.pas ├── dataportlasarus.pas ├── DataPortD7.dpk ├── LICENSE.md ├── DataPort.pas ├── dataportlasarus.lpk ├── DataPortEventer.pas ├── dataportlasarus.lrs ├── README.md ├── DataPortPipes.pas ├── DataPortUART.pas ├── DataPortFile.pas ├── DataPortHTTP.pas ├── DataPortSerial.pas ├── DataPortIP.pas └── DataPortFTDI.pas /icons/readme.txt: -------------------------------------------------------------------------------- 1 | For Delphi 7 icons must be 24x24 16 colors bitmaps 2 | -------------------------------------------------------------------------------- /DataPortD7.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/DataPortD7.res -------------------------------------------------------------------------------- /DataPortIcons.bcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/DataPortIcons.bcr -------------------------------------------------------------------------------- /demo/DataPortDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/demo/DataPortDemo.res -------------------------------------------------------------------------------- /icons/TDataPortCom.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortCom.png -------------------------------------------------------------------------------- /icons/TDataPortFile.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortFile.bmp -------------------------------------------------------------------------------- /icons/TDataPortFile.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortFile.png -------------------------------------------------------------------------------- /icons/TDataPortFtdi.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortFtdi.bmp -------------------------------------------------------------------------------- /icons/TDataPortFtdi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortFtdi.png -------------------------------------------------------------------------------- /icons/TDataPortHttp.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortHttp.bmp -------------------------------------------------------------------------------- /icons/TDataPortHttp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortHttp.png -------------------------------------------------------------------------------- /icons/TDataPortTcp.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortTcp.bmp -------------------------------------------------------------------------------- /icons/TDataPortTcp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortTcp.png -------------------------------------------------------------------------------- /icons/TDataPortUdp.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortUdp.bmp -------------------------------------------------------------------------------- /icons/TDataPortUdp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortUdp.png -------------------------------------------------------------------------------- /icons/TDataPortPipes.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortPipes.bmp -------------------------------------------------------------------------------- /icons/TDataPortPipes.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortPipes.png -------------------------------------------------------------------------------- /icons/TDataPortSerial.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortSerial.bmp -------------------------------------------------------------------------------- /icons/TDataPortSerial.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/serbod/dataport/HEAD/icons/TDataPortSerial.png -------------------------------------------------------------------------------- /dataportlasarus_reg.pas: -------------------------------------------------------------------------------- 1 | unit DataPortLasarus_reg; 2 | 3 | interface 4 | 5 | uses 6 | LResources; 7 | 8 | implementation 9 | 10 | initialization 11 | {$I dataportlasarus.lrs} 12 | end. 13 | -------------------------------------------------------------------------------- /icons/makeres.bat: -------------------------------------------------------------------------------- 1 | lazres ../DataPortLasarus.lrs TDataPortPipes.png TDataPortFtdi.png TDataPortHttp.png TDataPortSerial.png TDataPortTcp.png TDataPortUdp.png TDataPortFile.png 2 | brc32 DataPort.rc -r -fo../DataPortIcons.bcr 3 | 4 | 5 | -------------------------------------------------------------------------------- /icons/DataPort.rc: -------------------------------------------------------------------------------- 1 | LANGUAGE 0, 0 2 | TDataPortFile BITMAP "TDataPortFile.bmp" 3 | TDataPortHttp BITMAP "TDataPortHttp.bmp" 4 | TDataPortPipes BITMAP "TDataPortPipes.bmp" 5 | TDataPortSerial BITMAP "TDataPortSerial.bmp" 6 | TDataPortFtdi BITMAP "TDataPortFtdi.bmp" 7 | TDataPortTcp BITMAP "TDataPortTcp.bmp" 8 | TDataPortUdp BITMAP "TDataPortUdp.bmp" 9 | -------------------------------------------------------------------------------- /demo/DataPortDemo.lpr: -------------------------------------------------------------------------------- 1 | program DataPortDemo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, MainForm 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | RequireDerivedFormResource:=True; 17 | Application.Initialize; 18 | Application.CreateForm(TFormMain, FormMain); 19 | Application.Run; 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /dataportlasarus.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit DataPortLasarus; 6 | 7 | interface 8 | 9 | uses 10 | DataPort, DataPortUART, DataPortSerial, DataPortFTDI, DataPortHTTP, 11 | DataPortIP, DataPortFile, DataPortPipes, DataPortLasarus_reg, 12 | LazarusPackageIntf; 13 | 14 | implementation 15 | 16 | procedure Register; 17 | begin 18 | RegisterUnit('DataPortSerial', @DataPortSerial.Register); 19 | RegisterUnit('DataPortFTDI', @DataPortFTDI.Register); 20 | RegisterUnit('DataPortHTTP', @DataPortHTTP.Register); 21 | RegisterUnit('DataPortIP', @DataPortIP.Register); 22 | RegisterUnit('DataPortFile', @DataPortFile.Register); 23 | RegisterUnit('DataPortPipes', @DataPortPipes.Register); 24 | end; 25 | 26 | initialization 27 | RegisterPackage('DataPortLasarus', @Register); 28 | end. 29 | -------------------------------------------------------------------------------- /DataPortD7.dpk: -------------------------------------------------------------------------------- 1 | package DataPortD7; 2 | 3 | {$R *.res} 4 | {$R 'DataPortIcons.bcr'} 5 | {$ALIGN 8} 6 | {$ASSERTIONS OFF} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO ON} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION ON} 16 | {$OVERFLOWCHECKS OFF} 17 | {$RANGECHECKS OFF} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES OFF} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DESCRIPTION 'DataPort'} 27 | {$IMPLICITBUILD OFF} 28 | 29 | requires 30 | rtl, 31 | vcl; 32 | 33 | contains 34 | DataPortIP in 'DataPortIP.pas', 35 | DataPortFile in 'DataPortFile.pas', 36 | DataPortPipes in 'DataPortPipes.pas', 37 | DataPortHTTP in 'DataPortHTTP.pas', 38 | DataPortUART in 'DataPortUART.pas', 39 | DataPortSerial in 'DataPortSerial.pas', 40 | DataPortFTDI in 'DataPortFTDI.pas', 41 | DataPort in 'DataPort.pas', 42 | D2XXUnit in 'D2XXUnit.pas'; 43 | 44 | end. 45 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2012-2015 Sergey Bodrov 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /demo/DataPortDemo.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | <ResourceType Value="res"/> 14 | <UseXPManifest Value="True"/> 15 | <Icon Value="0"/> 16 | </General> 17 | <VersionInfo> 18 | <StringTable ProductVersion=""/> 19 | </VersionInfo> 20 | <BuildModes Count="1"> 21 | <Item1 Name="Default" Default="True"/> 22 | </BuildModes> 23 | <PublishOptions> 24 | <Version Value="2"/> 25 | </PublishOptions> 26 | <RunParams> 27 | <local> 28 | <FormatVersion Value="1"/> 29 | </local> 30 | </RunParams> 31 | <RequiredPackages Count="2"> 32 | <Item1> 33 | <PackageName Value="DataPortLasarus"/> 34 | </Item1> 35 | <Item2> 36 | <PackageName Value="LCL"/> 37 | </Item2> 38 | </RequiredPackages> 39 | <Units Count="1"> 40 | <Unit0> 41 | <Filename Value="DataPortDemo.lpr"/> 42 | <IsPartOfProject Value="True"/> 43 | </Unit0> 44 | </Units> 45 | </ProjectOptions> 46 | <CompilerOptions> 47 | <Version Value="11"/> 48 | <PathDelim Value="\"/> 49 | <Target> 50 | <Filename Value="DataPortDemo"/> 51 | </Target> 52 | <SearchPaths> 53 | <IncludeFiles Value="$(ProjOutDir)"/> 54 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 55 | </SearchPaths> 56 | <Linking> 57 | <Options> 58 | <Win32> 59 | <GraphicApplication Value="True"/> 60 | </Win32> 61 | </Options> 62 | </Linking> 63 | </CompilerOptions> 64 | <Debugging> 65 | <Exceptions Count="3"> 66 | <Item1> 67 | <Name Value="EAbort"/> 68 | </Item1> 69 | <Item2> 70 | <Name Value="ECodetoolError"/> 71 | </Item2> 72 | <Item3> 73 | <Name Value="EFOpenError"/> 74 | </Item3> 75 | </Exceptions> 76 | </Debugging> 77 | </CONFIG> 78 | -------------------------------------------------------------------------------- /DataPort.pas: -------------------------------------------------------------------------------- 1 | { 2 | DataPort - thread-safe abstract port for data exchange 3 | 4 | Sergey Bodrov (serbod@gmail.com) 2012-2016 5 | 6 | TDataPort is abstract component for reading and writing data to some port. 7 | It don't do anything and needs to be used as property or parent class for new components. 8 | 9 | Properties: 10 | Active - is port ready for data exchange 11 | 12 | Methods: 13 | Open() - Open data port. If InitStr specified, set parameters from InitStr 14 | Push() - Send data to port 15 | Pull() - Get data from port. Data readed from incoming buffer, and removed after that. 16 | You can specify number of bytes for read. If incoming buffer have less bytes, 17 | than specified, then will be returned while buffer. 18 | By default, return whole buffer and clear it after. 19 | Peek() - Read data from incoming buffer, but don't remove. You can specify number 20 | of bytes for read. If incoming buffer have less bytes, than specified, 21 | then will be returned while buffer. By default, return whole buffer. 22 | PeekSize() - Returns number of bytes in incoming buffer of port. 23 | 24 | Events: 25 | OnDataAppear - Triggered in data appear in incoming buffer of dataport. 26 | OnOpen - Triggered after sucсessful opening connection. 27 | OnClose - Triggered when connection gracefully closed. 28 | OnError - Triggered on error, contain error description. 29 | } 30 | 31 | unit DataPort; 32 | 33 | interface 34 | 35 | uses Classes; 36 | 37 | type 38 | TMsgEvent = procedure(Sender: TObject; const AMsg: AnsiString) of object; 39 | 40 | { TDataPort } 41 | 42 | TDataPort = class(TComponent) 43 | protected 44 | FOnDataAppear: TNotifyEvent; 45 | FOnOpen: TNotifyEvent; 46 | FOnClose: TNotifyEvent; 47 | FOnError: TMsgEvent; 48 | FActive: Boolean; 49 | procedure SetActive(Val: Boolean); virtual; 50 | public 51 | property Active: Boolean read FActive write SetActive; 52 | { Occurs when new data appears in incoming buffer } 53 | property OnDataAppear: TNotifyEvent read FOnDataAppear write FOnDataAppear; 54 | { Occurs immediately after dataport has been sucsessfully opened } 55 | property OnOpen: TNotifyEvent read FOnOpen write FOnOpen; 56 | { Occurs after dataport has been closed } 57 | property OnClose: TNotifyEvent read FOnClose write FOnClose; 58 | { Occurs when dataport operations fails, contain error description } 59 | property OnError: TMsgEvent read FOnError write FOnError; 60 | { Open dataport with specified initialization string 61 | If AInitStr not specified, used default or designed settings } 62 | procedure Open(const AInitStr: string = ''); virtual; 63 | { Close dataport } 64 | procedure Close(); virtual; 65 | { Write data string to port } 66 | function Push(const AData: AnsiString): Boolean; virtual; abstract; 67 | { Read and remove <size> bytes from incoming buffer. By default, read all data. } 68 | function Pull(ASize: Integer = MaxInt): AnsiString; virtual; abstract; 69 | { Read, but not remove <size> bytes from incoming buffer. } 70 | function Peek(ASize: Integer = MaxInt): AnsiString; virtual; abstract; 71 | { Get number of bytes waiting in incoming buffer } 72 | function PeekSize(): Cardinal; virtual; abstract; 73 | end; 74 | 75 | 76 | implementation 77 | 78 | { TDataPort } 79 | 80 | procedure TDataPort.SetActive(Val: Boolean); 81 | begin 82 | if FActive = Val then 83 | Exit; 84 | if Val then 85 | Open() 86 | else 87 | Close(); 88 | end; 89 | 90 | procedure TDataPort.Open(const AInitStr: string); 91 | begin 92 | FActive := True; 93 | if Assigned(OnOpen) then 94 | OnOpen(self); 95 | end; 96 | 97 | procedure TDataPort.Close(); 98 | begin 99 | FActive := False; 100 | if Assigned(OnClose) then 101 | OnClose(self); 102 | end; 103 | 104 | end. 105 | -------------------------------------------------------------------------------- /dataportlasarus.lpk: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <Package Version="4"> 4 | <PathDelim Value="\"/> 5 | <Name Value="DataPortLasarus"/> 6 | <Type Value="RunAndDesignTime"/> 7 | <Author Value="Sergey Bodrov"/> 8 | <CompilerOptions> 9 | <Version Value="11"/> 10 | <PathDelim Value="\"/> 11 | <SearchPaths> 12 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 13 | </SearchPaths> 14 | <Parsing> 15 | <SyntaxOptions> 16 | <SyntaxMode Value="Delphi"/> 17 | </SyntaxOptions> 18 | </Parsing> 19 | <Linking> 20 | <Debugging> 21 | <UseExternalDbgSyms Value="True"/> 22 | </Debugging> 23 | </Linking> 24 | </CompilerOptions> 25 | <Description Value="DataPort - thread-safe abstract port for data exchange. You can open DataPort and push some data into - data will appear on other side. And if other side send some data, you will get notified and can pull data from port at any time. 26 | - network (TCP/UDP/HTTP) 27 | - serial port (UART, COM-port) 28 | - device files (ioctl supported) and conventional files 29 | - named pipes"/> 30 | <License Value="The MIT License (MIT) 31 | 32 | Copyright (c) 2012-2025 Sergey Bodrov 33 | 34 | Permission is hereby granted, free of charge, to any person obtaining a copy 35 | of this software and associated documentation files (the "Software"), to deal 36 | in the Software without restriction, including without limitation the rights 37 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 38 | copies of the Software, and to permit persons to whom the Software is 39 | furnished to do so, subject to the following conditions: 40 | 41 | The above copyright notice and this permission notice shall be included in all 42 | copies or substantial portions of the Software. 43 | 44 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 45 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 46 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 47 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 48 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 49 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 50 | SOFTWARE."/> 51 | <Version Major="1" Release="5"/> 52 | <Files Count="10"> 53 | <Item1> 54 | <Filename Value="dataportlasarus.lrs"/> 55 | <Type Value="LRS"/> 56 | </Item1> 57 | <Item2> 58 | <Filename Value="DataPort.pas"/> 59 | <UnitName Value="DataPort"/> 60 | </Item2> 61 | <Item3> 62 | <Filename Value="DataPortUART.pas"/> 63 | <UnitName Value="DataPortUART"/> 64 | </Item3> 65 | <Item4> 66 | <Filename Value="DataPortSerial.pas"/> 67 | <HasRegisterProc Value="True"/> 68 | <AddToUsesPkgSection Value="False"/> 69 | <UnitName Value="DataPortSerial"/> 70 | </Item4> 71 | <Item5> 72 | <Filename Value="DataPortFTDI.pas"/> 73 | <HasRegisterProc Value="True"/> 74 | <AddToUsesPkgSection Value="False"/> 75 | <UnitName Value="DataPortFTDI"/> 76 | </Item5> 77 | <Item6> 78 | <Filename Value="DataPortHTTP.pas"/> 79 | <HasRegisterProc Value="True"/> 80 | <AddToUsesPkgSection Value="False"/> 81 | <UnitName Value="DataPortHTTP"/> 82 | </Item6> 83 | <Item7> 84 | <Filename Value="DataPortIP.pas"/> 85 | <HasRegisterProc Value="True"/> 86 | <AddToUsesPkgSection Value="False"/> 87 | <UnitName Value="DataPortIP"/> 88 | </Item7> 89 | <Item8> 90 | <Filename Value="DataPortFile.pas"/> 91 | <HasRegisterProc Value="True"/> 92 | <AddToUsesPkgSection Value="False"/> 93 | <UnitName Value="DataPortFile"/> 94 | </Item8> 95 | <Item9> 96 | <Filename Value="DataPortPipes.pas"/> 97 | <HasRegisterProc Value="True"/> 98 | <AddToUsesPkgSection Value="False"/> 99 | <UnitName Value="DataPortPipes"/> 100 | </Item9> 101 | <Item10> 102 | <Filename Value="dataportlasarus_reg.pas"/> 103 | <UnitName Value="DataPortLasarus_reg"/> 104 | </Item10> 105 | </Files> 106 | <RequiredPkgs Count="2"> 107 | <Item1> 108 | <PackageName Value="LCLBase"/> 109 | </Item1> 110 | <Item2> 111 | <PackageName Value="laz_synapse"/> 112 | </Item2> 113 | </RequiredPkgs> 114 | <UsageOptions> 115 | <CustomOptions Value="-dUseCThreads"/> 116 | <UnitPath Value="$(PkgOutDir)"/> 117 | </UsageOptions> 118 | <PublishOptions> 119 | <Version Value="2"/> 120 | </PublishOptions> 121 | <CustomOptions Items="ExternHelp" Version="2"> 122 | <_ExternHelp Items="Count"/> 123 | </CustomOptions> 124 | </Package> 125 | </CONFIG> 126 | -------------------------------------------------------------------------------- /DataPortEventer.pas: -------------------------------------------------------------------------------- 1 | { 2 | Cross-platform async events from read/write threads to main thread. 3 | 4 | (C) Sergey Bodrov, 2012-2025 5 | } 6 | unit DataPortEventer; 7 | 8 | {$IFDEF FPC} 9 | {$MODE DELPHI} 10 | {$DEFINE NO_LIBC} 11 | {$ENDIF} 12 | 13 | interface 14 | 15 | uses 16 | {$ifndef FPC}Windows, Messages, {$endif} 17 | SysUtils, Classes, DataPort; 18 | 19 | const 20 | DP_NOTIFY_NONE = 'N'; 21 | DP_NOTIFY_OPEN = 'O'; 22 | DP_NOTIFY_CLOSE = 'C'; 23 | DP_NOTIFY_ERROR = 'E'; 24 | DP_NOTIFY_DATA = 'D'; 25 | 26 | { Thread-safe functions } 27 | procedure RegisterDataportNotify(AValue: TDataPort); 28 | procedure UnRegisterDataportNotify(AValue: TDataPort); 29 | procedure NotifyDataport(ADataPort: TDataPort; AEventType: AnsiChar; 30 | const AErrorStr: string = ''); 31 | 32 | implementation 33 | 34 | {$ifndef FPC} 35 | const WM_DATAPORT_NOTIFY = WM_USER + 101; 36 | {$endif} 37 | 38 | type 39 | { TDataPortNotifyThread 40 | Call events of TDataPort objects from application main thread. 41 | Windows PostMessage() is not situable for cross-platform non-visual controls. 42 | In FreePascal AllocateHWnd() implemented in LCLIntf unit, and LM_USER instead of WM_USER 43 | } 44 | 45 | TDataPortNotifyThread = class(TThread) 46 | protected 47 | procedure SyncProc(); 48 | procedure Execute; override; 49 | end; 50 | 51 | TDataPortEventer = class(TComponent) 52 | protected 53 | FList: TStringList; 54 | FLock: TSimpleRWSync; 55 | FNotifyThread: TDataPortNotifyThread; 56 | 57 | {$ifndef FPC} 58 | FHWnd: HWND; 59 | procedure WndMsgProc(var AMessage: TMessage); 60 | {$endif} 61 | public 62 | constructor Create(AOwner: TComponent); override; 63 | destructor Destroy; override; 64 | 65 | procedure ExecEvent(); 66 | function GetCount: Integer; 67 | procedure RegisterDataport(ADataPort: TDataPort); 68 | procedure UnRegisterDataport(ADataPort: TDataPort); 69 | procedure NotifyDataport(ADataPort: TDataPort; AEventType: AnsiChar; 70 | const AErrorStr: string = ''); 71 | 72 | {$ifndef FPC} 73 | property HWnd: HWND read FHWnd; 74 | {$endif} 75 | end; 76 | 77 | var 78 | DataPortEventerObject: TDataPortEventer; 79 | 80 | { TDataPortNotifyThread } 81 | 82 | procedure TDataPortNotifyThread.SyncProc(); 83 | begin 84 | if Assigned(DataPortEventerObject) then 85 | DataPortEventerObject.ExecEvent(); 86 | end; 87 | 88 | procedure TDataPortNotifyThread.Execute; 89 | //var 90 | // i: Integer; 91 | begin 92 | while (not Terminated) and Assigned(DataPortEventerObject) do 93 | begin 94 | if DataPortEventerObject.GetCount > 0 then 95 | begin 96 | try 97 | Synchronize(SyncProc); 98 | except 99 | // show must go on 100 | end; 101 | end 102 | else 103 | Sleep(1); 104 | end; 105 | end; 106 | 107 | procedure RegisterDataportNotify(AValue: TDataPort); 108 | begin 109 | if not Assigned(DataPortEventerObject) then 110 | DataPortEventerObject := TDataPortEventer.Create(nil); 111 | DataPortEventerObject.RegisterDataport(AValue); 112 | end; 113 | 114 | procedure UnRegisterDataportNotify(AValue: TDataPort); 115 | begin 116 | if Assigned(DataPortEventerObject) then 117 | begin 118 | DataPortEventerObject.UnRegisterDataport(AValue); 119 | if DataPortEventerObject.GetCount = 0 then 120 | FreeAndNil(DataPortEventerObject); 121 | end; 122 | end; 123 | 124 | procedure NotifyDataport(ADataPort: TDataPort; AEventType: AnsiChar; 125 | const AErrorStr: string); 126 | begin 127 | if Assigned(DataPortEventerObject) then 128 | DataPortEventerObject.NotifyDataport(ADataPort, AEventType, AErrorStr); 129 | end; 130 | 131 | { TDataPortEventer } 132 | 133 | {$ifndef FPC} 134 | procedure TDataPortEventer.WndMsgProc(var AMessage: TMessage); 135 | begin 136 | case AMessage.Msg of 137 | WM_DATAPORT_NOTIFY: 138 | begin 139 | if Assigned(DataPortEventerObject) then 140 | DataPortEventerObject.ExecEvent(); 141 | AMessage.Result := 0; 142 | end; 143 | else 144 | AMessage.Result := DefWindowProc(FHWnd, AMessage.Msg, AMessage.WParam, AMessage.LParam); 145 | end; 146 | end; 147 | {$endif} 148 | 149 | constructor TDataPortEventer.Create(AOwner: TComponent); 150 | begin 151 | inherited Create(AOwner); 152 | FLock := TSimpleRWSync.Create(); 153 | FList := TStringList.Create(); 154 | {$ifndef FPC} 155 | FHWnd := AllocateHWnd(WndMsgProc); 156 | {$else} 157 | FNotifyThread := TDataPortNotifyThread.Create(False); 158 | {$endif} 159 | end; 160 | 161 | destructor TDataPortEventer.Destroy; 162 | begin 163 | {$ifndef FPC} 164 | DeallocateHWnd(FHWnd); 165 | {$else} 166 | FreeAndNil(FNotifyThread); 167 | {$endif} 168 | FreeAndNil(FList); 169 | FreeAndNil(FLock); 170 | inherited; 171 | end; 172 | 173 | procedure TDataPortEventer.ExecEvent; 174 | var 175 | cEventType: Char; 176 | Item: TDataPort; 177 | sError: string; 178 | begin 179 | cEventType := DP_NOTIFY_NONE; 180 | sError := ''; 181 | Item := nil; 182 | 183 | FLock.BeginWrite; 184 | try 185 | if FList.Count > 0 then 186 | begin 187 | Item := (FList.Objects[0] as TDataPort); 188 | cEventType := FList.Strings[0][1]; 189 | sError := Copy(FList.Strings[0], 2, MaxInt); 190 | FList.Delete(0); 191 | end; 192 | finally 193 | FLock.EndWrite; 194 | end; 195 | 196 | case cEventType of 197 | DP_NOTIFY_OPEN: 198 | begin 199 | if Assigned(Item.OnOpen) then Item.OnOpen(Item); 200 | end; 201 | DP_NOTIFY_CLOSE: 202 | begin 203 | //if Assigned(Item.OnClose) then Item.OnClose(Item); 204 | Item.Close(); 205 | end; 206 | DP_NOTIFY_ERROR: 207 | begin 208 | if Assigned(Item.OnError) then Item.OnError(Item, sError); 209 | end; 210 | DP_NOTIFY_DATA: 211 | begin 212 | if Assigned(Item.OnDataAppear) then Item.OnDataAppear(Item); 213 | end; 214 | end; 215 | end; 216 | 217 | function TDataPortEventer.GetCount: Integer; 218 | begin 219 | FLock.BeginRead; 220 | try 221 | Result := FList.Count; 222 | finally 223 | FLock.EndRead; 224 | end; 225 | end; 226 | 227 | procedure TDataPortEventer.RegisterDataport(ADataPort: TDataPort); 228 | begin 229 | // 230 | end; 231 | 232 | procedure TDataPortEventer.UnRegisterDataport(ADataPort: TDataPort); 233 | var 234 | i: Integer; 235 | begin 236 | FLock.BeginWrite; 237 | try 238 | for i := FList.Count-1 downto 0 do 239 | begin 240 | if FList.Objects[i] = ADataPort then 241 | FList.Delete(i); 242 | end; 243 | finally 244 | FLock.EndWrite; 245 | end; 246 | end; 247 | 248 | procedure TDataPortEventer.NotifyDataport(ADataPort: TDataPort; 249 | AEventType: AnsiChar; const AErrorStr: string); 250 | begin 251 | FLock.BeginWrite; 252 | try 253 | FList.AddObject(AEventType + AErrorStr, ADataPort); 254 | finally 255 | FLock.EndWrite; 256 | end; 257 | {$ifndef FPC} 258 | PostMessage(HWnd, WM_DATAPORT_NOTIFY, 0, 0); 259 | {$endif} 260 | end; 261 | 262 | initialization 263 | DataPortEventerObject := nil; 264 | 265 | finalization 266 | FreeAndNil(DataPortEventerObject); 267 | 268 | end. 269 | 270 | -------------------------------------------------------------------------------- /dataportlasarus.lrs: -------------------------------------------------------------------------------- 1 | LazarusResources.Add('TDataPortPipes','PNG',[ 2 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 3 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#193#0#0#14#193#1 4 | +#184#145'k'#237#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0 5 | +#0#200'IDATHK'#221#143#219#14#196' '#8'D'#253't'#255'|'#23'p'#166#165#172'UK' 6 | +#234#203#158'd'#2#140'\'#218#242#127#212'Z?+B'#251'3tp'#149#212#145#173#7#226 7 | +'r'#177#144#157'D'#239#209#145#217#1','#179#200#222#212#1'.'#16#235#200'''' 8 | +#222#26#218#188#253#128#151'?6'#242'0>'''#14'R'#242#212#253'r'#202#134'W'#232 9 | +#13#171#228#233#157#3#10#135'f'#164#150'+'#24'ZR'#234#192#22#240#215'C'#208 10 | +#154#3#11'."'#204'%'#230#241#139'H'#172'#'#156#243#220'y'#195#3'>R'#158#153 11 | +''''#177'e4)'#194'<'#227')R7''>'#16#250#26')'#226#189#232#19#201'[E'#211#12 12 | +#16'|'#139#158#158'G'#220#220#207#162#131#224'3'#26'V'#8#154#186#178'W'#187 13 | +'J0'#3#192#186#128''''#3#214'-'#173#171#148'/lr'#160#138#247#159'1'#231#0#0#0 14 | +#0'IEND'#174'B`'#130 15 | ]); 16 | LazarusResources.Add('TDataPortFtdi','PNG',[ 17 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#2#0#0#0'o'#21#170#175 18 | +#0#0#0#1'sRGB'#0#174#206#28#233#0#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9 19 | +'pHYs'#0#0#14#195#0#0#14#195#1#199'o'#168'd'#0#0#0#26'tEXtSoftware'#0'Paint.' 20 | +'NET v3.5.100'#244'r'#161#0#0#0#163'IDAT8O'#197'SA'#14#192' '#8#227#233#251 21 | +#249#198#130'C '#208#152#200'6.F"'#181'-@gSP'#19#206#233#128#14#24#248#203#9 22 | +#196' '#248')~'#208#13'd'#127'#rz'#237#21#144#26'5'#21#16#231#25'H'#172'c' 23 | +#225#171'@R'#160#149#233#181#242#209'1'#234#1#210#214#139#4'pMIMFa'#134'X`' 24 | +#208#168'N}'#2#164'r*/1'#29#174'r'#3')r'#170'X'#157#236#205#237#237#222#254 25 | +' '#231#214#236'#'#205'HR'#164'<'#135#223'/'#149'i'#23'-'#221#193'7'#129'T' 26 | +#138'u'#253'WF'#249#224#27#239':='#178#157#28#205#10']'#219#156'F.'#191#0#253 27 | +'6]'#233#253'U'#184#195#0#0#0#0'IEND'#174'B`'#130 28 | ]); 29 | LazarusResources.Add('TDataPortHttp','PNG',[ 30 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 31 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#194#0#0#14#194#1#21 32 | +'(J'#128#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0#0#202 33 | +'IDATHK'#221#143#219#14#195'0'#8'C'#243#233#249#243#13#24#166#212'M'#155#139 34 | +#154#151#29#9#129#13#132#182#252#31#181#214#207'H'#248#248#28#186'8'#202#210 35 | +#145#173#7#248'q'#177#188':`o'#234'H'#239#128'?f'#25#179'K'#7#240#128'XQw' 36 | +#188'1tx'#251#129#28#249#216#147#231#235'}x'#17'!'#173#230#151'#ly'#132#214 37 | +#178#134#180#222'9'#160'`'#169#199#210#227#138'/'#13#197#210#129'-'#248'_' 38 | +#219#215'x'#249#26'v@'#8#225#25#250#18'3>'#144':'#6#172#200'M'#133'5'#232#205 39 | +'AK~nd'#13#216#207#26#156#250#28#209#248#229#208#128'}'#232#28'@'#234'C('#208 40 | +'hd'#13#216#207':'#163'=%'#132#231'['#13#216'g'#205'D'#195#243#173#6#236#179 41 | +'>a'#174#144'k'#165#165#129'[FK'#31#148#242#5#154#243#161#137#227#208#179#147 42 | +#0#0#0#0'IEND'#174'B`'#130 43 | ]); 44 | LazarusResources.Add('TDataPortSerial','PNG',[ 45 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 46 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#194#0#0#14#194#1#21 47 | +'(J'#128#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0#0#199 48 | +'IDATHK'#221#143'Y'#14#3'1'#8'C{'#244#220'<'#5#132'S'#15'%'#171#154#159'>' 49 | +#137','#198#196'3'#175#255#163#148'RW'#202#237'{'#232#224'*G!W'#3#226#227'"' 50 | +#249#233'C'#212#182'Bf'#1#254#152#237#240#30#5#224#1#145#218'y'#162#173#161 51 | +#230#235#1'\'#28'6'#210'||N'#28'DI+'#253'r'#148#13#175#144#13'kI'#235'7'#1#10 52 | +#134'f'#28'='#174#248#208'R'#29#5'\'#195#255#252#129#183#186#184#205'p'#169 53 | +#225#178#209'.'#170#163#128#154'{x?'#245'=z|'#1#241'~'#194'0'#128#209#30#247 54 | +#249#222#211#149#230#177'U'#128'!3)m'#160#211#7#209#247#237#16#216#196#5#13 55 | +#196's'#230#179#149#141'J41'#172'e'#190#168#181#142#10'(&j'#163'3{i'''#23#209 56 | +#211#247#168#245#13'9'#242#251'/'#222'N'#189#147#0#0#0#0'IEND'#174'B`'#130 57 | ]); 58 | LazarusResources.Add('TDataPortTcp','PNG',[ 59 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 60 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#194#0#0#14#194#1#21 61 | +'(J'#128#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0#0#196 62 | +'IDATHK'#221#143#225#18#131'0'#8#131'}t'#223'|'#3'L*K'#187#21'{'#250'g'#223 63 | +#29'W'#8#1't'#251'?'#246'}'#127'U'#2#246'k'#248'`'#149#165'#'#143#30#208#229 64 | +'&!;Q'#237#210#145#217#1','#139#151#222#165#3'\`R'#203'''Z'#13'7?~ G>'#246'K' 65 | +#195#248#28#29'dXk'#248#229#140#24#174'0'#26#246#176#214'='#7#28#14#205'XZ' 66 | +#238'`'#168#20'K'#7#30#3#127'~'#27'X{'#2#177#11'R'#213#165'w'#2'-'#144#178 67 | +#171#29'j'#147'^'#143#26#180'v'#162#0'R'#6#212#194#172#168'A'#235#12'{'#26 68 | +#196#242#30'4'#154'Ak'''#10' e'#227'p'#14'@'#179#153'r'#157'I'#30#190'5t('#18 69 | +#195#211#28#132#185#189'5'#194#13' }h'#223#128'u'#192#182#189#1#28#241'n'#188 70 | +'JD"'#207#0#0#0#0'IEND'#174'B`'#130 71 | ]); 72 | LazarusResources.Add('TDataPortUdp','PNG',[ 73 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 74 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#194#0#0#14#194#1#21 75 | +'(J'#128#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0#0#195 76 | +'IDATHK'#221#143#219#14#195'0'#8'C'#251#233#249#243#13','#156' 7*i'#180#188 77 | +#236'H'#136'`si'#175#255#163#181#246'Y'#137'h'#127#135#15#174#178'u'#228#232 78 | +#1']nR'#188#6#170#189':R'#29#136'e'#200#236#221':'#192#5'&'#245'w'#161#173 79 | +#225#205#199#15#228#200#199#158#180#24#175#209'A'#134'Y'#211'/g`x'#133#217 80 | +#176#135'Y'#191'9'#224'p'#168'bk'#185#19'CK'#177'u'#224'('#241#247'@'#235#29 81 | +#176'4'#19'b7'#165#190#5')'#188'A'#8#221#144#26'9'#179#232#13#212#144#154#25 82 | +#136#134#156'I'#222'@'#13#169#153#129'h'#183' '#246#30#132#208#13#169#153#129 83 | +'h'#200#10#26'3!'#194'$'#172'Uw'#212#179#252#12#186#12#127'2H'#214'f^'#228#26 84 | +'tn'#18'+'#132#235#250#2'0\'#139#159#10#148'M/'#0#0#0#0'IEND'#174'B`'#130 85 | ]); 86 | LazarusResources.Add('TDataPortFile','PNG',[ 87 | #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0 88 | +#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0#9'pHYs'#0#0#14#193#0#0#14#193#1 89 | +#184#145'k'#237#0#0#0#24'tEXtSoftware'#0'paint.net 4.0.3'#140#230#151'P'#0#0 90 | +#0#187'IDATHK'#221#143'Q'#14#195'0'#8'Cs'#244#220'|'#11#200#172#212'm'#129'D' 91 | +#205#207#158#132#160#142#13'['#251'?z'#239#159'J'#193'>'#135#4#171','#29#217 92 | +'z'#128#151#15#9#211#1'kSG'#178#3'X'#166#221#188'K'#7'l'#193#144'~s'#162#213 93 | +#16#243#246#3#190#252#177'HC<'#135#131'V'#227#233#246#151'[i'#184#194']Xj<' 94 | +#189's@'#176'P'#198#210'r'#1#161'R-'#29#216#2#254'u'#9'D'#230'@'#240'R'#166 95 | +'S'#159#199'/x'#226#233']'#23'd'#192#168#1#198't'#255'.3}'#199#192't*'#195'f' 96 | +#238#130#211'b'#188#153'1'#221'w_'#208'b,'#200'f'#210'O'#221'#'#222#16#152'.' 97 | +'f'#210#181#11'2;=G'#157#0#146#2')'#4#214#128#214#190'['#26'"'#9'm'#206#19 98 | +#136#0#0#0#0'IEND'#174'B`'#130 99 | ]); 100 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # dataport 2 | DataPort - thread-safe abstract port for data exchange. You can open DataPort and push some data into - data will appear on other side. And if other side send some data, you will get notifyed and can pull data from port at any time. 3 | 4 | DataPort use Ararat Synapse library ( http://sourceforge.net/p/synalist/code/HEAD/tree/trunk/ ), which must be installed first as separate package for Lasarus. 5 | 6 | DataPort can be freely used and modified under MIT License. 7 | 8 | Features: 9 | 10 | * non-visual components for Lazarus/Delphi 11 | * network (TCP/UDP/HTTP) 12 | * serial port (UART, COM-port, FTDI) 13 | * device file (ioctl supported) and conventional file 14 | * named pipes 15 | 16 | Coming soon: 17 | 18 | * listener (server) 19 | * paralel port (LPT) 20 | * DDE 21 | * IPC 22 | 23 | # TDataPort # 24 | 25 | TDataPort is abstract component for reading and writing data to some port. It don't do anything and needs to be used as property or parent class for new components. 26 | 27 | Properties: 28 | 29 | * Active - is port ready for data exchange. 30 | 31 | Methods: 32 | 33 | * Push() - Send data to port 34 | * Pull() - Get data from port. Data readed from incoming buffer, and removed after that. You can specify number of bytes for read. If incoming buffer have less bytes, than specified, then will be returned while buffer. By default, return whole buffer and clear it after. 35 | * Peek() - Read data from incoming buffer, but don't remove. You can specify number of bytes for read. If incoming buffer have less bytes, than specified, then will be returned while buffer. By default, return whole buffer. 36 | * PeekSize() - Returns number of bytes in incoming buffer of port. 37 | * Open() - Open data port for data exchange. You can specify port initialisation string 38 | * Close() - Shut down port communication 39 | 40 | Events: 41 | 42 | * OnDataAppear - Triggered in data appear in incoming buffer of dataport. 43 | * OnError - Triggered on error, contain error description. 44 | 45 | ## TDataPortSerial ## 46 | 47 | Serial communication port. In Windows it COM-port (real or virtual). In Linux it /dev/ttyS or /dev/ttyUSB. Also, Linux use file /var/lock/LCK..ttyS for port locking 48 | 49 | Properties: 50 | 51 | * Port - port name (COM1, /dev/ttyS01) 52 | * BaudRate - data excange speed 53 | * MinDataBytes - minimal bytes count in buffer for triggering event OnDataAppear 54 | 55 | Methods: 56 | 57 | * Open() - Opens port. As parameter it use port initialization string: 58 | ``` 59 | InitStr = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 60 | 61 | Port - COM port name (COM1, /dev/ttyS01) 62 | BaudRate - connection speed (50..4000000 bits per second), default 9600 63 | DataBits - default 8 64 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 65 | StopBits - (1, 1.5, 2) 66 | SoftFlow - Enable XON/XOFF handshake, default 1 67 | HardFlow - Enable CTS/RTS handshake, default 0 68 | ``` 69 | 70 | Events: 71 | 72 | * OnConnect - Triggered after successful connection. 73 | * OnDisconnect - Triggered after disconnection. 74 | 75 | ## TDataPortFtdi ## 76 | 77 | Serial communication port based on FTD2XX library. 78 | 79 | Properties: 80 | 81 | * SerialNumber - device serial number 82 | * DeviceDescription - device description string 83 | * BaudRate - data excange speed (300, 1200, 9600, 115384, 230769, 923076) 84 | * MinDataBytes - minimal bytes count in buffer for triggering event OnDataAppear 85 | 86 | Methods: 87 | 88 | * Open() - Opens port. As parameter it use port initialization string: 89 | ``` 90 | InitStr = '<DeviceDescription>:<SerialNumber>:<PortInitStr>' 91 | <PortInitStr> = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 92 | 93 | Examples: 94 | 'USB Serial:' - first device of 'USB Serial' type 95 | ':FT425622' - device with s/n FT425622 96 | 97 | If device specified by <DeviceDescription> and/or <SerialNumber> 98 | then 'Port' parameter in <PortInitStr> is ignored 99 | ``` 100 | * GetFtdiDeviceList() - list of available devices in format: 101 | ``` 102 | <DeviceDescription>:<SerialNumber><LineFeed> 103 | ``` 104 | 105 | Events: 106 | 107 | * OnModemStatus - Triggered when modem status changes (CTS, DTR, RI, DCD) 108 | 109 | ## TDataPortIP, TDataPortTCP, TDataPortUDP ## 110 | 111 | Asynchronous wrapper around Synapse TBlockSocket. 112 | 113 | When using UDP, remember, that it not session protocol, data delivery and correct order not guaranteed. To start receive data, you must send empty packet to remote side, it tell remote side return address. 114 | 115 | From version 1.0.3 multiple DataPortIP instances uses common socket reader with single thread. It allow open thousands IP connections without performance losses. 116 | 117 | Properties: 118 | 119 | * RemoteHost - IP-address or name of remote host 120 | * RemotePort - remote UPD or TCP port number 121 | 122 | Methods: 123 | 124 | * Open() - Connect to remote port. Session establiched for TCP and just port initialised for UDP. Init string format: 125 | ``` 126 | InitStr = 'RemoteHost:RemotePort' 127 | 128 | RemoteHost - IP-address or name of remote host 129 | RemotePort - remote UPD or TCP port number 130 | ``` 131 | 132 | Events: 133 | 134 | * OnConnect - Triggered after UDP port init or TCP session establiched. 135 | 136 | ## TDataPortHTTP ## 137 | 138 | Allows you to communicate via HTTP. Specify URL and request parameters, then call Push() to connect and transfer data to a remote server. After successful execution of the request, data can be read from the input buffer. Large amounts of data received by parts, and OnDataAppear event can be triggered multiple times. 139 | 140 | If POST method selected, then request parameter mime-type='application/x-www-form-urlencoded' set, it allow transfer parameters as web form values. 141 | 142 | Properties: 143 | 144 | * Url: address and params string, URL 145 | * Params: HTTP request params in name=value format 146 | * Method: HTTP request method 147 | * httpGet - GET 148 | * httpPost - POST 149 | 150 | Methods: 151 | 152 | * Open() - sets URL string for HTTP request, but not send request itself. Request will be sent on Push(). URL string format: 153 | ``` 154 | URL = 'http://RemoteHost:RemotePort/Path' 155 | 156 | RemoteHost - IP-address or name of remote host 157 | RemotePort - remote UPD or TCP port number 158 | Path - path to requested resource 159 | ``` 160 | 161 | ## TDataPortFile ## 162 | 163 | Data exchange via file. Suitable for device files (/dev/* under Unix or special 164 | files in Windows). Conventional data files can be used too. 165 | 166 | Properties: 167 | 168 | * Filename - Path (optionally) and name of file. 169 | * FilePos - Current position in file, bytes from beginning (for conventional files). 170 | * QueryInterval - Interval for checking changes in file, milliseconds. 171 | * MinDataBytes - Minimum number of bytes in buffer for triggering OnDataAppear event. 172 | * KeepOpen - Keep the file open between read and write operations: 173 | * True - file stay opened 174 | * False - file will be opened before every read/write operation and closed after. 175 | * WriteMode - File write mode: 176 | * fwmRewrite - every write apply to beginning of file 177 | * fwmAppend - data written from last operation position or appended to the end of file 178 | 179 | Methods: 180 | 181 | * Open() - Opens file with given name, "file:" prefix can be used. 182 | 183 | ## TDataPortPipes ## 184 | 185 | Data exchange through named pipes. Pipe name is platform-specific. On Windows, '\\.\pipe\' prefix added automaticaly. 186 | 187 | Pipe must be already exists, created by Linux 'mkfifo' command or some other program. 188 | 189 | Methods: 190 | 191 | * Open() - open pipe channel with specified name -------------------------------------------------------------------------------- /demo/mainform.lfm: -------------------------------------------------------------------------------- 1 | object FormMain: TFormMain 2 | Left = 525 3 | Height = 452 4 | Top = 289 5 | Width = 669 6 | Caption = 'DataPort Terminal' 7 | ClientHeight = 452 8 | ClientWidth = 669 9 | OnCreate = FormCreate 10 | LCLVersion = '1.9.0.0' 11 | object memoTerminal: TMemo 12 | Left = 0 13 | Height = 388 14 | Top = 64 15 | Width = 669 16 | Align = alClient 17 | BorderStyle = bsNone 18 | Color = clBlack 19 | Font.Color = clLime 20 | Font.Height = -13 21 | Font.Name = 'Courier New' 22 | Font.Style = [fsBold] 23 | Lines.Strings = ( 24 | 'memoTerminal' 25 | ) 26 | OnKeyPress = memoTerminalKeyPress 27 | ParentFont = False 28 | ReadOnly = True 29 | ScrollBars = ssAutoBoth 30 | TabOrder = 0 31 | WordWrap = False 32 | end 33 | object pgcMain: TPageControl 34 | Left = 0 35 | Height = 64 36 | Top = 0 37 | Width = 669 38 | ActivePage = tsSerial 39 | Align = alTop 40 | Font.Height = -13 41 | ParentFont = False 42 | TabIndex = 0 43 | TabOrder = 1 44 | OnChange = pgcMainChange 45 | object tsSerial: TTabSheet 46 | Caption = 'Serial port' 47 | ClientHeight = 34 48 | ClientWidth = 661 49 | object lbSerialPort: TLabel 50 | Left = 8 51 | Height = 17 52 | Top = 7 53 | Width = 27 54 | Caption = 'Port:' 55 | ParentColor = False 56 | end 57 | object cbSerialPort: TComboBox 58 | Left = 48 59 | Height = 25 60 | Top = 7 61 | Width = 112 62 | ItemHeight = 17 63 | TabOrder = 0 64 | Text = 'cbSerialPort' 65 | end 66 | object lbSerialBitrate: TLabel 67 | Left = 173 68 | Height = 17 69 | Top = 11 70 | Width = 40 71 | Caption = 'Bitrate:' 72 | ParentColor = False 73 | end 74 | object cbSerialBitrate: TComboBox 75 | Left = 224 76 | Height = 25 77 | Top = 7 78 | Width = 112 79 | ItemHeight = 17 80 | TabOrder = 1 81 | Text = 'cbSerialBitrate' 82 | end 83 | object btnSerialConnect: TBitBtn 84 | Left = 351 85 | Height = 25 86 | Top = 7 87 | Width = 107 88 | Action = actConnect 89 | TabOrder = 2 90 | end 91 | object chkLocalEcho: TCheckBox 92 | Left = 487 93 | Height = 21 94 | Top = 12 95 | Width = 82 96 | Caption = 'Local echo' 97 | TabOrder = 3 98 | end 99 | end 100 | object tsTCP: TTabSheet 101 | Caption = 'TCP port' 102 | ClientHeight = 34 103 | ClientWidth = 661 104 | object lbTCPHost: TLabel 105 | Left = 7 106 | Height = 17 107 | Top = 9 108 | Width = 56 109 | Caption = 'TCP Host:' 110 | ParentColor = False 111 | end 112 | object edTCPHost: TEdit 113 | Left = 77 114 | Height = 25 115 | Top = 9 116 | Width = 179 117 | TabOrder = 0 118 | Text = 'localhost' 119 | end 120 | object lbTCPPort: TLabel 121 | Left = 272 122 | Height = 17 123 | Top = 9 124 | Width = 27 125 | Caption = 'Port:' 126 | ParentColor = False 127 | end 128 | object edTCPPort: TEdit 129 | Left = 312 130 | Height = 25 131 | Top = 9 132 | Width = 64 133 | TabOrder = 1 134 | Text = '23' 135 | end 136 | object btnTCPConnect: TBitBtn 137 | Left = 392 138 | Height = 25 139 | Top = 9 140 | Width = 107 141 | Action = actConnect 142 | TabOrder = 2 143 | end 144 | end 145 | object tsUDP: TTabSheet 146 | Caption = 'UDP port' 147 | ClientHeight = 36 148 | ClientWidth = 661 149 | object lbUDPHost: TLabel 150 | Left = 7 151 | Height = 17 152 | Top = 9 153 | Width = 59 154 | Caption = 'UDP Host:' 155 | ParentColor = False 156 | end 157 | object edUDPHost: TEdit 158 | Left = 77 159 | Height = 25 160 | Top = 9 161 | Width = 179 162 | TabOrder = 0 163 | Text = 'localhost' 164 | end 165 | object lbUDPPort: TLabel 166 | Left = 272 167 | Height = 17 168 | Top = 9 169 | Width = 27 170 | Caption = 'Port:' 171 | ParentColor = False 172 | end 173 | object edUDPPort: TEdit 174 | Left = 312 175 | Height = 25 176 | Top = 9 177 | Width = 64 178 | TabOrder = 1 179 | Text = '135' 180 | end 181 | object btnUDPConnect: TBitBtn 182 | Left = 392 183 | Height = 25 184 | Top = 9 185 | Width = 107 186 | Action = actConnect 187 | TabOrder = 2 188 | end 189 | end 190 | object tsHTTP: TTabSheet 191 | Caption = 'HTTP' 192 | ClientHeight = 36 193 | ClientWidth = 661 194 | object lbHTTPHost: TLabel 195 | Left = 7 196 | Height = 17 197 | Top = 9 198 | Width = 64 199 | Caption = 'HTTP Host:' 200 | ParentColor = False 201 | end 202 | object edHTTPHost: TEdit 203 | Left = 77 204 | Height = 25 205 | Top = 9 206 | Width = 259 207 | TabOrder = 0 208 | Text = 'google.com' 209 | end 210 | object btnHTTPConnect: TBitBtn 211 | Left = 351 212 | Height = 25 213 | Top = 7 214 | Width = 107 215 | Action = actConnect 216 | TabOrder = 1 217 | end 218 | end 219 | object tsFile: TTabSheet 220 | Caption = 'File / device' 221 | ClientHeight = 34 222 | ClientWidth = 661 223 | object lbFileName: TLabel 224 | Left = 7 225 | Height = 17 226 | Top = 9 227 | Width = 58 228 | Caption = 'File name:' 229 | ParentColor = False 230 | end 231 | object edFileName: TEdit 232 | Left = 77 233 | Height = 25 234 | Top = 9 235 | Width = 259 236 | TabOrder = 0 237 | Text = 'clip' 238 | end 239 | object btnFileConnect: TBitBtn 240 | Left = 351 241 | Height = 25 242 | Top = 7 243 | Width = 107 244 | Action = actConnect 245 | TabOrder = 1 246 | end 247 | end 248 | end 249 | object alMain: TActionList 250 | Left = 288 251 | Top = 168 252 | object actConnect: TAction 253 | Caption = 'Connect' 254 | OnExecute = actConnectExecute 255 | end 256 | object actClear: TAction 257 | Caption = 'Clear' 258 | OnExecute = actClearExecute 259 | end 260 | end 261 | object dpSerial: TDataPortSerial 262 | Port = 'COM1' 263 | BaudRate = 9600 264 | DataBits = 8 265 | Parity = 'N' 266 | StopBits = stb1 267 | SoftFlow = False 268 | HardFlow = False 269 | MinDataBytes = 1 270 | Active = False 271 | Left = 416 272 | Top = 168 273 | end 274 | object dpTCP: TDataPortTCP 275 | Active = False 276 | Left = 416 277 | Top = 232 278 | end 279 | object dpUDP: TDataPortUDP 280 | Active = False 281 | Left = 416 282 | Top = 296 283 | end 284 | object dpHTTP: TDataPortHTTP 285 | Method = httpGet 286 | SafeMode = True 287 | Active = False 288 | Left = 416 289 | Top = 360 290 | end 291 | object dpFile: TDataPortFile 292 | Active = False 293 | FilePos = 0 294 | QueryInterval = 100 295 | MinDataBytes = 1 296 | KeepOpen = True 297 | WriteMode = fwmAppend 298 | Left = 504 299 | Top = 168 300 | end 301 | end 302 | -------------------------------------------------------------------------------- /demo/mainform.pas: -------------------------------------------------------------------------------- 1 | unit MainForm; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, 9 | StdCtrls, ActnList, Buttons, DataPortSerial, DataPort, DataPortIP, 10 | DataPortHTTP, DataPortFile, LCLType, ComCtrls; 11 | 12 | type 13 | 14 | { TFormMain } 15 | 16 | TFormMain = class(TForm) 17 | actConnect: TAction; 18 | actClear: TAction; 19 | alMain: TActionList; 20 | btnFileConnect: TBitBtn; 21 | btnSerialConnect: TBitBtn; 22 | btnHTTPConnect: TBitBtn; 23 | btnUDPConnect: TBitBtn; 24 | btnTCPConnect: TBitBtn; 25 | cbSerialBitrate: TComboBox; 26 | cbSerialPort: TComboBox; 27 | chkLocalEcho: TCheckBox; 28 | dpFile: TDataPortFile; 29 | dpHTTP: TDataPortHTTP; 30 | dpUDP: TDataPortUDP; 31 | dpTCP: TDataPortTCP; 32 | dpSerial: TDataPortSerial; 33 | edFileName: TEdit; 34 | edTCPHost: TEdit; 35 | edHTTPHost: TEdit; 36 | edUDPHost: TEdit; 37 | edTCPPort: TEdit; 38 | edUDPPort: TEdit; 39 | lbFileName: TLabel; 40 | lbTCPHost: TLabel; 41 | lbSerialBitrate: TLabel; 42 | lbSerialPort: TLabel; 43 | lbHTTPHost: TLabel; 44 | lbUDPHost: TLabel; 45 | lbTCPPort: TLabel; 46 | lbUDPPort: TLabel; 47 | memoTerminal: TMemo; 48 | pgcMain: TPageControl; 49 | tsTCP: TTabSheet; 50 | tsUDP: TTabSheet; 51 | tsHTTP: TTabSheet; 52 | tsFile: TTabSheet; 53 | tsSerial: TTabSheet; 54 | procedure actClearExecute(Sender: TObject); 55 | procedure actConnectExecute(Sender: TObject); 56 | procedure FormCreate(Sender: TObject); 57 | procedure memoTerminalKeyPress(Sender: TObject; var Key: char); 58 | procedure pgcMainChange(Sender: TObject); 59 | private 60 | { private declarations } 61 | FDataPort: TDataPort; 62 | procedure SetDataPort(AValue: TDataPort); 63 | procedure UpdateSerialPortList(); 64 | procedure AppendToTerminal(const s: string); 65 | procedure OnDataAppearHandler(Sender: TObject); 66 | procedure OnErrorHandler(Sender: TObject; const AMsg: string); 67 | procedure OnOpenHandler(Sender: TObject); 68 | procedure OnCloseHandler(Sender: TObject); 69 | public 70 | { public declarations } 71 | property DataPort: TDataPort read FDataPort write SetDataPort; 72 | end; 73 | 74 | var 75 | FormMain: TFormMain; 76 | 77 | implementation 78 | 79 | {$R *.lfm} 80 | 81 | { TFormMain } 82 | 83 | procedure TFormMain.memoTerminalKeyPress(Sender: TObject; var Key: char); 84 | begin 85 | if Assigned(DataPort) then 86 | begin 87 | DataPort.Push(Key); 88 | if chkLocalEcho.Checked then 89 | begin 90 | AppendToTerminal(Key); 91 | end; 92 | end; 93 | end; 94 | 95 | procedure TFormMain.pgcMainChange(Sender: TObject); 96 | begin 97 | if pgcMain.ActivePage = tsSerial then 98 | begin 99 | DataPort := dpSerial; 100 | UpdateSerialPortList(); 101 | end 102 | else 103 | if pgcMain.ActivePage = tsTCP then 104 | begin 105 | DataPort := dpTCP; 106 | end 107 | else 108 | if pgcMain.ActivePage = tsUDP then 109 | begin 110 | DataPort := dpUDP; 111 | end 112 | else 113 | if pgcMain.ActivePage = tsHTTP then 114 | begin 115 | DataPort := dpHTTP; 116 | end 117 | else 118 | if pgcMain.ActivePage = tsFile then 119 | begin 120 | DataPort := dpFile; 121 | end; 122 | end; 123 | 124 | procedure TFormMain.UpdateSerialPortList(); 125 | var 126 | sl: TStringList; 127 | begin 128 | cbSerialPort.Items.Clear(); 129 | sl := TStringList.Create(); 130 | try 131 | sl.CommaText := dpSerial.GetSerialPortNames(); 132 | cbSerialPort.Items.AddStrings(sl); 133 | finally 134 | sl.Free(); 135 | end; 136 | 137 | if cbSerialPort.Items.Count > 0 then 138 | cbSerialPort.ItemIndex := 0 139 | else 140 | cbSerialPort.Text := ''; 141 | end; 142 | 143 | procedure TFormMain.SetDataPort(AValue: TDataPort); 144 | begin 145 | if FDataPort = AValue then Exit; 146 | 147 | if Assigned(FDataPort) then 148 | begin 149 | FDataPort.Close(); 150 | FDataPort.OnOpen := nil; 151 | FDataPort.OnClose := nil; 152 | FDataPort.OnDataAppear := nil; 153 | FDataPort.OnError := nil; 154 | FDataPort := nil; 155 | end; 156 | 157 | FDataPort := AValue; 158 | 159 | if Assigned(FDataPort) then 160 | begin 161 | FDataPort.OnOpen := @OnOpenHandler; 162 | FDataPort.OnClose := @OnCloseHandler; 163 | FDataPort.OnDataAppear := @OnDataAppearHandler; 164 | FDataPort.OnError := @OnErrorHandler; 165 | end; 166 | end; 167 | 168 | procedure TFormMain.AppendToTerminal(const s: string); 169 | begin 170 | memoTerminal.Lines.BeginUpdate(); 171 | memoTerminal.Text := memoTerminal.Text + s; 172 | if memoTerminal.Lines.Count > 1200 then 173 | begin 174 | while memoTerminal.Lines.Count > 1000 do 175 | memoTerminal.Lines.Delete(0); 176 | end; 177 | memoTerminal.SelStart := MaxInt; 178 | memoTerminal.Lines.EndUpdate(); 179 | memoTerminal.ScrollBy(0, -100000); 180 | end; 181 | 182 | procedure TFormMain.OnDataAppearHandler(Sender: TObject); 183 | var 184 | sData: AnsiString; 185 | begin 186 | sData := DataPort.Pull(); 187 | AppendToTerminal(sData); 188 | end; 189 | 190 | procedure TFormMain.OnErrorHandler(Sender: TObject; const AMsg: string); 191 | begin 192 | actConnect.Caption := 'Connect'; 193 | AppendToTerminal('Error: ' + AMsg + sLineBreak); 194 | end; 195 | 196 | procedure TFormMain.OnOpenHandler(Sender: TObject); 197 | begin 198 | actConnect.Caption := 'Disconnect'; 199 | end; 200 | 201 | procedure TFormMain.OnCloseHandler(Sender: TObject); 202 | begin 203 | actConnect.Caption := 'Connect'; 204 | end; 205 | 206 | procedure TFormMain.FormCreate(Sender: TObject); 207 | begin 208 | memoTerminal.Clear(); 209 | 210 | // bitrates 211 | cbSerialBitrate.Items.Clear(); 212 | cbSerialBitrate.Items.Append('300'); 213 | cbSerialBitrate.Items.Append('1200'); 214 | cbSerialBitrate.Items.Append('9600'); 215 | cbSerialBitrate.Items.Append('19200'); 216 | cbSerialBitrate.Items.Append('57600'); 217 | cbSerialBitrate.Items.Append('115200'); 218 | cbSerialBitrate.Items.Append('230400'); 219 | cbSerialBitrate.Items.Append('923076'); 220 | cbSerialBitrate.ItemIndex := 2; 221 | 222 | pgcMain.ActivePage := tsSerial; 223 | pgcMainChange(pgcMain); 224 | end; 225 | 226 | procedure TFormMain.actConnectExecute(Sender: TObject); 227 | begin 228 | if not Assigned(DataPort) then Exit; 229 | if DataPort.Active then 230 | begin 231 | DataPort.Close(); 232 | end 233 | else 234 | begin 235 | if pgcMain.ActivePage = tsSerial then 236 | begin 237 | dpSerial.Port := cbSerialPort.Text; 238 | dpSerial.BaudRate := StrToIntDef(cbSerialBitrate.Text, 9600); 239 | end 240 | else 241 | if pgcMain.ActivePage = tsTCP then 242 | begin 243 | dpTCP.RemoteHost := edTCPHost.Text; 244 | dpTCP.RemotePort := edTCPPort.Text; 245 | end 246 | else 247 | if pgcMain.ActivePage = tsUDP then 248 | begin 249 | dpUDP.RemoteHost := edUDPHost.Text; 250 | dpUDP.RemotePort := edUDPPort.Text; 251 | end 252 | else 253 | if pgcMain.ActivePage = tsHTTP then 254 | begin 255 | dpHTTP.Url := edHTTPHost.Text; 256 | end 257 | else 258 | if pgcMain.ActivePage = tsFile then 259 | begin 260 | dpFile.FileName := edFileName.Text; 261 | end; 262 | actConnect.Caption := 'Connecting..'; 263 | DataPort.Open(); 264 | 265 | if pgcMain.ActivePage = tsHTTP then 266 | begin 267 | // send HTTP request 268 | DataPort.Push(''); 269 | end; 270 | end; 271 | end; 272 | 273 | procedure TFormMain.actClearExecute(Sender: TObject); 274 | begin 275 | memoTerminal.Clear(); 276 | end; 277 | 278 | 279 | end. 280 | 281 | -------------------------------------------------------------------------------- /DataPortPipes.pas: -------------------------------------------------------------------------------- 1 | { 2 | Data exchange through named pipes 3 | 4 | Sergey Bodrov, 2012-2016 5 | 6 | Data exchange through named pipes. Pipe name is platform-specific. On Windows, 7 | '\\.\pipe\' prefix added automaticaly. 8 | 9 | Pipe must be already exists, created by Linux 'mkfifo' command or some other program. 10 | 11 | Methods: 12 | * Open() - open pipe channel with specified name 13 | } 14 | unit DataPortPipes; 15 | 16 | interface 17 | 18 | uses SysUtils, Classes, 19 | {$ifdef FPC}Pipes, {$endif} 20 | DataPort; 21 | 22 | type 23 | {$ifndef FPC} 24 | TInputPipeStream = class(THandleStream); 25 | TOutputPipeStream = class(THandleStream); 26 | {$endif} 27 | 28 | { TPipesClient - pipes port reader/writer } 29 | TPipesClient = class(TThread) 30 | private 31 | FInputPipeStream: TInputPipeStream; 32 | FOutputPipeStream: TOutputPipeStream; 33 | s: AnsiString; 34 | sLastError: string; 35 | FSafeMode: boolean; 36 | FInputHandle: THandle; 37 | FOutputHandle: THandle; 38 | FOnIncomingMsgEvent: TMsgEvent; 39 | FOnErrorEvent: TMsgEvent; 40 | FOnConnectEvent: TNotifyEvent; 41 | procedure SyncProc(); 42 | procedure SyncProcOnConnect(); 43 | protected 44 | procedure Execute(); override; 45 | public 46 | InitStr: string; 47 | CalledFromThread: boolean; 48 | sToSend: AnsiString; 49 | property SafeMode: boolean read FSafeMode write FSafeMode; 50 | property InputHandle: THandle read FInputHandle write FInputHandle; 51 | property OutputHandle: THandle read FOutputHandle write FOutputHandle; 52 | property OnIncomingMsgEvent: TMsgEvent read FOnIncomingMsgEvent 53 | write FOnIncomingMsgEvent; 54 | property OnErrorEvent: TMsgEvent read FOnErrorEvent write FOnErrorEvent; 55 | property OnConnectEvent: TNotifyEvent read FOnConnectEvent write FOnConnectEvent; 56 | function SendString(const s: AnsiString): boolean; 57 | procedure SendStream(st: TStream); 58 | end; 59 | 60 | { TDataPortPipes - serial DataPort } 61 | TDataPortPipes = class(TDataPort) 62 | private 63 | //slReadData: TStringList; // for storing every incoming data packet separately 64 | sReadData: AnsiString; 65 | lock: TMultiReadExclusiveWriteSynchronizer; 66 | FInitStr: string; 67 | FMinDataBytes: Integer; 68 | FInputHandle: THandle; 69 | FOutputHandle: THandle; 70 | procedure OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); 71 | procedure OnErrorHandler(Sender: TObject; const AMsg: AnsiString); 72 | procedure OnConnectHandler(Sender: TObject); 73 | public 74 | PipesClient: TPipesClient; 75 | constructor Create(AOwner: TComponent); override; 76 | destructor Destroy(); override; 77 | { Open pipe, InitStr = pipe name } 78 | procedure Open(const AInitStr: string = ''); override; 79 | procedure Close(); override; 80 | function Push(const AData: AnsiString): boolean; override; 81 | function Pull(size: Integer = MaxInt): AnsiString; override; 82 | function Peek(size: Integer = MaxInt): AnsiString; override; 83 | function PeekSize(): Cardinal; override; 84 | published 85 | property InputHandle: THandle read FInputHandle write FInputHandle; 86 | property OutputHandle: THandle read FOutputHandle write FOutputHandle; 87 | { Minimum bytes in incoming buffer to trigger OnDataAppear } 88 | property MinDataBytes: Integer read FMinDataBytes write FMinDataBytes; 89 | property Active; 90 | property OnDataAppear; 91 | property OnError; 92 | property OnOpen; 93 | property OnClose; 94 | end; 95 | 96 | 97 | procedure Register; 98 | 99 | implementation 100 | 101 | procedure Register; 102 | begin 103 | RegisterComponents('DataPort', [TDataPortPipes]); 104 | end; 105 | 106 | function AnsiStringToStream(AStream: TStream; AStr: AnsiString): Integer; 107 | begin 108 | Result := 0; 109 | if Assigned(AStream) and (AStr <> '') then 110 | Result := AStream.Write(AStr[1], Length(AStr)); 111 | end; 112 | 113 | // === TPipesClient === 114 | procedure TPipesClient.SyncProc(); 115 | begin 116 | if CalledFromThread then 117 | Exit; 118 | //if s:='' then Exit; 119 | CalledFromThread := True; 120 | if s <> '' then 121 | begin 122 | if Assigned(self.FOnIncomingMsgEvent) then 123 | FOnIncomingMsgEvent(self, s); 124 | s := ''; 125 | end; 126 | if sLastError <> '' then 127 | begin 128 | if Assigned(self.FOnErrorEvent) then 129 | FOnErrorEvent(self, sLastError); 130 | self.Terminate(); 131 | end; 132 | CalledFromThread := False; 133 | end; 134 | 135 | procedure TPipesClient.SyncProcOnConnect(); 136 | begin 137 | if CalledFromThread then 138 | Exit; 139 | CalledFromThread := True; 140 | if Assigned(self.FOnConnectEvent) then 141 | self.FOnConnectEvent(self); 142 | CalledFromThread := False; 143 | end; 144 | 145 | procedure TPipesClient.Execute(); 146 | var 147 | buf: array[0..1023] of byte; 148 | n: Integer; 149 | ss: AnsiString; 150 | begin 151 | sLastError := ''; 152 | buf[0] := 0; 153 | 154 | try 155 | FInputPipeStream := TInputPipeStream.Create(FInputHandle); 156 | FOutputPipeStream := TOutputPipeStream.Create(FOutputHandle); 157 | 158 | Synchronize(SyncProcOnConnect); 159 | 160 | while not Terminated do 161 | begin 162 | n := FInputPipeStream.Read(buf, Length(buf)); 163 | while n > 0 do 164 | begin 165 | SetString(ss, PAnsiChar(@buf), n); 166 | s := s + ss; 167 | n := FInputPipeStream.Read(buf, Length(buf)); 168 | end; 169 | sLastError := ''; 170 | if (Length(s) > 0) or (Length(sLastError) > 0) then 171 | Synchronize(SyncProc); 172 | 173 | Sleep(1); 174 | 175 | if sToSend <> '' then 176 | begin 177 | try 178 | //Self.FOutputPipeStream.WriteAnsiString(sToSend); 179 | AnsiStringToStream(Self.FOutputPipeStream, sToSend); 180 | except 181 | on E: Exception do 182 | begin 183 | sLastError := E.Message; 184 | Synchronize(SyncProc); 185 | end; 186 | end; 187 | sToSend := ''; 188 | end; 189 | end; 190 | finally 191 | FreeAndNil(FOutputPipeStream); 192 | FreeAndNil(FInputPipeStream); 193 | end; 194 | end; 195 | 196 | function TPipesClient.SendString(const s: AnsiString): boolean; 197 | begin 198 | Result := False; 199 | if not Assigned(Self.FOutputPipeStream) then 200 | Exit; 201 | if SafeMode then 202 | self.sToSend := s 203 | else 204 | begin 205 | try 206 | //Self.FOutputPipeStream.WriteAnsiString(s); 207 | AnsiStringToStream(Self.FOutputPipeStream, s); 208 | except 209 | on E: Exception do 210 | begin 211 | sLastError := E.Message; 212 | Synchronize(SyncProc); 213 | Exit; 214 | end; 215 | end; 216 | end; 217 | Result := True; 218 | end; 219 | 220 | procedure TPipesClient.SendStream(st: TStream); 221 | begin 222 | if not Assigned(Self.FOutputPipeStream) then 223 | Exit; 224 | try 225 | Self.FOutputPipeStream.CopyFrom(st, st.Size); 226 | except 227 | on E: Exception do 228 | begin 229 | sLastError := E.Message; 230 | Synchronize(SyncProc); 231 | end; 232 | end; 233 | end; 234 | 235 | 236 | { TDataPortPipes } 237 | 238 | constructor TDataPortPipes.Create(AOwner: TComponent); 239 | begin 240 | inherited Create(AOwner); 241 | self.lock := TMultiReadExclusiveWriteSynchronizer.Create(); 242 | FMinDataBytes := 1; 243 | FActive := False; 244 | Self.sReadData := ''; 245 | Self.PipesClient := nil; 246 | end; 247 | 248 | function GetFirstWord(var s: string; delimiter: string = ' '): string; 249 | var 250 | i: Integer; 251 | begin 252 | Result := ''; 253 | i := Pos(delimiter, s); 254 | if i > 0 then 255 | begin 256 | Result := Copy(s, 1, i - 1); 257 | s := Copy(s, i + 1, maxint); 258 | end 259 | else 260 | begin 261 | Result := s; 262 | s := ''; 263 | end; 264 | end; 265 | 266 | procedure TDataPortPipes.Open(const AInitStr: string = ''); 267 | var 268 | s, ss: string; 269 | begin 270 | ss := AInitStr; 271 | if ss = '' then 272 | ss := FInitStr 273 | else 274 | FInitStr := ss; 275 | if Assigned(self.PipesClient) then 276 | begin 277 | FreeAndNil(self.PipesClient); 278 | end; 279 | Self.PipesClient := TPipesClient.Create(True); 280 | Self.PipesClient.OnIncomingMsgEvent := self.OnIncomingMsgHandler; 281 | Self.PipesClient.OnErrorEvent := self.OnErrorHandler; 282 | Self.PipesClient.OnConnectEvent := self.OnConnectHandler; 283 | Self.PipesClient.SafeMode := True; 284 | 285 | if ss <> '' then 286 | begin 287 | s := AInitStr; 288 | {$IFDEF MSWINDOWS} 289 | if Pos('\\.\pipe\', FInitStr) = 0 then 290 | s := '\\.\pipe\' + FInitStr; 291 | {$ENDIF} 292 | PipesClient.InputHandle := FileOpen(s, fmOpenReadWrite or fmShareDenyNone); 293 | PipesClient.OutputHandle := PipesClient.InputHandle; 294 | end 295 | else 296 | begin 297 | PipesClient.InputHandle := InputHandle; 298 | PipesClient.OutputHandle := OutputHandle; 299 | end; 300 | 301 | Self.PipesClient.Suspended := False; 302 | 303 | // don't inherits Open() - OnOpen event will be after successfull connection 304 | end; 305 | 306 | procedure TDataPortPipes.Close(); 307 | begin 308 | if Assigned(self.PipesClient) then 309 | begin 310 | if self.PipesClient.CalledFromThread then 311 | self.PipesClient.Terminate() 312 | else 313 | FreeAndNil(self.PipesClient); 314 | end; 315 | inherited Close(); 316 | end; 317 | 318 | destructor TDataPortPipes.Destroy(); 319 | begin 320 | if Assigned(self.PipesClient) then 321 | begin 322 | self.PipesClient.OnIncomingMsgEvent := nil; 323 | self.PipesClient.OnErrorEvent := nil; 324 | self.PipesClient.OnConnectEvent := nil; 325 | FreeAndNil(self.PipesClient); 326 | end; 327 | FreeAndNil(self.lock); 328 | inherited Destroy(); 329 | end; 330 | 331 | procedure TDataPortPipes.OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); 332 | begin 333 | if AMsg <> '' then 334 | begin 335 | if lock.BeginWrite then 336 | begin 337 | sReadData := sReadData + AMsg; 338 | lock.EndWrite; 339 | 340 | if Assigned(FOnDataAppear) then 341 | FOnDataAppear(self); 342 | end; 343 | end; 344 | end; 345 | 346 | procedure TDataPortPipes.OnErrorHandler(Sender: TObject; const AMsg: AnsiString); 347 | begin 348 | if Assigned(Self.FOnError) then 349 | Self.FOnError(Self, AMsg); 350 | self.FActive := False; 351 | end; 352 | 353 | function TDataPortPipes.Peek(size: Integer = MaxInt): AnsiString; 354 | begin 355 | lock.BeginRead(); 356 | Result := Copy(sReadData, 1, size); 357 | lock.EndRead(); 358 | end; 359 | 360 | function TDataPortPipes.PeekSize(): Cardinal; 361 | begin 362 | lock.BeginRead(); 363 | Result := Cardinal(Length(sReadData)); 364 | lock.EndRead(); 365 | end; 366 | 367 | function TDataPortPipes.Pull(size: Integer = MaxInt): AnsiString; 368 | begin 369 | Result := ''; 370 | if lock.BeginWrite() then 371 | begin 372 | try 373 | Result := Copy(sReadData, 1, size); 374 | Delete(sReadData, 1, size); 375 | finally 376 | lock.EndWrite(); 377 | end; 378 | end; 379 | end; 380 | 381 | function TDataPortPipes.Push(const AData: AnsiString): boolean; 382 | begin 383 | Result := False; 384 | if Assigned(self.PipesClient) and lock.BeginWrite() then 385 | begin 386 | try 387 | Result := self.PipesClient.SendString(AData); 388 | finally 389 | lock.EndWrite(); 390 | end; 391 | end; 392 | end; 393 | 394 | procedure TDataPortPipes.OnConnectHandler(Sender: TObject); 395 | begin 396 | self.FActive := True; 397 | if Assigned(OnOpen) then 398 | OnOpen(Self); 399 | end; 400 | 401 | end. 402 | -------------------------------------------------------------------------------- /DataPortUART.pas: -------------------------------------------------------------------------------- 1 | { 2 | Serial communication port (UART). In Windows it COM-port, real or virtual. 3 | In Linux it /dev/ttyS or /dev/ttyUSB. Also, Linux use file /var/FLock/LCK..ttyS for port FLocking 4 | 5 | (C) Sergey Bodrov, 2012-2025 6 | 7 | Properties: 8 | Port - port name (COM1, /dev/ttyS01) 9 | BaudRate - data excange speed 10 | DataBits - default 8 (5 for Baudot code, 7 for true ASCII) 11 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 12 | StopBits - (stb1, stb15, stb2), default stb1 13 | FlowControl - (sfcNone, sfcSend, sfcReady, sfcSoft) default sfcNone 14 | sfcSend - SEND signal pair CTS/RTS, used for hardware flow control 15 | sfcReady - READY signal pair DTR/DSR, used for modem control 16 | sfcSoft - software flow control XON/XOFF byte ($11 for resume and $13 for pause transmission) 17 | 18 | MinDataBytes - minimal bytes count in buffer for triggering event OnDataAppear 19 | 20 | Methods: 21 | Open() - Opens port. As parameter it use port initialization string: 22 | InitStr = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 23 | 24 | Port - COM port name (COM1, /dev/ttyS01) 25 | BaudRate - connection speed (50..4000000 bits per second), default 9600 26 | DataBits - default 8 27 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 28 | StopBits - (1, 1.5, 2) default 0 29 | SoftFlow - Enable XON/XOFF handshake, default 0 30 | HardFlow - Enable CTS/RTS handshake, default 0 31 | 32 | Events: 33 | OnOpen - Triggered after sucсessful connection. 34 | OnClose - Triggered after disconnection. 35 | 36 | Roles: 37 | Data Terminal Equipment (DTE) - computer terminal 38 | Data Circuit-terminating Equipment (DCE) - modem, peripreral device 39 | } 40 | unit DataPortUART; 41 | 42 | interface 43 | 44 | uses 45 | SysUtils, Classes, DataPort, DataPortEventer; 46 | 47 | type 48 | TSerialStopBits = (stb1, stb15, stb2); 49 | 50 | TSerialFlowControl = (sfcNone, sfcSend, sfcReady, sfcSoft); 51 | 52 | TModemStatus = record 53 | { RTS (Request to send) signal (w) - DTE requests the DCE prepare to transmit data. } 54 | { RTR (Ready To Receive) (w) - DTE is ready to receive data from DCE. If in use, RTS is assumed to be always asserted. } 55 | RTS: Boolean; 56 | { CTS (Clear to send) signal (r) - DCE is ready to accept data from the DTE. } 57 | CTS: boolean; 58 | { DTR (Data Terminal Ready) signal (w) - DTE is ready to receive, initiate, or continue a call. } 59 | DTR: Boolean; 60 | { DSR (Data Set Ready) signal (r) - DCE is ready to receive and send data. } 61 | DSR: Boolean; 62 | { Data Carrier Detect (r) - DCE is receiving a carrier from a remote DCE. } 63 | Carrier: Boolean; 64 | { Ring Indicator (r) - DCE has detected an incoming ring signal on the telephone line. } 65 | Ring: Boolean; 66 | end; 67 | 68 | { TDataPortUART - serial DataPort } 69 | TDataPortUART = class(TDataPort) 70 | private 71 | FOnModemStatus: TNotifyEvent; 72 | FOnDataAppearUnsafe: TNotifyEvent; 73 | procedure SetHardFlow(AValue: Boolean); 74 | procedure SetSoftFlow(AValue: Boolean); 75 | protected 76 | FReadDataStr: AnsiString; 77 | FLock: TSimpleRWSync; 78 | FPort: string; 79 | FBaudRate: Integer; 80 | FDataBits: Integer; 81 | FParity: AnsiChar; 82 | FStopBits: TSerialStopBits; 83 | FFlowControl: TSerialFlowControl; 84 | FSoftFlow: Boolean; 85 | FHardFlow: Boolean; 86 | FMinDataBytes: Integer; 87 | FHalfDuplex: Boolean; 88 | FModemStatus: TModemStatus; 89 | procedure SetBaudRate(AValue: Integer); virtual; 90 | procedure SetDataBits(AValue: Integer); virtual; 91 | procedure SetParity(AValue: AnsiChar); virtual; 92 | procedure SetStopBits(AValue: TSerialStopBits); virtual; 93 | procedure SetFlowControl(AValue: TSerialFlowControl); virtual; 94 | // called from inner thread! 95 | procedure OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); virtual; 96 | procedure OnErrorHandler(Sender: TObject; const AMsg: AnsiString); virtual; 97 | procedure OnConnectHandler(Sender: TObject); virtual; 98 | public 99 | constructor Create(AOwner: TComponent); override; 100 | destructor Destroy(); override; 101 | { Open serial DataPort 102 | InitStr = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 103 | 104 | Port - COM port name (COM1, /dev/tty01) 105 | BaudRate - connection speed (50..4000000 bits per second), default 9600 106 | DataBits - default 8 107 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 108 | StopBits - (1, 1.5, 2) 109 | SoftFlow - Enable XON/XOFF handshake, default 0 110 | HardFlow - Enable CTS/RTS handshake, default 0 } 111 | procedure Open(const AInitStr: string = ''); override; 112 | function Pull(ASize: Integer = MaxInt): AnsiString; override; 113 | function Peek(ASize: Integer = MaxInt): AnsiString; override; 114 | function PeekSize(): Cardinal; override; 115 | 116 | { Get modem wires status (DSR,CTS,Ring,Carrier) } 117 | function GetModemStatus(): TModemStatus; virtual; 118 | { Set DTR (Data Terminal Ready) signal } 119 | procedure SetDTR(AValue: Boolean); virtual; 120 | { Set RTS (Request to send) signal } 121 | procedure SetRTS(AValue: Boolean); virtual; 122 | { Modem wires status } 123 | property ModemStatus: TModemStatus read FModemStatus; 124 | published 125 | { Serial port name (COM1, /dev/ttyS01) } 126 | property Port: string read FPort write FPort nodefault; 127 | { BaudRate - connection speed (50..4000000 bits per second), default 9600 } 128 | property BaudRate: Integer read FBaudRate write SetBaudRate default 9600; 129 | { DataBits - default 8 (5 for Baudot code, 7 for true ASCII) } 130 | property DataBits: Integer read FDataBits write SetDataBits default 8; 131 | { Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N } 132 | property Parity: AnsiChar read FParity write SetParity default 'N'; 133 | { StopBits - (stb1, stb15, stb2), default stb1 } 134 | property StopBits: TSerialStopBits read FStopBits write SetStopBits default stb1; 135 | { Flow control - (sfcNone, sfcRTS, sfcDTR, sfcXON) default sfcNone 136 | sfcSend - SEND signal pair CTS/RTS, used for hardware flow control 137 | sfcReady - READY signal pair DTR/DSR, used for modem control 138 | sfcSoft - software flow control XON/XOFF byte ($11 for resume and $13 for pause transmission) } 139 | property FlowControl: TSerialFlowControl read FFlowControl write SetFlowControl default sfcNone; 140 | { deprecated, set to False and use FlowControl } 141 | property SoftFlow: Boolean read FSoftFlow write SetSoftFlow; {$ifdef FPC}deprecated;{$endif} 142 | { deprecated, set to False and use FlowControl } 143 | property HardFlow: Boolean read FHardFlow write SetHardFlow; {$ifdef FPC}deprecated;{$endif} 144 | { Minimum bytes in incoming buffer to trigger OnDataAppear } 145 | property MinDataBytes: Integer read FMinDataBytes write FMinDataBytes default 1; 146 | { Use half-duplex for send and receive data } 147 | property HalfDuplex: Boolean read FHalfDuplex write FHalfDuplex default False; 148 | property Active; 149 | property OnDataAppear; 150 | property OnError; 151 | property OnOpen; 152 | property OnClose; 153 | { Triggered when modem status changed } 154 | property OnModemStatus: TNotifyEvent read FOnModemStatus write FOnModemStatus; 155 | { Triggered when data appeared (not thread-safe, called from inner thread!) } 156 | property OnDataAppearUnsafe: TNotifyEvent read FOnDataAppearUnsafe write FOnDataAppearUnsafe; 157 | end; 158 | 159 | function ExtractFirstWord(var s: string; const delimiter: string = ' '): string; 160 | 161 | implementation 162 | 163 | function ExtractFirstWord(var s: string; const delimiter: string = ' '): string; 164 | var 165 | i: Integer; 166 | begin 167 | Result := ''; 168 | i := Pos(delimiter, s); 169 | if i > 0 then 170 | begin 171 | Result := Copy(s, 1, i - 1); 172 | s := Copy(s, i + 1, maxint); 173 | end 174 | else 175 | begin 176 | Result := s; 177 | s := ''; 178 | end; 179 | end; 180 | 181 | { TDataPortUART } 182 | 183 | constructor TDataPortUART.Create(AOwner: TComponent); 184 | begin 185 | inherited Create(AOwner); 186 | FLock := TSimpleRWSync.Create(); 187 | FPort := 'COM1'; 188 | FBaudRate := 9600; 189 | FDataBits := 8; 190 | FParity := 'N'; 191 | FStopBits := stb1; 192 | FFlowControl := sfcNone; 193 | FMinDataBytes := 1; 194 | FActive := False; 195 | //Self.slReadData := TStringList.Create(); 196 | FReadDataStr := ''; 197 | RegisterDataportNotify(Self); 198 | end; 199 | 200 | procedure TDataPortUART.Open(const AInitStr: string = ''); 201 | var 202 | s, ss: string; 203 | begin 204 | ss := AInitStr; 205 | 206 | // Port 207 | s := ExtractFirstWord(ss, ','); 208 | if s <> '' then 209 | FPort := s; 210 | 211 | // BaudRate 212 | s := ExtractFirstWord(ss, ','); 213 | FBaudRate := StrToIntDef(s, FBaudRate); 214 | 215 | // DataBits 216 | s := ExtractFirstWord(ss, ','); 217 | FDataBits := StrToIntDef(s, FDataBits); 218 | 219 | // Parity 220 | s := ExtractFirstWord(ss, ','); 221 | if s <> '' then 222 | FParity := AnsiChar(s[1]); 223 | if Pos(FParity, 'NOEMSnoems') = 0 then 224 | FParity := 'N'; 225 | 226 | // StopBits 227 | s := ExtractFirstWord(ss, ','); 228 | if s = '1' then 229 | FStopBits := stb1 230 | else if s = '1.5' then 231 | FStopBits := stb15 232 | else if s = '2' then 233 | FStopBits := stb2; 234 | 235 | FFlowControl := sfcNone; 236 | // SoftFlow 237 | s := ExtractFirstWord(ss, ','); 238 | if s = '1' then 239 | FFlowControl := sfcSoft; 240 | 241 | // HardFlow 242 | s := ExtractFirstWord(ss, ','); 243 | if s = '1' then 244 | FFlowControl := sfcSend; 245 | 246 | // don't inherits Open() - OnOpen event will be after successfull connection 247 | end; 248 | 249 | destructor TDataPortUART.Destroy(); 250 | begin 251 | UnRegisterDataportNotify(Self); 252 | FreeAndNil(FLock); 253 | inherited Destroy(); 254 | end; 255 | 256 | procedure TDataPortUART.OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); 257 | begin 258 | if AMsg <> '' then 259 | begin 260 | if FLock.BeginWrite then 261 | begin 262 | try 263 | FReadDataStr := FReadDataStr + AMsg; 264 | finally 265 | FLock.EndWrite; 266 | end; 267 | 268 | NotifyDataport(Self, DP_NOTIFY_DATA); 269 | 270 | if Assigned(OnDataAppearUnsafe) then 271 | OnDataAppearUnsafe(Self); 272 | end; 273 | end 274 | else 275 | begin 276 | FModemStatus := GetModemStatus(); 277 | if Assigned(OnModemStatus) then 278 | OnModemStatus(Self); 279 | end; 280 | end; 281 | 282 | procedure TDataPortUART.OnErrorHandler(Sender: TObject; const AMsg: AnsiString); 283 | begin 284 | FActive := False; 285 | if (AMsg <> '') and Assigned(OnError) then 286 | //OnError(Self, AMsg) 287 | NotifyDataport(Self, DP_NOTIFY_ERROR, AMsg) 288 | else if Assigned(OnClose) then 289 | NotifyDataport(Self, DP_NOTIFY_CLOSE) 290 | //OnClose(Self); 291 | end; 292 | 293 | procedure TDataPortUART.OnConnectHandler(Sender: TObject); 294 | begin 295 | FActive := True; 296 | if Assigned(OnOpen) then 297 | //OnOpen(Self); 298 | NotifyDataport(Self, DP_NOTIFY_OPEN); 299 | end; 300 | 301 | function TDataPortUART.Peek(ASize: Integer): AnsiString; 302 | begin 303 | FLock.BeginRead(); 304 | try 305 | Result := Copy(FReadDataStr, 1, ASize); 306 | finally 307 | FLock.EndRead(); 308 | end; 309 | end; 310 | 311 | function TDataPortUART.PeekSize(): Cardinal; 312 | begin 313 | FLock.BeginRead(); 314 | try 315 | Result := Cardinal(Length(FReadDataStr)); 316 | finally 317 | FLock.EndRead(); 318 | end; 319 | end; 320 | 321 | function TDataPortUART.GetModemStatus(): TModemStatus; 322 | begin 323 | Result := FModemStatus; 324 | end; 325 | 326 | procedure TDataPortUART.SetDTR(AValue: Boolean); 327 | begin 328 | FModemStatus.DTR := AValue; 329 | end; 330 | 331 | procedure TDataPortUART.SetRTS(AValue: Boolean); 332 | begin 333 | FModemStatus.RTS := AValue; 334 | end; 335 | 336 | function TDataPortUART.Pull(ASize: Integer): AnsiString; 337 | begin 338 | Result := ''; 339 | if FLock.BeginWrite() then 340 | begin 341 | try 342 | Result := Copy(FReadDataStr, 1, ASize); 343 | Delete(FReadDataStr, 1, ASize); 344 | finally 345 | FLock.EndWrite(); 346 | end; 347 | end; 348 | end; 349 | 350 | procedure TDataPortUART.SetHardFlow(AValue: Boolean); 351 | begin 352 | FHardFlow := AValue; 353 | if FHardFlow then 354 | FFlowControl := sfcSend; 355 | end; 356 | 357 | procedure TDataPortUART.SetSoftFlow(AValue: Boolean); 358 | begin 359 | FSoftFlow := AValue; 360 | if FSoftFlow then 361 | FFlowControl := sfcSoft; 362 | end; 363 | 364 | procedure TDataPortUART.SetBaudRate(AValue: Integer); 365 | begin 366 | FBaudRate := AValue; 367 | end; 368 | 369 | procedure TDataPortUART.SetDataBits(AValue: Integer); 370 | begin 371 | if (AValue < 5) or (AValue > 9) then 372 | Exit; 373 | FDataBits := AValue; 374 | end; 375 | 376 | procedure TDataPortUART.SetFlowControl(AValue: TSerialFlowControl); 377 | begin 378 | FFlowControl := AValue; 379 | end; 380 | 381 | procedure TDataPortUART.SetParity(AValue: AnsiChar); 382 | begin 383 | if Pos(AValue, 'NOEMSnoems') > 0 then 384 | FParity := AValue; 385 | end; 386 | 387 | procedure TDataPortUART.SetStopBits(AValue: TSerialStopBits); 388 | begin 389 | FStopBits := AValue; 390 | end; 391 | 392 | end. 393 | -------------------------------------------------------------------------------- /DataPortFile.pas: -------------------------------------------------------------------------------- 1 | { 2 | Sergey Bodrov, 2012-2016 3 | 4 | Data exchange via file. Suitable for device files (/dev/* under Unix or special 5 | files in Windows). Conventional data files can be used too. 6 | 7 | Properties: 8 | Filename - Path (optionally) and name of file. 9 | FilePos - Current position in file, bytes from beginning (for conventional files). 10 | QueryInterval - Interval for checking changes in file, milliseconds. 11 | MinDataBytes - Minimum number of bytes in buffer for triggering OnDataAppear event. 12 | KeepOpen - Keep the file open between read and write operations: 13 | True - file stay opened 14 | False - file will be opened before every read/write operation and closed after. 15 | WriteMode - File write mode: 16 | fwmRewrite - every write apply to beginning of file 17 | fwmAppend - data written from last operation position or appended to the end of file 18 | 19 | Methods: 20 | Open() - Opens file with given name, "file:" prefix can be used. 21 | } 22 | { TODO : Add thread-safe file reader } 23 | unit DataPortFile; 24 | 25 | interface 26 | 27 | uses SysUtils, Classes, DataPort 28 | {$IFDEF UNIX} 29 | , BaseUnix 30 | {$ENDIF} 31 | {$ifndef FPC} 32 | , Windows 33 | {$endif}; 34 | 35 | type 36 | TFileWriteMode = (fwmRewrite, fwmAppend); 37 | 38 | { TDataPortFile } 39 | 40 | TDataPortFile = class(TDataPort) 41 | private 42 | sReadData: AnsiString; 43 | lock: TMultiReadExclusiveWriteSynchronizer; 44 | FFileHandle: THandle; 45 | FFileName: string; 46 | FFilePos: Cardinal; 47 | FQueryInterval: Cardinal; 48 | FMinDataBytes: Cardinal; 49 | FKeepOpen: boolean; 50 | FWriteMode: TFileWriteMode; 51 | procedure OnIncomingMsgHandler(Sender: TObject; const AMsg: string); 52 | procedure OnErrorHandler(Sender: TObject; const AMsg: string); 53 | procedure ReadToSelf(); 54 | protected 55 | procedure SetActive(Val: boolean); override; 56 | public 57 | constructor Create(AOwner: TComponent); override; 58 | destructor Destroy(); override; 59 | { Opens file with given name, "file:" prefix can be used } 60 | procedure Open(const AInitStr: string = ''); override; 61 | procedure Close(); override; 62 | function Push(const AData: AnsiString): boolean; override; 63 | function Pull(size: Integer = MaxInt): AnsiString; override; 64 | function Peek(size: Integer = MaxInt): AnsiString; override; 65 | function PeekSize(): Cardinal; override; 66 | function ioctl_cmd(const ACmd: string): string; 67 | published 68 | property Active; 69 | { Path (optionally) and name of file } 70 | property FileName: string read FFileName write FFileName; 71 | { Current position in file, bytes from beginning (for conventional files) } 72 | property FilePos: Cardinal read FFilePos write FFilePos; 73 | { Interval for checking changes in file, milliseconds } 74 | property QueryInterval: Cardinal read FQueryInterval write FQueryInterval; 75 | { Minimum number of bytes in buffer for triggering OnDataAppear event } 76 | property MinDataBytes: Cardinal read FMinDataBytes write FMinDataBytes; 77 | { Keep the file open between read and write operations: 78 | True - file stay opened 79 | False - file will be opened before every read/write operation and closed after. } 80 | property KeepOpen: boolean read FKeepOpen write FKeepOpen; 81 | { WriteMode - File write mode: 82 | fwmRewrite - every write apply to beginning of file 83 | fwmAppend - data written from last operation position or appended to the end of file } 84 | property WriteMode: TFileWriteMode read FWriteMode write FWriteMode; 85 | property OnDataAppear; 86 | property OnError; 87 | property OnOpen; 88 | property OnClose; 89 | end; 90 | 91 | procedure Register; 92 | 93 | 94 | implementation 95 | 96 | {$ifndef FPC} 97 | const 98 | feInvalidHandle = INVALID_HANDLE_VALUE; 99 | fsFromBeginning = 0; 100 | fsFromEnd = 2; 101 | 102 | procedure FileTruncate(AFileHandle: Cardinal; ASize: Cardinal); 103 | begin 104 | FileSeek(AFileHandle, ASize, fsFromBeginning); 105 | SetEndOfFile(AFileHandle); 106 | end; 107 | 108 | {$endif} 109 | 110 | procedure Register; 111 | begin 112 | RegisterComponents('DataPort', [TDataPortFile]); 113 | end; 114 | 115 | 116 | { TDataPortFile } 117 | 118 | constructor TDataPortFile.Create(AOwner: TComponent); 119 | begin 120 | inherited Create(AOwner); 121 | self.lock := TMultiReadExclusiveWriteSynchronizer.Create(); 122 | sReadData := ''; 123 | FFilePos := 0; 124 | FQueryInterval := 100; 125 | FMinDataBytes := 1; 126 | FFileHandle := feInvalidHandle; 127 | FKeepOpen := False; 128 | FWriteMode := fwmAppend; 129 | FActive := False; 130 | end; 131 | 132 | procedure TDataPortFile.Open(const AInitStr: string = ''); 133 | var 134 | n: Integer; 135 | begin 136 | // Set filename from init string 137 | if AInitStr <> '' then 138 | begin 139 | n := Pos(':', AInitStr); 140 | if n > 0 then 141 | begin 142 | Self.FFileName := Copy(AInitStr, n + 1, MaxInt); 143 | end 144 | else 145 | Self.FFileName := AInitStr; 146 | end; 147 | 148 | if FFileName = '' then 149 | Exit; 150 | if not FileExists(FFileName) then 151 | begin 152 | // file not exists - test file create and write 153 | try 154 | FFileHandle := FileCreate(FFileName); 155 | except 156 | FFileHandle := feInvalidHandle; 157 | end; 158 | if FFileHandle = feInvalidHandle then 159 | Exit; 160 | {$ifdef CHECK_FILE_WRITE} 161 | // try to write first char of filename into file 162 | try 163 | FileWrite(FFileHandle, FFileName[1], 1); 164 | FileTruncate(FFileHandle, 0); 165 | if not FKeepOpen then 166 | begin 167 | FileClose(FFileHandle); 168 | FFileHandle := feInvalidHandle; 169 | end; 170 | except 171 | FileClose(FFileHandle); 172 | FFileHandle := feInvalidHandle; 173 | Exit; 174 | end; 175 | {$endif} 176 | end 177 | else 178 | begin 179 | if KeepOpen then 180 | begin 181 | try 182 | FFileHandle := FileOpen(FFileName, fmOpenReadWrite); 183 | except 184 | FFileHandle := feInvalidHandle; 185 | end; 186 | if FFileHandle = feInvalidHandle then 187 | Exit; 188 | if WriteMode = fwmAppend then 189 | FileSeek(FFileHandle, 0, fsFromEnd); 190 | end; 191 | end; 192 | inherited Open(AInitStr); 193 | end; 194 | 195 | procedure TDataPortFile.Close(); 196 | begin 197 | if KeepOpen or (FFileHandle <> feInvalidHandle) then 198 | begin 199 | FileClose(FFileHandle); 200 | FFileHandle := feInvalidHandle; 201 | end; 202 | inherited Close(); 203 | end; 204 | 205 | destructor TDataPortFile.Destroy(); 206 | begin 207 | FreeAndNil(self.lock); 208 | inherited Destroy(); 209 | end; 210 | 211 | procedure TDataPortFile.OnIncomingMsgHandler(Sender: TObject; const AMsg: string); 212 | begin 213 | if AMsg <> '' then 214 | begin 215 | if lock.BeginWrite then 216 | begin 217 | sReadData := sReadData + AMsg; 218 | lock.EndWrite; 219 | 220 | if Cardinal(Length(sReadData)) >= FMinDataBytes then 221 | begin 222 | if Assigned(FOnDataAppear) then 223 | FOnDataAppear(self); 224 | end; 225 | end; 226 | 227 | end; 228 | end; 229 | 230 | procedure TDataPortFile.OnErrorHandler(Sender: TObject; const AMsg: string); 231 | begin 232 | if Assigned(Self.FOnError) then 233 | Self.FOnError(Self, AMsg); 234 | end; 235 | 236 | procedure TDataPortFile.ReadToSelf(); 237 | var 238 | buf: array [0..1023] of byte; 239 | s: string; 240 | res: Integer; 241 | begin 242 | if not KeepOpen then 243 | begin 244 | // open file 245 | if FFileName = '' then 246 | Exit; 247 | try 248 | FFileHandle := FileOpen(FFileName, fmOpenReadWrite or fmShareDenyNone); 249 | if WriteMode = fwmAppend then 250 | FileSeek(FFileHandle, FilePos, fsFromBeginning); 251 | except 252 | on E: Exception do 253 | begin 254 | if Assigned(FOnError) then 255 | FOnError(Self, E.Message); 256 | Exit; 257 | end; 258 | end; 259 | end; 260 | 261 | // read data to buf 262 | try 263 | res := FileRead(FFileHandle, buf, SizeOf(buf)); 264 | except 265 | on E: Exception do 266 | begin 267 | if Assigned(FOnError) then 268 | FOnError(Self, E.Message); 269 | Exit; 270 | end; 271 | end; 272 | 273 | // if write-mode Rewrite then truncate readed data 274 | if WriteMode = fwmRewrite then 275 | FileTruncate(FFileHandle, 0) 276 | else if (WriteMode = fwmAppend) and (res > 0) then 277 | FilePos := FilePos + Cardinal(res); 278 | 279 | 280 | // read data from buf to result 281 | {$ifdef FPC} 282 | SetString(s, @buf, res); 283 | {$else} 284 | SetString(s, PChar(@buf), res); 285 | {$endif} 286 | sReadData := sReadData + s; 287 | 288 | if not KeepOpen then 289 | begin 290 | // close file 291 | FileClose(FFileHandle); 292 | FFileHandle := feInvalidHandle; 293 | end; 294 | end; 295 | 296 | function TDataPortFile.Peek(size: Integer = MaxInt): AnsiString; 297 | begin 298 | lock.BeginRead(); 299 | try 300 | ReadToSelf(); 301 | Result := Copy(sReadData, 1, size); 302 | finally 303 | lock.EndRead(); 304 | end; 305 | end; 306 | 307 | function TDataPortFile.PeekSize(): Cardinal; 308 | begin 309 | lock.BeginRead(); 310 | try 311 | ReadToSelf(); 312 | Result := Cardinal(Length(sReadData)); 313 | finally 314 | lock.EndRead(); 315 | end; 316 | end; 317 | 318 | function TDataPortFile.ioctl_cmd(const ACmd: string): string; 319 | {$IFDEF UNIX} 320 | var 321 | iArg, iRes: Integer; 322 | {$ENDIF} 323 | begin 324 | { 325 | * Per POSIX guidelines, this module reserves the LP and lp prefixes 326 | * These are the lp_table[minor].flags flags... 327 | #define LP_EXIST 0x0001 328 | #define LP_SELEC 0x0002 329 | #define LP_BUSY 0x0004 330 | #define LP_BUSY_BIT_POS 2 331 | #define LP_OFFL 0x0008 332 | #define LP_NOPA 0x0010 333 | #define LP_ERR 0x0020 334 | #define LP_ABORT 0x0040 335 | #define LP_CAREFUL 0x0080 /* obsoleted -arca */ 336 | #define LP_ABORTOPEN 0x0100 337 | 338 | * bit defines for 8255 status port 339 | * base + 1 340 | * accessed with LP_S(minor), which gets the byte... 341 | #define LP_PBUSY 0x80 /* inverted input, active high */ 342 | #define LP_PACK 0x40 /* unchanged input, active low */ 343 | #define LP_POUTPA 0x20 /* unchanged input, active high */ 344 | #define LP_PSELECD 0x10 /* unchanged input, active high */ 345 | #define LP_PERRORP 0x08 /* unchanged input, active low */ 346 | 347 | #define LPGETSTATUS 0x060b /* return LP_S(minor) */ 348 | #define LPRESET 0x060c /* reset printer */ 349 | 350 | } 351 | Result := ''; 352 | 353 | if not KeepOpen then 354 | begin 355 | // open file 356 | if FFileName = '' then 357 | Exit; 358 | try 359 | FFileHandle := FileOpen(FFileName, fmOpenReadWrite or fmShareDenyNone); 360 | except 361 | on E: Exception do 362 | begin 363 | if Assigned(FOnError) then 364 | FOnError(Self, E.Message); 365 | Exit; 366 | end; 367 | end; 368 | end; 369 | 370 | if ACmd = 'LPGETSTATUS' then 371 | begin 372 | {$IFDEF UNIX} 373 | iRes := FpIOCtl(FFileHandle, $060b, @iArg); 374 | Result := IntToHex(iArg, 4) + ' '; 375 | if (iArg and $80) > 0 then 376 | Result := Result + 'busy '; // busy input 377 | if (iArg and $40) = 0 then 378 | Result := Result + 'ack '; // acknowleged input 379 | if (iArg and $20) > 0 then 380 | Result := Result + 'outpa '; // out-of-paper 381 | if (iArg and $10) > 0 then 382 | Result := Result + 'selectd '; // selected input 383 | if (iArg and $08) = 0 then 384 | Result := Result + 'errorp '; // error input 385 | {$ENDIF} 386 | end 387 | 388 | else if ACmd = 'LPRESET' then 389 | begin 390 | {$IFDEF UNIX} 391 | iRes := FpIOCtl(FFileHandle, $060c, @iArg); 392 | {$ENDIF} 393 | end; 394 | 395 | if not KeepOpen then 396 | begin 397 | // close file 398 | FileClose(FFileHandle); 399 | FFileHandle := feInvalidHandle; 400 | end; 401 | end; 402 | 403 | function TDataPortFile.Pull(size: Integer = MaxInt): AnsiString; 404 | begin 405 | Result := ''; 406 | if lock.BeginWrite() then 407 | begin 408 | try 409 | ReadToSelf(); 410 | Result := Copy(sReadData, 1, size); 411 | Delete(sReadData, 1, size); 412 | //sReadData:=''; 413 | finally 414 | lock.EndWrite(); 415 | end; 416 | end; 417 | end; 418 | 419 | function TDataPortFile.Push(const AData: AnsiString): boolean; 420 | var 421 | sErrMsg: string; 422 | begin 423 | Result := False; 424 | if Length(AData) = 0 then 425 | Exit; 426 | if lock.BeginWrite() then 427 | begin 428 | sErrMsg := ''; 429 | try 430 | if KeepOpen then 431 | begin 432 | try 433 | if Length(AData) > 0 then 434 | FileWrite(FFileHandle, PAnsiChar(AData)^, Length(AData)); 435 | Result := True; 436 | except 437 | on E: Exception do 438 | begin 439 | sErrMsg := E.Message; 440 | end; 441 | end; 442 | end 443 | else 444 | begin 445 | if FFileName = '' then 446 | Exit; 447 | try 448 | //FFileHandle:=FileOpen(FFileName, fmOpenReadWrite or fmShareCompat); 449 | FFileHandle := FileOpen(FFileName, fmOpenReadWrite or fmShareDenyWrite); 450 | if WriteMode = fwmAppend then 451 | FileSeek(FFileHandle, 0, fsFromEnd); 452 | if Length(AData) > 0 then 453 | FileWrite(FFileHandle, PAnsiChar(AData)^, Length(AData)); 454 | FileClose(FFileHandle); 455 | Result := True; 456 | except 457 | on E: Exception do 458 | begin 459 | sErrMsg := E.Message; 460 | end; 461 | end; 462 | FFileHandle := feInvalidHandle; 463 | end; 464 | 465 | finally 466 | lock.EndWrite(); 467 | end; 468 | 469 | if Assigned(FOnError) and (sErrMsg <> '') then 470 | FOnError(Self, sErrMsg); 471 | end; 472 | end; 473 | 474 | procedure TDataPortFile.SetActive(Val: boolean); 475 | begin 476 | inherited SetActive(Val); 477 | //if FActive then Open(); 478 | //else if Assigned(self.IpClient) then FreeAndNil(self.IpClient); 479 | end; 480 | 481 | end. 482 | -------------------------------------------------------------------------------- /DataPortHTTP.pas: -------------------------------------------------------------------------------- 1 | { 2 | Allows you to communicate via HTTP. Specify URL and request parameters, 3 | then call Push() to connect and transfer data to a remote server. 4 | After successful execution of the request, data can be read from the input buffer. 5 | Large amounts of data received by parts, and OnDataAppear event can be triggered multiple times. 6 | 7 | If POST method selected, then request parameter mime-type='application/x-www-form-urlencoded' set, 8 | it allow transfer parameters as web form values. 9 | 10 | Sergey Bodrov, 2012-2025 11 | 12 | Properties: 13 | Url - address and params string, URL 14 | Params - HTTP request params in name=value format 15 | Method - HTTP request method 16 | httpGet - GET 17 | httpPost - POST 18 | 19 | Methods: 20 | Open() - sets URL string for HTTP request, but not send request itself. Request will be sent on Push(). URL string format: 21 | URL = 'http://RemoteHost:RemotePort/Path' 22 | RemoteHost - IP-address or name of remote host 23 | RemotePort - remote UPD or TCP port number 24 | Path - path to requested resource 25 | } 26 | unit DataPortHTTP; 27 | 28 | interface 29 | 30 | uses SysUtils, Classes, DataPort, httpsend, synautil, synacode; 31 | 32 | type 33 | THttpMethods = (httpGet, httpPost); 34 | 35 | THttpClient = class(TThread) 36 | private 37 | HttpSend: THTTPSend; 38 | s: string; 39 | sLastError: string; 40 | FOnIncomingMsgEvent: TMsgEvent; 41 | FOnErrorEvent: TMsgEvent; 42 | procedure SyncProc(); 43 | protected 44 | procedure Execute(); override; 45 | public 46 | url: string; 47 | method: THttpMethods; 48 | Data: string; 49 | property OnIncomingMsgEvent: TMsgEvent read FOnIncomingMsgEvent write FOnIncomingMsgEvent; 50 | property OnErrorEvent: TMsgEvent read FOnErrorEvent write FOnErrorEvent; 51 | function SendString(s: string): Boolean; 52 | procedure SendStream(st: TStream; Dest: string); 53 | end; 54 | 55 | { TDataPortHTTP } 56 | 57 | TDataPortHTTP = class(TDataPort) 58 | private 59 | //slReadData: TStringList; // for storing every incoming data packet separately 60 | sReadData: AnsiString; 61 | lock: TMultiReadExclusiveWriteSynchronizer; 62 | HttpClient: THttpClient; 63 | HttpSend: THTTPSend; 64 | FUrl: string; 65 | FParams: TStrings; 66 | FMethod: THttpMethods; 67 | FSafeMode: Boolean; 68 | procedure OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); 69 | procedure OnErrorHandler(Sender: TObject; const AMsg: AnsiString); 70 | protected 71 | procedure FSetParams(Val: TStrings); 72 | public 73 | constructor Create(AOwner: TComponent); override; 74 | destructor Destroy(); override; 75 | { Open() - sets URL string for HTTP request, but not send request itself. Request will be sent on Push(). URL string format: 76 | URL = 'http://RemoteHost:RemotePort/Path' 77 | RemoteHost - IP-address or name of remote host 78 | RemotePort - remote UPD or TCP port number 79 | Path - path to requested resource } 80 | procedure Open(const AInitStr: string = ''); override; 81 | procedure Close(); override; 82 | function Push(const AData: AnsiString): Boolean; override; 83 | function Pull(size: Integer = MaxInt): AnsiString; override; 84 | function Peek(size: Integer = MaxInt): AnsiString; override; 85 | function PeekSize(): Cardinal; override; 86 | published 87 | { address and params string, URL } 88 | property Url: string read FUrl write FUrl; 89 | { HTTP request params in name=value format } 90 | property Params: TStrings read FParams write FSetParams; 91 | { Method - HTTP request method 92 | httpGet - GET 93 | httpPost - POST } 94 | property Method: THttpMethods read FMethod write FMethod; 95 | { Use this property if you encounter troubles: 96 | True - Non-threaded synchronous behavior 97 | False - Asynchronous behavior } 98 | property SafeMode: Boolean read FSafeMode write FSafeMode; 99 | property Active; 100 | property OnDataAppear; 101 | property OnError; 102 | property OnOpen; 103 | property OnClose; 104 | end; 105 | 106 | 107 | procedure Register; 108 | 109 | implementation 110 | 111 | procedure Register; 112 | begin 113 | RegisterComponents('DataPort', [TDataPortHTTP]); 114 | end; 115 | 116 | // === THttpClient === 117 | procedure THttpClient.SyncProc(); 118 | begin 119 | //if s:='' then Exit; 120 | if s <> '' then 121 | begin 122 | if Assigned(self.FOnIncomingMsgEvent) then 123 | FOnIncomingMsgEvent(self, s); 124 | s := ''; 125 | end; 126 | if sLastError <> '' then 127 | begin 128 | if Assigned(self.FOnErrorEvent) then 129 | FOnErrorEvent(self, sLastError); 130 | //self.Terminate(); 131 | end; 132 | end; 133 | 134 | procedure THttpClient.Execute(); 135 | var 136 | bResult: Boolean; 137 | sMethod: string; 138 | begin 139 | Self.HttpSend := THTTPSend.Create(); 140 | sLastError := ''; 141 | sMethod := 'GET'; 142 | synautil.WriteStrToStream(Self.HttpSend.Document, self.Data); 143 | if self.method = httpPost then 144 | begin 145 | sMethod := 'POST'; 146 | Self.HttpSend.MimeType := 'application/x-www-form-urlencoded'; 147 | end; 148 | 149 | try 150 | bResult := self.HttpSend.HTTPMethod(sMethod, Self.url); 151 | except 152 | bResult := False; 153 | end; 154 | 155 | if not bResult then 156 | begin 157 | sLastError := 'Cannot connect'; 158 | Synchronize(SyncProc); 159 | end; 160 | 161 | if Self.HttpSend.Document.Size = 0 then 162 | begin 163 | sLastError := 'Zero content size'; 164 | Synchronize(SyncProc); 165 | end; 166 | 167 | if self.HttpSend.DownloadSize <> Self.HttpSend.Document.Size then 168 | begin 169 | sLastError := 'Download size=' + IntToStr(self.HttpSend.DownloadSize) + 170 | ' doc size=' + IntToStr(Self.HttpSend.Document.Size); 171 | Synchronize(SyncProc); 172 | end; 173 | 174 | s := synautil.ReadStrFromStream(Self.HttpSend.Document, Self.HttpSend.Document.Size); 175 | Synchronize(SyncProc); 176 | Self.HttpSend.Clear(); 177 | FreeAndNil(Self.HttpSend); 178 | Terminate(); 179 | end; 180 | 181 | function THttpClient.SendString(s: string): Boolean; 182 | begin 183 | Result := False; 184 | if Assigned(Self.HttpSend) then 185 | Exit; 186 | self.Data := s; 187 | self.Suspended := False; 188 | Result := True; 189 | end; 190 | 191 | procedure THttpClient.SendStream(st: TStream; Dest: string); 192 | begin 193 | if Assigned(Self.HttpSend) then 194 | Exit; 195 | self.Data := synautil.ReadStrFromStream(st, st.Size); 196 | self.Suspended := False; 197 | end; 198 | 199 | 200 | { TDataPortHTTP } 201 | 202 | constructor TDataPortHTTP.Create(AOwner: TComponent); 203 | begin 204 | inherited Create(AOwner); 205 | self.lock := TMultiReadExclusiveWriteSynchronizer.Create(); 206 | FParams := TStringList.Create(); 207 | FMethod := httpGet; 208 | FActive := False; 209 | FSafeMode := True; 210 | //Self.slReadData:=TStringList.Create(); 211 | Self.sReadData := ''; 212 | Self.HttpClient := nil; 213 | end; 214 | 215 | procedure TDataPortHTTP.Open(const AInitStr: string); 216 | begin 217 | if Assigned(self.HttpClient) then 218 | FreeAndNil(self.HttpClient); 219 | if Length(AInitStr) > 0 then 220 | Url := AInitStr; 221 | if Length(Url) = 0 then 222 | begin 223 | if Assigned(Self.FOnError) then 224 | Self.FOnError(Self, 'Empty URL'); 225 | Exit; 226 | end; 227 | if not self.SafeMode then 228 | begin 229 | // threaded request 230 | Self.HttpClient := THttpClient.Create(True); 231 | Self.HttpClient.OnIncomingMsgEvent := self.OnIncomingMsgHandler; 232 | Self.HttpClient.OnErrorEvent := Self.OnErrorHandler; 233 | Self.HttpClient.url := Url; 234 | Self.HttpClient.FreeOnTerminate := True; 235 | Self.HttpClient.Suspended := False; 236 | end; 237 | inherited Open(AInitStr); 238 | end; 239 | 240 | procedure TDataPortHTTP.Close(); 241 | begin 242 | if not self.SafeMode then 243 | begin 244 | if Assigned(self.HttpClient) then 245 | begin 246 | //Self.HttpClient.OnIncomingMsgEvent:=nil; 247 | //Self.HttpClient.OnErrorEvent:=nil; 248 | self.HttpClient.Terminate(); 249 | //FreeAndNil(self.HttpClient); 250 | self.HttpClient := nil; 251 | end; 252 | end; 253 | inherited Close(); 254 | end; 255 | 256 | destructor TDataPortHTTP.Destroy(); 257 | begin 258 | if Assigned(self.HttpClient) then 259 | FreeAndNil(self.HttpClient); 260 | //FreeAndNil(self.slReadData); 261 | FreeAndNil(FParams); 262 | FreeAndNil(self.lock); 263 | inherited Destroy(); 264 | end; 265 | 266 | procedure TDataPortHTTP.OnIncomingMsgHandler(Sender: TObject; const AMsg: AnsiString); 267 | begin 268 | if AMsg <> '' then 269 | begin 270 | if lock.BeginWrite then 271 | begin 272 | //slReadData.Add(AMsg); 273 | sReadData := sReadData + AMsg; 274 | lock.EndWrite; 275 | 276 | if Assigned(FOnDataAppear) then 277 | FOnDataAppear(self); 278 | end 279 | else if Assigned(FOnError) then 280 | FOnError(self, 'Lock failed'); 281 | 282 | end; 283 | end; 284 | 285 | procedure TDataPortHTTP.OnErrorHandler(Sender: TObject; const AMsg: AnsiString); 286 | begin 287 | if Assigned(Self.FOnError) then 288 | Self.FOnError(Self, AMsg); 289 | self.FActive := False; 290 | end; 291 | 292 | { 293 | function TDataPortIP.Peek(size: Integer = MaxInt): AnsiString; 294 | var 295 | i, num, remain: Integer; 296 | begin 297 | Result:=''; 298 | remain:=size; 299 | lock.BeginRead(); 300 | for i:=0 to slReadData.Count do 301 | begin 302 | num:=Length(slReadData[i]); 303 | if num>remain then num:=remain; 304 | Result:=Result+Copy(slReadData[i], 1, num); 305 | remain:=remain-num; 306 | if remain<=0 then Break; 307 | end; 308 | lock.EndRead(); 309 | end; 310 | } 311 | 312 | function TDataPortHTTP.Peek(size: Integer = MaxInt): AnsiString; 313 | begin 314 | lock.BeginRead(); 315 | Result := Copy(sReadData, 1, size); 316 | lock.EndRead(); 317 | end; 318 | 319 | function TDataPortHTTP.PeekSize(): Cardinal; 320 | //var i: Integer; 321 | begin 322 | //Result:=0; 323 | lock.BeginRead(); 324 | //// Length of all strings 325 | //for i:=0 to slReadData.Count-1 do Result:=Result+Cardinal(Length(slReadData[i])); 326 | Result := Cardinal(Length(sReadData)); 327 | lock.EndRead(); 328 | end; 329 | 330 | { 331 | function TDataPortIP.Pull(size: Integer = MaxInt): AnsiString; 332 | var 333 | num, len, remain: Integer; 334 | begin 335 | Result:=''; 336 | remain:=size; 337 | if not lock.BeginWrite() then Exit; 338 | while slReadData.Count>0 do 339 | begin 340 | // we read every string to exclude line delimiters 341 | len:=Length(slReadData[0]); 342 | num:=len; 343 | if num>remain then num:=remain; 344 | Result:=Result+Copy(slReadData[0], 1, num); 345 | remain:=remain-num; 346 | if num>=len then slReadData.Delete(0) 347 | else 348 | begin 349 | Delete(slReadData[0], 1, num); 350 | Break; 351 | end; 352 | if remain<=0 then Break; 353 | end; 354 | lock.EndWrite(); 355 | end; 356 | } 357 | 358 | function TDataPortHTTP.Pull(size: Integer = MaxInt): AnsiString; 359 | begin 360 | Result := ''; 361 | if not lock.BeginWrite() then 362 | Exit; 363 | Result := Copy(sReadData, 1, size); 364 | Delete(sReadData, 1, size); 365 | //sReadData:=''; 366 | lock.EndWrite(); 367 | end; 368 | 369 | function TDataPortHTTP.Push(const AData: AnsiString): Boolean; 370 | var 371 | i: Integer; 372 | sUrl, sParams, sData: string; 373 | sMethod: string; 374 | bResult: Boolean; 375 | begin 376 | Result := False; 377 | 378 | sUrl := url; 379 | sData := AData; 380 | sParams := ''; 381 | // encode params into string 382 | for i := 0 to FParams.Count - 1 do 383 | begin 384 | if sParams <> '' then 385 | sParams := sParams + '&'; 386 | sParams := sParams + synacode.EncodeURL(FParams[i]); 387 | end; 388 | 389 | if method = httpGet then 390 | begin 391 | if FParams.Count > 0 then 392 | begin 393 | sUrl := sUrl + '?' + sParams; 394 | end; 395 | end 396 | else if method = httpPost then 397 | begin 398 | sData := sParams + AData; 399 | end; 400 | 401 | if self.SafeMode then 402 | begin 403 | // non-threaded 404 | Self.HttpSend := THTTPSend.Create(); 405 | sMethod := 'GET'; 406 | synautil.WriteStrToStream(Self.HttpSend.Document, sData); 407 | if self.method = httpPost then 408 | begin 409 | sMethod := 'POST'; 410 | Self.HttpSend.MimeType := 'application/x-www-form-urlencoded'; 411 | end; 412 | 413 | try 414 | bResult := self.HttpSend.HTTPMethod(sMethod, sUrl); 415 | except 416 | bResult := False; 417 | end; 418 | 419 | if not bResult then 420 | begin 421 | if Assigned(OnError) then 422 | OnError(self, 'Cannot connect'); 423 | end 424 | 425 | else if Self.HttpSend.Document.Size = 0 then 426 | begin 427 | if Assigned(OnError) then 428 | OnError(self, 'Zero content size'); 429 | end 430 | 431 | else 432 | begin 433 | if lock.BeginWrite() then 434 | begin 435 | try 436 | sReadData := sReadData + synautil.ReadStrFromStream(Self.HttpSend.Document, 437 | Self.HttpSend.Document.Size); 438 | finally 439 | lock.EndWrite(); 440 | end; 441 | end; 442 | if Assigned(OnDataAppear) then 443 | OnDataAppear(self); 444 | end; 445 | 446 | FreeAndNil(Self.HttpSend); 447 | end 448 | else 449 | begin 450 | // threaded 451 | if not Assigned(self.HttpClient) then 452 | Exit; 453 | if not Active then 454 | Exit; 455 | if lock.BeginWrite() then 456 | begin 457 | try 458 | HttpClient.url := FUrl; 459 | HttpClient.method := FMethod; 460 | sParams := ''; 461 | for i := 0 to FParams.Count - 1 do 462 | begin 463 | if sParams <> '' then 464 | sParams := sParams + '&'; 465 | sParams := sParams + synacode.EncodeURL(FParams[i]); 466 | end; 467 | 468 | if method = httpGet then 469 | begin 470 | if FParams.Count > 0 then 471 | begin 472 | HttpClient.url := HttpClient.url + '?' + sParams; 473 | self.HttpClient.SendString(AData); 474 | end; 475 | end 476 | else if method = httpPost then 477 | begin 478 | HttpClient.SendString(sParams + AData); 479 | end; 480 | Result := True; 481 | 482 | finally 483 | lock.EndWrite(); 484 | end; 485 | end; 486 | end; 487 | end; 488 | 489 | procedure TDataPortHTTP.FSetParams(Val: TStrings); 490 | begin 491 | FParams.Assign(Val); 492 | end; 493 | 494 | end. 495 | -------------------------------------------------------------------------------- /DataPortSerial.pas: -------------------------------------------------------------------------------- 1 | { 2 | Serial communication port (UART). In Windows it COM-port, real or virtual. 3 | In Linux it /dev/ttyS or /dev/ttyUSB. Also, Linux use file /var/lock/LCK..ttyS for port locking 4 | 5 | (C) Sergey Bodrov, 2012-2025 6 | 7 | Properties: 8 | Port - port name (COM1, /dev/ttyS01) 9 | BaudRate - data excange speed 10 | MinDataBytes - minimal bytes count in buffer for triggering event OnDataAppear 11 | 12 | Methods: 13 | Open() - Opens port. As parameter it use port initialization string: 14 | InitStr = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 15 | 16 | Port - COM port name (COM1, /dev/ttyS01) 17 | BaudRate - connection speed (50..4000000 bits per second), default 9600 18 | DataBits - default 8 19 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 20 | StopBits - (1, 1.5, 2) 21 | SoftFlow - Enable XON/XOFF byte ($11 for resume and $13 for pause transmission), default 1 22 | HardFlow - Enable CTS/RTS handshake, default 0 23 | 24 | Events: 25 | OnOpen - Triggered after sucсessful connection. 26 | OnClose - Triggered after disconnection. 27 | } 28 | unit DataPortSerial; 29 | 30 | {$IFDEF FPC} 31 | {$MODE DELPHI} 32 | {$DEFINE NO_LIBC} 33 | {$ENDIF} 34 | 35 | interface 36 | 37 | uses 38 | {$IFNDEF MSWINDOWS} 39 | {$IFNDEF NO_LIBC} 40 | Libc, 41 | KernelIoctl, 42 | {$ELSE} 43 | termio, baseunix, unix, 44 | {$ENDIF} 45 | {$IFNDEF FPC} 46 | Types, 47 | {$ENDIF} 48 | {$ELSE} 49 | Windows, 50 | {$ENDIF} 51 | SysUtils, Classes, DataPort, DataPortUART, DataPortEventer, synaser, synautil; 52 | 53 | type 54 | { TSerialClient - serial port reader/writer, based on Ararat Synapse } 55 | TSerialClient = class(TThread) 56 | private 57 | FSerial: TBlockSerial; 58 | sFromPort: AnsiString; 59 | sData: AnsiString; 60 | sLastError: string; 61 | FSafeMode: Boolean; 62 | FOnIncomingMsgEvent: TMsgEvent; 63 | FOnErrorEvent: TMsgEvent; 64 | FOnConnectEvent: TNotifyEvent; 65 | FDoConfig: Boolean; 66 | FLock: TSimpleRWSync; 67 | procedure SyncProc(); 68 | procedure SyncProcOnError(); 69 | procedure SyncProcOnConnect(); 70 | protected 71 | FParentDataPort: TDataPortUART; 72 | function IsError(): Boolean; 73 | procedure Execute(); override; 74 | public 75 | sPort: string; 76 | BaudRate: Integer; 77 | DataBits: Integer; 78 | Parity: AnsiChar; 79 | StopBits: TSerialStopBits; 80 | FlowControl: TSerialFlowControl; 81 | CalledFromThread: Boolean; 82 | TxData: AnsiString; 83 | SleepInterval: Integer; 84 | TxPortionSize: Integer; // max bytes to send in one operation 85 | constructor Create(AParent: TDataPortUART); reintroduce; 86 | destructor Destroy(); override; 87 | property SafeMode: Boolean read FSafeMode write FSafeMode; 88 | property Serial: TBlockSerial read FSerial; 89 | property OnIncomingMsgEvent: TMsgEvent read FOnIncomingMsgEvent 90 | write FOnIncomingMsgEvent; 91 | property OnErrorEvent: TMsgEvent read FOnErrorEvent write FOnErrorEvent; 92 | property OnConnectEvent: TNotifyEvent read FOnConnectEvent write FOnConnectEvent; 93 | { Set port parameters (baud rate, data bits, etc..) } 94 | procedure Config(); 95 | function SendString(const AData: AnsiString): Boolean; 96 | procedure SendStream(st: TStream); 97 | end; 98 | 99 | { TDataPortSerial - serial DataPort } 100 | TDataPortSerial = class(TDataPortUART) 101 | private 102 | FSerialClient: TSerialClient; 103 | function CloseClient(): Boolean; 104 | protected 105 | procedure SetBaudRate(AValue: Integer); override; 106 | procedure SetDataBits(AValue: Integer); override; 107 | procedure SetParity(AValue: AnsiChar); override; 108 | procedure SetStopBits(AValue: TSerialStopBits); override; 109 | procedure SetFlowControl(AValue: TSerialFlowControl); override; 110 | public 111 | constructor Create(AOwner: TComponent); override; 112 | destructor Destroy(); override; 113 | { Open serial DataPort 114 | InitStr = 'Port,BaudRate,DataBits,Parity,StopBits,SoftFlow,HardFlow' 115 | 116 | Port - COM port name (COM1, /dev/tty01) 117 | BaudRate - connection speed (50..4000000 bits per second), default 9600 118 | DataBits - default 8 119 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 120 | StopBits - (1, 1.5, 2) 121 | SoftFlow - Enable XON/XOFF handshake, default 0 122 | HardFlow - Enable CTS/RTS handshake, default 0 } 123 | procedure Open(const AInitStr: string = ''); override; 124 | procedure Close(); override; 125 | function Push(const AData: AnsiString): Boolean; override; 126 | class function GetSerialPortNames(): string; 127 | 128 | { Get modem wires status (DSR,CTS,Ring,Carrier) } 129 | function GetModemStatus(): TModemStatus; override; 130 | { Set DTR (Data Terminal Ready) signal } 131 | procedure SetDTR(AValue: Boolean); override; 132 | { Set RTS (Request to send) signal } 133 | procedure SetRTS(AValue: Boolean); override; 134 | 135 | property SerialClient: TSerialClient read FSerialClient; 136 | 137 | published 138 | { Serial port name (COM1, /dev/ttyS01) } 139 | property Port: string read FPort write FPort; 140 | { BaudRate - connection speed (50..4000000 bits per second), default 9600 } 141 | property BaudRate: Integer read FBaudRate write SetBaudRate; 142 | { DataBits - default 8 (5 for Baudot code, 7 for true ASCII) } 143 | property DataBits: Integer read FDataBits write SetDataBits; 144 | { Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N } 145 | property Parity: AnsiChar read FParity write SetParity; 146 | { StopBits - (stb1, stb15, stb2), default stb1 } 147 | property StopBits: TSerialStopBits read FStopBits write SetStopBits; 148 | { FlowControl - (sfcNone, sfcSend, sfcReady, sfcSoft) default sfcNone } 149 | property FlowControl: TSerialFlowControl read FFlowControl write SetFlowControl; 150 | { Minimum bytes in incoming buffer to trigger OnDataAppear } 151 | property MinDataBytes: Integer read FMinDataBytes write FMinDataBytes; 152 | property Active; 153 | property OnDataAppear; 154 | property OnError; 155 | property OnOpen; 156 | property OnClose; 157 | end; 158 | 159 | procedure Register; 160 | 161 | implementation 162 | 163 | procedure Register; 164 | begin 165 | RegisterComponents('DataPort', [TDataPortSerial]); 166 | end; 167 | 168 | // === TSerialClient === 169 | constructor TSerialClient.Create(AParent: TDataPortUART); 170 | begin 171 | FLock := TSimpleRWSync.Create(); 172 | inherited Create(True); 173 | FParentDataPort := AParent; 174 | SleepInterval := 1; 175 | TxPortionSize := 1024; 176 | end; 177 | 178 | destructor TSerialClient.Destroy(); 179 | begin 180 | inherited Destroy(); 181 | FreeAndNil(FLock); // need to be AFTER destroy 182 | end; 183 | 184 | procedure TSerialClient.Config(); 185 | begin 186 | FDoConfig := True; 187 | end; 188 | 189 | procedure TSerialClient.SyncProc(); 190 | begin 191 | if not CalledFromThread then 192 | begin 193 | CalledFromThread := True; 194 | try 195 | if Assigned(OnIncomingMsgEvent) then 196 | OnIncomingMsgEvent(Self, sFromPort); 197 | finally 198 | CalledFromThread := False; 199 | end; 200 | end; 201 | end; 202 | 203 | procedure TSerialClient.SyncProcOnError(); 204 | begin 205 | if not CalledFromThread then 206 | begin 207 | CalledFromThread := True; 208 | try 209 | if Assigned(OnErrorEvent) then 210 | OnErrorEvent(Self, sLastError); 211 | finally 212 | CalledFromThread := False; 213 | end; 214 | end; 215 | end; 216 | 217 | procedure TSerialClient.SyncProcOnConnect(); 218 | begin 219 | if not CalledFromThread then 220 | begin 221 | CalledFromThread := True; 222 | try 223 | if Assigned(OnConnectEvent) then 224 | OnConnectEvent(Self); 225 | finally 226 | CalledFromThread := False; 227 | end; 228 | end; 229 | end; 230 | 231 | function TSerialClient.IsError(): Boolean; 232 | begin 233 | Result := (Serial.LastError <> 0) and (Serial.LastError <> ErrTimeout); 234 | if Result then 235 | begin 236 | sLastError := Serial.GetErrorDesc(Serial.LastError); 237 | //sLastError := sLastError + ' OutBuf=' + IntToStr(Serial.SendingData); 238 | //sLastError := sLastError + ' InBuf=' + IntToStr(Serial.WaitingData); 239 | if Assigned(OnErrorEvent) then 240 | OnErrorEvent(Self, sLastError); 241 | Terminate(); 242 | end 243 | end; 244 | 245 | procedure TSerialClient.Execute(); 246 | var 247 | SoftFlow: Boolean; 248 | HardFlow: Boolean; 249 | iStopBits: Integer; 250 | DataSize: Integer; 251 | {$IFDEF MSWINDOWS} 252 | CommProp: TCommProp; 253 | {$ENDIF} 254 | begin 255 | sLastError := ''; 256 | SoftFlow := False; 257 | HardFlow := False; 258 | iStopBits := 1; 259 | 260 | if Terminated then Exit; 261 | 262 | FSerial := TBlockSerial.Create(); 263 | try 264 | Serial.DeadlockTimeout := 3000; 265 | Serial.Connect(sPort); 266 | Sleep(SleepInterval); 267 | if Serial.LastError = 0 then 268 | begin 269 | case StopBits of 270 | stb1: iStopBits := SB1; 271 | stb15: iStopBits := SB1andHalf; 272 | stb2: iStopBits := SB2; 273 | end; 274 | 275 | if FlowControl = sfcSoft then 276 | SoftFlow := True 277 | else if FlowControl = sfcSend then 278 | HardFlow := True; 279 | 280 | Serial.Config(BaudRate, DataBits, Char(Parity), iStopBits, SoftFlow, HardFlow); 281 | FDoConfig := False; 282 | Sleep(SleepInterval); 283 | end; 284 | 285 | if not IsError() then 286 | begin 287 | if Assigned(OnConnectEvent) then 288 | OnConnectEvent(Self); 289 | end; 290 | 291 | {$IFDEF MSWINDOWS} 292 | // get comm proprties 293 | if GetCommProperties(Serial.Handle, CommProp) then 294 | begin 295 | if CommProp.dwCurrentTxQueue > 0 then 296 | TxPortionSize := CommProp.dwCurrentTxQueue; 297 | end; 298 | {$ENDIF} 299 | 300 | while not Terminated do 301 | begin 302 | sLastError := ''; 303 | 304 | Serial.GetCommState(); 305 | if IsError() then 306 | Break; 307 | 308 | if FDoConfig then 309 | begin 310 | if FlowControl = sfcSoft then 311 | SoftFlow := True 312 | else if FlowControl = sfcSend then 313 | HardFlow := True; 314 | Serial.Config(BaudRate, DataBits, Char(Parity), iStopBits, SoftFlow, HardFlow); 315 | FDoConfig := False; 316 | Sleep(SleepInterval); 317 | end 318 | else 319 | begin 320 | // receive all available data 321 | sFromPort := Serial.RecvPacket(0); 322 | 323 | {DataSize := Serial.WaitingData; 324 | if DataSize > 0 then 325 | begin 326 | SetLength(sData, DataSize); 327 | DataSize := Serial.RecvBuffer(@sData[1], Length(sData)); 328 | //SetLength(sData, DataSize); 329 | sFromPort := Copy(sData, 1, DataSize); 330 | end; } 331 | end; 332 | 333 | if IsError() then 334 | Break 335 | else if (Length(sFromPort) > 0) then 336 | begin 337 | try 338 | if Assigned(OnIncomingMsgEvent) then 339 | OnIncomingMsgEvent(Self, sFromPort); 340 | finally 341 | sFromPort := ''; 342 | end; 343 | end; 344 | 345 | FLock.BeginWrite; 346 | try 347 | if TxData <> '' then 348 | begin 349 | //if Serial.CanWrite(0) then // Tx queue empty 350 | begin 351 | sData := Copy(TxData, 1, TxPortionSize); 352 | //Serial.SendString(sData); 353 | if Length(sData) > 0 then 354 | begin 355 | DataSize := Serial.SendBuffer(@sData[1], Length(sData)); 356 | IsError(); // check for error 357 | Delete(TxData, 1, DataSize); 358 | if DataSize < Length(sData) then 359 | begin 360 | // Tx buffer overrun, decrease TxPortionSize 361 | //TxPortionSize := TxPortionSize div 2; 362 | sData := ''; 363 | end; 364 | end; 365 | end; 366 | end; 367 | finally 368 | FLock.EndWrite; 369 | end; 370 | end; 371 | finally 372 | FreeAndNil(FSerial); 373 | end; 374 | end; 375 | 376 | function TSerialClient.SendString(const AData: AnsiString): Boolean; 377 | begin 378 | Result := False; 379 | if not Assigned(Self.Serial) then 380 | Exit; 381 | FLock.BeginWrite; 382 | try 383 | TxData := TxData + AData; 384 | finally 385 | FLock.EndWrite; 386 | end; 387 | Result := True; 388 | end; 389 | 390 | procedure TSerialClient.SendStream(st: TStream); 391 | var 392 | ss: TStringStream; 393 | begin 394 | if not Assigned(Self.Serial) then 395 | Exit; 396 | ss := TStringStream.Create(''); 397 | try 398 | ss.CopyFrom(st, st.Size); 399 | Self.SendString(ss.DataString); 400 | finally 401 | ss.Free(); 402 | end; 403 | end; 404 | 405 | 406 | { TDataPortSerial } 407 | 408 | constructor TDataPortSerial.Create(AOwner: TComponent); 409 | begin 410 | inherited Create(AOwner); 411 | FSerialClient := nil; 412 | end; 413 | 414 | destructor TDataPortSerial.Destroy(); 415 | begin 416 | if Assigned(FSerialClient) then 417 | begin 418 | FSerialClient.OnIncomingMsgEvent := nil; 419 | FSerialClient.OnErrorEvent := nil; 420 | FSerialClient.OnConnectEvent := nil; 421 | FreeAndNil(FSerialClient); 422 | end; 423 | inherited Destroy(); 424 | end; 425 | 426 | function TDataPortSerial.CloseClient(): Boolean; 427 | begin 428 | Result := True; 429 | if Assigned(FSerialClient) then 430 | begin 431 | Result := not FSerialClient.CalledFromThread; 432 | if Result then 433 | begin 434 | FSerialClient.OnIncomingMsgEvent := nil; 435 | FSerialClient.OnErrorEvent := nil; 436 | FSerialClient.OnConnectEvent := nil; 437 | FreeAndNil(FSerialClient); 438 | end 439 | else 440 | FSerialClient.Terminate() 441 | end; 442 | end; 443 | 444 | procedure TDataPortSerial.Open(const AInitStr: string = ''); 445 | {$IFDEF UNIX} 446 | var 447 | s: string; 448 | {$ENDIF} 449 | begin 450 | inherited Open(AInitStr); 451 | 452 | if not CloseClient() then 453 | Exit; 454 | 455 | FSerialClient := TSerialClient.Create(Self); 456 | FSerialClient.OnIncomingMsgEvent := OnIncomingMsgHandler; 457 | FSerialClient.OnErrorEvent := OnErrorHandler; 458 | FSerialClient.OnConnectEvent := OnConnectHandler; 459 | FSerialClient.SafeMode := HalfDuplex; 460 | 461 | FSerialClient.sPort := FPort; 462 | FSerialClient.BaudRate := FBaudRate; 463 | FSerialClient.DataBits := FDataBits; 464 | FSerialClient.Parity := FParity; 465 | FSerialClient.StopBits := FStopBits; 466 | FSerialClient.FlowControl := FFlowControl; 467 | 468 | // Check serial port 469 | //if Pos(Port, synaser.GetSerialPortNames())=0 then Exit; 470 | {$IFDEF UNIX} 471 | // detect lock file name 472 | if Pos('tty', Port) > 0 then 473 | begin 474 | s := '/var/lock/LCK..' + Copy(Port, Pos('tty', Port), maxint); 475 | if FileExists(s) then 476 | begin 477 | // try to remove lock file (if any) 478 | DeleteFile(s); 479 | end; 480 | end; 481 | {$ENDIF} 482 | FSerialClient.Suspended := False; 483 | // don't set FActive - will be set in OnConnect event after successfull connection 484 | end; 485 | 486 | procedure TDataPortSerial.Close(); 487 | begin 488 | if Assigned(FSerialClient) then 489 | begin 490 | if FSerialClient.CalledFromThread then 491 | FSerialClient.Terminate() 492 | else 493 | FreeAndNil(FSerialClient); 494 | end; 495 | inherited Close(); 496 | end; 497 | 498 | class function TDataPortSerial.GetSerialPortNames: string; 499 | begin 500 | Result := synaser.GetSerialPortNames(); 501 | end; 502 | 503 | function TDataPortSerial.GetModemStatus(): TModemStatus; 504 | var 505 | ModemWord: Integer; 506 | begin 507 | if Assigned(SerialClient) and Assigned(SerialClient.Serial) then 508 | begin 509 | ModemWord := SerialClient.Serial.ModemStatus(); 510 | {$IFNDEF MSWINDOWS} 511 | FModemStatus.DSR := (ModemWord and TIOCM_DSR) > 0; 512 | FModemStatus.CTS := (ModemWord and TIOCM_CTS) > 0; 513 | FModemStatus.Carrier := (ModemWord and TIOCM_CAR) > 0; 514 | FModemStatus.Ring := (ModemWord and TIOCM_RNG) > 0; 515 | {$ELSE} 516 | FModemStatus.DSR := (ModemWord and MS_DSR_ON) > 0; 517 | FModemStatus.CTS := (ModemWord and MS_CTS_ON) > 0; 518 | FModemStatus.Carrier := (ModemWord and MS_RLSD_ON) > 0; 519 | FModemStatus.Ring := (ModemWord and MS_RING_ON) > 0; 520 | {$ENDIF} 521 | end; 522 | Result := inherited GetModemStatus; 523 | end; 524 | 525 | procedure TDataPortSerial.SetDTR(AValue: Boolean); 526 | begin 527 | if Assigned(SerialClient) and Assigned(SerialClient.Serial) then 528 | begin 529 | SerialClient.Serial.DTR := AValue; 530 | end; 531 | inherited SetDTR(AValue); 532 | end; 533 | 534 | procedure TDataPortSerial.SetRTS(AValue: Boolean); 535 | begin 536 | if Assigned(SerialClient) and Assigned(SerialClient.Serial) then 537 | begin 538 | SerialClient.Serial.RTS := AValue; 539 | end; 540 | inherited SetRTS(AValue); 541 | end; 542 | 543 | function TDataPortSerial.Push(const AData: AnsiString): Boolean; 544 | begin 545 | Result := False; 546 | if Assigned(SerialClient) and FLock.BeginWrite() then 547 | begin 548 | try 549 | Result := SerialClient.SendString(AData); 550 | finally 551 | FLock.EndWrite(); 552 | end; 553 | end; 554 | end; 555 | 556 | procedure TDataPortSerial.SetBaudRate(AValue: Integer); 557 | begin 558 | inherited SetBaudRate(AValue); 559 | if Active then 560 | begin 561 | SerialClient.BaudRate := FBaudRate; 562 | SerialClient.Config(); 563 | end; 564 | end; 565 | 566 | procedure TDataPortSerial.SetDataBits(AValue: Integer); 567 | begin 568 | inherited SetDataBits(AValue); 569 | if Active then 570 | begin 571 | SerialClient.DataBits := FDataBits; 572 | SerialClient.Config(); 573 | end; 574 | end; 575 | 576 | procedure TDataPortSerial.SetParity(AValue: AnsiChar); 577 | begin 578 | inherited SetParity(AValue); 579 | if Active then 580 | begin 581 | SerialClient.Parity := FParity; 582 | SerialClient.Config(); 583 | end; 584 | end; 585 | 586 | procedure TDataPortSerial.SetFlowControl(AValue: TSerialFlowControl); 587 | begin 588 | inherited SetFlowControl(AValue); 589 | if Active then 590 | begin 591 | SerialClient.FlowControl := FFlowControl; 592 | SerialClient.Config(); 593 | end; 594 | end; 595 | 596 | procedure TDataPortSerial.SetStopBits(AValue: TSerialStopBits); 597 | begin 598 | inherited SetStopBits(AValue); 599 | if Active then 600 | begin 601 | SerialClient.StopBits := FStopBits; 602 | SerialClient.Config(); 603 | end; 604 | end; 605 | 606 | end. 607 | -------------------------------------------------------------------------------- /DataPortIP.pas: -------------------------------------------------------------------------------- 1 | { 2 | Asynchronous wrapper around Synapse TBlockSocket. 3 | 4 | (C) Sergey Bodrov, 2012-2025 5 | 6 | When using UDP, remember, that it not session protocol, data delivery and correct 7 | order not guaranteed. To start receive data, you must send empty packet to 8 | remote side, it tell remote side return address. 9 | 10 | From version 1.0.3 multiple DataPortIP instances uses common socket reader with single thread. 11 | 12 | Properties: 13 | RemoteHost - IP-address or name of remote host 14 | RemotePort - remote UPD or TCP port number 15 | LocalHost - IP-address or name of local host 16 | LocalPort - local UPD or TCP port number 17 | 18 | Methods: 19 | Open() - Connect to remote port. Session establiched for TCP and just port initialised for UDP. Init string format: 20 | InitStr = 'RemoteHost:RemotePort' 21 | RemoteHost - IP-address or name of remote host 22 | RemotePort - remote UPD or TCP port number 23 | 24 | Events: 25 | OnOpen - Triggered after UDP port init or TCP session establiched. 26 | } 27 | unit DataPortIP; 28 | 29 | interface 30 | 31 | uses {$ifndef FPC}Windows,{$endif} SysUtils, Classes, 32 | DataPort, DataPortEventer, synsock, blcksock, synautil; 33 | 34 | {$ifdef Linux} 35 | // Uncomment next line to enable TCP keep-alive in Linux 36 | //{$define LINUX_TCP_KEEPALIVE} 37 | {$endif} 38 | 39 | type 40 | TIpProtocolEnum = (ippUDP, ippTCP); 41 | TIpSocketItem = class; 42 | 43 | { TDataPortIP } 44 | 45 | TDataPortIP = class(TDataPort) 46 | private 47 | //slReadData: TStringList; // for storing every incoming data packet separately 48 | procedure SetIpProtocol(AValue: TIpProtocolEnum); 49 | protected 50 | FIpSocketItem: TIpSocketItem; 51 | FRemoteHost: string; 52 | FRemotePort: string; 53 | FIpProtocol: TIpProtocolEnum; 54 | function GetLocalHost: string; virtual; 55 | function GetLocalPort: string; virtual; 56 | public 57 | constructor Create(AOwner: TComponent); override; 58 | destructor Destroy(); override; 59 | { Open() - Connect to remote port. Session establiched for TCP and just port initialised for UDP. Init string format: 60 | InitStr = 'RemoteHost:RemotePort' 61 | RemoteHost - IP-address or name of remote host 62 | RemotePort - remote UPD or TCP port number } 63 | procedure Open(const AInitStr: string = ''); override; 64 | procedure Close(); override; 65 | function Push(const AData: AnsiString): boolean; override; 66 | function Pull(ASize: Integer = MaxInt): AnsiString; override; 67 | function Peek(ASize: Integer = MaxInt): AnsiString; override; 68 | function PeekSize(): Cardinal; override; 69 | { IP protocol type } 70 | property IpProtocol: TIpProtocolEnum read FIpProtocol write SetIpProtocol; 71 | { internal IP socket } 72 | property IpSocketItem: TIpSocketItem read FIpSocketItem; 73 | published 74 | { IP-address or name of remote host } 75 | property RemoteHost: string read FRemoteHost write FRemoteHost; 76 | { remote UPD or TCP port number } 77 | property RemotePort: string read FRemotePort write FRemotePort; 78 | { IP-address or name of local host } 79 | property LocalHost: string read GetLocalHost; 80 | { local UPD or TCP port number } 81 | property LocalPort: string read GetLocalPort; 82 | property Active; 83 | property OnDataAppear; 84 | property OnError; 85 | { Triggered after UDP port init or TCP session establiched } 86 | property OnOpen; 87 | property OnClose; 88 | end; 89 | 90 | TDataPortTCP = class(TDataPortIP) 91 | public 92 | procedure Open(const AInitStr: string = ''); override; 93 | end; 94 | 95 | { TDataPortUDP } 96 | 97 | TDataPortUDP = class(TDataPortIP) 98 | public 99 | procedure Open(const AInitStr: string = ''); override; 100 | { Send data to destination address ADestAddr as 'host:port' } 101 | function PushTo(const AData: AnsiString; ADestAddr: string): Boolean; 102 | end; 103 | 104 | { TIpSocketItem } 105 | { Item for sockets list, created on Open(), used by reader thread } 106 | TIpSocketItem = class(TObject) 107 | public 108 | Lock: TSimpleRWSync; // managed by TIpSocketPool 109 | // Only socket reader can manage Socket 110 | Socket: TBlockSocket; 111 | DataPortIP: TDataPortIP; 112 | Protocol: TIpProtocolEnum; 113 | LockCount: Integer; 114 | RxDataStr: AnsiString; 115 | //TxDataStr: AnsiString; 116 | ErrorStr: string; 117 | Active: Boolean; 118 | Connected: Boolean; 119 | 120 | function GetLocalHost(): string; 121 | function GetLocalPort(): string; 122 | function SendString(const ADataStr: AnsiString): Boolean; 123 | function SendStream(st: TStream): Boolean; 124 | // thread-safe 125 | procedure RxPush(const AData: AnsiString); 126 | function RxPull(ASize: Integer = MaxInt): AnsiString; 127 | function RxPeek(ASize: Integer = MaxInt): AnsiString; 128 | function RxPeekSize(): Cardinal; 129 | end; 130 | 131 | procedure Register; 132 | 133 | implementation 134 | 135 | type 136 | { TIpSocketPool } 137 | { For better portability to DLL and stability, reader thread and critical section 138 | automaticaly created after unit initialisation, when first DataPortIP opened. 139 | And destroyed when last DataPortIP closed, before unit finalization. } 140 | TIpSocketPool = class(TList) 141 | private 142 | FIpReadThread: TThread; 143 | FLock: TSimpleRWSync; 144 | protected 145 | procedure Notify(Ptr: Pointer; Action: TListNotification); override; 146 | public 147 | procedure BeforeDestruction(); override; 148 | function DataPortOpen(ADataPortIP: TDataPortIP): TIpSocketItem; 149 | procedure DataPortClose(ADataPortIP: TDataPortIP); 150 | function GetItem(AIndex: Integer): TIpSocketItem; 151 | { Lock for modifing items list. NOTE! Can be nil if no items in list! } 152 | property Lock: TSimpleRWSync read FLock; 153 | end; 154 | 155 | { TIpReadThread } 156 | 157 | TIpReadThread = class(TThread) 158 | protected 159 | FItem: TIpSocketItem; 160 | procedure CloseSocket(); 161 | procedure Execute(); override; 162 | public 163 | IpSocketPool: TIpSocketPool; 164 | end; 165 | 166 | var 167 | GlobalIpSocketPool: TIpSocketPool; 168 | 169 | procedure Register; 170 | begin 171 | RegisterComponents('DataPort', [TDataPortTCP]); 172 | RegisterComponents('DataPort', [TDataPortUDP]); 173 | end; 174 | 175 | { TIpReadThread } 176 | 177 | procedure TIpReadThread.CloseSocket(); 178 | begin 179 | FItem.Active := False; 180 | if Assigned(FItem.Socket) then 181 | begin 182 | try 183 | FItem.Socket.CloseSocket(); 184 | finally 185 | FreeAndNil(FItem.Socket); 186 | end; 187 | end; 188 | end; 189 | 190 | procedure TIpReadThread.Execute(); 191 | var 192 | n, ItemLockCount: Integer; 193 | {$ifdef LINUX_TCP_KEEPALIVE}OptVal: Integer;{$endif} 194 | IsNeedSleep: Boolean; 195 | begin 196 | n := 0; 197 | while not Terminated do 198 | begin 199 | IsNeedSleep := True; 200 | if n < IpSocketPool.Count then 201 | begin 202 | FItem := IpSocketPool.GetItem(n); 203 | if Assigned(FItem.DataPortIP) then 204 | begin 205 | // acquire lock 206 | //ItemLockCount := InterLockedIncrement(FItem.LockCount); 207 | try 208 | //if (ItemLockCount = 1) then 209 | begin 210 | // connect 211 | if FItem.Active and (not Assigned(FItem.Socket)) then 212 | begin 213 | FItem.Connected := False; 214 | FItem.ErrorStr := ''; 215 | case FItem.DataPortIP.IpProtocol of 216 | ippUDP: FItem.Socket := TUDPBlockSocket.Create(); 217 | ippTCP: FItem.Socket := TTCPBlockSocket.Create(); 218 | end; 219 | 220 | FItem.Socket.Connect(FItem.DataPortIP.RemoteHost, FItem.DataPortIP.RemotePort); 221 | if FItem.Socket.LastError <> 0 then 222 | begin 223 | // Error event 224 | FItem.ErrorStr := IntToStr(FItem.Socket.LastError) + ' ' + FItem.Socket.LastErrorDesc; 225 | FItem.Active := False; 226 | end 227 | else 228 | begin 229 | // Connected event 230 | FItem.Connected := True; 231 | NotifyDataport(FItem.DataPortIP, DP_NOTIFY_OPEN); 232 | 233 | {$ifdef LINUX_TCP_KEEPALIVE} 234 | // Set TCP keep-alive for Linux 235 | OptVal := 1; 236 | SetSockOpt(FItem.Socket.Socket, SOL_SOCKET, SO_KEEPALIVE, @OptVal, SizeOf(OptVal)); 237 | OptVal := 3; // TCP_KEEPIDLE - Start keepalives after this period 238 | SetSockOpt(FItem.Socket.Socket, 6, 4, @OptVal, SizeOf(OptVal)); 239 | OptVal := 3; // TCP_KEEPINTVL - Interval between keepalives 240 | SetSockOpt(FItem.Socket.Socket, 6, 5, @OptVal, SizeOf(OptVal)); 241 | OptVal := 3; // TCP_KEEPCNT - Number of keepalives before death 242 | SetSockOpt(FItem.Socket.Socket, 6, 6, @OptVal, SizeOf(OptVal)); 243 | {$endif} 244 | end; 245 | //IsNeedSleep := False; 246 | end; 247 | 248 | // read 249 | //if FItem.Active and Assigned(FItem.Socket) and (FItem.Socket.WaitingData > 0) then 250 | //if FItem.Active and Assigned(FItem.Socket) and (FItem.Socket.WaitingDataEx() > 0) then 251 | if FItem.Active and Assigned(FItem.Socket) then 252 | begin 253 | try 254 | FItem.RxPush(FItem.Socket.RecvPacket(0)); 255 | if FItem.Socket.LastError = 0 then 256 | begin 257 | // DataRead event 258 | NotifyDataport(FItem.DataPortIP, DP_NOTIFY_DATA); 259 | end 260 | else if FItem.Socket.LastError = WSAETIMEDOUT then 261 | begin 262 | // nothing 263 | end 264 | else 265 | begin 266 | // Error event 267 | FItem.ErrorStr := IntToStr(FItem.Socket.LastError) + ' ' + FItem.Socket.LastErrorDesc; 268 | FItem.Active := False; 269 | end; 270 | IsNeedSleep := False; 271 | except on E: Exception do 272 | begin 273 | FItem.ErrorStr := E.Message; 274 | CloseSocket(); 275 | end; 276 | end; 277 | end; 278 | 279 | // disconnect 280 | if (not FItem.Active) and Assigned(FItem.Socket) then 281 | begin 282 | CloseSocket(); 283 | IsNeedSleep := False; 284 | end; 285 | end; 286 | finally 287 | // release lock 288 | //InterLockedDecrement(FItem.LockCount); 289 | end; 290 | end 291 | else 292 | begin 293 | // delete item 294 | CloseSocket(); 295 | if Assigned(IpSocketPool.Lock) then 296 | begin 297 | IpSocketPool.Lock.BeginWrite(); 298 | try 299 | IpSocketPool.Delete(n); 300 | Dec(n); 301 | finally 302 | IpSocketPool.Lock.EndWrite(); 303 | end; 304 | end; 305 | end; 306 | 307 | // Error event 308 | if FItem.ErrorStr <> '' then 309 | begin 310 | NotifyDataport(FItem.DataPortIP, DP_NOTIFY_ERROR, FItem.ErrorStr); 311 | FItem.ErrorStr := ''; 312 | NotifyDataport(FItem.DataPortIP, DP_NOTIFY_CLOSE); 313 | end; 314 | 315 | Inc(n); 316 | end 317 | else 318 | n := 0; 319 | 320 | if IsNeedSleep then 321 | Sleep(1); 322 | end; 323 | 324 | if Terminated then 325 | begin 326 | // cleanup sockets 327 | for n := IpSocketPool.Count-1 downto 0 do 328 | begin 329 | FItem := IpSocketPool.GetItem(n); 330 | CloseSocket(); 331 | IpSocketPool.Delete(n); 332 | end; 333 | end; 334 | end; 335 | 336 | { TIpSocketPool } 337 | 338 | procedure TIpSocketPool.Notify(Ptr: Pointer; Action: TListNotification); 339 | begin 340 | inherited Notify(Ptr, Action); 341 | if Action = lnDeleted then 342 | TIpSocketItem(Ptr).Free(); 343 | end; 344 | 345 | procedure TIpSocketPool.BeforeDestruction(); 346 | begin 347 | if Assigned(FIpReadThread) then 348 | FreeAndNil(FIpReadThread); 349 | 350 | if Assigned(FLock) then 351 | FreeAndNil(FLock); 352 | 353 | inherited BeforeDestruction; 354 | end; 355 | 356 | function TIpSocketPool.DataPortOpen(ADataPortIP: TDataPortIP): TIpSocketItem; 357 | var 358 | i: Integer; 359 | begin 360 | for i := 0 to Count-1 do 361 | begin 362 | Result := GetItem(i); 363 | if Result.DataPortIP = ADataPortIP then 364 | Exit; 365 | end; 366 | 367 | if not Assigned(FLock) then 368 | FLock := TSimpleRWSync.Create(); 369 | 370 | Result := TIpSocketItem.Create(); 371 | Result.Lock := FLock; 372 | Result.DataPortIP := ADataPortIP; 373 | Result.Active := True; 374 | 375 | FLock.BeginWrite(); 376 | try 377 | Add(Result); 378 | finally 379 | FLock.EndWrite(); 380 | end; 381 | 382 | if (not Assigned(FIpReadThread)) then 383 | begin 384 | // create socket reader 385 | FIpReadThread := TIpReadThread.Create(True); 386 | (FIpReadThread as TIpReadThread).IpSocketPool := Self; 387 | FIpReadThread.Suspended := False; 388 | end; 389 | end; 390 | 391 | procedure TIpSocketPool.DataPortClose(ADataPortIP: TDataPortIP); 392 | var 393 | i, ActiveCount: Integer; 394 | Item: TIpSocketItem; 395 | begin 396 | ActiveCount := 0; 397 | if Assigned(FLock) then 398 | begin 399 | FLock.BeginWrite(); 400 | try 401 | for i := Count-1 downto 0 do 402 | begin 403 | Item := GetItem(i); 404 | if Item.DataPortIP = ADataPortIP then 405 | begin 406 | Item.DataPortIP := nil; 407 | Break; 408 | end 409 | else if Assigned(Item.DataPortIP) then 410 | Inc(ActiveCount); 411 | end; 412 | 413 | finally 414 | FLock.EndWrite(); 415 | end; 416 | end; 417 | 418 | {if (ActiveCount = 0) then 419 | begin 420 | if Assigned(FIpReadThread) then 421 | FreeAndNil(FIpReadThread); 422 | if Assigned(FLock) then 423 | FreeAndNil(FLock); 424 | end; } 425 | end; 426 | 427 | function TIpSocketPool.GetItem(AIndex: Integer): TIpSocketItem; 428 | begin 429 | Result := TIpSocketItem(Get(AIndex)); 430 | end; 431 | 432 | { TIpSocketItem } 433 | 434 | function TIpSocketItem.GetLocalHost(): string; 435 | begin 436 | if Assigned(Socket) then 437 | begin 438 | Socket.GetSinLocal(); 439 | Result := Socket.GetLocalSinIP; 440 | end 441 | else 442 | Result := ''; 443 | end; 444 | 445 | function TIpSocketItem.GetLocalPort(): string; 446 | begin 447 | if Assigned(Socket) then 448 | begin 449 | Socket.GetSinLocal(); 450 | Result := IntToStr(Socket.GetLocalSinPort); 451 | end 452 | else 453 | Result := ''; 454 | end; 455 | 456 | function TIpSocketItem.RxPeek(ASize: Integer): AnsiString; 457 | begin 458 | Lock.BeginRead; 459 | try 460 | Result := Copy(RxDataStr, 1, ASize); 461 | finally 462 | Lock.EndRead; 463 | end; 464 | end; 465 | 466 | function TIpSocketItem.RxPeekSize: Cardinal; 467 | begin 468 | Lock.BeginRead; 469 | try 470 | Result := Length(RxDataStr); 471 | finally 472 | Lock.EndRead; 473 | end; 474 | end; 475 | 476 | function TIpSocketItem.RxPull(ASize: Integer): AnsiString; 477 | begin 478 | Lock.BeginWrite; 479 | try 480 | Result := Copy(RxDataStr, 1, ASize); 481 | Delete(RxDataStr, 1, ASize); 482 | finally 483 | Lock.EndWrite; 484 | end; 485 | end; 486 | 487 | procedure TIpSocketItem.RxPush(const AData: AnsiString); 488 | begin 489 | Lock.BeginWrite; 490 | try 491 | RxDataStr := RxDataStr + AData; 492 | finally 493 | Lock.EndWrite; 494 | end; 495 | end; 496 | 497 | function TIpSocketItem.SendString(const ADataStr: AnsiString): Boolean; 498 | var 499 | LockTryCount: Integer; 500 | begin 501 | //TxDataStr := TxDataStr + ADataStr; 502 | Result := False; 503 | if Assigned(Socket) then 504 | begin 505 | // try to acquire exclusive lock 506 | LockTryCount := 10; 507 | while (InterLockedIncrement(LockCount) > 1) and (LockTryCount > 0) do 508 | begin 509 | InterLockedDecrement(LockCount); 510 | Dec(LockTryCount); 511 | if (LockTryCount = 0) then 512 | Exit; 513 | Sleep(1); 514 | end; 515 | 516 | try 517 | try 518 | Result := Socket.CanWrite(0); 519 | if Result then 520 | begin 521 | Socket.SendString(ADataStr); 522 | Result := (Socket.LastError = 0); 523 | if not Result then 524 | begin 525 | ErrorStr := IntToStr(Socket.LastError) + ' ' + Socket.LastErrorDesc; 526 | end; 527 | end; 528 | except 529 | ErrorStr := 'Socket write exception'; 530 | end; 531 | 532 | finally 533 | // release exclusive lock 534 | InterLockedDecrement(LockCount); 535 | end; 536 | end; 537 | end; 538 | 539 | function TIpSocketItem.SendStream(st: TStream): Boolean; 540 | begin 541 | Result := False; 542 | if Assigned(st) and (st.Size <> 0) and Assigned(Socket) then 543 | begin 544 | st.Position := 0; 545 | try 546 | Result := Socket.CanWrite(0); 547 | if Result then 548 | begin 549 | Socket.SendStream(st); 550 | Result := (Socket.LastError = 0); 551 | if not Result then 552 | begin 553 | ErrorStr := IntToStr(Socket.LastError) + ' ' + Socket.LastErrorDesc; 554 | end; 555 | end; 556 | except 557 | ErrorStr := 'Socket write exception'; 558 | end; 559 | end; 560 | end; 561 | 562 | { TDataPortIP } 563 | 564 | constructor TDataPortIP.Create(AOwner: TComponent); 565 | begin 566 | inherited Create(AOwner); 567 | Self.FRemoteHost := ''; 568 | Self.FRemotePort := ''; 569 | Self.FActive := False; 570 | end; 571 | 572 | procedure TDataPortIP.Open(const AInitStr: string = ''); 573 | var 574 | n: integer; 575 | begin 576 | // Set host and port from init string 577 | if AInitStr <> '' then 578 | begin 579 | n := Pos(':', AInitStr); 580 | if n > 0 then 581 | begin 582 | Self.FRemoteHost := Copy(AInitStr, 1, n - 1); 583 | Self.FRemotePort := Copy(AInitStr, n + 1, MaxInt); 584 | end 585 | else 586 | Self.FRemoteHost := AInitStr; 587 | end; 588 | 589 | if Assigned(GlobalIpSocketPool) then 590 | begin 591 | FIpSocketItem := GlobalIpSocketPool.DataPortOpen(Self); 592 | end; 593 | 594 | // don't inherits Open() - OnOpen event will be after successfull connection 595 | end; 596 | 597 | procedure TDataPortIP.Close(); 598 | begin 599 | FIpSocketItem := nil; 600 | if Active and Assigned(GlobalIpSocketPool) then 601 | GlobalIpSocketPool.DataPortClose(Self); 602 | inherited Close(); 603 | end; 604 | 605 | destructor TDataPortIP.Destroy(); 606 | begin 607 | FIpSocketItem := nil; 608 | if Assigned(GlobalIpSocketPool) then 609 | GlobalIpSocketPool.DataPortClose(Self); 610 | inherited Destroy(); 611 | end; 612 | 613 | procedure TDataPortIP.SetIpProtocol(AValue: TIpProtocolEnum); 614 | begin 615 | if FIpProtocol = AValue then Exit; 616 | Close(); 617 | FIpProtocol := AValue; 618 | end; 619 | 620 | function TDataPortIP.GetLocalHost: string; 621 | begin 622 | if Assigned(FIpSocketItem) then 623 | Result := FIpSocketItem.GetLocalHost() 624 | else 625 | Result := ''; 626 | end; 627 | 628 | function TDataPortIP.GetLocalPort: string; 629 | begin 630 | if Assigned(FIpSocketItem) then 631 | Result := FIpSocketItem.GetLocalPort() 632 | else 633 | Result := ''; 634 | end; 635 | 636 | function TDataPortIP.Peek(ASize: Integer): AnsiString; 637 | begin 638 | Result := ''; 639 | if Assigned(FIpSocketItem) then 640 | Result := FIpSocketItem.RxPeek(ASize); 641 | end; 642 | 643 | function TDataPortIP.PeekSize(): Cardinal; 644 | begin 645 | Result := 0; 646 | if Assigned(FIpSocketItem) then 647 | Result := FIpSocketItem.RxPeekSize(); 648 | end; 649 | 650 | function TDataPortIP.Pull(ASize: Integer): AnsiString; 651 | begin 652 | Result := ''; 653 | if Assigned(FIpSocketItem) then 654 | Result := FIpSocketItem.RxPull(ASize); 655 | end; 656 | 657 | function TDataPortIP.Push(const AData: AnsiString): boolean; 658 | begin 659 | Result := False; 660 | if Assigned(FIpSocketItem) then 661 | begin 662 | Result := FIpSocketItem.SendString(AData); 663 | end; 664 | end; 665 | 666 | procedure TDataPortTCP.Open(const AInitStr: string = ''); 667 | begin 668 | FIpProtocol := ippTCP; 669 | inherited Open(AInitStr); 670 | FActive := True; 671 | end; 672 | 673 | procedure TDataPortUDP.Open(const AInitStr: string = ''); 674 | begin 675 | FIpProtocol := ippUDP; 676 | inherited Open(AInitStr); 677 | FActive := True; 678 | end; 679 | 680 | function TDataPortUDP.PushTo(const AData: AnsiString; ADestAddr: string 681 | ): Boolean; 682 | var 683 | n: integer; 684 | ss, sh, sp: string; 685 | begin 686 | Result := False; 687 | if Assigned(FIpSocketItem) and Assigned(FIpSocketItem.Socket) then 688 | begin 689 | if ADestAddr = '' then 690 | begin 691 | //UdpSocket.SetRemoteSin(remoteHost, remotePort); 692 | end 693 | else 694 | begin 695 | ss := ADestAddr; 696 | n := Pos(':', ss); 697 | sh := Copy(ss, 1, n - 1); 698 | sp := Copy(ss, n + 1, MaxInt); 699 | FIpSocketItem.Socket.SetRemoteSin(sh, sp); 700 | end; 701 | FIpSocketItem.Socket.SendString(AData); 702 | Result := (FIpSocketItem.Socket.LastError = 0); 703 | if not Result then 704 | begin 705 | FIpSocketItem.ErrorStr := IntToStr(FIpSocketItem.Socket.LastError) + ' ' + FIpSocketItem.Socket.LastErrorDesc; 706 | end; 707 | end; 708 | end; 709 | 710 | 711 | initialization 712 | GlobalIpSocketPool := TIpSocketPool.Create(); 713 | 714 | finalization 715 | FreeAndNil(GlobalIpSocketPool); 716 | 717 | end. 718 | -------------------------------------------------------------------------------- /DataPortFTDI.pas: -------------------------------------------------------------------------------- 1 | { 2 | Serial communication port based on FTD2XX library. 3 | 4 | (C) Sergey Bodrov, 2012-2025 5 | 6 | Properties: 7 | SerialNumber - FTDI device serial number 8 | DeviceDescription - FTDI device description string 9 | BaudRate - data exchange speed (300, 1200, 9600, 115384, 230769, 923076) 10 | DataBits - default 8 11 | Parity - (N - None, O - Odd, E - Even, M - Mark or S - Space) default N 12 | StopBits - (1, 1.5, 2) default 1 13 | MinDataBytes - minimal bytes count in buffer for triggering event OnDataAppear 14 | 15 | Methods: 16 | Open() - Opens port. As parameter it use port initialization string: 17 | InitStr = '<DeviceDescription>:<SerialNumber>:<PortInitStr>' 18 | Examples: 19 | 'USB Serial::' - first device of 'USB Serial' type 20 | ':FT425622:' - device with s/n FT425622 21 | GetFtdiDeviceList() - list of available devices in format <DeviceDescription>:<SerialNumber><LineFeed> 22 | 23 | Events: 24 | OnModemStatus - Triggered when modem status changes (CTS, DTR, RI, DCD) 25 | } 26 | unit DataPortFTDI; 27 | 28 | interface 29 | 30 | uses {$ifndef FPC}Windows,{$endif} SysUtils, Classes, DataPort, DataPortUART, D2XXUnit; 31 | 32 | type 33 | { TFtdiClient - FTDI device reader/writer thread } 34 | TFtdiClient = class(TThread) 35 | private 36 | FLock: TSimpleRWSync; 37 | FRxData: AnsiString; 38 | FTxData: AnsiString; 39 | 40 | FLastErrorStr: string; 41 | FOnIncomingMsgEvent: TMsgEvent; 42 | FOnErrorEvent: TMsgEvent; 43 | FOnConnectEvent: TNotifyEvent; 44 | FDoConfig: Boolean; 45 | { how many bytes read for once, default 64k } 46 | FReadCount: Integer; 47 | 48 | FFtHandle: LongWord; 49 | FFtIOStatus: FT_Result; 50 | { bytes in receive queue } 51 | FFtRxQBytes: LongWord; 52 | { bytes in transmit queue } 53 | FFtTxQBytes: LongWord; 54 | { wakeup event status } 55 | FFtEventStatus: LongWord; 56 | { input buffer } 57 | FFtInBuffer: array[0..FT_In_Buffer_Index] of byte; 58 | { output buffer } 59 | //FFtOutBuffer: array[0..FT_Out_Buffer_Index] of byte; 60 | 61 | function SendStringInternal(const AData: AnsiString): Integer; 62 | function CheckFtError(APortStatus: FT_Result; AFunctionName: string = ''): Boolean; 63 | function GetFtErrorDescription(APortStatus: FT_Result): string; 64 | protected 65 | FParentDataPort: TDataPortUART; 66 | procedure Execute(); override; 67 | public 68 | InitStr: string; 69 | // port properties 70 | BaudRate: Integer; 71 | DataBits: Integer; 72 | Parity: AnsiChar; 73 | StopBits: TSerialStopBits; 74 | FlowControl: TSerialFlowControl; 75 | MinDataBytes: Integer; 76 | 77 | constructor Create(AParent: TDataPortUART); reintroduce; 78 | destructor Destroy; override; 79 | // thread-unsafe events 80 | property OnIncomingMsgEvent: TMsgEvent read FOnIncomingMsgEvent 81 | write FOnIncomingMsgEvent; 82 | property OnError: TMsgEvent read FOnErrorEvent write FOnErrorEvent; 83 | property OnConnect: TNotifyEvent read FOnConnectEvent write FOnConnectEvent; 84 | { Set port parameters (baud rate, data bits, etc..) } 85 | procedure Config(); 86 | function SendAnsiString(const AData: AnsiString): Boolean; 87 | { Get modem wires status (DSR,CTS,Ring,Carrier) } 88 | function ReadModemStatus(var AModemStatus: TModemStatus): Boolean; 89 | { Set DTR (Data Terminal Ready) signal } 90 | procedure SetDTR(AValue: Boolean); 91 | { Set RTS (Request to send) signal } 92 | procedure SetRTS(AValue: Boolean); 93 | { Get COM port name } 94 | function GetPortName(): string; 95 | 96 | property TxData: AnsiString read FTxData; 97 | end; 98 | 99 | { TDataPortFtdi } 100 | 101 | TDataPortFtdi = class(TDataPortUART) 102 | private 103 | FFtdiClient: TFtdiClient; 104 | FFtSerialNumber: string; 105 | FFtDeviceDescription: string; 106 | FFlowControl: TSerialFlowControl; 107 | FOnModemStatus: TNotifyEvent; 108 | 109 | function CloseClient(): Boolean; 110 | protected 111 | procedure SetBaudRate(AValue: Integer); override; 112 | procedure SetDataBits(AValue: Integer); override; 113 | procedure SetParity(AValue: AnsiChar); override; 114 | procedure SetStopBits(AValue: TSerialStopBits); override; 115 | procedure SetFlowControl(AValue: TSerialFlowControl); override; 116 | 117 | public 118 | constructor Create(AOwner: TComponent); override; 119 | destructor Destroy(); override; 120 | { Open FTDI device for data transmission 121 | InitStr = '<DeviceDescription>:<SerialNumber>:<PortInitStr>' 122 | Examples: 123 | 'USB Serial:' - first device of 'USB Serial' type 124 | ':FT425622' - device with s/n FT425622 125 | List of available devices can be acquired in GetFtdiDeviceList() 126 | } 127 | procedure Open(const AInitStr: string = ''); override; 128 | procedure Close(); override; 129 | function Push(const AData: AnsiString): Boolean; override; 130 | 131 | { list of available devices in format <DeviceDescription>:<SerialNumber><LineFeed> } 132 | class function GetFtdiDeviceList(): AnsiString; 133 | //class function GetFtdiDriverVersion(): string; 134 | 135 | { Get modem wires status (DSR,CTS,Ring,Carrier) } 136 | function GetModemStatus(): TModemStatus; override; 137 | { Set DTR (Data Terminal Ready) signal } 138 | procedure SetDTR(AValue: Boolean); override; 139 | { Set RTS (Request to send) signal } 140 | procedure SetRTS(AValue: Boolean); override; 141 | 142 | property FtdiClient: TFtdiClient read FFtdiClient; 143 | published 144 | property Active; 145 | { FTDI device serial number } 146 | property SerialNumber: string read FFtSerialNumber write FFtSerialNumber; 147 | { FTDI device description string } 148 | property DeviceDescription: string read FFtDeviceDescription write FFtDeviceDescription; 149 | { FlowControl - (sfcNone, sfcSend, sfcReady, sfcSoft) default sfcNone } 150 | property FlowControl: TSerialFlowControl read FFlowControl write SetFlowControl; 151 | property BaudRate; 152 | property DataBits; 153 | property MinDataBytes; 154 | property OnDataAppear; 155 | property OnError; 156 | property OnOpen; 157 | property OnClose; 158 | { Triggered when modem status changes (CTS, DTR, RI, DCD) } 159 | property OnModemStatus: TNotifyEvent read FOnModemStatus write FOnModemStatus; 160 | end; 161 | 162 | procedure Register; 163 | 164 | 165 | implementation 166 | 167 | const 168 | //TX_BUF_SIZE = 128; // safe size 169 | TX_BUF_SIZE = 512; // optimal size 170 | 171 | procedure Register; 172 | begin 173 | RegisterComponents('DataPort', [TDataPortFtdi]); 174 | end; 175 | 176 | { TFtdiClient } 177 | 178 | procedure TFtdiClient.Config(); 179 | begin 180 | FDoConfig := True; 181 | end; 182 | 183 | function TFtdiClient.CheckFtError(APortStatus: FT_Result; 184 | AFunctionName: string): Boolean; 185 | begin 186 | Result := True; 187 | if APortStatus <> FT_OK then 188 | begin 189 | Terminate(); 190 | FLastErrorStr := AFunctionName + ': ' + GetFtErrorDescription(APortStatus); 191 | Result := False; 192 | end; 193 | end; 194 | 195 | function TFtdiClient.SendStringInternal(const AData: AnsiString): Integer; 196 | var 197 | WriteResult: Integer; 198 | WritePos, WriteSize, TotalSize: Integer; 199 | begin 200 | Result := 0; 201 | TotalSize := Length(AData); 202 | if (TotalSize = 0) or Terminated then 203 | Exit; 204 | WritePos := 0; 205 | while (FFtIOStatus = FT_OK) and (Result < TotalSize) do 206 | begin 207 | // some FTDI chips or drivers can't receive many bytes at once 208 | WriteSize := TX_BUF_SIZE; 209 | //WriteSize := $FF; 210 | if (WritePos + WriteSize) > TotalSize then 211 | WriteSize := TotalSize - WritePos; 212 | 213 | FFtIOStatus := FT_GetStatus(FFtHandle, @FFtRxQBytes, @FFtTxQBytes, @FFtEventStatus); 214 | if FFtIOStatus = FT_OK then 215 | begin 216 | if FFtTxQBytes > TX_BUF_SIZE then 217 | Break; 218 | 219 | // Writes Write_Count Bytes from FT_Out_Buffer to the USB device 220 | // Function returns the number of bytes actually sent 221 | // In this example, Write_Count should be 64k bytes max 222 | if WriteSize > 0 then 223 | begin 224 | //Move(AData[WritePos+1], FFtOutBuffer, WriteSize); 225 | //FFtIOStatus := FT_Write(FFtHandle, @FFtOutBuffer, WriteSize, @WriteResult); 226 | if WritePos + WriteSize > Length(AData) then 227 | Break; 228 | WriteResult := 0; 229 | FFtIOStatus := FT_Write(FFtHandle, @AData[WritePos+1], WriteSize, @WriteResult); 230 | if FFtIOStatus = FT_OK then 231 | begin 232 | if WriteResult = 0 then 233 | WriteResult := WriteSize; 234 | Result := Result + WriteResult; 235 | if WriteResult <> WriteSize then 236 | Break; 237 | end 238 | else 239 | Break; 240 | WritePos := WritePos + WriteSize; 241 | end; 242 | end; 243 | 244 | end; 245 | 246 | CheckFtError(FFtIOStatus, 'FT_Write'); 247 | end; 248 | 249 | procedure TFtdiClient.Execute(); 250 | var 251 | FtBaudRate: LongWord; 252 | FtDataBits: byte; 253 | FtStopBits: byte; 254 | FtParity: byte; 255 | FtFlowControl: word; 256 | FtModemStatus: LongWord; 257 | FtModemStatusPrev: LongWord; 258 | 259 | PortStatus: FT_Result; 260 | SerialString, DeviceString: AnsiString; 261 | s, ss: string; 262 | FtDeviceStringBuffer: array [1..50] of AnsiChar; 263 | ReadCount, ReadResult, WriteSize, WriteResult: Integer; 264 | ReadTimeout, WriteTimeout: LongWord; 265 | NeedSleep: Boolean; 266 | 267 | begin 268 | // Default settings 269 | FLastErrorStr := ''; 270 | DeviceString := ''; 271 | FDoConfig := True; 272 | FFtHandle := FT_INVALID_HANDLE; 273 | FReadCount := SizeOf(FFtInBuffer); 274 | ReadTimeout := 100; 275 | WriteTimeout := 100; 276 | FtBaudRate := FT_BAUD_9600; 277 | FtDataBits := FT_DATA_BITS_8; 278 | FtParity := FT_PARITY_NONE; 279 | FtStopBits := FT_STOP_BITS_1; 280 | FtFlowControl := FT_FLOW_NONE; 281 | FtModemStatus := 0; 282 | FtModemStatusPrev := 0; 283 | 284 | if Terminated then Exit; 285 | 286 | // parse InitStr, open port 287 | FtDeviceStringBuffer[1] := #0; // remove warning 288 | ss := InitStr; 289 | DeviceString := ExtractFirstWord(ss, ':'); 290 | SerialString := ExtractFirstWord(ss, ':'); // Serial num 291 | if Length(SerialString) > 0 then 292 | begin 293 | FillChar(FtDeviceStringBuffer, SizeOf(FtDeviceStringBuffer), 0); 294 | Move(SerialString[1], FtDeviceStringBuffer, Length(SerialString)); 295 | PortStatus := FT_OpenEx(@FtDeviceStringBuffer, FT_OPEN_BY_SERIAL_NUMBER, @FFtHandle); 296 | end 297 | else if Length(DeviceString) > 0 then 298 | begin 299 | FillChar(FtDeviceStringBuffer, SizeOf(FtDeviceStringBuffer), 0); 300 | Move(DeviceString[1], FtDeviceStringBuffer, Length(DeviceString)); 301 | PortStatus := FT_OpenEx(@FtDeviceStringBuffer, FT_OPEN_BY_DESCRIPTION, @FFtHandle); 302 | end 303 | else 304 | PortStatus := FT_DEVICE_NOT_FOUND; 305 | 306 | if not CheckFtError(PortStatus, 'FT_OpenEx') then 307 | FFtHandle := FT_INVALID_HANDLE; 308 | 309 | // Device handle acquired, we must release it in any case 310 | try 311 | while not Terminated do 312 | begin 313 | NeedSleep := True; 314 | // configure port 315 | if FDoConfig then 316 | begin 317 | FDoConfig := False; 318 | if BaudRate <> 0 then 319 | FtBaudRate := BaudRate; 320 | if DataBits <> 0 then 321 | FtDataBits := Byte(DataBits); 322 | case Parity of 323 | 'N', 'n': FtParity := FT_PARITY_NONE; 324 | 'O', 'o': FtParity := FT_PARITY_ODD; 325 | 'E', 'e': FtParity := FT_PARITY_EVEN; 326 | 'M', 'm': FtParity := FT_PARITY_MARK; 327 | 'S', 's': FtParity := FT_PARITY_SPACE; 328 | end; 329 | case StopBits of 330 | stb1: FtStopBits := FT_STOP_BITS_1; 331 | stb15: FtStopBits := FT_STOP_BITS_15; 332 | stb2: FtStopBits := FT_STOP_BITS_2; 333 | end; 334 | case FlowControl of 335 | sfcNone: FtFlowControl := FT_FLOW_NONE; 336 | sfcSend: FtFlowControl := FT_FLOW_RTS_CTS; 337 | sfcReady: FtFlowControl := FT_FLOW_DTR_DSR; 338 | sfcSoft: FtFlowControl := FT_FLOW_XON_XOFF; 339 | end; 340 | 341 | // This function sends a reset command to the device. 342 | PortStatus := FT_ResetDevice(FFtHandle); 343 | if CheckFtError(PortStatus, 'FT_ResetDevice') then 344 | begin 345 | // set BaudRate 346 | PortStatus := FT_SetBaudRate(FFtHandle, FtBaudRate); 347 | if CheckFtError(PortStatus, 'FT_SetBaudRate') then 348 | begin 349 | // set data characteristics 350 | PortStatus := FT_SetDataCharacteristics(FFtHandle, FtDataBits, FtStopBits, FtParity); 351 | if CheckFtError(PortStatus, 'FT_SetDataCharacteristics') then 352 | begin 353 | // set flow control 354 | PortStatus := FT_SetFlowControl(FFtHandle, FtFlowControl, FT_XON_Value, FT_XOFF_Value); 355 | if CheckFtError(PortStatus, 'FT_SetFlowControl') then 356 | begin 357 | // This function sets the read and write timeouts (in milliseconds) for the device 358 | PortStatus := FT_SetTimeouts(FFtHandle, ReadTimeout, WriteTimeout); 359 | if CheckFtError(PortStatus, 'FT_SetTimeouts') then 360 | begin 361 | // This function purges receive and transmit buffers in the device. 362 | PortStatus := FT_Purge(FFtHandle, (FT_PURGE_RX + FT_PURGE_TX)); 363 | CheckFtError(PortStatus, 'FT_Purge'); 364 | PortStatus := FT_ResetDevice(FFtHandle); 365 | CheckFtError(PortStatus, 'FT_ResetDevice_2'); 366 | end; 367 | end; 368 | end; 369 | end; 370 | end; 371 | 372 | if PortStatus = FT_OK then 373 | begin 374 | if Assigned(OnConnect) then 375 | OnConnect(Self); 376 | end 377 | else 378 | begin 379 | Terminate(); 380 | Continue; 381 | end; 382 | end; 383 | 384 | // update modem status 385 | if Assigned(FParentDataPort.OnModemStatus) then 386 | begin 387 | FFtIOStatus := FT_GetModemStatus(FFtHandle, @FtModemStatus); 388 | if CheckFtError(FFtIOStatus, 'FT_GetModemStatus') then 389 | begin 390 | if FtModemStatusPrev <> FtModemStatus then 391 | begin 392 | FtModemStatusPrev := FtModemStatus; 393 | if Assigned(OnIncomingMsgEvent) then 394 | OnIncomingMsgEvent(Self, ''); 395 | end; 396 | end; 397 | end; 398 | 399 | // Reads Read_Count Bytes (or less) from the USB device to the FT_In_Buffer 400 | // Function returns the number of bytes actually received which may range from zero 401 | // to the actual number of bytes requested, depending on how many have been received 402 | // at the time of the request + the read timeout value. 403 | FRxData := ''; 404 | ReadCount := FReadCount; 405 | ReadResult := 0; 406 | 407 | FFtIOStatus := FT_GetStatus(FFtHandle, @FFtRxQBytes, @FFtTxQBytes, 408 | @FFtEventStatus); 409 | if CheckFtError(FFtIOStatus, 'FT_GetStatus') and (FFtRxQBytes > 0) then 410 | begin 411 | if ReadCount > FFtRxQBytes then 412 | ReadCount := FFtRxQBytes; 413 | // This function does not return until dwBytesToRead bytes have been read into the buffer 414 | FFtIOStatus := FT_Read(FFtHandle, @FFtInBuffer, ReadCount, @ReadResult); 415 | if CheckFtError(FFtIOStatus, 'FT_Read') and (ReadResult > 0) then 416 | begin 417 | // copy input buffer to string 418 | SetLength(FRxData, ReadResult); 419 | Move(FFtInBuffer, FRxData[1], ReadResult); 420 | if Assigned(OnIncomingMsgEvent) then 421 | OnIncomingMsgEvent(Self, FRxData); 422 | FRxData := ''; 423 | NeedSleep := False; 424 | end; 425 | end; 426 | 427 | FLock.BeginWrite; 428 | try 429 | if (Length(FTxData) > 0) then 430 | begin 431 | DeviceString := Copy(FTxData, 1, TX_BUF_SIZE); 432 | end; 433 | finally 434 | FLock.EndWrite; 435 | end; 436 | 437 | if DeviceString <> '' then 438 | begin 439 | WriteSize := Length(DeviceString); 440 | WriteResult := 0; 441 | FFtIOStatus := FT_Write(FFtHandle, @DeviceString[1], WriteSize, @WriteResult); 442 | if (FFtIOStatus = FT_OK) then 443 | begin 444 | if WriteResult = 0 then 445 | WriteResult := WriteSize; 446 | 447 | FLock.BeginWrite; 448 | try 449 | Delete(FTxData, 1, WriteResult); 450 | finally 451 | FLock.EndWrite; 452 | end; 453 | NeedSleep := False; 454 | end; 455 | DeviceString := ''; 456 | end; 457 | 458 | if NeedSleep then 459 | Sleep(1); 460 | end; 461 | 462 | finally 463 | if FFtHandle <> FT_INVALID_HANDLE then 464 | FT_Close(FFtHandle); 465 | FFtHandle := FT_INVALID_HANDLE; 466 | FFtIOStatus := FT_INVALID_HANDLE; 467 | end; 468 | 469 | if Assigned(OnError) then 470 | OnError(Self, FLastErrorStr); 471 | 472 | OnIncomingMsgEvent := nil; 473 | OnError := nil; 474 | OnConnect := nil; 475 | end; 476 | 477 | constructor TFtdiClient.Create(AParent: TDataPortUART); 478 | begin 479 | FLock := TSimpleRWSync.Create(); 480 | inherited Create(True); 481 | FParentDataPort := AParent; 482 | BaudRate := 9600; 483 | end; 484 | 485 | destructor TFtdiClient.Destroy; 486 | begin 487 | inherited Destroy; // terminate thread, if running 488 | FreeAndNil(FLock); 489 | end; 490 | 491 | function TFtdiClient.GetFtErrorDescription(APortStatus: FT_Result): string; 492 | begin 493 | Result := ''; 494 | if APortStatus = FT_OK then 495 | Exit; 496 | case APortStatus of 497 | FT_INVALID_HANDLE: Result := 'Invalid handle'; 498 | FT_DEVICE_NOT_FOUND: Result := 'Device not found'; 499 | FT_DEVICE_NOT_OPENED: Result := 'Device not opened'; 500 | FT_IO_ERROR: Result := 'General IO error'; 501 | FT_INSUFFICIENT_RESOURCES: Result := 'Insufficient resources'; 502 | FT_INVALID_PARAMETER: Result := 'Invalid parameter'; 503 | FT_INVALID_BAUD_RATE: Result := 'Invalid baud rate'; 504 | FT_DEVICE_NOT_OPENED_FOR_ERASE: Result := 'Device not opened for erase'; 505 | FT_DEVICE_NOT_OPENED_FOR_WRITE: Result := 'Device not opened for write'; 506 | FT_FAILED_TO_WRITE_DEVICE: Result := 'Failed to write'; 507 | FT_EEPROM_READ_FAILED: Result := 'EEPROM read failed'; 508 | FT_EEPROM_WRITE_FAILED: Result := 'EEPROM write failed'; 509 | FT_EEPROM_ERASE_FAILED: Result := 'EEPROM erase failed'; 510 | FT_EEPROM_NOT_PRESENT: Result := 'EEPROM not present'; 511 | FT_EEPROM_NOT_PROGRAMMED: Result := 'EEPROM not programmed'; 512 | FT_INVALID_ARGS: Result := 'Invalid arguments'; 513 | FT_OTHER_ERROR: Result := 'Other error'; 514 | else 515 | Result := 'Unknown error'; 516 | end; 517 | end; 518 | 519 | function TFtdiClient.SendAnsiString(const AData: AnsiString): Boolean; 520 | begin 521 | Result := FLock.BeginWrite; 522 | if Result then 523 | try 524 | FTxData := FTxData + AData; 525 | finally 526 | FLock.EndWrite; 527 | end; 528 | end; 529 | 530 | function TFtdiClient.ReadModemStatus(var AModemStatus: TModemStatus): Boolean; 531 | var 532 | ModemStat: LongWord; 533 | begin 534 | if FFtHandle <> FT_INVALID_HANDLE then 535 | begin 536 | Result := (FT_GetModemStatus(FFtHandle, @ModemStat) = FT_OK); 537 | if Result then 538 | begin 539 | AModemStatus.CTS := (ModemStat and FT_CTS) <> 0; 540 | AModemStatus.DSR := (ModemStat and FT_DSR) <> 0; 541 | AModemStatus.Ring := (ModemStat and FT_RI) <> 0; 542 | AModemStatus.Carrier := (ModemStat and FT_DCD) <> 0; 543 | end; 544 | end 545 | else 546 | Result := False; 547 | end; 548 | 549 | procedure TFtdiClient.SetDTR(AValue: Boolean); 550 | begin 551 | if FFtHandle <> FT_INVALID_HANDLE then 552 | begin 553 | if AValue then 554 | FT_SetDtr(FFtHandle) 555 | else 556 | FT_ClrDtr(FFtHandle); 557 | end; 558 | end; 559 | 560 | procedure TFtdiClient.SetRTS(AValue: Boolean); 561 | begin 562 | if FFtHandle <> FT_INVALID_HANDLE then 563 | begin 564 | if AValue then 565 | FT_SetRts(FFtHandle) 566 | else 567 | FT_ClrRts(FFtHandle); 568 | end; 569 | end; 570 | 571 | function TFtdiClient.GetPortName(): string; 572 | var 573 | ComPortNum: Longint; 574 | begin 575 | Result := ''; 576 | if (FFtHandle <> FT_INVALID_HANDLE) then 577 | begin 578 | FT_GetComPortNumber(FFtHandle, @ComPortNum); 579 | if ComPortNum <> -1 then 580 | Result := 'COM' + IntToStr(ComPortNum); 581 | end; 582 | end; 583 | 584 | { TDataPortFtdi } 585 | 586 | constructor TDataPortFtdi.Create(AOwner: TComponent); 587 | begin 588 | inherited Create(AOwner); 589 | FFlowControl := sfcNone; 590 | FFtdiClient := nil; 591 | end; 592 | 593 | destructor TDataPortFtdi.Destroy(); 594 | begin 595 | CloseClient(); 596 | inherited Destroy(); 597 | end; 598 | 599 | function TDataPortFtdi.CloseClient(): Boolean; 600 | begin 601 | Result := True; 602 | FreeAndNil(FFtdiClient); 603 | end; 604 | 605 | procedure TDataPortFtdi.Open(const AInitStr: string); 606 | var 607 | ss: string; 608 | begin 609 | ss := AInitStr; 610 | // Set device description and serial number 611 | if ss <> '' then 612 | begin 613 | Self.FFtDeviceDescription := ExtractFirstWord(ss, ':'); 614 | 615 | Self.FFtSerialNumber := ExtractFirstWord(ss, ':'); 616 | end; 617 | 618 | inherited Open(ss); 619 | 620 | if CloseClient() then 621 | begin 622 | FFtdiClient := TFtdiClient.Create(Self); 623 | FFtdiClient.InitStr := FFtDeviceDescription + ':' + FFtSerialNumber; 624 | FFtdiClient.BaudRate := FBaudRate; 625 | FFtdiClient.DataBits := FDataBits; 626 | FFtdiClient.Parity := FParity; 627 | FFtdiClient.StopBits := FStopBits; 628 | FFtdiClient.FlowControl := FFlowControl; 629 | 630 | FFtdiClient.OnIncomingMsgEvent := OnIncomingMsgHandler; 631 | FFtdiClient.OnError := OnErrorHandler; 632 | FFtdiClient.OnConnect := OnConnectHandler; 633 | FFtdiClient.Suspended := False; 634 | // don't set FActive - will be set in OnConnect event after successfull connection 635 | end; 636 | end; 637 | 638 | procedure TDataPortFtdi.Close(); 639 | begin 640 | CloseClient(); 641 | inherited Close(); 642 | end; 643 | 644 | function TDataPortFtdi.Push(const AData: AnsiString): Boolean; 645 | begin 646 | Result := False; 647 | if Active and Assigned(FtdiClient) then 648 | begin 649 | Result := FtdiClient.SendAnsiString(AData); 650 | end; 651 | end; 652 | 653 | class function TDataPortFtdi.GetFtdiDeviceList(): AnsiString; 654 | var 655 | FtDeviceCount, DeviceIndex: LongWord; 656 | PortStatus: FT_Result; 657 | DeviceInfo: FT_Device_Info_Node; 658 | //FtDeviceInfoList: array of FT_Device_Info_Node; 659 | i: Integer; 660 | //sDevType: string; 661 | begin 662 | Result := ''; 663 | //PortStatus := FT_GetNumDevices(@FtDeviceCount, nil, FT_LIST_NUMBER_ONLY); 664 | //if PortStatus <> FT_OK then Exit; 665 | 666 | PortStatus := FT_CreateDeviceInfoList(@FtDeviceCount); 667 | if PortStatus <> FT_OK then 668 | Exit; 669 | 670 | //SetLength(FT_DeviceInfoList, FtDeviceCount); 671 | //PortStatus := FT_GetDeviceInfoList(FtDeviceInfoList, @FtDeviceCount); 672 | //if PortStatus <> FT_OK then Exit; 673 | 674 | for i := 1 to FtDeviceCount do 675 | begin 676 | DeviceIndex := i-1; 677 | DeviceInfo.Flags := 0; 678 | DeviceInfo.DeviceType := 0; 679 | DeviceInfo.ID := 0; 680 | DeviceInfo.LocID := 0; 681 | DeviceInfo.SerialNumber := ''; 682 | DeviceInfo.Description := ''; 683 | DeviceInfo.DeviceHandle := 0; 684 | 685 | PortStatus := FT_GetDeviceInfoDetail(DeviceIndex, 686 | @DeviceInfo.Flags, @DeviceInfo.DeviceType, @DeviceInfo.ID, 687 | @DeviceInfo.LocID, @DeviceInfo.SerialNumber, @DeviceInfo.Description, 688 | @DeviceInfo.DeviceHandle); 689 | if PortStatus = FT_OK then 690 | begin 691 | if (DeviceInfo.Flags and $1) > 0 then 692 | Continue; // device busy 693 | { 694 | //if (DeviceInfo.Flags and $2) > 0 then; // HighSpeed device 695 | case DeviceInfo.DeviceType of 696 | FT_DEVICE_232BM: sDevType := '232BM'; 697 | FT_DEVICE_232AM: sDevType := '232AM'; 698 | FT_DEVICE_100AX: sDevType := '100AX'; 699 | FT_DEVICE_UNKNOWN: sDevType := 'Unknown'; 700 | FT_DEVICE_2232C: sDevType := '2232C'; 701 | FT_DEVICE_232R: sDevType := '232R'; 702 | FT_DEVICE_2232H: sDevType := '2232H'; 703 | FT_DEVICE_4232H: sDevType := '4232H'; 704 | FT_DEVICE_232H: sDevType := '232H'; 705 | FT_DEVICE_X_SERIES: sDevType := 'X Series'; 706 | else 707 | sDevType := 'Unknown'; 708 | end; 709 | } 710 | 711 | if Length(Result) > 0 then 712 | Result := Result + sLineBreak; 713 | Result := Result + Trim(DeviceInfo.Description) + ':' + Trim(DeviceInfo.SerialNumber); 714 | end; 715 | end; 716 | 717 | end; 718 | 719 | function TDataPortFtdi.GetModemStatus(): TModemStatus; 720 | begin 721 | if Assigned(FtdiClient) then 722 | begin 723 | FtdiClient.ReadModemStatus(FModemStatus); 724 | end; 725 | Result := inherited GetModemStatus; 726 | end; 727 | 728 | procedure TDataPortFtdi.SetDTR(AValue: Boolean); 729 | begin 730 | if Assigned(FtdiClient) then 731 | FtdiClient.SetDTR(AValue); 732 | inherited SetDTR(AValue); 733 | end; 734 | 735 | procedure TDataPortFtdi.SetRTS(AValue: Boolean); 736 | begin 737 | if Assigned(FtdiClient) then 738 | FtdiClient.SetRTS(AValue); 739 | inherited SetRTS(AValue); 740 | end; 741 | 742 | (* 743 | class function TDataPortFtdi.GetFtdiDriverVersion(): string; 744 | var 745 | DrVersion: LongWord; 746 | begin 747 | Result := ''; 748 | {$ifdef WINDOWS} 749 | if not Active then Exit; 750 | if FT_GetDriverVersion(FtdiClient.FFtHandle, @DrVersion) = FT_OK then 751 | begin 752 | Result := IntToStr((DrVersion shr 16) and $FF) 753 | +'.'+IntToStr((DrVersion shr 8) and $FF) 754 | +'.'+IntToStr(DrVersion and $FF); 755 | end; 756 | {$endif} 757 | end; 758 | *) 759 | 760 | procedure TDataPortFtdi.SetBaudRate(AValue: Integer); 761 | begin 762 | inherited SetBaudRate(AValue); 763 | if Active then 764 | begin 765 | FtdiClient.BaudRate := FBaudRate; 766 | FtdiClient.Config(); 767 | end; 768 | end; 769 | 770 | procedure TDataPortFtdi.SetDataBits(AValue: Integer); 771 | begin 772 | inherited SetDataBits(AValue); 773 | if Active then 774 | begin 775 | FtdiClient.DataBits := FDataBits; 776 | FtdiClient.Config(); 777 | end; 778 | end; 779 | 780 | procedure TDataPortFtdi.SetFlowControl(AValue: TSerialFlowControl); 781 | begin 782 | FFlowControl := AValue; 783 | if Active then 784 | begin 785 | FtdiClient.FlowControl := FFlowControl; 786 | FtdiClient.Config(); 787 | end; 788 | end; 789 | 790 | procedure TDataPortFtdi.SetParity(AValue: AnsiChar); 791 | begin 792 | inherited SetParity(AValue); 793 | if Active then 794 | begin 795 | FtdiClient.Parity := FParity; 796 | FtdiClient.Config(); 797 | end; 798 | end; 799 | 800 | procedure TDataPortFtdi.SetStopBits(AValue: TSerialStopBits); 801 | begin 802 | inherited SetStopBits(AValue); 803 | if Active then 804 | begin 805 | FtdiClient.StopBits := FStopBits; 806 | FtdiClient.Config(); 807 | end; 808 | end; 809 | 810 | end. 811 | --------------------------------------------------------------------------------