diff --git a/.gitattributes b/.gitattributes index 3a7f64af14..ddbb1287ad 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2006,6 +2006,7 @@ packages/fcl-base/src/wtex.pp svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.lpi svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain packages/fcl-base/tests/tcbufferedfilestream.pp svneol=native#text/plain +packages/fcl-base/tests/tccsvdocument.pp svneol=native#text/plain packages/fcl-base/tests/tccsvreadwrite.pp svneol=native#text/plain packages/fcl-base/tests/tchashlist.pp svneol=native#text/plain packages/fcl-base/tests/tcinifile.pp svneol=native#text/plain @@ -2308,6 +2309,14 @@ packages/fcl-extra/examples/Makefile svneol=native#text/plain packages/fcl-extra/examples/Makefile.fpc svneol=native#text/plain packages/fcl-extra/examples/daemon.pp svneol=native#text/plain packages/fcl-extra/examples/daemon.txt svneol=native#text/plain +packages/fcl-extra/examples/double/daemonmapperunit1.lfm svneol=native#text/plain +packages/fcl-extra/examples/double/daemonmapperunit1.pas svneol=native#text/plain +packages/fcl-extra/examples/double/daemonunit1.lfm svneol=native#text/plain +packages/fcl-extra/examples/double/daemonunit1.pas svneol=native#text/plain +packages/fcl-extra/examples/double/daemonunit2.lfm svneol=native#text/plain +packages/fcl-extra/examples/double/daemonunit2.pas svneol=native#text/plain +packages/fcl-extra/examples/double/double.pp svneol=native#text/plain +packages/fcl-extra/examples/double/resdaemonapp.pp svneol=native#text/plain packages/fcl-extra/fpmake.pp svneol=native#text/pascal packages/fcl-extra/src/daemonapp.pp svneol=native#text/plain packages/fcl-extra/src/unix/daemonapp.inc svneol=native#text/plain diff --git a/packages/fcl-base/src/csvdocument.pp b/packages/fcl-base/src/csvdocument.pp index e61740ee10..757a2e699b 100644 --- a/packages/fcl-base/src/csvdocument.pp +++ b/packages/fcl-base/src/csvdocument.pp @@ -44,7 +44,7 @@ unit csvdocument; interface uses - Classes, SysUtils, Contnrs, csvreadwrite; + Classes, SysUtils, Contnrs, csvreadwrite, bufstream; type TCSVChar = csvreadwrite.TCSVChar; @@ -73,13 +73,15 @@ type function GetColCount(ARow: Integer): Integer; function GetMaxColCount: Integer; public - constructor Create; + constructor Create; override; destructor Destroy; override; // Input/output - // Load document from file AFileName - procedure LoadFromFile(const AFilename: String); + // Load document from file AFileName. Use default buffer size of 16kb + procedure LoadFromFile(const AFilename: String); overload; + // Load document from file AFileName. Buffer size is in Kb. + procedure LoadFromFile(const AFilename: String; ABufferSize : Integer); overload; // Load document from stream AStream procedure LoadFromStream(AStream: TStream); // Save document to file AFilename @@ -392,14 +394,27 @@ begin end; procedure TCSVDocument.LoadFromFile(const AFilename: String); + +begin + LoadFromFile(aFileName,DefaultBufferCapacity); +end; + +procedure TCSVDocument.LoadFromFile(const AFilename: String; ABufferSize : Integer); var FileStream: TFileStream; + B : TBufStream; + begin + B:=Nil; FileStream := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyNone); try - LoadFromStream(FileStream); + B:=TReadBufStream.Create(FileStream,aBufferSize); + B.SourceOwner:=True; + FileStream:=Nil; + LoadFromStream(B); finally FileStream.Free; + B.Free; end; end; diff --git a/packages/fcl-base/tests/fclbase-unittests.lpi b/packages/fcl-base/tests/fclbase-unittests.lpi index d910d16140..54d9634c14 100644 --- a/packages/fcl-base/tests/fclbase-unittests.lpi +++ b/packages/fcl-base/tests/fclbase-unittests.lpi @@ -36,7 +36,7 @@ - + @@ -65,6 +65,10 @@ + + + + diff --git a/packages/fcl-base/tests/fclbase-unittests.pp b/packages/fcl-base/tests/fclbase-unittests.pp index 33e79d4d0c..80728b7e9b 100644 --- a/packages/fcl-base/tests/fclbase-unittests.pp +++ b/packages/fcl-base/tests/fclbase-unittests.pp @@ -4,7 +4,7 @@ program fclbase_unittests; uses Classes, consoletestrunner, tests_fptemplate, tchashlist, - testexprpars, tcmaskutils, tcinifile, tccsvreadwrite,tcbufferedfilestream; + testexprpars, tcmaskutils, tcinifile, tccsvreadwrite,tcbufferedfilestream, tccsvdocument; var Application: TTestRunner; diff --git a/packages/fcl-base/tests/tccsvdocument.pp b/packages/fcl-base/tests/tccsvdocument.pp new file mode 100644 index 0000000000..54442e75a4 --- /dev/null +++ b/packages/fcl-base/tests/tccsvdocument.pp @@ -0,0 +1,148 @@ +unit tccsvdocument; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, csvdocument; + +Type + + { TTestCSVDocument } + + TTestCSVDocument = Class(TTestCase) + private + FDoc: TCSVDocument; + procedure RemoveTestFile; + function StripQuotes(S: String): string; + procedure TestTestFile; + Public + Procedure SetUp; override; + Procedure TearDown; override; + Procedure CreateTestFile; + Property Doc : TCSVDocument Read FDoc; + Published + Procedure TestEmpty; + Procedure TestRead; + end; + + + + + +implementation + +Const + TestFileName = 'test.csv'; + +{ TTestCSVDocument } + +procedure TTestCSVDocument.SetUp; +begin + FDoc:=TCSVDocument.Create; + Inherited; +end; + +procedure TTestCSVDocument.TearDown; +begin + RemoveTestFile; + FreeAndNil(FDoc); + Inherited; +end; + +procedure TTestCSVDocument.RemoveTestFile; + +begin + If FileExists(TestFileName) then + AssertTrue('Deleting test file',DeleteFile(TestFileName)); +end; + +Const + ColCount = 3; + RowCount = 4; + +Type + TRow = Array[0..ColCount-1] of string; + TCells = Array[0..RowCount-1] of TRow; + +Const + Cells : TCells = ( + ('a','b','c'), + ('1','"one"','1.1'), + ('2','"two"','2.2'), + ('3','"three"','3.3') + ); + +procedure TTestCSVDocument.CreateTestFile; + +Var + L : TStringList; + R,C : Integer; + S : String; + +begin + L:=TStringList.Create; + try + for R:=0 to RowCount-1 do + begin + S:=''; + for C:=0 to ColCount-1 do + begin + if S<>'' then + S:=S+','; + S:=S+Cells[R,C]; + end; + L.Add(S); + end; + L.SaveToFile(TestFileName); + finally + L.Free; + end; +end; + +procedure TTestCSVDocument.TestEmpty; +begin + AssertNotNull('Have document',Doc); +end; + +Function TTestCSVDocument.StripQuotes(S : String) : string; + +Var + L : integer; + +begin + Result:=S; + L:=Length(Result); + if (L>1) then + if (Result[1]='"') and (Result[L]='"') then + Result:=Copy(Result,2,L-2); +end; + +procedure TTestCSVDocument.TestTestFile; + +Var + R,C : Integer; + +begin + AssertEquals('Row count',RowCount,Doc.RowCount); + For R:=0 to RowCount-1 do + For C:=0 to ColCount-1 do + begin + AssertEquals('Col['+IntToStr(R)+'] count',ColCount,Doc.ColCount[R]); + AssertEquals(Format('Cell[%d,%d]',[C,R]),StripQuotes(Cells[R,C]),Doc.Cells[C,R]); + end; +end; + +procedure TTestCSVDocument.TestRead; + +begin + CreateTestFile; + Doc.LoadFromFile(TestFileName); + TestTestFile; +end; + +initialization + RegisterTest(TTestCSVDocument); +end. + diff --git a/packages/fcl-base/tests/tccsvreadwrite.pp b/packages/fcl-base/tests/tccsvreadwrite.pp index 23b5c38cd3..991f39f902 100644 --- a/packages/fcl-base/tests/tccsvreadwrite.pp +++ b/packages/fcl-base/tests/tccsvreadwrite.pp @@ -112,7 +112,6 @@ begin end; initialization - RegisterTest(TTestCSVReadWrite); end. diff --git a/packages/fcl-db/src/base/bufdataset.pas b/packages/fcl-db/src/base/bufdataset.pas index 73f5d43ec1..0c96d44234 100644 --- a/packages/fcl-db/src/base/bufdataset.pas +++ b/packages/fcl-db/src/base/bufdataset.pas @@ -353,7 +353,7 @@ type { TDataPacketReader } - TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny); + TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny,dfDefault); TDatapacketReaderClass = class of TDatapacketReader; TDataPacketReader = class(TObject) @@ -564,6 +564,9 @@ type Property BufIndexes[Aindex : Integer] : TBufIndex Read GetBufIndex; protected // abstract & virtual methods of TDataset + class function DefaultReadFileFormat : TDataPacketFormat; virtual; + class function DefaultWriteFileFormat : TDataPacketFormat; virtual; + class function DefaultPacketClass : TDataPacketReaderClass ; virtual; procedure SetPacketRecords(aValue : integer); virtual; procedure SetRecNo(Value: Longint); override; function GetRecNo: Longint; override; @@ -640,9 +643,9 @@ type procedure SetDatasetPacket(AReader : TDataPacketReader); procedure GetDatasetPacket(AWriter : TDataPacketReader); - procedure LoadFromStream(AStream : TStream; Format: TDataPacketFormat = dfAny); + procedure LoadFromStream(AStream : TStream; Format: TDataPacketFormat = dfDefault); procedure SaveToStream(AStream : TStream; Format: TDataPacketFormat = dfBinary); - procedure LoadFromFile(AFileName: string = ''; Format: TDataPacketFormat = dfAny); + procedure LoadFromFile(AFileName: string = ''; Format: TDataPacketFormat = dfDefault); procedure SaveToFile(AFileName: string = ''; Format: TDataPacketFormat = dfBinary); procedure CreateDataset; Procedure Clear; // Will close and remove all field definitions. @@ -738,17 +741,18 @@ var begin Result := False; - for i := 0 to length(RegisteredDatapacketReaders)-1 do if ((AFormat=dfAny) or (AFormat=RegisteredDatapacketReaders[i].Format)) then - begin - if (AStream=nil) or (RegisteredDatapacketReaders[i].ReaderClass.RecognizeStream(AStream)) then + for i := 0 to length(RegisteredDatapacketReaders)-1 do + if ((AFormat=dfAny) or (AFormat=RegisteredDatapacketReaders[i].Format)) then begin - ADataReaderClass := RegisteredDatapacketReaders[i]; - Result := True; - if (AStream <> nil) then AStream.Seek(0,soFromBeginning); - break; + if (AStream=nil) or (RegisteredDatapacketReaders[i].ReaderClass.RecognizeStream(AStream)) then + begin + ADataReaderClass := RegisteredDatapacketReaders[i]; + Result := True; + if (AStream <> nil) then AStream.Seek(0,soFromBeginning); + break; + end; + AStream.Seek(0,soFromBeginning); end; - AStream.Seek(0,soFromBeginning); - end; end; function DBCompareText(subValue, aValue: pointer; size: integer; options: TLocateOptions): LargeInt; @@ -1431,8 +1435,8 @@ end; procedure TCustomBufDataset.DoBeforeClose; begin inherited DoBeforeClose; - if FFileName<>'' then - SaveToFile(FFileName); + if (FFileName<>'') then + SaveToFile(FFileName,dfDefault); end; procedure TCustomBufDataset.InternalClose; @@ -2249,6 +2253,22 @@ begin FMaxIndexesCount:=FIndexes.Count+2; // Custom+Default order end; +class function TCustomBufDataset.DefaultReadFileFormat: TDataPacketFormat; +begin + Result:=dfAny; +end; + +class function TCustomBufDataset.DefaultWriteFileFormat: TDataPacketFormat; +begin + Result:=dfBinary; +end; + +class function TCustomBufDataset.DefaultPacketClass: TDataPacketReaderClass; +begin + Result:=TFpcBinaryDatapacketReader; +end; + + procedure TCustomBufDataset.SetIndexFieldNames(const AValue: String); begin @@ -3046,11 +3066,17 @@ end; function TCustomBufDataset.GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; -var APacketReader: TDataPacketReader; - APacketReaderReg: TDatapacketReaderRegistration; - +var + APacketReader: TDataPacketReader; + APacketReaderReg: TDatapacketReaderRegistration; + Fmt : TDataPacketFormat; begin - if GetRegisterDatapacketReader(AStream, format, APacketReaderReg) then + fmt:=Format; + if (Fmt=dfDefault) then + fmt:=DefaultReadFileFormat; + if fmt=dfDefault then + APacketReader := DefaultPacketClass.Create(Self, AStream) + else if GetRegisterDatapacketReader(AStream, fmt, APacketReaderReg) then APacketReader := APacketReaderReg.ReaderClass.Create(Self, AStream) else if TFpcBinaryDatapacketReader.RecognizeStream(AStream) then begin @@ -3423,11 +3449,17 @@ end; procedure TCustomBufDataset.SaveToStream(AStream: TStream; Format: TDataPacketFormat); var APacketReaderReg : TDatapacketReaderRegistration; APacketWriter : TDataPacketReader; + Fmt : TDataPacketFormat; begin CheckBiDirectional; - if GetRegisterDatapacketReader(Nil,format,APacketReaderReg) then + fmt:=Format; + if Fmt=dfDefault then + fmt:=DefaultWriteFileFormat; + if fmt=dfDefault then + APacketWriter := DefaultPacketClass.Create(Self, AStream) + else if GetRegisterDatapacketReader(Nil,fmt,APacketReaderReg) then APacketWriter := APacketReaderReg.ReaderClass.Create(Self, AStream) - else if Format = dfBinary then + else if fmt = dfBinary then APacketWriter := TFpcBinaryDatapacketReader.Create(Self, AStream) else DatabaseError(SNoReaderClassRegistered,Self); @@ -3439,9 +3471,13 @@ begin end; procedure TCustomBufDataset.LoadFromFile(AFileName: string; Format: TDataPacketFormat); -var AFileStream : TFileStream; + +var + AFileStream : TFileStream; + begin - if AFileName='' then AFileName := FFileName; + if AFileName='' then + AFileName := FFileName; AFileStream := TFileStream.Create(AFileName,fmOpenRead); try LoadFromStream(AFileStream, Format); @@ -3450,11 +3486,14 @@ begin end; end; -procedure TCustomBufDataset.SaveToFile(AFileName: string; - Format: TDataPacketFormat); -var AFileStream : TFileStream; +procedure TCustomBufDataset.SaveToFile(AFileName: string; Format: TDataPacketFormat); + +var + AFileStream : TFileStream; + begin - if AFileName='' then AFileName := FFileName; + if AFileName='' then + AFileName := FFileName; AFileStream := TFileStream.Create(AFileName,fmCreate); try SaveToStream(AFileStream, Format); @@ -3526,7 +3565,7 @@ begin if not assigned(FDatasetReader) then begin FFileStream := TFileStream.Create(FileName, fmOpenRead); - FDatasetReader := GetPacketReader(dfAny, FFileStream); + FDatasetReader := GetPacketReader(dfDefault, FFileStream); end; FieldDefs.Clear; diff --git a/packages/fcl-db/src/base/csvdataset.pp b/packages/fcl-db/src/base/csvdataset.pp index b1ba535281..7e08edd1bd 100644 --- a/packages/fcl-db/src/base/csvdataset.pp +++ b/packages/fcl-db/src/base/csvdataset.pp @@ -95,6 +95,9 @@ Type FCSVOptions: TCSVOptions; procedure SetCSVOptions(AValue: TCSVOptions); Protected + class function DefaultReadFileFormat : TDataPacketFormat; override; + class function DefaultWriteFileFormat : TDataPacketFormat; override; + class function DefaultPacketClass : TDataPacketReaderClass ; override; function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; override; procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); override; procedure InternalInitFieldDefs; override; @@ -305,10 +308,25 @@ begin FCSVOptions.Assign(AValue); end; +class function TCustomCSVDataset.DefaultReadFileFormat: TDataPacketFormat; +begin + Result:=dfDefault; +end; + +class function TCustomCSVDataset.DefaultWriteFileFormat: TDataPacketFormat; +begin + Result:=dfDefault; +end; + +class function TCustomCSVDataset.DefaultPacketClass: TDataPacketReaderClass; +begin + Result:=TCSVDataPacketReader; +end; + function TCustomCSVDataset.GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; begin - If (Format=dfAny) then + If (Format in [dfAny,dfDefault]) then Result:=TCSVDataPacketReader.Create(Self,AStream,FCSVOptions) else Result:=Inherited GetPacketReader(Format,AStream); diff --git a/packages/fcl-db/tests/tccsvdataset.pp b/packages/fcl-db/tests/tccsvdataset.pp index 48e021d4a3..c0b678837f 100644 --- a/packages/fcl-db/tests/tccsvdataset.pp +++ b/packages/fcl-db/tests/tccsvdataset.pp @@ -15,6 +15,7 @@ type private FCSVDataset: TCSVDataset; // Load CSVDataset from CSV stream containing lines + procedure DoOpenClose; Procedure LoadFromLines(Const Lines: Array of string); // Save CSVDataset to CSV stream, transform to lines Procedure SaveToLines(Const Lines: TStrings); @@ -47,6 +48,7 @@ type Procedure TestLoadPriorFieldDefsNoFieldNamesWrongCount; Procedure TestLoadPriorFieldDefsFieldNamesWrongCount; Procedure TestLoadPriorFieldDefsFieldNamesWrongNames; + Procedure TestOpenCloseCycle; end; implementation @@ -421,6 +423,89 @@ begin Fail(OK); end; +const + FILENAME = 'test.dat'; + +procedure TTestCSVDataset.DoOpenClose; + +begin + CSVDataset.FileName := FILENAME; + With CSVDataset do + begin + CSVOptions.FirstLineAsFieldNames := True; + CSVOptions.DefaultFieldLength := 255; + CSVOptions.Delimiter := ','; + CSVOptions.QuoteChar := '"'; + CSVOptions.IgnoreOuterWhitespace := False; + CSVOptions.QuoteOuterWhitespace := True; + end; + // When the program runs for the first time, the data file does not yet exist. + // We must create the FieldDefs and create the dataset. + if FileExists(CSVDataset.FileName) then + CSVDataset.Open + else + with CSVDataset do + begin + FieldDefs.Add('FirstName', ftString, 20); + FieldDefs.Add('LastName', ftstring, 20); + FieldDefs.Add('City', ftString, 20); + FieldDefs.Add('Address', ftString, 30); + FieldDefs.Add('Birthdate', ftDate); + CreateDataset; + + // Open the dataset... + Open; + + // ... and add some dummy data: + // Names from https://donatellanobatti.blogspot.de/ + Append; + FieldByName('FirstName').AsString := 'Walter'; + FieldByName('LastName').AsString := 'Mellon'; + FieldByName('City').AsString := 'Oklahoma City'; + FieldByName('Address').AsString := '1261, Main Street'; + FieldbyName('Birthdate').AsDateTime := EncodeDate(1980, 1, 1); + Post; + + Append; + FieldByName('FirstName').AsString := 'Mario'; + FieldByName('LastName').AsString := 'Speedwagon'; + FieldByName('City').AsString := 'Hollywood'; + FieldByName('Address').AsString := '1500, Hollywood Blvd'; + FieldbyName('Birthdate').AsDateTime := EncodeDate(1982, 12, 17); + Post; + + Append; + FieldByName('FirstName').AsString := 'Anna'; + FieldByName('LastName').AsString := 'Mull'; + FieldByName('City').AsString := 'Los Angeles'; + FieldByName('Address').AsString := '2202, Capitol Square'; + FieldbyName('Birthdate').AsDateTime := EncodeDate(1982, 12, 17); + Post; + end; + // This will write the file; + CSVDataset.Close; +end; + +procedure TTestCSVDataset.TestOpenCloseCycle; +begin + if FileExists(FileName) then + AssertTrue('Delete before',DeleteFile(FileName)); + try + // This will create the file + DoOpenClose; + // Recreate to be sure + FreeAndNil(FCSVDataset); + FCSVDataset:=TCSVDataset.Create(Nil); + FCSVDataset.Name:='DS'; + DoOpenClose; + except + On E : Exception do + Fail('Failed using exception %s : %s',[E.ClassName,E.Message]); + end; + if FileExists(FileName) then + AssertTrue('Delete after',DeleteFile(FileName)); +end; + procedure TTestCSVDataset.SetUp; begin FCSVDataset:=TCSVDataset.Create(Nil); diff --git a/packages/fcl-db/tests/testbufdatasetstreams.pas b/packages/fcl-db/tests/testbufdatasetstreams.pas index 4c679d19ec..b70c3eb1f9 100644 --- a/packages/fcl-db/tests/testbufdatasetstreams.pas +++ b/packages/fcl-db/tests/testbufdatasetstreams.pas @@ -100,7 +100,7 @@ uses toolsunit, SQLDBToolsUnit, sqldb, XMLDatapacketReader; const TestXMLFileName = 'test.xml'; TestBINFileName = 'test.dat'; - TestFileNames: array[TDataPacketFormat] of string = (TestBINFileName, TestXMLFileName, TestXMLFileName, ''); + TestFileNames: array[TDataPacketFormat] of string = (TestBINFileName, TestXMLFileName, TestXMLFileName, '',''); { TMyCustomBufDataset } diff --git a/packages/fcl-extra/examples/double/daemonmapperunit1.lfm b/packages/fcl-extra/examples/double/daemonmapperunit1.lfm new file mode 100644 index 0000000000..a1127150e3 --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonmapperunit1.lfm @@ -0,0 +1,29 @@ +object DaemonMapper1: TDaemonMapper1 + DaemonDefs = < + item + DaemonClassName = 'TDaemon1' + Name = 'TDaemon1' + Options = [doAllowStop, doAllowPause] + WinBindings.Dependencies = <> + WinBindings.StartType = stBoot + WinBindings.WaitHint = 0 + WinBindings.IDTag = 0 + WinBindings.ServiceType = stWin32 + WinBindings.ErrorSeverity = esIgnore + LogStatusReport = False + end + item + DaemonClassName = 'TDaemon2' + Name = 'TDaemon2' + Options = [doAllowStop, doAllowPause] + WinBindings.Dependencies = <> + WinBindings.StartType = stBoot + WinBindings.WaitHint = 0 + WinBindings.IDTag = 0 + WinBindings.ServiceType = stWin32 + WinBindings.ErrorSeverity = esIgnore + LogStatusReport = False + end> + Left = 284 + Top = 140 +end diff --git a/packages/fcl-extra/examples/double/daemonmapperunit1.pas b/packages/fcl-extra/examples/double/daemonmapperunit1.pas new file mode 100644 index 0000000000..e652a687cf --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonmapperunit1.pas @@ -0,0 +1,34 @@ +unit DaemonMapperUnit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DaemonApp; + +type + TDaemonMapper1 = class(TDaemonMapper) + private + + public + + end; + +var + DaemonMapper1: TDaemonMapper1; + +implementation + +procedure RegisterMapper; +begin + RegisterDaemonMapper(TDaemonMapper1) +end; + +{$R *.lfm} + + +initialization + RegisterMapper; +end. + diff --git a/packages/fcl-extra/examples/double/daemonunit1.lfm b/packages/fcl-extra/examples/double/daemonunit1.lfm new file mode 100644 index 0000000000..529ff9655d --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonunit1.lfm @@ -0,0 +1,8 @@ +object Daemon1: TDaemon1 + OldCreateOrder = False + OnExecute = DataModuleExecute + Height = 150 + HorizontalOffset = 284 + VerticalOffset = 140 + Width = 150 +end diff --git a/packages/fcl-extra/examples/double/daemonunit1.pas b/packages/fcl-extra/examples/double/daemonunit1.pas new file mode 100644 index 0000000000..8f9caa84e0 --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonunit1.pas @@ -0,0 +1,52 @@ +unit DaemonUnit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DaemonApp; + +type + + { TDaemon1 } + + TDaemon1 = class(TDaemon) + procedure DataModuleExecute(Sender: TCustomDaemon); + private + + public + + end; + +var + Daemon1: TDaemon1; + +implementation + +procedure RegisterDaemon; +begin + RegisterDaemonClass(TDaemon1) +end; + +{$R *.lfm} + +{ TDaemon1 } + +procedure TDaemon1.DataModuleExecute(Sender: TCustomDaemon); +Var + I : Integer; +begin + I := 0; + Application.EventLog.Log('TDaemon1 execution start'); + While Self.Status = csRunning Do Begin + Sleep(10); + end; + Application.EventLog.Log('TDaemon1 execution stop'); +end; + + +initialization + RegisterDaemon; +end. + diff --git a/packages/fcl-extra/examples/double/daemonunit2.lfm b/packages/fcl-extra/examples/double/daemonunit2.lfm new file mode 100644 index 0000000000..525c1a5520 --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonunit2.lfm @@ -0,0 +1,8 @@ +object Daemon2: TDaemon2 + OldCreateOrder = False + OnExecute = DataModuleExecute + Height = 150 + HorizontalOffset = 284 + VerticalOffset = 140 + Width = 150 +end diff --git a/packages/fcl-extra/examples/double/daemonunit2.pas b/packages/fcl-extra/examples/double/daemonunit2.pas new file mode 100644 index 0000000000..090934c28a --- /dev/null +++ b/packages/fcl-extra/examples/double/daemonunit2.pas @@ -0,0 +1,52 @@ +unit daemonunit2; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, DaemonApp; + +type + + { TDaemon2 } + + TDaemon2 = class(TDaemon) + procedure DataModuleExecute(Sender: TCustomDaemon); + private + + public + + end; + +var + Daemon2: TDaemon2; + +implementation + +procedure RegisterDaemon; +begin + RegisterDaemonClass(TDaemon2) +end; + +{$R *.lfm} + +{ TDaemon2 } + +procedure TDaemon2.DataModuleExecute(Sender: TCustomDaemon); +Var + I : Integer; +begin + I := 0; + Application.EventLog.Log('TDaemon2 execution start'); + While Self.Status = csRunning Do Begin + Sleep(10); + end; + Application.EventLog.Log('TDaemon2 execution stop'); +end; + + +initialization + RegisterDaemon; +end. + diff --git a/packages/fcl-extra/examples/double/double.pp b/packages/fcl-extra/examples/double/double.pp new file mode 100644 index 0000000000..a6559ebdeb --- /dev/null +++ b/packages/fcl-extra/examples/double/double.pp @@ -0,0 +1,23 @@ +Program double; + +Uses +{$IFDEF UNIX} + CThreads, +{$ENDIF} + ResDaemonApp, DaemonApp, DaemonMapperUnit1, DaemonUnit1, daemonunit2, SysUtils, eventlog + { add your units here }; + +Var + AExecutableFilenamePath : String; +begin + AExecutableFilenamePath := ParamStr(0); + AExecutableFilenamePath := ExpandFileName(AExecutableFilenamePath); + AExecutableFilenamePath := ExtractFilePath(AExecutableFilenamePath); + Application.Title:='Daemon application'; + Application.Initialize; + Application.EventLog.FileName := SysUtils.ConcatPaths([AExecutableFilenamePath, 'event-log.txt']); + Application.EventLog.LogType := ltFile; + Application.EventLog.AppendContent := False; + Application.EventLog.Active := True; + Application.Run; +end. diff --git a/packages/fcl-extra/examples/double/resdaemonapp.pp b/packages/fcl-extra/examples/double/resdaemonapp.pp new file mode 100644 index 0000000000..fc64190366 --- /dev/null +++ b/packages/fcl-extra/examples/double/resdaemonapp.pp @@ -0,0 +1,32 @@ +{ + ***************************************************************************** + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** +} +{$mode objfpc} +{$h+} +unit resdaemonapp; + +interface + +uses daemonapp; + +Type + TResDaemonApplication = Class(TCustomDaemonApplication) + Procedure CreateDaemonInstance(Var ADaemon : TCustomDaemon; DaemonDef : TDaemonDef); override; + end; + +implementation + +uses classes; + +Procedure TResDaemonApplication.CreateDaemonInstance(Var ADaemon : TCustomDaemon; DaemonDef : TDaemonDef); + +begin + ADaemon:=DaemonDef.DaemonClass.Create(Self); +end; + +Initialization + RegisterDaemonApplicationClass(TResDaemonApplication) +end. diff --git a/packages/fcl-extra/src/daemonapp.pp b/packages/fcl-extra/src/daemonapp.pp index 52491bbdb2..da5846e1a0 100644 --- a/packages/fcl-extra/src/daemonapp.pp +++ b/packages/fcl-extra/src/daemonapp.pp @@ -56,6 +56,7 @@ Type Function Install : Boolean; virtual; Function UnInstall: boolean; virtual; Function HandleCustomCode(ACode : DWord) : Boolean; Virtual; + procedure DoThreadTerminate(Sender: TObject);virtual; Public Procedure CheckControlMessages(Wait : Boolean); Procedure LogMessage(const Msg : String); @@ -694,7 +695,12 @@ begin Result:=False end; -Procedure TCustomDaemon.CheckControlMessages(Wait : Boolean); +procedure TCustomDaemon.DoThreadTerminate(Sender: TObject); +begin + Self.FThread := NIL; +end; + +procedure TCustomDaemon.CheckControlMessages(Wait: Boolean); begin If Assigned(FThread) then diff --git a/packages/fcl-extra/src/unix/daemonapp.inc b/packages/fcl-extra/src/unix/daemonapp.inc index a33bf85991..c124e235f5 100644 --- a/packages/fcl-extra/src/unix/daemonapp.inc +++ b/packages/fcl-extra/src/unix/daemonapp.inc @@ -167,9 +167,8 @@ begin Try T:=TDaemonThread.Create(FDaemon); T.FreeOnTerminate:=True; + T.OnTerminate := @FDaemon.DoThreadTerminate; T.Resume; - T.WaitFor; - FDaemon.FThread:=Nil; except On E : Exception do FDaemon.Logmessage(Format(SErrDaemonStartFailed,[FDaemon.Definition.Name,E.Message])); diff --git a/packages/fcl-image/src/fpreadpnm.pp b/packages/fcl-image/src/fpreadpnm.pp index 0a5503ed75..1c8464f74f 100644 --- a/packages/fcl-image/src/fpreadpnm.pp +++ b/packages/fcl-image/src/fpreadpnm.pp @@ -113,6 +113,7 @@ Var C : Char; begin + C:=#0; Stream.ReadBuffer(C,1); If (C<>'P') then Raise Exception.Create('Not a valid PNM image.'); @@ -157,7 +158,7 @@ begin Case FBitmapType of 5,6 : FScanLineSize:=(FBitPP div 8) * FWidth; else - FScanLineSize:=FBitPP*((FWidth+7)shr 3); + FScanLineSize:=FBitPP*((FWidth+7) shr 3); end; GetMem(FScanLine,FScanLineSize); try @@ -165,6 +166,7 @@ begin begin ReadScanLine(Row,Stream); WriteScanLine(Row,Img); +// Writeln(Stream.Position,' ',Stream.Size); end; finally FreeMem(FScanLine); @@ -212,7 +214,8 @@ begin Inc(P) end; end; - 4,5,6 : Stream.ReadBuffer(FScanLine^,FScanLineSize); + 4,5,6 : + Stream.ReadBuffer(FScanLine^,FScanLineSize); end; end; @@ -222,7 +225,7 @@ procedure TFPReaderPNM.WriteScanLine(Row : Integer; Img : TFPCustomImage); Var C : TFPColor; L : Cardinal; - Scale: Cardinal; + Scale: Int64; function ScaleByte(B: Byte):Word; begin @@ -235,7 +238,7 @@ Var function ScaleWord(W: Word):Word; begin if FMaxVal = 65535 then - Result := W + Result := BEtoN(W) else { Mimic the above with multiplications } Result := Int64(W*(FMaxVal+1) + W) * 65535 div Scale; end; diff --git a/packages/fcl-image/src/fpwritepnm.pp b/packages/fcl-image/src/fpwritepnm.pp index 35137f4411..5b767e2827 100644 --- a/packages/fcl-image/src/fpwritepnm.pp +++ b/packages/fcl-image/src/fpwritepnm.pp @@ -30,15 +30,21 @@ type { TFPWriterPNM } TFPWriterPNM = class(TFPCustomImageWriter) - protected - procedure InternalWrite(Stream:TStream;Img:TFPCustomImage);override; - public - ColorDepth: TPNMColorDepth; - BinaryFormat: boolean; - function GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth; - function GetColorDepthOfExtension(AExtension: string): TPNMColorDepth; - function GetFileExtension(AColorDepth: TPNMColorDepth): string; - constructor Create; override; + private + FFullWidth: Boolean; + FColorDepth: TPNMColorDepth; + FBinaryFormat: boolean; + procedure SetFullWidth(AValue: Boolean); + protected + procedure InternalWrite(Stream:TStream;Img:TFPCustomImage);override; + public + Property FullWidth: Boolean Read FFullWidth Write SetFullWidth; + function GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth; + function GetColorDepthOfExtension(AExtension: string): TPNMColorDepth; + function GetFileExtension(AColorDepth: TPNMColorDepth): string; + constructor Create; override; + Property BinaryFormat : Boolean Read FBinaryFormat Write FBinaryFormat; + Property ColorDepth: TPNMColorDepth Read FColorDepth Write FColorDepth; end; { TFPWriterPBM } @@ -113,6 +119,14 @@ begin BinaryFormat := True; end; +procedure TFPWriterPNM.SetFullWidth(AValue: Boolean); +begin + if FFullWidth=AValue then Exit; + FFullWidth:=AValue; + if FFullWidth then + BinaryFormat:=True; +end; + procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); var useBitMapType: integer; @@ -130,8 +144,9 @@ var useBitMapType: integer; Str(Img.Height,StrHeight); end; PNMInfo:=Concat(MagicWords[useBitMapType],#10,StrWidth,#32,StrHeight,#10); - if useBitMapType in [2,3,5,6] - then + if (useBitMapType in [5,6]) and FullWidth then + PNMInfo:=Concat(PNMInfo,'65535'#10) + else if (useBitMapType in [2,3,5,6]) then PNMInfo:=Concat(PNMInfo,'255'#10); stream.seek(0,soFromBeginning); stream.Write(PNMInfo[1],Length(PNMInfo)); @@ -141,6 +156,7 @@ var useBitMapType: integer; Row,Coulumn,nBpLine,i:Integer; aColor:TFPColor; aLine:PByte; + dLine : PWord; strCol:String[3]; LinuxEndOfLine: char; UseColorDepth: TPNMColorDepth; @@ -160,17 +176,20 @@ var useBitMapType: integer; pcdRGB: useBitMapType := 3; end; if BinaryFormat then inc(useBitMapType,3); - + if FullWidth and Not BinaryFormat then + Raise FPImageException.Create('Fullwidth can only be used with binary format'); SaveHeader(Stream); case useBitMapType of 1:nBpLine:=Img.Width*2;{p p p} 2:nBpLine:=Img.Width*4;{lll lll lll} 3:nBpLine:=Img.Width*3*4;{rrr ggg bbb rrr ggg bbb} 4:nBpLine:=(Img.Width+7) SHR 3; - 5:nBpLine:=Img.Width; - 6:nBpLine:=Img.Width*3; + 5:nBpLine:=Img.Width*(1+Ord(FullWidth)); + 6:nBpLine:=Img.Width*3*(1+Ord(FullWidth)); end; + GetMem(aLine,nBpLine);//3 extra byte for BMP 4Bytes alignement. + dLine:=PWord(aLine); for Row:=0 to img.Height-1 do begin FillChar(aLine^,nBpLine,0); @@ -214,8 +233,18 @@ var useBitMapType: integer; 4:if(Red<=$2F00)or(Green<=$2F00)or(Blue<=$2F00) then aLine[Coulumn shr 3]:=aLine[Coulumn shr 3] or ($80 shr (Coulumn and $07)); - 5:aLine[Coulumn]:=Hi(Word(Round(Red*0.299+Green*0.587+Blue*0.114))); - 6:begin + 5: if FullWidth then + dLine[Coulumn]:=Word(Round(Red*0.299+Green*0.587+Blue*0.114)) + else + aLine[Coulumn]:=Hi(Word(Round(Red*0.299+Green*0.587+Blue*0.114))); + 6:if FullWidth then + begin + dLine[3*Coulumn]:=NToBE(Red); + dLine[3*Coulumn+1]:=NToBE(Green); + dLine[3*Coulumn+2]:=NToBE(Blue); + end + else + begin aLine[3*Coulumn]:=Hi(Red); aLine[3*Coulumn+1]:=Hi(Green); aLine[3*Coulumn+2]:=Hi(Blue);