diff --git a/components/fpspreadsheet/images/components/make_res.bat b/components/fpspreadsheet/images/components/make_res.bat
index 053b7cc35..bcf78934a 100644
--- a/components/fpspreadsheet/images/components/make_res.bat
+++ b/components/fpspreadsheet/images/components/make_res.bat
@@ -1,3 +1,4 @@
lazres ../../resource/fpsvisualreg.res @list_visual.txt
lazres ../../resource/fpsvisual.lrs cur_dragcopy.cur
lazres ../../resource/fpsvisualexportreg.res @list_export.txt
+lazres ../../resource/fpsdatasetreg.res @list_dataset.txt
diff --git a/components/fpspreadsheet/install.txt b/components/fpspreadsheet/install.txt
index 9753939ef..884a97e10 100644
--- a/components/fpspreadsheet/install.txt
+++ b/components/fpspreadsheet/install.txt
@@ -10,4 +10,7 @@
(4) If you need to unlock xls file protection
Make sure that the package dcpcrypt.lpk can be found by the IDE
- Open laz_fpspreadsheet_crypto.lpk -- > Compile
\ No newline at end of file
+ Open laz_fpspreadsheet_crypto.lpk -- > Compile
+
+(5) If need database access to spreadsheets:
+ Open laz_fpsdataset.lpk --> Use --> Install
\ No newline at end of file
diff --git a/components/fpspreadsheet/laz_fpspreadsheet_dataset.lpk b/components/fpspreadsheet/laz_fpspreadsheet_dataset.lpk
new file mode 100644
index 000000000..22f217190
--- /dev/null
+++ b/components/fpspreadsheet/laz_fpspreadsheet_dataset.lpk
@@ -0,0 +1,43 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/fpspreadsheet/resource/fpsdatasetreg.res b/components/fpspreadsheet/resource/fpsdatasetreg.res
new file mode 100644
index 000000000..30beae404
Binary files /dev/null and b/components/fpspreadsheet/resource/fpsdatasetreg.res differ
diff --git a/components/fpspreadsheet/source/dataset/fpsdataset.pas b/components/fpspreadsheet/source/dataset/fpsdataset.pas
new file mode 100644
index 000000000..58fb54596
--- /dev/null
+++ b/components/fpspreadsheet/source/dataset/fpsdataset.pas
@@ -0,0 +1,2231 @@
+{@@ ----------------------------------------------------------------------------
+ Unit **fpsDataset** implements a TDataset based on spreadsheet data.
+ This way spreadsheets can be accessed in a database-like manner.
+ Of course, it is required that all cells in a column have the same type.
+
+ AUTHORS: Werner Pamler
+
+ LICENSE: See the file COPYING.modifiedLGPL.txt, included in the Lazarus
+ distribution, for details about the license.
+
+ References:
+ * https://www.delphipower.xyz/guide_8/building_custom_datasets.html
+ * http://etutorials.org/Programming/mastering+delphi+7/Part+III+Delphi+Database-Oriented+Architectures/Chapter+17+Writing+Database+Components/Building+Custom+Datasets/
+ * http://216.19.73.24/articles/customds.asp
+ * https://delphi.cjcsoft.net/viewthread.php?tid=44220
+
+ Much of the code is adapted from TMemDataset.
+
+ Current status (Sept 12, 2021):
+
+ Working
+ * Field defs: determined automatically from file
+ * Field defs defined by user: working (requires AutoFieldDefs = false)
+ * Fields: working
+ * Field types: ftFloat, ftInteger, ftAutoInc, ftByte, ftSmallInt, ftWord, ftLargeInt,
+ ftCurrency, ftBCD, ftFmtBCD, ftDateTime, ftDate, ftTime, ftString, ftFixedChar,
+ ftBoolean, ftWideString, ftFixedWideString, ftMemo
+ * Locate: working
+ * Lookup: working
+ * Edit, Delete, Insert, Append, Post, Cancel: working
+ * NULL fields: working
+ * GetBookmark, GotoBookmark: working
+ * Filtering by OnFilter event and by Filter property: working.
+ * Persistent and calculated fields working
+ * Sorting by method SortOnFields
+ * Selecting specific spreadsheet file format or automatic format detection.
+
+ Planned but not yet working
+ ' Field defs: Required, Unique etc possibly not supported ATM - to be tested
+ * IndexDefs: not implemented
+
+ Issues
+ * Text cells should be converted to text fields in UTF8 encoding. However,
+ TField supports codepages only in FPC 3.2+.
+
+ * Manually deleting a fielddef removes it from the object tree, but not from
+ the lfm file.
+
+ * Insert initially adds a new record before the current position, but after
+ Post the new record is moved to the end.
+-------------------------------------------------------------------------------}
+
+unit fpsDataset;
+
+{$mode ObjFPC}{$H+}
+{$R ../../resource/fpsdatasetreg.res}
+
+interface
+
+uses
+ Classes, SysUtils, Contnrs, DB, BufDataset_Parser,
+ fpSpreadsheet, fpsTypes, fpsUtils, fpsAllFormats;
+
+type
+ TRowIndex = Int64;
+ TColIndex = Int64;
+ PPCell = ^PCell;
+
+ TsSortOptionsArray = array of TsSortOptions;
+
+ { TsFieldDef }
+ TsFieldDef = class(TFieldDef)
+ private
+ FColIndex: TColIndex;
+ public
+ constructor Create(ACollection: TCollection); override;
+ constructor Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType;
+ ASize: Integer; ARequired: Boolean; AFieldNo: Longint; AColIndex: TColIndex
+ {$IF FPC_FullVersion >= 30200}; ACodePage: TSystemCodePage = CP_UTF8{$IFEND}
+ ); overload;
+ procedure Assign(ASource: TPersistent); override;
+ published
+ property ColIndex: TColIndex read FColIndex write FColIndex default -1;
+ end;
+
+ { TsFieldDefs }
+ TsFieldDefs = class(TFieldDefs)
+ protected
+ class function FieldDefClass : TFieldDefClass; override;
+ end;
+
+ { TsRecordInfo }
+ TsRecordInfo = record
+ Bookmark: PCell; // Pointer to a cell in the bookmarked row.
+ BookmarkFlag: TBookmarkFlag;
+ end;
+ PsRecordInfo = ^TsRecordInfo;
+
+ { TsWorksheetDataset }
+ TsWorksheetDataset = class(TDataset)
+ private
+ FFileName: TFileName; // Name of the spreadsheet file
+ FSheetName: String; // Name of the worksheet used by the dataset
+ FWorkbook: TsWorkbook; // Underlying workbook providing the data
+ FWorksheet: TsWorksheet; // Underlying worksheet providing the data
+ FRecNo: Integer; // Current record number
+ FFirstRow: TRowIndex; // WorksheetIndex of the first record
+ FLastRow: TRowIndex; // Worksheet index of the last record
+ FLastCol: TColIndex; // Worksheet index of the last column
+ FRecordCount: Integer; // Number of records between first and last data rows
+ FRecordBufferSize: Integer; // Size of the record buffer
+ FTotalFieldSize: Integer; // Total size of the field data
+ FFieldOffsets: array of Integer; // Offset to field start in buffer
+ FModified: Boolean; // Flag to show that workbook needs saving
+ FFilterBuffer: TRecordBuffer; // Buffer for filtered record
+ FTableCreated: boolean; // Flag telling that the table has been created
+ FAutoFieldDefs: Boolean; // Automatically detect fielddefs in the worksheet
+ FAutoFieldDefStringSize: Integer; // Default size of automatically detected string fields
+ FIsOpen: boolean; // Flag storing that the dataset is open
+ FParser: TBufDatasetParser; // Parser for filter expressions
+ FAutoIncValue: Integer; // Automatically incremented value
+ FAutoIncField: TAutoIncField; // Field which is automatically incremented
+ FSortParams: TsSortParams; // Parameters for sorting
+ FAutoFileFormat: Boolean; // Automatically detect the spreadsheet file format
+ FFileFormat: TsSpreadsheetFormat; // Format of the spreadsheet file
+ private
+ procedure CreateSortParams(const FieldNames: string;
+ const Options: TsSortOptionsArray);
+ procedure FixFieldDefs;
+// function FixFieldName(const AText: String): String;
+ procedure FreeSortParams;
+ function GetActiveBuffer(out Buffer: TRecordBuffer): Boolean;
+ function GetBookmarkCellFromRecNo(ARecNo: Integer): PCell;
+ function GetCurrentRowIndex: TRowIndex;
+ function GetFirstDataRowIndex: TRowIndex;
+ function GetLastDataRowIndex: TRowIndex;
+ function GetNullMaskPtr(Buffer: TRecordBuffer): Pointer;
+ function GetNullMaskSize: Integer;
+ function GetRecordInfoPtr(Buffer: TRecordBuffer): PsRecordInfo;
+ function GetRowIndexFromRecNo(ARecNo: Integer): TRowIndex;
+ procedure SetAutoFieldDefStringSize(Value: Integer);
+ procedure SetCurrentRow(ARow: TRowIndex);
+
+ protected
+ // methods inherited from TDataset
+ function AllocRecordBuffer: TRecordBuffer; override;
+ procedure ClearCalcFields(Buffer: TRecordBuffer); override;
+ procedure DoBeforeOpen; override;
+ class function FieldDefsClass : TFieldDefsClass; override;
+ procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override;
+ procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
+ function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override;
+ function GetRecNo: LongInt; override;
+ function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode;
+ DoCheck: Boolean): TGetResult; override;
+ function GetRecordCount: LongInt; override;
+ function GetRecordSize: Word; override;
+ procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override;
+ procedure InternalClose; override;
+ procedure InternalDelete; override;
+ procedure InternalFirst; override;
+ procedure InternalGotoBookmark(ABookmark: Pointer); override;
+ procedure InternalInitFieldDefs; override;
+ procedure InternalInitRecord(Buffer: TRecordBuffer); override;
+ procedure InternalLast; override;
+ procedure InternalOpen; override;
+ procedure InternalPost; override;
+ procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
+ function IsCursorOpen: Boolean; override;
+ procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
+ procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
+ procedure SetFiltered(Value: Boolean); override;
+ procedure SetFilterText(const Value: String); override;
+ procedure SetRecNo(Value: Integer); override;
+
+ // new methods
+ procedure AllocBlobPointers(Buffer: TRecordBuffer);
+ procedure CalcFieldOffsets;
+ function ColIndexFromField(AField: TField): TColIndex;
+ procedure DetectFieldDefs;
+ function FilterRecord(Buffer: TRecordBuffer): Boolean;
+ procedure FreeBlobPointers(Buffer: TRecordBuffer);
+ procedure FreeWorkbook;
+ function GetTotalFieldSize: Integer;
+ procedure LoadWorksheetToBuffer(Buffer: TRecordBuffer; ARecNo: Integer);
+ function LocateRecord(const KeyFields: string; const KeyValues: Variant;
+ Options: TLocateOptions; out ARecNo: integer): Boolean;
+ procedure ParseFilter(const AFilter: STring);
+ procedure SetupAutoInc;
+ procedure Sort;
+ procedure WriteBufferToWorksheet(Buffer: TRecordBuffer);
+
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ function AddFieldDef(AName: String; ADataType: TFieldType; ASize: Integer = 0;
+ AColIndex: Integer = -1; ACodePage: TSystemCodePage = CP_UTF8): TsFieldDef; overload;
+ function BookmarkValid(ABookmark: TBookmark): Boolean; override;
+ procedure Clear;
+ procedure Clear(ClearDefs: Boolean);
+ function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override;
+ procedure CopyFromDataset(ADataset: TDataset;
+ const AWorkbookFileName, ASheetName: String);
+ function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
+ procedure CreateTable;
+ function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
+ function Locate(const KeyFields: String; const KeyValues: Variant;
+ Options: TLocateOptions): boolean; override;
+ function Lookup(const Keyfields: String; const KeyValues: Variant;
+ const ResultFields: String): Variant; override;
+ procedure SetFieldData(Field: TField; Buffer: Pointer); override;
+
+ procedure SortOnField(const FieldName: String); overload;
+ procedure SortOnField(const FieldName: String; const Options: TsSortOptions); overload;
+ procedure SortOnFields(const FieldNames: String); overload;
+ procedure SortOnFields(const FieldNames: String; const Options: TsSortOptionsArray); overload;
+
+ { Defines the field size of string fields to be used by FieldDef autodetection.
+ When AutoFieldDefStringSize is 0 field size depends on the longest text in
+ the worksheet column. }
+ property AutoFieldDefStringSize: Integer read FAutoFieldDefStringSize write SetAutoFieldDefStringSize default 0;
+ property Modified: boolean read FModified;
+
+ published
+ property AutoFieldDefs: Boolean read FAutoFieldDefs write FAutoFieldDefs default true;
+ property AutoFileFormat: Boolean read FAutoFileFormat write FAutoFileFormat default true;
+ property FileFormat: TsSpreadsheetFormat read FFileFormat write FFileFormat default sfUser;
+ property FileName: TFileName read FFileName write FFileName;
+ property SheetName: String read FSheetName write FSheetName;
+
+ // inherited properties
+ property Active;
+ property AutoCalcFields;
+ property FieldDefs;
+ property Filter;
+ property Filtered;
+ property FilterOptions default [];
+
+ // inherited events
+ property AfterCancel;
+ property AfterClose;
+ property AfterDelete;
+ property AfterEdit;
+ property AfterInsert;
+ property AfterOpen;
+ property AfterPost;
+ property AfterRefresh;
+ property AfterScroll;
+ property BeforeCancel;
+ property BeforeClose;
+ property BeforeDelete;
+ property BeforeEdit;
+ property BeforeInsert;
+ property BeforeOpen;
+ property BeforePost;
+ property BeforeRefresh;
+ property BeforeScroll;
+ property OnCalcFields;
+ property OnDeleteError;
+ property OnEditError;
+ property OnFilterRecord;
+ property OnNewRecord;
+ property OnPostError;
+ end;
+
+procedure Register;
+
+
+implementation
+
+uses
+ LazUTF8, LazUTF16, Math, TypInfo, Variants, FmtBCD, fpsNumFormat;
+
+const // This are the field types of FPC 3.3.x
+ ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
+ ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
+ {ftBytes, ftVarBytes, } ftAutoInc, ftBlob, ftMemo,
+ {ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, }
+ ftFixedChar, ftWideString, ftLargeint,
+ {ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant,
+ ftInterface, ftIDispatch, ftGuid, ftTimeStamp,}
+ ftFMTBCD, ftFixedWideChar, ftWideMemo
+ {
+ , ftOraTimeStamp, ftOraInterval, ftLongWord, ftShortint,
+ }
+ {$IF FPC_FullVersion >= 30300}
+ , ftByte
+ {$IFEND}
+ {, ftExtended}
+ ];
+
+
+{ Null mask handling
+
+ The null mask is a part of the record buffer which stores in its bits the
+ information which fields are NULL. Since all bytes in a new record all bits
+ are cleared and a new record has NULL fields the logic must "inverted", i.e.
+ a 0-bit means: "field is NULL", and a 1-bit means "field is not NULL". }
+
+{ Clears the information that the field is null by setting the corresponding
+ bit in the null mask. }
+procedure ClearFieldIsNull(NullMask: PByte; FieldNo: Integer);
+var
+ n: Integer = 0;
+ m: Integer = 0;
+begin
+ DivMod(FieldNo - 1, 8, n, m);
+ inc(NullMask, n);
+ // Set the bit to indicate that the field is not NULL.
+ NullMask^ := NullMask^ or (1 shl m);
+end;
+
+{ Returns true when the field is null, i.e. when its bit in the null mask is not set. }
+function GetFieldIsNull(NullMask: PByte; FieldNo: Integer): Boolean;
+var
+ n: Integer = 0;
+ m: Integer = 0;
+begin
+ DivMod(FieldNo - 1, 8, n, m);
+ inc(NullMask, n);
+ Result := NullMask^ and (1 shl m) = 0;
+end;
+
+{ Clears in the null mask the bit corresponding to FieldNo to indicate that the
+ associated field is NULL. }
+procedure SetFieldIsNull(NullMask: PByte; FieldNo: Integer);
+var
+ n: Integer = 0;
+ m: Integer = 0;
+begin
+ DivMod(FieldNo - 1, 8, n, m);
+ inc(NullMask, n);
+ NullMask^ := nullMask^ and not (1 shl m);
+end;
+
+
+{ TsFieldDef }
+
+constructor TsFieldDef.Create(ACollection: TCollection);
+begin
+ inherited;
+ FColIndex := -1;
+end;
+
+constructor TsFieldDef.Create(AOwner: TFieldDefs; const AName: string;
+ ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint;
+ AColIndex: TColIndex
+ {$IF FPC_FullVersion >= 30200}
+ ; ACodePage: TSystemCodePage = CP_UTF8
+ {$IFEND}); overload;
+begin
+ inherited Create(AOwner, AName, ADataType, ASize, ARequired, AFieldNo{$IF FPC_FullVersion >= 30200}, ACodePage{$IFEND});
+ FColIndex := AColIndex;
+end;
+
+procedure TsFieldDef.Assign(ASource: TPersistent);
+begin
+ if ASource is TsFieldDef then
+ FColIndex := TsFieldDef(ASource).FColIndex;
+ inherited Assign(ASource);
+end;
+
+
+{ TsFieldDefs }
+
+class function TsFieldDefs.FieldDefClass: TFieldDefClass;
+begin
+ Result := TsFieldDef;
+end;
+
+
+{ TsBlobData }
+
+type
+ TsBlobData = record
+ Data: TBytes;
+// dummy: Int64;
+ end;
+ PsBlobData = ^TsBlobData;
+
+
+{ TsBlobStream }
+
+type
+ TsBlobStream = class(TMemoryStream)
+ private
+ FField: TBlobField;
+ FDataSet: TsWorksheetDataSet;
+ FMode: TBlobStreamMode;
+ FModified: Boolean;
+ procedure LoadBlobData;
+ procedure SaveBlobData;
+ public
+ constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
+ destructor Destroy; override;
+ function Read(var Buffer; Count: Longint): Longint; override;
+ function Write(const Buffer; Count: Longint): Longint; override;
+ end;
+
+constructor TsBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
+begin
+ inherited Create;
+ FField := Field;
+ FMode := Mode;
+ FDataset := FField.Dataset as TsWorksheetDataset;
+ if Mode <> bmWrite then
+ LoadBlobData;
+end;
+
+destructor TsBlobStream.Destroy;
+begin
+ if FModified then
+ SaveBlobData;
+ inherited Destroy;
+end;
+
+// Copies the BLOB field data from the active buffer into the stream
+procedure TsBlobStream.LoadBlobData;
+var
+ buffer: TRecordBuffer;
+ nullMask: Pointer;
+begin
+ Self.Size := 0;
+ if FDataset.GetActiveBuffer(buffer) then
+ begin
+ nullMask := FDataset.GetNullMaskPtr(buffer);
+ inc(buffer, FDataset.FFieldOffsets[FField.FieldNo-1]);
+ Size := 0;
+ if not GetFieldIsNull(nullMask, FField.FieldNo) then
+ with PsBlobData(buffer)^ do
+ Write(Data[0], Length(Data)); // Writes the data into the stream
+ Position := 0;
+ SaveToFile('test.txt');
+ end;
+ Position := 0;
+end;
+
+function TsBlobStream.Read(var Buffer; Count: LongInt): LongInt;
+begin
+ Result := inherited Read(Buffer, Count);
+end;
+
+// Writes the stream data to the buffer of the BLOB field.
+// Take care of the null mask!
+procedure TsBlobStream.SaveBlobData;
+var
+ buffer: TRecordBuffer;
+ nullMask: Pointer;
+begin
+ if FDataset.GetActiveBuffer(buffer) then
+ begin
+ nullMask := FDataset.GetNullMaskPtr(buffer);
+ inc(buffer, FDataset.FFieldOffsets[FField.FieldNo-1]);
+ Position := 0;
+ if Size = 0 then
+ SetFieldIsNull(nullMask, FField.FieldNo)
+ else
+ with PsBlobData(buffer)^ do
+ begin
+ SetLength(Data, Size);
+ Read(Data[0], Size); // Reads the stream data to put them into the buffer
+ ClearFieldIsNull(nullMask, FField.FieldNo);
+ end;
+ Position := 0;
+ end;
+ FModified := false;
+end;
+
+function TsBlobStream.Write(const Buffer; Count: LongInt): LongInt;
+begin
+ Result := inherited Write(Buffer, Count);
+ FModified := true;
+end;
+
+
+{ TsWorksheetDataset }
+
+constructor TsWorksheetDataset.Create(AOwner: TComponent);
+begin
+ inherited;
+ FAutoFieldDefs := true;
+ FAutoFileFormat := true;
+ FFileFormat := sfUser;
+ FRecordCount := -1;
+ FTotalFieldSize := -1;
+ FRecordBufferSize := -1;
+ FRecNo := -1;
+ FAutoIncValue := -1;
+ BookmarkSize := SizeOf(TRowIndex);
+end;
+
+destructor TsWorksheetDataset.Destroy;
+begin
+ Close;
+ inherited;
+end;
+
+{ Adds a FieldDef to the FieldDefs collection. This is an adapted version
+ for this dataset class because defines the column index of the field in the
+ worksheet, and, in case of FPC 3.2+, creates string fields with UTF8 codepage.
+
+ ALWAYS USE THIS METHOD TO CREATE FIELDDEFS.
+
+ When the fielddef is added in the "normal" way (i.e. FieldDefs.Add(...) ),
+ the column index is not specified and the dataset will not work!
+
+ The argument ACodePage is ignored when FPC is older than v3.2. }
+function TsWorksheetDataset.AddFieldDef(
+ AName: String; ADataType: TFieldType; ASize: Integer = 0; AColIndex: Integer = -1;
+ ACodePage: TSystemCodePage = CP_UTF8): TsFieldDef;
+begin
+ if AColIndex = -1 then
+ AColIndex := FieldDefs.Count;
+ Result := TsFieldDef.Create(TsFieldDefs(FieldDefs),
+ AName, ADataType, ASize, false, FieldDefs.Count+1, AColIndex
+ {$IF FPC_FullVersion >= 30200}, ACodePage {$IFEND}
+ );
+end;
+
+procedure TsWorksheetDataset.AllocBlobPointers(Buffer: TRecordBuffer);
+var
+ i: Integer;
+ f: TField;
+ offset: Integer;
+begin
+ for i := 0 to FieldCount-1 do
+ begin
+ f := Fields[i];
+ if f.DataType in [ftMemo{, ftGraphic}] then
+ begin
+ offset := FFieldOffsets[f.FieldNo-1];
+ // FillChar(PsBlobData(Buffer + offset)^, SizeOf(TsBlobData), 0);
+ PsBlobData(Buffer + offset)^.Data := nil;
+// SetLength(PsBlobData(Buffer + offset)^.Data, 0);
+ end;
+ end;
+end;
+
+
+{ Allocates a buffer for the dataset
+
+ Structure of the TsWorksheetDataset buffer
+ +---------------------------------------------------+-----------------------+
+ | field data | null mask | record info | calculated fields |
+ +---------------------------------------------------+-----------------------+
+
+ <-------------------- GetRecordSize ----------------> <-- CalcFieldsSize --->
+}
+function TsWorksheetDataset.AllocRecordBuffer: TRecordBuffer;
+var
+ n: Integer;
+begin
+ n := GetRecordSize + CalcFieldsSize;
+ GetMem(Result, n);
+ FillChar(Result^, n, 0);
+ AllocBlobPointers(Result);
+end;
+
+{ Returns whether the specified bookmark is valid, i.e. the worksheet row index
+ associated with the bookmark cell is between first and last data rows. }
+function TsWorksheetDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
+var
+ bookmarkCell: PCell;
+begin
+ Result := False;
+ if ABookMark = nil then exit;
+ bookmarkCell := PPCell(ABookmark)^;
+ Result := (bookmarkCell^.Row >= GetFirstDataRowIndex) and
+ (bookmarkCell^.Row <= GetLastDataRowIndex);
+end;
+
+procedure TsWorksheetDataset.CalcFieldOffsets;
+var
+ i: Integer;
+ fs: Integer; // field size
+begin
+ SetLength(FFieldOffsets, FieldDefs.Count);
+ FFieldOffsets[0] := 0;
+ for i := 0 to FieldDefs.Count-2 do
+ begin
+ case FieldDefs[i].DataType of
+ ftString, ftFixedChar:
+ {$IF FPC_FullVersion >= 30200}
+ if FieldDefs[i].Codepage = CP_UTF8 then
+ fs := FieldDefs[i].Size*4 + 1
+ // a UTF8 char point requires 1-4 bytes - we must reserve the maximum!
+ else
+ {$IFEND}
+ fs := FieldDefs[i].Size + 1; // +1 for zero termination
+ ftWideString, ftFixedWideChar:
+ fs := (FieldDefs[i].Size + 1) * 2;
+ ftInteger, ftAutoInc:
+ fs := SizeOf(Integer);
+ {$IF FPC_FullVersion >= 30300}
+ ftByte:
+ fs := SizeOf(Byte);
+ {$IFEND}
+ ftSmallInt:
+ fs := SizeOf(SmallInt);
+ ftWord:
+ fs := SizeOf(Word);
+ ftLargeInt:
+ fs := Sizeof(LargeInt);
+ ftFloat, ftCurrency: // Currency is expected by TCurrencyField as double
+ fs := SizeOf(Double);
+ ftBCD:
+ fs := SizeOf(Currency); // BCD is expected by TBCDField as currency
+ ftFmtBCD:
+ fs := SizeOf(TBCD); // The TFmtBCDField expects data as true TBCD.
+ ftDateTime, ftDate, ftTime:
+ fs := SizeOf(TDateTime); // date/time values are TDateTime in the buffer
+ ftBoolean:
+ fs := SizeOf(WordBool); // boolean is expected by TBooleanField to be WordBool
+ ftMemo:
+ fs := SizeOf(TsBlobData);
+ else
+ DatabaseError(Format('Field data type %s not supported.', [
+ GetEnumName(TypeInfo(TFieldType), integer(FieldDefs[i].DataType))
+ ]));
+ end;
+ FFieldOffsets[i+1] := FFieldOffsets[i] + fs;
+ end;
+end;
+
+procedure TsWorksheetDataset.Clear;
+begin
+ Clear(true);
+end;
+
+procedure TsWorksheetDataset.Clear(ClearDefs: Boolean);
+begin
+ FRecNo := -1;
+ FRecordCount := -1;
+ FTotalFieldSize := -1;
+ FRecordBufferSize := -1;
+ if Active then
+ Resync([]);
+ if ClearDefs then
+ begin
+ Close;
+ FieldDefs.Clear;
+ FTableCreated := false;
+ end;
+end;
+
+procedure TsWorksheetDataset.ClearCalcFields(Buffer: TRecordBuffer);
+begin
+ FillChar(Buffer[RecordSize], CalcFieldsSize, 0);
+end;
+
+{ Determines the worksheet column index for a specific field }
+function TsWorksheetDataset.ColIndexFromField(AField: TField): TColIndex;
+var
+ fieldDef: TsFieldDef;
+begin
+ fieldDef := AField.FieldDef as TsFieldDef;
+ if fieldDef <> nil then
+ Result := fieldDef.ColIndex
+ else
+ Result := -1;
+end;
+
+// Compares two bookmarks (row indices). This tricky handling of nil is
+// "borrowed" from TMemDataset
+function TsWorksheetDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
+const
+ r: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
+var
+ cell1, cell2: PCell;
+begin
+ Result := r[Bookmark1 = nil, Bookmark2 = nil];
+ if Result = 2 then
+ begin
+ cell1 := PPCell(Bookmark1)^;
+ cell2 := PPCell(Bookmark2)^;
+ Result := Int64(cell1^.Row) - Int64(cell2^.Row);
+ end;
+end;
+
+{ Copies the specified dataset to the worksheet dataset: copies fielddefs as
+ well as data.
+ Important: In order to avoid data loss in the worksheet dataset it must be
+ closed and FileName and SheetName must be empty; they will be set to the
+ values passed as parameters. }
+procedure TsWorksheetDataset.CopyFromDataset(ADataset: TDataset;
+ const AWorkbookFileName, ASheetName: String);
+var
+ i: Integer;
+ fsrc, fdest: TField;
+ fd: TFieldDef;
+ stream: TMemoryStream;
+ bm: TBookmark;
+begin
+ if Active then
+ DatabaseError('Dataset must not be active when calling CopyFromDataset.');
+ if FFileName <> '' then
+ DatabaseError('Filename must be empty when calling CopyFromDataset.');
+ if FSheetName <> '' then
+ DatabaseError('SheetName must be empty when calling CopyFromDataset.');
+
+ FFileName := AWorkbookFileName;
+ FSheetName := ASheetName;
+
+ Fields.Clear;
+ FieldDefs.Clear;
+ for fsrc in ADataset.Fields do
+ begin
+ fd := AddFieldDef(fsrc.FieldName, fsrc.DataType, fsrc.Size, fsrc.FieldNo-1, CP_UTF8);
+ if fsrc is TAutoIncField then
+ begin
+ FAutoIncField := TAutoIncField(fsrc);
+ FAutoIncValue := -1;
+ end;
+ end;
+ CreateTable;
+
+ Open;
+ DisableControls;
+ ADataset.DisableControls;
+ bm := ADataset.GetBookmark;
+ stream := TMemoryStream.Create;
+ try
+ ADataset.Open;
+ ADataset.First;
+ while not ADataset.EoF do
+ begin
+ Append;
+ for i := 0 to FieldCount-1 do begin
+ fdest := Fields[i];
+ fsrc := ADataset.FieldByName(fdest.FieldName);
+ if not fsrc.IsNull then
+ case fdest.DataType of
+ ftString, ftFixedChar:
+ fdest.AsString := fsrc.AsString;
+ ftWideString, ftFixedWideChar:
+ fdest.AsWideString := fsrc.AsWideString;
+ ftBoolean:
+ fdest.AsBoolean := fsrc.AsBoolean;
+ ftFloat:
+ fdest.AsFloat := fsrc.AsFloat;
+ ftCurrency:
+ fdest.AsCurrency := fsrc.AsCurrency;
+ ftInteger, ftWord, ftSmallInt {, ftShortInt}
+ {$IF FPC_FullVersion >= 30300}, ftByte{$IFEND}:
+ fdest.AsInteger := fsrc.AsInteger;
+ ftAutoInc:
+ begin
+ fdest.AsInteger := fsrc.AsInteger;
+ FAutoIncValue := Max(fdest.AsInteger, FAutoIncValue);
+ end;
+ ftLargeInt:
+ fdest.AsLargeInt := fsrc.AsLargeInt;
+ ftDate, ftTime, ftDateTime:
+ fdest.AsDateTime := fsrc.AsDateTime;
+ ftBCD, ftFmtBCD:
+ fdest.AsBCD := fsrc.AsBCD;
+ ftMemo:
+ begin
+ stream.Clear;
+ TBlobField(fsrc).SaveToStream(stream);
+ stream.Position := 0;
+ TBlobField(fdest).LoadFromStream(stream);
+ end;
+ else
+ fdest.AsString := fsrc.AsString;
+ end;
+ end;
+ try
+ Post;
+ except
+ Cancel;
+ raise;
+ end;
+ ADataset.Next;
+ end;
+ inc(FAutoIncValue);
+ FModified := true;
+ finally
+ stream.Free;
+ ADataset.GotoBookmark(bm);
+ ADataset.EnableControls;
+ EnableControls;
+ end;
+end;
+
+function TsWorksheetDataSet.CreateBlobStream(Field: TField;
+ Mode: TBlobStreamMode): TStream;
+begin
+ Result := TsBlobStream.Create(Field as TBlobField, Mode);
+end;
+
+procedure TsWorksheetDataset.CreateSortParams(const FieldNames: string;
+ const Options: TsSortOptionsArray);
+var
+ field_names: TStringArray;
+ field: TField;
+ i: Integer;
+begin
+ if pos(';', FieldNames) > 0 then
+ field_names := FieldNames.Split(';')
+ else if pos(',', FieldNames) > 0 then
+ field_names := FieldNames.Split(',')
+ else
+ begin
+ SetLength(field_names, 1);
+ field_names[0] := FieldNames;
+ end;
+
+ FSortParams := InitSortParams(true, Length(field_names));
+ for i := 0 to High(field_names) do
+ begin
+ field := FieldByName(field_names[i]);
+ if not (field.DataType in (ftSupported - [ftMemo, ftWideMemo])) then
+ DatabaseError(Format('Type of field "%s" not supported.', [field_names[i]]));
+ FSortParams.Keys[i].ColRowIndex := ColIndexFromField(field);
+ if i < Length(Options) then
+ FSortParams.Keys[i].Options := Options[i];
+ end;
+end;
+
+{ Creates a new table, i.e. a new empty worksheet based on the given FieldDefs
+ The field names are written to the first row of the worksheet. }
+procedure TsWorksheetDataset.CreateTable;
+var
+ i: Integer;
+ fd: TsFieldDef;
+begin
+ CheckInactive;
+ Clear(false); // false = do not clear FieldDefs
+
+ if FAutoIncValue < 0 then
+ FAutoIncValue := 1;
+
+ if FileExists(FFileName) then
+ exit;
+
+ FWorkbook := TsWorkbook.Create;
+ FWorkSheet := FWorkbook.AddWorksheet(FSheetName);
+
+ for i := 0 to FieldDefs.Count-1 do
+ begin
+ fd := FieldDefs[i] as TsFieldDef;
+ FWorksheet.WriteText(0, fd.ColIndex, fd.Name);
+ end;
+ if FAutoFileFormat then
+ FWorkbook.WriteToFile(FFileName, true)
+ else
+ FWorkbook.WriteToFile(FFileName, FFileFormat, true);
+
+ FreeAndNil(FWorkbook);
+ FWorksheet := nil;
+
+ FTableCreated := true;
+end;
+
+{ Automatic detection of field types and field sizes, as well as the offsets
+ for each field in the buffers to be used when accessing records.
+ Is called in case of auto-detection from a spreadsheet file (i.e. when
+ AutoFieldDefs is true and no other field defs have been defined. }
+procedure TsWorksheetDataset.DetectFieldDefs;
+var
+ r, c: Integer;
+ cLast: cardinal;
+ cell: PCell;
+ fd: TFieldDef;
+ fn: String;
+ ft: TFieldType;
+ fs: Integer;
+ isDate, isTime: Boolean;
+ fmt: TsCellFormat;
+ numFmt: TsNumFormatParams;
+begin
+ FieldDefs.Clear;
+
+ // Iterate through all columns and collect field defs.
+ cLast := FWorksheet.GetLastOccupiedColIndex;
+ for c := 0 to cLast do
+ begin
+ cell := FWorksheet.FindCell(FFirstRow, c);
+ if cell = nil then
+ Continue;
+
+ // Store field name from cell in FFirstRow
+ fn := FWorksheet.ReadAsText(cell);
+
+ // Determine field type: Iterate over rows until first data value is found.
+ // The cell content type determines the field type. Iteration stops then.
+ for r := GetFirstDataRowIndex to GetLastDataRowIndex do
+ begin
+ cell := FWorksheet.FindCell(r, c);
+ if (cell = nil) then
+ continue;
+ fmt := FWorkbook.GetCellFormat(FWorksheet.GetEffectiveCellFormatIndex(cell));
+ numFmt := FWorkbook.GetNumberFormat(fmt.NumberFormatIndex);
+ case cell^.ContentType of
+ cctNumber:
+ if IsCurrencyFormat(numfmt) then
+ ft := ftCurrency
+ else
+ if (numfmt <> nil) and (CountDecs(numfmt.NumFormatStr) > 0) then
+ ft := ftFloat
+ else
+ ft := ftInteger; // float will be checked further below
+ cctUTF8String:
+ ft := ftString;
+ cctDateTime:
+ ft := ftDateTime; // ftDate, ftTime will be checked below
+ cctBool:
+ ft := ftBoolean;
+ else
+ continue;
+ end;
+ break;
+ end;
+
+ // Determine field size and distinguish between similar field types
+ fs := 0;
+ case ft of
+ ftString:
+ if FAutoFieldDefStringSize > 0 then
+ fs := FAutoFieldDefStringSize
+ else
+ begin
+ // Find longest text in column...
+ for r := GetFirstDataRowIndex to GetLastDataRowIndex do
+ fs := Max(fs, Length(FWorksheet.ReadAsText(r, c)));
+ if fs > 255 then // Switch to memo when the strings are "very" long
+ begin
+ ft := ftMemo;
+ fs := 0;
+ end else
+ if fs > 128 then
+ fs := 255
+ else
+ if fs > 64 then
+ fs := 128
+ else
+ if fs > 32 then
+ fs := 64
+ else
+ if fs > 16 then
+ fs := 32
+ else
+ if fs > 8 then
+ fs := 16
+ else
+ if fs <> 1 then
+ fs := 8;
+ end;
+ ftInteger: // Distinguish between integer and float
+ for r := GetFirstDataRowIndex to GetLastDataRowIndex do
+ begin
+ cell := FWorksheet.FindCell(r, c);
+ if cell = nil then
+ continue;
+ if (cell^.ContentType = cctNumber) and (frac(cell^.NumberValue) <> 0) then
+ begin
+ ft := ftFloat;
+ break;
+ end;
+ end;
+ ftDateTime:
+ begin
+ // Determine whether the date/time can be simplified to a pure date or pure time.
+ isDate := true;
+ isTime := true;
+ for r := GetFirstDataRowIndex to GetLastDataRowIndex do
+ begin
+ cell := FWorksheet.FindCell(r, c);
+ if cell = nil then
+ continue;
+ if frac(cell^.DateTimeValue) <> 0 then isDate := false; // Non-integer date/time is date
+ if (cell^.DateTimeValue > 0) then isTime := false; // We assume that time is only between 0:00 and 23:59:59.999
+ if (not isDate) and (not isTime) then break;
+ end;
+ if isDate then ft := ftDate;
+ if isTime then ft := ftTime;
+ end;
+ else
+ ;
+ end;
+
+ // Add FieldDef and set its properties
+ AddFieldDef(fn, ft, fs, c, CP_UTF8);
+ end;
+
+ // Determine the offsets at which the field data will begin in the buffer.
+ CalcFieldOffsets;
+end;
+
+{ Is called before the workbook is opened: checks for filename and sheet name
+ as well as file existence. }
+procedure TsWorksheetDataset.DoBeforeOpen;
+begin
+ if (FFileName = '') then
+ DatabaseError('Filename not specified.');
+
+ if (FieldDefs.Count = 0) then begin
+ if not FileExists(FFileName) then
+ DatabaseError('File not found.');
+ end;
+
+ inherited;
+end;
+
+// Returns the class to be used for FieldDefs. Is overridden to get access
+// to the worksheet column index of a field.
+class function TsWorksheetDataset.FieldDefsClass : TFieldDefsClass;
+begin
+ Result := TsFieldDefs;
+end;
+
+{ Is called during filtering and returns true when the record who's buffer is
+ specified as parameter passes the filter criterions.
+ These are determined by the OnFilterRecord event and/or by the Filter property.
+
+ Based on TMemDataset and TBufDataset. }
+function TsWorksheetDataset.FilterRecord(Buffer: TRecordBuffer): Boolean;
+var
+ SaveState: TDatasetState;
+begin
+ Result := True;
+
+ SaveState := SetTempState(dsFilter);
+ try
+ FFilterBuffer := Buffer;
+
+ // Check user filter
+ if Assigned(OnFilterRecord) then
+ OnFilterRecord(Self, Result);
+
+ // Check filter text
+ if Result and (Length(Filter) > 0) then
+ Result := Boolean(FParser.ExtractFromBuffer(FFilterBuffer)^);
+ finally
+ RestoreState(SaveState);
+ end;
+end;
+
+{ Fixes the column index in FieldDefs which is not assigned when FieldDefs are
+ added by code (FieldDefs.Add* is not virtual!) }
+procedure TsWorksheetDataset.FixFieldDefs;
+var
+ i: Integer;
+ isFirstZero: Boolean = true;
+ fd: TsFieldDef;
+begin
+ for i := 0 to FieldDefs.Count-1 do
+ begin
+ fd := TsFieldDef(FieldDefs[i]);
+ if (fd.ColIndex = 0) then
+ begin
+ if isFirstZero then
+ isFirstZero := false
+ else
+ fd.ColIndex := i;
+ end else
+ if (fd.ColIndex = -1) then
+ fd.ColIndex := i;
+ end;
+end;
+
+(*
+// Removes characters from AText which would make it an invalid fieldname.
+function TsWorksheetDataset.FixFieldName(const AText: String): String;
+var
+ ch: char;
+begin
+ Result := '';
+ for ch in AText do
+ if (ch in ['A'..'Z', 'a'..'z', '0'..'9']) then
+ Result := Result + ch;
+end;
+*)
+
+procedure TsWorksheetDataset.FreeBlobPointers(Buffer: TRecordBuffer);
+var
+ i: Integer;
+ f: TField;
+ offset: Integer;
+begin
+ for i := 0 to FieldCount-1 do
+ begin
+ f := Fields[i];
+ if f is TBlobField then
+// if f.DataType in [ftMemo{, ftGraphic}] then
+ begin
+ offset := FFieldOffsets[f.FieldNo-1];
+ PsBlobData(Buffer + offset)^.Data := nil;
+// SetLength(PsBlobData(Buffer + offset)^.Data,0);
+// FillChar(PsBlobData(Buffer + offset)^, SizeOf(TsBlobData), 0);
+ end;
+ end;
+end;
+
+// Frees a record buffer.
+procedure TsWorksheetDataset.FreeRecordBuffer(var Buffer: TRecordBuffer);
+begin
+ FreeBlobPointers(Buffer);
+ FreeMem(Buffer);
+end;
+
+procedure TsWorksheetDataset.FreeSortParams;
+begin
+ FSortParams.Keys := nil;
+end;
+
+procedure TsWorksheetDataset.FreeWorkbook;
+begin
+ FreeAndNil(FWorkbook);
+ FWorksheet := nil;
+end;
+
+// Returns the active buffer, depending on dataset's state.
+// Borrowed from TMemDataset.
+function TsWorksheetDataset.GetActiveBuffer(out Buffer: TRecordBuffer): Boolean;
+begin
+ case State of
+ dsEdit,
+ dsInsert:
+ Buffer := ActiveBuffer;
+ dsFilter:
+ Buffer := FFilterBuffer;
+ dsCalcFields:
+ Buffer := CalcBuffer;
+ else
+ if IsEmpty then
+ Buffer := nil
+ else
+ Buffer := ActiveBuffer;
+ end;
+ Result := (Buffer <> nil);
+end;
+
+{ Returns the pointer to the first cell in the row corresponding to the RecNo
+ to be used as a bookmark. }
+function TsWorksheetDataset.GetBookmarkCellFromRecNo(ARecNo: Integer): PCell;
+var
+ row: TRowIndex;
+ col: TColIndex;
+begin
+ row := GetRowIndexFromRecNo(ARecNo);
+ col := FWorksheet.GetFirstColIndex;
+ Result := FWorksheet.GetCell(row, col);
+ // Do not use FindCell here because the returned cell is referenced by the
+ // bookmark system.
+end;
+
+// Extracts the bookmark from the specified buffer.
+procedure TsWorksheetDataset.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
+var
+ bookmarkCell: PCell;
+begin
+ if Data <> nil then
+ begin
+ bookmarkCell := GetRecordInfoPtr(Buffer)^.Bookmark;
+ PPCell(Data)^ := bookmarkcell;
+ end;
+end;
+
+// Extracts the bookmark flag from the specified buffer.
+function TsWorksheetDataset.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
+begin
+ Result := GetRecordInfoPtr(Buffer)^.BookmarkFlag;
+end;
+
+// Determines worksheet row index for the current record.
+function TsWorksheetDataset.GetCurrentRowIndex: TRowIndex;
+begin
+ Result := GetFirstDataRowIndex + FRecNo;
+end;
+
+{ Extracts the data value of a specific field from the active buffer and copies
+ it to the memory to which Buffer points.
+ Returns false when nothing is copied.
+ Adapted from TMemDataset. }
+function TsWorksheetDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
+var
+ srcBuffer: TRecordBuffer;
+ idx: Integer;
+ dt: TDateTime = 0;
+ {%H-}dtr: TDateTimeRec;
+begin
+ Result := GetActiveBuffer(srcBuffer);
+ if not Result then
+ exit;
+
+ idx := Field.FieldNo - 1;
+ if idx >= 0 then
+ begin
+ Result := not GetFieldIsNull(GetNullMaskPtr(srcBuffer), Field.FieldNo);
+ if not Result then
+ begin
+ if Field = FAutoIncField then
+ Move(FAutoIncValue, Buffer^, Field.DataSize);
+ exit;
+ end;
+ if Assigned(Buffer) then
+ begin
+ inc(srcBuffer, FFieldOffsets[idx]);
+ if (Field.DataType in [ftDate, ftTime, ftDateTime]) then
+ begin
+ // The srcBuffer contains date/time values as TDateTime, but the
+ // field expects them to be TDateTimeRec --> convert to TDateTimeRec
+ Move(srcBuffer^, dt, SizeOf(TDateTime));
+ dtr := DateTimeToDateTimeRec(Field.DataType, dt);
+ Move(dtr, Buffer^, SizeOf(TDateTimeRec));
+ end else
+ // No need to handle BLOB fields here because they always have Buffer=nil
+ Move(srcBuffer^, Buffer^, Field.DataSize);
+ end;
+ end else
+ begin // Calculated, Lookup
+ inc(srcBuffer, RecordSize + Field.Offset);
+ Result := Boolean(SrcBuffer[0]);
+ if Result and Assigned(Buffer) then
+ Move(srcBuffer[1], Buffer^, Field.DataSize);
+ end;
+end;
+
+// Returns the worksheet row index of the record. This is the row
+// following the first worksheet row because that is reserved for the column
+// titles (field names).
+function TsWorksheetDataset.GetFirstDataRowIndex: TRowIndex;
+begin
+ Result := FFirstRow + 1; // +1 because the first row contains the column titles.
+end;
+
+// Returns the worksheet row index of the record.
+function TsWorksheetDataset.GetLastDataRowIndex: TRowIndex;
+begin
+ Result := FLastRow;
+end;
+
+{ Calculates the pointer to the position of the null mask in the buffer.
+ The null mask is after the data block. }
+function TsWorksheetDataset.GetNullMaskPtr(Buffer: TRecordBuffer): Pointer;
+begin
+ Result := Buffer;
+ inc(Result, GetTotalFieldSize);
+end;
+
+// The information whether a field is NULL is stored in the bits of the
+// "Null mask". Each bit corresponds to a field.
+// Calculates the size of the null mask.
+function TsWorksheetDataset.GetNullMaskSize: Integer;
+var
+ n: Integer;
+begin
+ n := FieldDefs.Count;
+ Result := n div 8 + 1;
+end;
+
+// Returns the number of the current record.
+function TsWorksheetDataset.GetRecNo: LongInt;
+begin
+ UpdateCursorPos;
+ if (FRecNo < 0) or (RecordCount = 0) or (State = dsInsert) then
+ Result := 0
+ else
+ Result := FRecNo + 1;
+end;
+
+function TsWorksheetDataset.GetRecord(Buffer: TRecordBuffer;
+ GetMode: TGetMode; DoCheck: Boolean): TGetResult;
+var
+ accepted: Boolean;
+begin
+ Result := grOK;
+ accepted := false;
+
+ if RecordCount < 1 then
+ begin
+ Result := grEOF;
+ exit;
+ end;
+
+ repeat
+ case GetMode of
+ gmCurrent:
+ if (FRecNo >= RecordCount) or (FRecNo < 0) then
+ Result := grError;
+ gmNext:
+ if (FRecNo < RecordCount - 1) then
+ inc(FRecNo)
+ else
+ Result := grEOF;
+ gmPrior:
+ if (FRecNo > 0) then
+ dec(FRecNo)
+ else
+ Result := grBOF;
+ end;
+
+ // Load the data
+ if Result = grOK then
+ begin
+ LoadWorksheetToBuffer(Buffer, FRecNo);
+ with GetRecordInfoPtr(Buffer)^ do
+ begin
+ Bookmark := GetBookmarkCellFromRecNo(FRecNo);
+ BookmarkFlag := bfCurrent;
+ end;
+ GetCalcFields(Buffer);
+ if Filtered then
+ accepted := FilterRecord(Buffer) // Filtering
+ else
+ accepted := true;
+ if (GetMode = gmCurrent) and not accepted then
+ Result := grError;
+ end;
+ until (Result <> grOK) or accepted;
+
+ if (Result = grError) and DoCheck then
+ DatabaseError('[GetRecord] Invalid record.');
+end;
+
+function TsWorksheetDataset.GetRecordCount: LongInt;
+begin
+ //CheckActive;
+ if FRecordCount = -1 then
+ FRecordCount := GetLastDataRowIndex - GetFirstDataRowIndex + 1;
+ Result := FRecordCount;
+end;
+
+// Returns a pointer to the bookmark block inside the given buffer.
+function TsWorksheetDataset.GetRecordInfoPtr(Buffer: TRecordBuffer): PsRecordInfo;
+begin
+ Result := PsRecordInfo(Buffer + GetTotalFieldSize + GetNullMaskSize);
+end;
+
+{ Determines the size of the full record buffer:
+ - data block: a contiguous field of bytes consisting of the field values
+ - null mask: a bit mask storing the information that a field is null
+ - Record Info: the bookmark part of the record }
+function TsWorksheetDataset.GetRecordSize: Word;
+begin
+ if FRecordBufferSize = -1 then
+ FRecordBufferSize := GetTotalFieldSize + GetNullMaskSize + SizeOf(TsRecordInfo);
+ Result := FRecordBufferSize;
+end;
+
+function TsWorksheetDataset.GetRowIndexFromRecNo(ARecNo: Integer): TRowIndex;
+begin
+ Result := GetFirstDataRowIndex + ARecNo;
+end;
+
+// Returns the size of the data part in a buffer. This is the sume of all
+// field sizes.
+function TsWorksheetDataset.GetTotalFieldSize: Integer;
+var
+ f: TField;
+begin
+ if FTotalFieldSize = -1 then
+ begin
+ FTotalFieldSize := 0;
+ for f in Fields do
+ if f is TBlobField then
+ // Blob fields have zero DataSize, but they occupy space in the record buffer.
+ FTotalFieldSize := FTotalFieldSize + SizeOf(TsBlobData)
+ else
+ FTotalFieldSize := FTotalFieldSize + f.DataSize;
+ end;
+ Result := FTotalFieldSize;
+end;
+
+{ Called internally when a record is added. }
+procedure TsWorksheetDataset.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
+var
+ row: TRowIndex;
+begin
+ inc(FLastRow);
+ inc(FRecordCount);
+ if DoAppend then
+ begin
+ row := FLastRow;
+ SetCurrentRow(row);
+ end;
+ WriteBufferToWorksheet(Buffer);
+ FModified := true;
+end;
+
+{ Closes the dataset }
+procedure TsWorksheetDataset.InternalClose;
+begin
+ FIsOpen := false;
+
+ if FModified then begin
+ if FAutoFileFormat then
+ FWorkbook.WriteToFile(FFileName, true)
+ else
+ FWorkbook.WriteToFile(FFileName, FFileFormat, true);
+ FModified := false;
+ end;
+ FreeWorkbook;
+ if FAutoIncValue > -1 then FAUtoIncValue := 1;
+ FreeAndNil(FParser);
+
+ if DefaultFields then
+ DestroyFields;
+ FTotalFieldSize := -1;
+ FRecordBufferSize := -1;
+ FRecNo := -1;
+end;
+
+{ Called internally when a record is deleted.
+ Must delete the row from the worksheet. }
+procedure TsWorksheetDataset.InternalDelete;
+var
+ row: TRowIndex;
+begin
+ if (FRecNo <0) or (FRecNo >= GetRecordCount) then
+ exit;
+
+ row := GetRowIndexFromRecNo(FRecNo);
+ FWorksheet.DeleteRow(row);
+ dec(FRecordCount);
+ if FRecordCount = 0 then
+ FRecNo := -1
+ else
+ if FRecNo >= FRecordCount then FRecNo := FRecordCount - 1;
+ FModified := true;
+end;
+
+{ Moves the cursor to the first record, i.e. the first data row in the worksheet.}
+procedure TsWorksheetDataset.InternalFirst;
+begin
+ FRecNo := -1;
+end;
+
+{ Internally, a bookmark is a cell in a worksheet row. }
+procedure TsWorksheetDataset.InternalGotoBookmark(ABookmark: Pointer);
+var
+ bookmarkCell: PCell;
+begin
+ bookmarkCell := PPCell(ABookmark)^;
+ if (bookmarkCell <> nil) and (bookmarkCell^.Row >= GetFirstDataRowIndex) and
+ (bookmarkCell^.Row <= GetLastDataRowIndex)
+ then
+ SetCurrentRow(bookmarkCell^.Row)
+ else
+ DatabaseError('Bookmark not found.');
+end;
+
+{ Initializes the field defs. }
+procedure TsWorksheetDataset.InternalInitFieldDefs;
+begin
+ FixFieldDefs;
+ if FAutoFieldDefs and (FieldDefs.Count = 0) then
+ DetectFieldDefs;
+ CalcFieldOffsets;
+end;
+
+{ Moves the cursor to the last record, the last data row of the worksheet }
+procedure TsWorksheetDataset.InternalLast;
+begin
+ FRecNo := RecordCount;
+end;
+
+{ Opens the dataset: Opens the workbook, initializes field defs, creates fields }
+procedure TsWorksheetDataset.InternalOpen;
+begin
+ FWorkbook := TsWorkbook.Create;
+ try
+ if (FSheetName <> '') and (not FWorkbook.ValidWorksheetName(FSheetName)) then
+ DatabaseError('"' + FSheetName + '" is not a valid worksheet name.');
+
+ if not FileExists(FFileName) and (not FAutoFieldDefs) and (not FTableCreated) then
+ begin
+ if FSheetName = '' then
+ DatabaseError('Worksheet name not specified.');
+ FWorkSheet := FWorkbook.AddWorksheet(FSheetName);
+ CreateTable;
+ end else
+ begin
+ if FAutoFileFormat then
+ FWorkbook.ReadFromFile(FFileName)
+ else
+ FWorkbook.ReadFromFile(FFileName, FFileFormat);
+ if FSheetName = '' then
+ begin
+ FWorksheet := FWorkbook.GetFirstWorksheet;
+ if not (csDesigning in ComponentState) then
+ FSheetName := FWorksheet.Name;
+ end
+ else
+ FWorksheet := FWorkbook.GetWorksheetByName(FSheetName);
+ if FWorksheet = nil then
+ DatabaseError('Worksheet not found.');
+ end;
+
+ FLastCol := FWorksheet.GetLastColIndex(true);
+ FFirstRow := FWorksheet.GetFirstRowIndex(true);
+ FLastRow := FWorksheet.GetLastOccupiedRowIndex;
+ FRecordCount := -1;
+ FTotalFieldSize := -1;
+ FRecordBufferSize := -1;
+
+ InternalInitFieldDefs;
+ if DefaultFields then
+ CreateFields;
+ BindFields(True); // Computes CalcFieldsSize
+ GetTotalFieldSize;
+ GetRecordSize;
+ FRecNo := -1;
+
+ SetupAutoInc;
+ FModified := false;
+
+ FIsOpen := true;
+ except
+ on E: Exception do
+ begin
+ FreeWorkbook;
+ DatabaseError('Error opening workbook: ' + E.Message);
+ end;
+ end;
+end;
+
+{ Called inernally when a record is posted. }
+procedure TsWorksheetDataset.InternalPost;
+begin
+ CheckActive;
+ if not (State in [dsEdit, dsInsert]) then
+ Exit;
+ inherited InternalPost;
+ if (State=dsEdit) then
+ WriteBufferToWorksheet(ActiveBuffer)
+ else
+ begin
+ if Assigned(FAutoIncField) then
+ begin
+ FAutoIncField.AsInteger := FAutoIncValue;
+ inc(FAutoIncValue);
+ end;
+ InternalAddRecord(ActiveBuffer, True);
+ end;
+end;
+
+{ Reinitializes a buffer which has been allocated previously
+ -> zero out everything
+ In this step the NullMask is erased, and this means that all fields are null.
+
+ We cannot just fill the buffer with 0s since that would overwrite our BLOB
+ pointers. Therefore we free the blob pointers first, then fill the buffer
+ with zeros, then reallocate the blob pointers }
+procedure TsWorksheetDataset.InternalInitRecord(Buffer: TRecordBuffer);
+begin
+ FreeBlobPointers(Buffer);
+ FillChar(Buffer^, FRecordBufferSize, 0);
+ AllocBlobPointers(Buffer);
+end;
+
+{ Sets the database cursor to the record specified by the given buffer. We
+ extract here the bookmark associated with the buffer and go to this bookmark. }
+procedure TsWorksheetDataset.InternalSetToRecord(Buffer: TRecordBuffer);
+var
+ bookmarkCell: PCell;
+begin
+ bookmarkCell := GetRecordInfoPtr(Buffer)^.Bookmark;
+ InternalGotoBookmark(@bookmarkCell);
+end;
+
+function TsWorksheetDataset.IsCursorOpen: boolean;
+begin
+ Result := FIsOpen;
+end;
+
+{ Reads the cells data of the current worksheet row and
+ copies them to the buffer. }
+procedure TsWorksheetDataset.LoadWorksheetToBuffer(Buffer: TRecordBuffer;
+ ARecNo: Integer);
+var
+ field: TField;
+ row: TRowIndex;
+ col: TColIndex;
+ cell: PCell;
+ s: String;
+ ws: WideString;
+ {%H-}i: Integer;
+ {%H-}si: SmallInt;
+ {%H-}b: Byte;
+ {%H-}w: word;
+ {%H-}li: LargeInt;
+ {%H-}wb: WordBool;
+ {%H-}c: Currency;
+ {%H-}bcd: TBCD;
+ nullMask: Pointer;
+ maxLen: Integer;
+ fs: Integer;
+begin
+ nullMask := GetNullMaskPtr(Buffer);
+ row := GetRowIndexFromRecNo(ARecNo);
+ for field in Fields do
+ begin
+ col := ColIndexFromField(field);
+ if col = -1 then // this happens for calculated fields.
+ continue;
+ // Find the cell at the column and row. BUT: For bookmark support, we need
+ // a cell even when there is none. So: Find the cell by calling GetCell
+ // which adds a blank cell in such a case.
+ cell := FWorksheet.GetCell(row, col);
+ ClearFieldIsNull(nullMask, field.FieldNo);
+ if field is TBlobField then
+ // BLOB fields have zero DataSize although they occupy space in the buffer
+ fs := SizeOf(TsBlobData)
+ else
+ fs := field.DataSize;
+ case cell^.ContentType of
+ cctUTF8String:
+ begin
+ s := FWorksheet.ReadAsText(cell);
+ if s = '' then
+ SetFieldIsNull(nullMask, field.FieldNo)
+ else
+ if field.DataType = ftMemo then
+ begin
+ with PsBlobData(Buffer)^ do
+ begin
+ SetLength(Data, Length(s));
+ Move(s[1], Data[0], Length(s));
+ end;
+ end else
+ if field.DataType in [ftWideString, ftFixedWideChar] then
+ begin
+ maxLen := field.Size;
+ ws := UTF8ToUTF16(s);
+ ws := UTF16Copy(ws, 1, maxLen) + #0#0;
+ Move(ws[1], Buffer^, Length(ws)*2);
+ end else
+ begin
+ maxLen := field.Size;
+ s := UTF8Copy(s, 1, maxLen) + #0;
+ Move(s[1], Buffer^, Length(s));
+ end;
+ end;
+ cctNumber:
+ case field.DataType of
+ ftFloat, ftCurrency:
+ Move(cell^.NumberValue, Buffer^, SizeOf(cell^.NumberValue));
+ ftBCD:
+ begin
+ c := cell^.NumberValue;
+ Move(c, Buffer^, SizeOf(Currency));
+ end;
+ ftFmtBCD:
+ begin
+ c := cell^.NumberValue;
+ bcd := CurrToBCD(c);
+ Move(bcd, Buffer^, SizeOf(TBCD));
+ end;
+ ftInteger, ftAutoInc:
+ begin
+ i := Round(cell^.NumberValue);
+ Move(i, Buffer^, SizeOf(i));
+ if field.DataType = ftAutoInc then
+ FAutoIncField := TAutoIncField(field);
+ end;
+ {$IF FPC_FullVersion >= 30300}
+ ftByte:
+ begin
+ b := byte(round(cell^.NumberValue));
+ Move(b, Buffer^, SizeOf(b));
+ end;
+ {$IFEND}
+ ftSmallInt:
+ begin
+ si := SmallInt(round(cell^.NumberValue));
+ Move(si, Buffer^, SizeOf(si));
+ end;
+ ftWord:
+ begin
+ w := word(round(cell^.NumberValue));
+ Move(w, Buffer^, SizeOf(w));
+ end;
+ ftLargeInt:
+ begin
+ li := LargeInt(round(cell^.NumberValue));
+ Move(li, Buffer^, SizeOf(li));
+ end;
+ ftString, ftFixedChar:
+ begin
+ s := FWorksheet.ReadAsText(cell) + #0;
+ Move(s[1], Buffer^, Length(s));
+ end;
+ else
+ ;
+ end;
+ cctDateTime:
+ // TDataset handles date/time value as TDateTimeRec but expects them
+ // to be TDateTime in the buffer. How strange!
+ Move(cell^.DateTimeValue, Buffer^, SizeOf(TDateTime));
+ cctBool:
+ begin
+ wb := cell^.BoolValue; // Boolean field stores value as wordbool
+ Move(wb, Buffer^, SizeOf(wb));
+ end;
+ cctEmpty:
+ SetFieldIsNull(nullMask, field.FieldNo);
+ else
+ ;
+ end;
+ inc(Buffer, fs);
+ end;
+end;
+
+{ Searches the first record for which the fields specified by Keyfields
+ (semicolon-separated list) have the values defined in KeyValues.
+ Returns false, when no such record is found.
+ Code from TMemDataset. }
+function TsWorksheetDataset.Locate(const KeyFields: string;
+ const KeyValues: Variant; Options: TLocateOptions): boolean;
+var
+ ARecNo: integer;
+begin
+ // Call inherited to make sure the dataset is bi-directional
+ Result := inherited;
+ CheckActive;
+
+ Result := LocateRecord(KeyFields, KeyValues, Options, ARecNo);
+ if Result then begin
+ // TODO: generate scroll events if matched record is found
+ FRecNo := ARecNo;
+ Resync([]);
+ end;
+end;
+
+{ Helper function for locating records.
+ Taken from TMemDataset: This implements a simple search from record to record.
+ To do: introduce an index for faster searching. }
+function TsWorksheetDataset.LocateRecord(
+ const KeyFields: string;
+ const KeyValues: Variant; Options: TLocateOptions;
+ out ARecNo: integer): Boolean;
+var
+ SaveState: TDataSetState;
+ lKeyFields: TList;
+ Matched: boolean;
+ AKeyValues: variant;
+ i: integer;
+ field: TField;
+ s1,s2: String;
+ ws1, ws2: WideString;
+begin
+ Result := false;
+ SaveState := SetTempState(dsFilter);
+ FFilterBuffer := TempBuffer;
+ lKeyFields := TList.Create;
+ try
+ GetFieldList(lKeyFields, KeyFields);
+ if VarArrayDimCount(KeyValues) = 0 then
+ begin
+ Matched := lKeyFields.Count = 1;
+ AKeyValues := VarArrayOf([KeyValues]);
+ end else
+ if VarArrayDimCount(KeyValues) = 1 then
+ begin
+ Matched := VarArrayHighBound(KeyValues,1) + 1 = lKeyFields.Count;
+ AKeyValues := KeyValues;
+ end
+ else
+ Matched := false;
+
+ if Matched then
+ begin
+ ARecNo := 0;
+ while ARecNo < RecordCount do
+ begin
+ LoadWorksheetToBuffer(FFilterBuffer, ARecNo);
+ if Filtered then
+ Result := FilterRecord(FFilterBuffer)
+ else
+ Result := true;
+ // compare field by field
+ i := 0;
+ while Result and (i < lKeyFields.Count) do
+ begin
+ field := TField(lKeyFields[i]);
+ // string fields
+ if field.DataType in [ftString, ftFixedChar] then
+ begin
+ {$IF FPC_FullVersion >= 30200}
+ if TStringField(field).CodePage=CP_UTF8 then
+ begin
+ s1 := field.AsUTF8String;
+ s2 := UTF8Encode(VarToUnicodeStr(AKeyValues[i]));
+ end else
+ {$IFEND}
+ begin
+ s1 := field.AsString;
+ s2 := VarToStr(AKeyValues[i]);
+ end;
+ if loPartialKey in Options then
+ s1 := copy(s1, 1, length(s2));
+ if loCaseInsensitive in Options then
+ Result := AnsiCompareText(s1, s2)=0
+ else
+ Result := s1=s2;
+ end else
+ // widestring fields
+ if field.DataType in [ftWideString, ftFixedWideChar] then
+ begin
+ ws1 := field.AsWideString;
+ ws2 := VarToWideStr(AKeyValues[i]);
+ if loPartialKey in Options then
+ ws1 := UTF16Copy(ws1, 1, Length(ws2));
+ if loCaseInsensitive in Options then
+ Result := WideCompareText(ws1, ws2) = 0
+ else
+ Result := ws1 = ws2;
+ end
+ // all other fields
+ else
+ Result := (field.Value=AKeyValues[i]);
+ inc(i);
+ end;
+ if Result then
+ break;
+ inc(ARecNo);
+ end;
+ end;
+ finally
+ lKeyFields.Free;
+ RestoreState(SaveState);
+ end;
+end;
+
+{ Searches the first record for which the fields specified by KeyFields
+ (semicolon-separated list of field names) have the values defined in KeyValues.
+ Returns the field values of the ResultFields (a semicolon-separated list of field
+ names), or NULL if there is no match.
+ Code from TMemDataset. }
+function TsWorksheetDataset.Lookup(const KeyFields: string; const KeyValues: Variant;
+ const ResultFields: string): Variant;
+var
+ ARecNo: integer;
+ SaveState: TDataSetState;
+begin
+ if LocateRecord(KeyFields, KeyValues, [], ARecNo) then
+ begin
+ SaveState := SetTempState(dsCalcFields);
+ try
+ // FFilterBuffer contains found record
+ CalculateFields(FFilterBuffer); // CalcBuffer is set to FFilterBuffer
+ Result := FieldValues[ResultFields];
+ finally
+ RestoreState(SaveState);
+ end;
+ end
+ else
+ Result := Null;
+end;
+
+// from TBufDataset
+procedure TsWorksheetDataset.ParseFilter(const AFilter: string);
+begin
+ // parser created?
+ if Length(AFilter) > 0 then
+ begin
+ if (FParser = nil) and IsCursorOpen then
+ FParser := TBufDatasetParser.Create(Self);
+ // is there a parser now?
+ if FParser <> nil then
+ begin
+ // set options
+ FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
+ FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
+ // parse expression
+ FParser.ParseExpression(AFilter);
+ end;
+ end;
+end;
+
+procedure TsWorksheetDataset.SetAutoFieldDefStringSize(Value: Integer);
+begin
+ if FAutoFieldDefStringSize = Value then
+ exit;
+ CheckInactive;
+ FAutoFieldDefStringSize := Value;
+end;
+
+procedure TsWorksheetDataset.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
+begin
+ if Data <> nil then
+ GetRecordInfoPtr(Buffer)^.Bookmark := PPCell(Data)^
+ else
+ GetRecordInfoPtr(Buffer)^.Bookmark := nil;
+end;
+
+procedure TsWorksheetDataset.SetBookmarkFlag(Buffer: TRecordBuffer;
+ Value: TBookmarkFlag);
+begin
+ GetRecordInfoPtr(Buffer)^.BookmarkFlag := Value;
+end;
+
+procedure TsWorksheetDataset.SetCurrentRow(ARow: TRowIndex);
+begin
+ FRecNo := ARow - GetFirstDataRowIndex;
+end;
+
+{ Copies the data to which Buffer points to the position in the active buffer
+ which belongs to the specified field.
+ Adapted from TMemDataset. }
+procedure TsWorksheetDataset.SetFieldData(Field: TField; Buffer: Pointer);
+var
+ destBuffer: TRecordBuffer;
+ idx: Integer;
+ fsize: Integer;
+ {%H-}dt: TDateTime;
+ dtr: TDateTimeRec;
+ s: String;
+ ws: widestring;
+ L: Integer;
+begin
+ if not GetActiveBuffer(destBuffer) then
+ exit;
+
+ idx := Field.FieldNo - 1;
+ if idx >= 0 then
+ begin
+ if State in [dsEdit, dsInsert, dsNewValue] then
+ Field.Validate(Buffer);
+ if Buffer = nil then
+ SetFieldIsNull(GetNullMaskPtr(destBuffer), Field.FieldNo)
+ else
+ begin
+ ClearFieldIsNull(GetNullMaskPtr(destBuffer), Field.FieldNo);
+ inc(destBuffer, FFieldOffsets[idx]);
+ if Field.DataType in [ftDate, ftTime, ftDateTime] then
+ begin
+ // Special treatment for date/time values: TDataset expects them
+ // to be TDateTime in the destBuffer, but to be TDateTimeRec in the
+ // input Buffer.
+ dtr := Default(TDateTimeRec);
+ Move(Buffer^, dtr, SizeOf(dtr));
+ dt := DateTimeRecToDateTime(Field.DataType, dtr);
+ Move(dt, destBuffer^, SizeOf(dt));
+ end else
+ if Field.DataType in [ftString, ftFixedChar] then
+ begin
+ FillChar(destBuffer^, Field.DataSize, 0);
+ // Truncate strings which have more characters than efined by Field.Size.
+ // This should have been done by the calling routine, but it considers
+ // only Field.Datasize.
+ s := StrPas(PAnsiChar(Buffer));
+ {$IF FPC_FullVersion >= 30200};
+ if (TStringField(Field).CodePage = CP_UTF8) then
+ begin
+ L := UTF8Length(s);
+ if L > Field.Size then
+ s := UTF8Copy(s, 1, Field.Size);
+ Move(s[1], destBuffer^, Length(s));
+ end else
+ {$IFEND}
+ begin
+ L := Length(s);
+ if L > Field.Size then
+ s := Copy(s, 1, Field.Size);
+ Move(s[1], destBuffer^, Length(s))
+ end;
+ end else
+ if Field.DataType in [ftWideString, ftFixedWideChar] then
+ begin
+ // Truncate strings which have more characters than defined by Field.Size.
+ // This should have been done by the calling routine, but it considers
+ // only Field.Datasize.
+ FillChar(destBuffer^, Field.Size*2, 0);
+ ws := StrPas(PWideChar(Buffer));
+ if Length(ws) > Field.Size then
+ ws := UTF16Copy(ws, 1, Field.Size);
+ Move(ws[1], destBuffer^, Length(ws)*2);
+ end else
+ Move(Buffer^, destBuffer^, Field.DataSize);
+ end;
+ end else
+ begin // Calculated, Lookup
+ inc(destBuffer, RecordSize + Field.Offset);
+ Boolean(destBuffer[0]) := Buffer <> nil;
+ if Assigned(Buffer) then
+ Move(Buffer^, DestBuffer[1], Field.DataSize);
+ end;
+
+ if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
+ DataEvent(deFieldChange, PtrInt(Field));
+end;
+
+// From TBufDataset
+procedure TsWorksheetDataset.SetFiltered(Value: Boolean);
+begin
+ if Value = Filtered then
+ exit;
+
+ // Pass on to ancestor
+ inherited;
+
+ // Only refresh if active
+ if IsCursorOpen then
+ Resync([]);
+end;
+
+// From TBufDataset
+procedure TsWorksheetDataset.SetFilterText(const Value: string);
+begin
+ if Value = Filter then
+ exit;
+
+ // Parse
+ ParseFilter(Value);
+
+ // Call dataset method
+ inherited;
+
+ // Refilter dataset if filtered
+ if IsCursorOpen and Filtered then Resync([]);
+end;
+
+procedure TsWorksheetDataset.SetRecNo(Value: Integer);
+begin
+ CheckBrowseMode;
+ if (Value >= 1) and (Value <= RecordCount) then
+ begin
+ FRecNo := Value-1;
+ Resync([]);
+ end;
+end;
+
+{ Finds the field declared as AutoInc field.
+ Determines the starting value of the AutoInc counter by looking for the max
+ value in the AutoInc column. }
+procedure TsWorksheetDataset.SetupAutoInc;
+var
+ f: TField;
+ c: TColIndex;
+ r: Integer;
+ mx: Integer;
+ cell: PCell;
+begin
+ FAutoIncField := nil;
+ FAutoIncValue := -1;
+
+ for f in Fields do
+ if f is TAutoIncField then
+ begin
+ FAutoIncField := TAutoIncField(f);
+ break;
+ end;
+
+ // No AutoInc field found among FieldDefs.
+ if FAutoIncField = nil then
+ exit;
+
+ // Search for the maximum value in the autoinc column.
+ // Take care of blank and non-numeric cells - this should not happen but
+ // the spreadsheet file can be opened outside the db-aware application
+ // and modified there.
+ mx := -MaxInt;
+ c := ColIndexFromField(f);
+ r := GetFirstDataRowIndex;
+ for r := GetFirstDataRowIndex to FLastRow do
+ begin
+ cell := FWorksheet.FindCell(r, c);
+ if cell <> nil then
+ begin
+ case cell^.ContentType of
+ cctNumber: mx := Max(mx, round(FWorksheet.ReadAsNumber(cell)));
+ cctEmpty: ;
+ else DatabaseError('AutoInc field must be a assigned to numeric cells.');
+ end;
+ end;
+ end;
+ if mx = -MaxInt then
+ FAutoIncvalue := 1
+ else
+ FAutoIncValue := mx + 1;
+end;
+
+procedure TsWorksheetDataset.Sort;
+const
+ firstCol = 0;
+begin
+ FWorksheet.Sort(FSortParams, GetFirstDataRowIndex, firstCol, GetLastDataRowIndex, FLastCol);
+end;
+
+procedure TsWorksheetDataset.SortOnField(const FieldName: String);
+begin
+ SortOnField(FieldName, []);
+end;
+
+procedure TsWorksheetDataset.SortOnField(const FieldName: String;
+ const Options: TsSortOptions);
+var
+ bm: TBookmark;
+ optns: TsSortOptionsArray;
+begin
+ bm := GetBookmark;
+ try
+ DisableControls;
+ try
+ SetLength(optns, 1);
+ optns[0] := Options;
+ CreateSortParams(FieldName, optns);
+ Sort;
+ FModified := true;
+ finally
+ EnableControls;
+ end;
+ finally
+ GotoBookmark(bm);
+ FreeBookmark(bm);
+ end;
+ Resync([]);
+end;
+
+procedure TsWorksheetDataset.SortOnFields(const FieldNames: String);
+begin
+ SortOnFields(FieldNames, nil);
+end;
+
+procedure TsWorksheetDataset.SortOnFields(const FieldNames: string;
+ const Options: TsSortOptionsArray);
+var
+ bm: TBookmark;
+begin
+ bm := GetBookmark;
+ try
+ DisableControls;
+ try
+ CreateSortParams(FieldNames, Options);
+ Sort;
+ FModified := true;
+ finally
+ EnableControls;
+ end;
+ GotoBookmark(bm);
+ finally
+ FreeBookmark(bm);
+ end;
+ Resync([]);
+end;
+
+{ Writes the buffer back to the worksheet. }
+procedure TsWorksheetDataset.WriteBufferToWorksheet(Buffer: TRecordBuffer);
+var
+ row: TRowIndex;
+ col: TColIndex;
+ cell: PCell;
+ field: TField;
+ P: Pointer;
+ s: String = '';
+ ws: WideString = '';
+ curr: Currency;
+begin
+ row := GetCurrentRowIndex;
+ P := Buffer;
+ for field in Fields do begin
+ col := ColIndexFromField(field);
+ cell := FWorksheet.FindCell(row, col);
+ if GetFieldIsNull(GetNullMaskPtr(Buffer), field.FieldNo) then
+ FWorksheet.WriteBlank(cell)
+ else
+ begin
+ P := Buffer + FFieldOffsets[field.FieldNo-1];
+ cell := FWorksheet.GetCell(row, col);
+ case field.DataType of
+ ftFloat:
+ if (TFloatField(field).Precision >= 15) or (TFloatField(field).Precision < 0) then
+ FWorksheet.WriteNumber(cell, PDouble(P)^, nfGeneral)
+ else
+ FWorksheet.WriteNumber(cell, PDouble(P)^, nfFixed, TFloatField(field).Precision);
+ ftCurrency:
+ FWorksheet.WriteCurrency(cell, PDouble(P)^, nfCurrency, 2);
+ ftBCD:
+ FWorksheet.WriteNumber(cell, PCurrency(P)^, nfFixed, TBCDField(field).Size);
+ ftFmtBCD:
+ if BCDToCurr(PBCD(P)^, curr) then
+ FWorksheet.WriteNumber(cell, curr, nfFixed, TFmtBCDField(field).Size);
+ ftInteger, ftAutoInc:
+ FWorksheet.WriteNumber(cell, PInteger(P)^);
+ {$IF FPC_FullVersion >= 30300}
+ ftByte:
+ FWorksheet.WriteNumber(cell, PByte(P)^);
+ {$IFEND}
+ ftSmallInt:
+ FWorksheet.WriteNumber(cell, PSmallInt(P)^);
+ ftWord:
+ FWorksheet.WriteNumber(cell, PWord(P)^);
+ ftLargeInt:
+ FWorksheet.WriteNumber(cell, PLargeInt(P)^);
+ ftDateTime:
+ FWorksheet.WriteDateTime(cell, PDateTime(P)^, nfShortDateTime);
+ ftDate:
+ FWorksheet.WriteDateTime(Cell, PDateTime(P)^, nfShortDate);
+ ftTime:
+ FWorksheet.WriteDateTime(cell, PDateTime(P)^, nfLongTime);
+ ftBoolean:
+ FWorksheet.WriteBoolValue(cell, PWordBool(P)^);
+ ftString, ftFixedChar:
+ FWorksheet.WriteText(cell, StrPas(PChar(P)));
+ ftWideString, ftFixedWideChar:
+ begin
+ Setlength(ws, StrLen(PWideChar(P)));
+ Move(P^, ws[1], Length(ws)*2);
+ s := UTF16ToUTF8(ws);
+ FWorksheet.WriteText(cell, s);
+ end;
+ ftMemo:
+ begin
+ SetLength(s, Length(PsBlobData(P)^.Data));
+ if Length(PsBlobData(P)^.Data) > 0 then
+ Move(PsBlobData(P)^.Data[0], s[1], Length(s));
+ FWorksheet.WriteText(cell, s);
+ end;
+ else
+ ;
+ end;
+ end;
+ end;
+ FModified := true;
+end;
+
+
+procedure Register;
+begin
+ RegisterComponents('Data Access', [
+ TsWorksheetDataset
+ ]);
+end;
+
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpi b/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpi
new file mode 100644
index 000000000..c74262882
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpi
@@ -0,0 +1,132 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpr b/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpr
new file mode 100644
index 000000000..badead2ec
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/GuiTestProject.lpr
@@ -0,0 +1,17 @@
+program GuiTestProject;
+
+{$mode objfpc}{$H+}
+
+uses
+ Interfaces, Forms, GuiTestRunner,
+ ReadFieldsTestUnit, SortTestUnit, SearchTestUnit, FilterTestUnit, PostTestUnit,
+ EmptyColumnsTestUnit, CopyFromDatasetUnit;
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TGuiTestRunner, TestRunner);
+ Application.Run;
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/copyfromdatasetunit.pas b/components/fpspreadsheet/unit-tests/dataset/copyfromdatasetunit.pas
new file mode 100644
index 000000000..3e9357874
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/copyfromdatasetunit.pas
@@ -0,0 +1,219 @@
+unit CopyFromDatasetUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testutils, testregistry,
+ DB, dbf,
+ fpspreadsheet, fpsDataset;
+
+type
+
+ { TCopyFromDatasetTest }
+
+ TCopyFromDatasetTest= class(TTestCase)
+ private
+ function CreateDbf: TDbf;
+ procedure CopyDatasetTest(ATestIndex: Integer);
+ protected
+ procedure SetUp; override;
+ procedure TearDown; override;
+ published
+ procedure CopyDatasetTest_FieldDefs;
+ procedure CopyDatasetTest_Fields;
+ procedure CopyDatasetTest_Records;
+ end;
+
+implementation
+
+uses
+ TypInfo;
+
+const
+ DBF_FILE_NAME = 'testdata.dbf';
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+
+ STRING_FIELD = 'StringCol';
+ INT_FIELD = 'IntegerCol';
+ FLOAT_FIELD = 'FloatCol';
+
+ NUM_RECORDS = 10;
+
+var
+ DataFileName: String;
+ DbfPath: String;
+
+
+function TCopyFromDatasetTest.CreateDbf: TDbf;
+var
+ i: Integer;
+begin
+ Result := TDbf.Create(nil);
+ Result.FilePathFull := DbfPath;
+ Result.TableName := DBF_FILE_NAME;
+ Result.FieldDefs.Add(STRING_FIELD, ftString, 20);
+ Result.FieldDefs.Add(INT_FIELD, ftInteger);
+ Result.FieldDefs.Add(FLOAT_FIELD, ftFloat);
+ Result.CreateTable;
+ Result.Open;
+ for i := 1 to NUM_RECORDS do
+ begin
+ Result.Append;
+ Result.FieldByName(STRING_FIELD).AsString := 'abc' + IntToStr(i);
+ Result.FieldByName(INT_FIELD).AsInteger := -5 + i;
+ Result.FieldByName(FLOAT_FIELD).AsFloat := -5.1 * (i + 5.1);
+ Result.Post;
+ end;
+end;
+
+procedure TCopyFromDatasetTest.CopyDatasetTest(ATestIndex: Integer);
+const
+ DEBUG = false;
+var
+ dbf: TDbf;
+ dataset: TsWorksheetDataset;
+ i: Integer;
+begin
+ dbf := CreateDbf;
+
+ if DEBUG then
+ begin
+ dbf.Close;
+ dbf.Open;
+ end;
+
+ dataset := TsWorksheetDataset.Create(nil);
+ try
+ dataset.CopyFromDataset(dbf, DataFileName, dbf.TableName);
+
+ // Save for debugging
+ if DEBUG then
+ begin
+ dataset.Close;
+ dataset.Open;
+ end;
+
+ case ATestIndex of
+ // FIELD DEFS
+ 0: begin
+ CheckEquals( // Compare FieldDef count
+ dbf.FieldDefs.Count,
+ dataset.FieldDefs.Count,
+ 'Mismatch in number of FieldDefs'
+ );
+
+ // Compare FieldDefs
+ for i := 0 to dbf.FieldDefs.Count-1 do
+ begin
+ CheckEquals(
+ dbf.FieldDefs[i].Name,
+ dataset.FieldDefs[i].Name,
+ 'Mismatch in FieldDefs[' + IntToStr(i) + '].Name'
+ );
+ CheckEquals(
+ GetEnumName(TypeInfo(TFieldType), integer(dbf.FieldDefs[i].DataType)),
+ GetEnumName(TypeInfo(TFieldType), integer(dataset.FieldDefs[i].DataType)),
+ 'Mismatch in FieldDefs[' + IntToStr(i) + '].DataType'
+ );
+ CheckEquals(
+ dbf.FieldDefs[i].Size,
+ dataset.FieldDefs[i].Size,
+ 'Mismatch in FieldDefs[' + IntToStr(i) + '].Size'
+ );
+ end;
+ end;
+
+ // FIELDS
+ 1: begin
+ // Compare field count
+ CheckEquals(
+ dbf.FieldCount,
+ dataset.FieldCount,
+ 'Mismatch in FieldCount'
+ );
+
+ // Compare fields
+ for i := 0 to dbf.FieldCount-1 do
+ begin
+ CheckEquals(
+ dbf.Fields[i].FieldName,
+ dataset.Fields[i].FieldName,
+ 'Mismatch in Fields[' + IntToStr(i) + '].FieldName'
+ );
+ CheckEquals(
+ GetEnumName(TypeInfo(TFieldType), integer(dbf.Fields[i].DataType)),
+ GetEnumName(TypeInfo(TFieldType), integer(dataset.Fields[i].DataType)),
+ 'Mismatch in Fields[' + IntToStr(i) + '].DataType'
+ );
+ end;
+ end;
+
+ // RECORDS
+ 2: begin
+ // Compare record count
+ CheckEquals(
+ dbf.RecordCount,
+ dataset.RecordCount,
+ 'Mismatch in RecordCount'
+ );
+
+ dbf.First;
+ dataset.First;
+ while not dbf.EoF do
+ begin
+ for i := 0 to dbf.FieldCount-1 do
+ begin
+ CheckEquals(
+ dbf.Fields[i].AsString,
+ dataset.Fields[i].AsString,
+ 'Record value mismatch, Field #[' + IntToStr(i) + '], RecNo ' + IntToStr(dbf.RecNo)
+ );
+ end;
+ dbf.Next;
+ dataset.Next;
+ end;
+ end;
+ end;
+
+ finally
+ dataset.Free;
+ dbf.Free;
+ end;
+end;
+
+procedure TCopyFromDatasetTest.CopyDatasetTest_FieldDefs;
+begin
+ CopyDatasetTest(0);
+end;
+
+procedure TCopyFromDatasetTest.CopyDatasetTest_Fields;
+begin
+ CopyDatasetTest(1);
+end;
+
+procedure TCopyFromDatasetTest.CopyDatasetTest_Records;
+begin
+ CopyDatasetTest(2);
+end;
+
+procedure TCopyFromDatasetTest.SetUp;
+begin
+ DataFileName := GetTempDir + FILE_NAME;
+ DbfPath := GetTempDir;
+end;
+
+procedure TCopyFromDatasetTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+ if FileExists(DbfPath + DBF_FILE_NAME) then DeleteFile(DbfPath + DBF_FILE_NAME);
+end;
+
+
+initialization
+ RegisterTest(TCopyFromDatasetTest);
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/emptycolumnstestunit.pas b/components/fpspreadsheet/unit-tests/dataset/emptycolumnstestunit.pas
new file mode 100644
index 000000000..e508b26f9
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/emptycolumnstestunit.pas
@@ -0,0 +1,297 @@
+{ These tests check whether empty columns in the worksheet are ignored when
+ FieldDefs are determined. }
+
+unit EmptyColumnsTestUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testregistry,
+ DB,
+ fpSpreadsheet, fpsTypes, fpsDataset;
+
+type
+
+ TEmptyColumnsTest = class(TTestCase)
+ private
+ function CreateAndOpenDataset(
+ ATestIndex: Integer; AutoFieldDefs: Boolean): TsWorksheetDataset;
+ procedure CreateWorksheet(ATestIndex: Integer);
+ protected
+ procedure TestFieldDefs(ATestIndex: Integer; AutoFieldDefs: Boolean);
+ procedure SetUp; override;
+ procedure TearDown; override;
+ published
+ procedure Test_0;
+ procedure Test_1;
+ procedure Test_2;
+ procedure Test_3;
+ procedure Test_4;
+ procedure Test_5;
+ procedure Test_6;
+ procedure Test_0_AutoFieldDefs;
+ procedure Test_1_AutoFieldDefs;
+ procedure Test_2_AutoFieldDefs;
+ procedure Test_3_AutoFieldDefs;
+ procedure Test_4_AutoFieldDefs;
+ procedure Test_5_AutoFieldDefs;
+ procedure Test_6_AutoFieldDefs;
+ end;
+
+
+implementation
+
+const
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+
+var
+ DataFileName: String;
+
+type
+ TDataRec = record
+ ColumnType: TFieldType;
+ FieldDefIndex: Integer;
+ end;
+ TTestData = array [0..3] of TDataRec; // colums 0..3 in worksheet
+
+const
+ TestCases: array[0..6] of TTestData = (
+ ( //0
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftFloat; FieldDefIndex: 1),
+ (ColumnType:ftString; FieldDefIndex: 2),
+ (ColumnType:ftDate; FieldDefIndex: 3)
+ ),
+ ( // 1
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftFloat; FieldDefIndex: 1),
+ (ColumnType:ftDate; FieldDefIndex: 2)
+ ),
+ ( // 2
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftFloat; FieldDefIndex: 1),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftString; FieldDefIndex: 2)
+ ),
+ ( // 3
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftFloat; FieldDefIndex: 1),
+ (ColumnType:ftString; FieldDefIndex: 2)
+ ),
+ ( // 4
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftString; FieldDefIndex: 1),
+ (ColumnType:ftDate; FieldDefIndex: 2),
+ (ColumnType:ftUnknown; FieldDefIndex:-1)
+ ),
+ ( // 5
+ (ColumnType:ftInteger; FieldDefIndex: 0),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftFloat; FieldDefIndex: 1)
+ ),
+ ( // 6
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftUnknown; FieldDefIndex:-1),
+ (ColumnType:ftInteger; FieldDefIndex: 0)
+ )
+ );
+
+function TEmptyColumnsTest.CreateAndOpenDataset(
+ ATestIndex: Integer; AutoFieldDefs: Boolean): TsWorksheetDataset;
+var
+ i: Integer;
+begin
+ Result := TsWorksheetDataset.Create(nil);
+ Result.FileName := DataFileName;
+ Result.SheetName := SHEET_NAME;
+ Result.AutoFieldDefs := AutoFieldDefs;
+ if not AutoFieldDefs then
+ begin
+ for i := 0 to Length(TTestData)-1 do
+ begin
+ case TestCases[ATestIndex][i].ColumnType of
+ ftUnknown: ;
+ ftInteger: Result.AddFieldDef('IntCol', ftInteger, 0, i);
+ ftFloat: Result.AddFieldDef('FloatCol', ftFloat, 0, i);
+ ftString: Result.AddFieldDef('StringCol', ftString, 20, i);
+ ftDate: Result.AddFieldDef('DateCol', ftDate, 0, i);
+ else raise Exception.Create('Field type not expected in this test.');
+ end;
+ end;
+ Result.CreateTable;
+ end;
+ Result.Open;
+end;
+
+{ Creates a worksheet with columns as defined by the TestColumns.
+ ftUnknown will become an empty column. }
+procedure TEmptyColumnsTest.CreateWorksheet(ATestIndex: Integer);
+const
+ NumRows = 10;
+var
+ r, c: Integer;
+ s: String;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+begin
+ // Create test spreadsheet file
+ workbook := TsWorkbook.Create;
+ try
+ // Create worksheet
+ worksheet := workbook.AddWorkSheet(SHEET_NAME);
+ // Write headers (= field names) and record values
+ for c := 0 to Length(TTestData)-1 do
+ begin
+ case TestCases[ATestIndex][c].ColumnType of
+ ftUnknown: ;
+ ftInteger:
+ begin
+ worksheet.WriteText(0, c, 'IntCol');
+ for r := 1 to NumRows do
+ worksheet.WriteNumber(r, c, Random(100));
+ end;
+ ftFloat:
+ begin
+ worksheet.WriteText(0, c, 'FloatCol');
+ for r := 1 to NumRows do
+ worksheet.WriteNumber(r, c, Random*100);
+ end;
+ ftString:
+ begin
+ worksheet.WriteText(0, c, 'StringCol');
+ for r := 1 to NumRows do
+ worksheet.WriteText(r, c, char(ord('a') + random(26)));
+ end;
+ ftDate:
+ begin
+ worksheet.WriteText(0, c, 'DateCol');
+ for r := 1 to NumRows do
+ worksheet.WriteDateTime(r, c, EncodeDate(2000,1,1) + Random(1000), nfShortDate);
+ end;
+ end;
+ end;
+
+ // Save
+ workbook.WriteToFile(DataFileName, true);
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TEmptyColumnsTest.TestFieldDefs(ATestIndex: Integer; AutoFieldDefs: Boolean);
+var
+ dataset: TsWorksheetDataset;
+ c, i: Integer;
+ expectedFieldDefIndex, actualFieldDefIndex: Integer;
+begin
+ CreateWorksheet(ATestIndex);
+ dataset := CreateAndOpenDataset(ATestIndex, AutoFieldDefs);
+ try
+ for i := 0 to dataset.FieldDefs.Count-1 do
+ begin
+ c := TsFieldDef(dataset.FieldDefs[i]).ColIndex;
+ expectedFieldDefIndex := TestCases[ATestIndex][c].FieldDefIndex;
+ actualFieldDefIndex := i;
+ CheckEquals(
+ expectedFieldDefIndex,
+ actualFieldDefIndex,
+ 'FieldDef index mismatch, fieldDef #' + IntToStr(i)
+ );
+ end;
+ finally
+ dataset.Free;
+ end;
+end;
+
+procedure TEmptyColumnsTest.Test_0;
+begin
+ TestFieldDefs(0, false);
+end;
+
+procedure TEmptyColumnsTest.Test_1;
+begin
+ TestFieldDefs(1, false);
+end;
+
+procedure TEmptyColumnsTest.Test_2;
+begin
+ TestFieldDefs(2, false);
+end;
+
+procedure TEmptyColumnsTest.Test_3;
+begin
+ TestFieldDefs(3, false);
+end;
+
+procedure TEmptyColumnsTest.Test_4;
+begin
+ TestFieldDefs(4, false);
+end;
+
+procedure TEmptyColumnsTest.Test_5;
+begin
+ TestFieldDefs(5, false);
+end;
+
+procedure TEmptyColumnsTest.Test_6;
+begin
+ TestFieldDefs(6, false);
+end;
+
+procedure TEmptyColumnsTest.Test_0_AutoFieldDefs;
+begin
+ TestFieldDefs(0, true);
+end;
+
+procedure TEmptyColumnsTest.Test_1_AutoFieldDefs;
+begin
+ TestFieldDefs(1, true);
+end;
+
+procedure TEmptyColumnsTest.Test_2_AutoFieldDefs;
+begin
+ TestFieldDefs(2, true);
+end;
+
+procedure TEmptyColumnsTest.Test_3_AutoFieldDefs;
+begin
+ TestFieldDefs(3, true);
+end;
+
+procedure TEmptyColumnsTest.Test_4_AutoFieldDefs;
+begin
+ TestFieldDefs(4, true);
+end;
+
+procedure TEmptyColumnsTest.Test_5_AutoFieldDefs;
+begin
+ TestFieldDefs(5, true);
+end;
+
+procedure TEmptyColumnsTest.Test_6_AutoFieldDefs;
+begin
+ TestFieldDefs(6, true);
+end;
+
+procedure TEmptyColumnsTest.SetUp;
+begin
+ DataFileName := GetTempDir + FILE_NAME;
+end;
+
+procedure TEmptyColumnsTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+initialization
+
+ RegisterTest(TEmptyColumnsTest);
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/filtertestunit.pas b/components/fpspreadsheet/unit-tests/dataset/filtertestunit.pas
new file mode 100644
index 000000000..80481cac8
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/filtertestunit.pas
@@ -0,0 +1,370 @@
+unit FilterTestUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testregistry,
+ DB,
+ fpspreadsheet, fpstypes, fpsutils, fpsdataset;
+
+type
+ TFilterTest= class(TTestCase)
+ private
+ function CreateAndOpenDataset: TsWorksheetDataset;
+ procedure Filter_01(Dataset: TDataset; var Accept: Boolean); // 'IntCol < 2'
+ procedure Filter_10(Dataset: TDataset; var Accept: Boolean); // 'StringCol = 'abc
+ procedure Filter_11(Dataset: TDataset; var Accept: Boolean); // 'UPPER(StringCol) = 'ABC'
+ procedure Filter_12(Dataset: TDataset; var Accept: Boolean); // 'StringCol = 'ä'
+ procedure Filter_13(Dataset: TDataset; var Accept: Boolean); // 'StringCol > 'α'
+ procedure Filter_20(Dataset: TDataset; var Accept: Boolean); // 'WideStringCol = 'wABC'
+ procedure Filter_21(Dataset: TDataset; var Accept: Boolean); // 'UPPER(WideStringCol) = 'WABC'
+ procedure Filter_22(Dataset: TDataset; var Accept: Boolean); // 'WideStringCol = 'wä'
+ protected
+ procedure FilterTest(TestIndex: Integer);
+ procedure SetUp; override;
+ procedure TearDown; override;
+ published
+ procedure FilterTest_01_Int;
+ procedure FilterTest_10_String;
+ procedure FilterTest_11_UpperString;
+ procedure FilterTest_12_StringUTF8;
+ procedure FilterTest_13_StringUTF8;
+
+ procedure FilterTest_ByEvent_101_Int;
+ procedure FilterTest_ByEvent_110_String;
+ procedure FilterTest_ByEvent_111_UpperString;
+ procedure FilterTest_ByEvent_112_String_UTF8;
+ procedure FilterTest_ByEvent_113_String_UTF8;
+ procedure FilterTest_ByEvent_120_WideString;
+ procedure FilterTest_ByEvent_121_UpperWideString;
+ procedure FilterTest_ByEvent_122_WideString_UTF8;
+ end;
+
+implementation
+
+const
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+ INT_COL = 0;
+ STRING_COL = 1;
+ WIDESTRING_COL = 2;
+ INT_FIELD = 'IntCol';
+ STRING_FIELD = 'StringCol';
+ WIDESTRING_FIELD = 'WideStringCol';
+
+var
+ DataFileName: String;
+
+type
+ TTestRow = record
+ IntValue: Integer;
+ StringValue: String;
+ WideStringValue: Widestring;
+ end;
+
+const
+ // Unfiltered test values
+ UNFILTERED: array[0..7] of TTestRow = ( // Index
+ (IntValue: 10; StringValue: 'abc'; WideStringValue: 'wabc'), // 0
+ (IntValue: 1; StringValue: 'ABC'; WideStringvalue: 'wABC'), // 1
+ (IntValue: 1; StringValue: 'a'; WideStringValue: 'wa'), // 2
+ (IntValue: 2; StringValue: 'A'; WideStringValue: 'wA'), // 3
+ (IntValue: -1; StringValue: 'xyz'; WideStringValue: 'wxyz'), // 4
+ (IntValue: 25; StringValue: 'ä'; WideStringValue: 'wä'), // 5
+ (IntValue: 30; StringValue: 'Äöü'; WideStringValue: 'wÄöü'), // 6
+ (IntValue: 5; StringValue: 'αβγä';WideStringValue: 'wαβγä') // 7
+ );
+
+ // These are the indexes into the UNFILTERED array after filtering
+ FILTERED_01: array[0..2] of Integer = (1, 2, 4); // 'IntCol < 2'
+ FILTERED_10: array[0..0] of Integer = (0); // 'StringCol = 'abc'
+ FILTERED_11: array[0..1] of Integer = (0, 1); // 'UPPER(StringCol) = 'ABC'
+ FILTERED_12: array[0..0] of Integer = (5); // StringCol = 'ä'
+ FILTERED_13: array[0..0] of Integer = (7); // StringCol >= 'α'
+ FILTERED_20: array[0..0] of Integer = (1); // 'WideStringCol = 'wABC'
+ FILTERED_21: array[0..1] of Integer = (0, 1); // 'UPPER(WideStringCol) = 'WABC'
+ FILTERED_22: array[0..0] of Integer = (5); // WideStringCol = 'wä'
+
+ EXPRESSION_01 = 'IntCol < 2';
+ EXPRESSION_10 = 'StringCol = "abc"';
+ EXPRESSION_11 = 'UPPER(StringCol) = "ABC"';
+ EXPRESSION_12 = 'StringCol = "ä"';
+ EXPRESSION_13 = 'StringCol >= "α"';
+ EXPRESSION_20 = 'WideStringCol = "wABC"';
+ EXPRESSION_21 = 'UPPER(WideStringCol) = "WABC"';
+ EXPRESSION_22 = 'WideStringCol = "wä"';
+
+
+procedure TFilterTest.Filter_01(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(INT_FIELD).AsInteger < 2;
+end;
+
+procedure TFilterTest.Filter_10(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(STRING_FIELD).AsString = 'abc';
+end;
+
+procedure TFilterTest.Filter_11(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := UpperCase(Dataset.FieldByName(STRING_FIELD).AsString) = 'ABC';
+end;
+
+procedure TFilterTest.Filter_12(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(STRING_FIELD).AsString = 'ä';
+end;
+
+procedure TFilterTest.Filter_13(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(STRING_FIELD).AsString >= 'α';
+end;
+
+procedure TFilterTest.Filter_20(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(WIDESTRING_FIELD).AsWideString = WideString('wABC');
+end;
+
+procedure TFilterTest.Filter_21(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Uppercase(Dataset.FieldByName(WIDESTRING_FIELD).AsWideString) = WideString('WABC');
+end;
+
+procedure TFilterTest.Filter_22(Dataset: TDataset; var Accept: Boolean);
+begin
+ Accept := Dataset.FieldByName(WIDESTRING_FIELD).AsWideString = WideString('wä');
+end;
+
+function TFilterTest.CreateAndOpenDataset: TsWorksheetDataset;
+begin
+ Result := TsWorksheetDataset.Create(nil);
+ Result.FileName := DataFileName;
+ Result.SheetName := SHEET_NAME;
+ Result.AutoFieldDefs := false;
+ Result.AddFieldDef(INT_FIELD, ftInteger);
+ Result.AddFieldDef(STRING_FIELD, ftString, 20);
+ Result.AddFieldDef(WIDESTRING_FIELD, ftWideString, 20);
+ Result.CreateTable;
+ Result.Open;
+end;
+
+procedure TFilterTest.FilterTest(TestIndex: Integer);
+var
+ dataset: TsWorksheetDataset;
+ intField: TField;
+ stringField: TField;
+ widestringField: TField;
+ actualInt: Integer;
+ actualString: String;
+ actualWideString: WideString;
+ expectedInt: Integer;
+ expectedString: String;
+ expectedWideString: WideString;
+ expectedRecordCount: Integer;
+ i, idx: Integer;
+begin
+ dataset := CreateAndOpenDataset;
+ try
+ dataset.Filter := '';
+ dataset.OnFilterRecord := nil;
+ case TestIndex of
+ // Tests using the Filter property
+ 1: dataset.Filter := EXPRESSION_01; // Integer test
+ 10: dataset.Filter := EXPRESSION_10; // String tests
+ 11: dataset.Filter := EXPRESSION_11;
+ 12: dataset.Filter := EXPRESSION_12;
+ 13: dataset.Filter := EXPRESSION_13;
+ 20: dataset.Filter := EXPRESSION_20; // widestring tests
+ 21: dataset.Filter := EXPRESSION_21;
+ 22: dataset.Filter := EXPRESSION_22;
+ // Tests using the OnFilterRecord event
+ 101: dataset.OnFilterRecord := @Filter_01;
+ 110: dataset.OnFilterRecord := @Filter_10;
+ 111: dataset.OnFilterRecord := @Filter_11;
+ 112: dataset.OnFilterRecord := @Filter_12;
+ 113: dataset.OnFilterRecord := @Filter_13;
+ 120: dataset.OnFilterRecord := @Filter_20;
+ 121: dataset.OnFilterRecord := @Filter_21;
+ 122: dataset.OnFilterRecord := @Filter_22;
+ end;
+ dataset.Filtered := true;
+
+ case (TestIndex mod 100) of
+ 1: expectedRecordCount := Length(FILTERED_01);
+ 10: expectedRecordCount := Length(FILTERED_10);
+ 11: expectedRecordCount := Length(FILTERED_11);
+ 12: expectedRecordCount := Length(FILTERED_12);
+ 13: expectedRecordCount := Length(FILTERED_13);
+ 20: expectedRecordCount := Length(FILTERED_20);
+ 21: expectedRecordCount := Length(FILTERED_21);
+ 22: expectedRecordCount := Length(FILTERED_22);
+ end;
+
+ intField := dataset.FieldByName(INT_FIELD);
+ stringField := dataset.FieldByName(STRING_FIELD);
+ wideStringField := dataset.FieldByName(WIDESTRING_FIELD);
+
+ dataset.First;
+ i := 0;
+ while not dataset.EOF do
+ begin
+ CheckEquals(true, i < expectedRecordCount, 'Record count mismatch.');
+
+ case TestIndex mod 100 of
+ 1: idx := FILTERED_01[i];
+ 10: idx := FILTERED_10[i];
+ 11: idx := FILTERED_11[i];
+ 12: idx := FILTERED_12[i];
+ 13: idx := FILTERED_13[i];
+ 20: idx := FILTERED_20[i];
+ 21: idx := FILTERED_21[i];
+ 22: idx := FILTERED_22[i];
+ end;
+
+ actualInt := intField.AsInteger;
+ actualString := stringField.AsString;
+ actualWideString := wideStringField.AsWideString;
+
+ expectedInt := UNFILTERED[idx].IntValue;
+ expectedString := UNFILTERED[idx].StringValue;
+ expectedWideString := UNFILTERED[idx].WideStringValue;
+
+ CheckEquals(
+ expectedInt,
+ actualInt,
+ 'Integer field value mismatch in row ' + IntToStr(i)
+ );
+ CheckEquals(
+ expectedString,
+ actualString,
+ 'String field value mismatch in row ' + IntToStr(i)
+ );
+ CheckEquals(
+ expectedWideString,
+ actualWideString,
+ 'Widestring field value mismatch in row ' + IntToStr(i)
+ );
+
+ inc(i);
+ dataset.Next;
+ end;
+
+ CheckEquals(true, i = expectedRecordCount, 'Record count mismatch.');
+
+ finally
+ dataset.Free;
+ end;
+end;
+
+procedure TFilterTest.FilterTest_01_Int;
+begin
+ FilterTest(1);
+end;
+
+procedure TFilterTest.FilterTest_10_String;
+begin
+ FilterTest(10);
+end;
+
+procedure TFilterTest.FilterTest_11_UpperString;
+begin
+ FilterTest(11);
+end;
+
+procedure TFilterTest.FilterTest_12_StringUTF8;
+begin
+ FilterTest(12);
+end;
+
+procedure TFilterTest.FilterTest_13_StringUTF8;
+begin
+ FilterTest(13);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_101_Int;
+begin
+ FilterTest(101);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_110_String;
+begin
+ FilterTest(110);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_111_UpperString;
+begin
+ FilterTest(111);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_112_String_UTF8;
+begin
+ FilterTest(112);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_113_String_UTF8;
+begin
+ FilterTest(113);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_120_WideString;
+begin
+ FilterTest(120);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_121_UpperWideString;
+begin
+ FilterTest(121);
+end;
+
+procedure TFilterTest.FilterTest_ByEvent_122_WideString_UTF8;
+begin
+ FilterTest(122);
+end;
+
+procedure TFilterTest.SetUp;
+var
+ i, r: Integer;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+begin
+ // Create test spreadsheet file
+ workbook := TsWorkbook.Create;
+ try
+ // Create worksheet
+ worksheet := workbook.AddWorkSheet(SHEET_NAME);
+
+ // Write headers (= field names)
+ worksheet.WriteText(0, INT_COL, INT_FIELD);
+ worksheet.WriteText(0, STRING_COL, STRING_FIELD);
+ worksheet.WriteText(0, WIDESTRING_COL, WIDESTRING_FIELD);
+
+ // Write values
+ for i := Low(UNFILTERED) to High(UNFILTERED) do
+ begin
+ r := 1 + (i - Low(UNFILTERED));
+ worksheet.WriteNumber(r, INT_COL, UNFILTERED[i].IntValue, nfFixed, 0);
+ worksheet.WriteText(r, STRING_COL, UNFILTERED[i].StringValue);
+ worksheet.WriteText(r, WIDESTRING_COL, UNFILTERED[i].WideStringValue);
+ end;
+
+ // Save
+ DataFileName := GetTempDir + FILE_NAME;
+ workbook.WriteToFile(DataFileName, true);
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TFilterTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+
+initialization
+ RegisterTest(TFilterTest);
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/posttestunit.pas b/components/fpspreadsheet/unit-tests/dataset/posttestunit.pas
new file mode 100644
index 000000000..d3eea3641
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/posttestunit.pas
@@ -0,0 +1,216 @@
+{ - Creates a new WorksheetDataset with a variety of fields
+ - Appends a record and posts the dataset
+ - Opens the created spreadsheet file and compares its cells with the
+ posted data.
+}
+
+unit PostTestUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testregistry,
+ DB,
+ fpsdataset, fpspreadsheet, fpstypes, fpsutils;
+
+type
+
+ TPostTest= class(TTestCase)
+ protected
+ procedure RunPostTest(ADataType: TFieldType; ASize: Integer = 0);
+ procedure SetUp; override;
+ procedure TearDown; override;
+ published
+ procedure PostTest_Int;
+ procedure PostTest_String_20;
+ procedure PostTest_String_10;
+ procedure PostTest_Widestring_20;
+ procedure PostTest_Widestring_10;
+ end;
+
+implementation
+
+uses
+ LazUTF8, LazUTF16;
+
+const
+ FILE_NAME = 'testfile.xls';
+ SHEET_NAME = 'Sheet';
+ COL_NAME = 'TestCol';
+
+var
+ DataFileName: String;
+
+type
+ TTestRecord = record
+ IntValue: Integer;
+ StringValue: String;
+ WideStringValue: WideString;
+ end;
+
+const
+ TestData: Array[0..5] of TTestRecord = (
+ (IntValue: 10; StringValue: 'abc'; WideStringValue: 'abc'), // 0
+ (IntValue: -20; StringValue: 'äöüαβγ'; WideStringvalue: 'äöüαβγ'), // 1
+ (IntValue: 100; StringValue: 'a234567890'; WideStringvalue: 'a234567890'), // 2
+ (IntValue: 0; StringValue: 'a234567890123'; WideStringvalue: 'a234567890123'), // 3
+ (IntValue: 501; StringValue: 'äα34567890'; WideStringValue: 'äα34567890'), // 4
+ (IntValue: 502; StringValue: 'äα34567890123'; WideStringValue: 'äα34567890123') // 5
+ );
+
+procedure TPostTest.RunPostTest(ADataType: TFieldType; ASize: Integer = 0);
+var
+ dataset: TsWorksheetDataset;
+ field: TField;
+ i: Integer;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+ row, lastRow: Integer;
+ actualIntValue: Integer;
+ actualStringValue: String;
+ actualWideStringValue: WideString;
+ expectedIntValue: Integer;
+ expectedStringValue: String;
+ expectedWideStringValue: WideString;
+begin
+ dataset := TsWorksheetDataset.Create(nil);
+ try
+ dataset.FileName := DataFileName;
+ dataset.SheetName := SHEET_NAME;
+ dataset.AddFieldDef(COL_NAME, ADataType, ASize);
+ dataset.CreateTable;
+ dataset.Open;
+
+ field := dataset.FieldByName(COL_NAME);
+ for i := 0 to High(TestData) do
+ begin
+ dataset.Append;
+ case ADataType of
+ ftInteger : field.AsInteger := TestData[i].IntValue;
+ ftString : field.AsString := TestData[i].StringValue;
+ ftWideString : field.AsString := UTF8Decode(TestData[i].WideStringValue);
+ end;
+ dataset.Post;
+ end;
+ dataset.Close;
+ finally
+ dataset.Free;
+ end;
+
+ CheckEquals(
+ true,
+ FileExists(DatafileName),
+ 'Spreadsheet data file not found'
+ );
+
+ workbook := TsWorkbook.Create;
+ try
+ workbook.ReadFromFile(DataFileName);
+ worksheet := workbook.GetWorksheetByName(SHEET_NAME);
+ CheckEquals(
+ true,
+ worksheet <> nil,
+ 'Worksheet not found'
+ );
+
+ lastRow := worksheet.GetLastRowIndex(true);
+ CheckEquals(
+ Length(TestData),
+ lastRow,
+ 'Row count mismatch in worksheet'
+ );
+
+ actualStringValue := worksheet.ReadAsText(0, 0);
+ CheckEquals(
+ COL_NAME,
+ actualStringValue,
+ 'Column name mismatch'
+ );
+
+ i := 0;
+ for row := 1 to lastRow do
+ begin
+ case ADataType of
+ ftInteger:
+ begin
+ expectedIntValue := TestData[i].IntValue;
+ actualIntValue := Round(worksheet.ReadAsNumber(row, 0));
+ CheckEquals(
+ expectedIntValue,
+ actualIntValue,
+ 'Integer field mismatch, row ' + IntToStr(row)
+ );
+ end;
+ ftString:
+ begin
+ expectedStringValue := UTF8Copy(TestData[i].StringValue, 1, ASize);
+ actualStringValue := worksheet.ReadAsText(row, 0);
+ CheckEquals(
+ expectedStringValue,
+ actualStringValue,
+ 'String field mismatch, Row ' + IntToStr(row)
+ );
+ end;
+ ftWideString:
+ begin
+ expectedWideStringValue := UTF16Copy(TestData[i].WideStringValue, 1, ASize);
+ actualWideStringValue := UTF8Decode(worksheet.ReadAsText(row, 0));
+ CheckEquals(
+ expectedWidestringValue,
+ actualWideStringValue,
+ 'Widestring field mismatch, row ' + IntToStr(row)
+ );
+ end;
+ else
+ raise Exception.Create('Field type not tested here.');
+ end;
+ inc(i);
+ end;
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TPostTest.PostTest_Int;
+begin
+ RunPostTest(ftInteger);
+end;
+
+procedure TPostTest.PostTest_String_20;
+begin
+ RunPostTest(ftString, 20);
+end;
+
+procedure TPostTest.PostTest_String_10;
+begin
+ RunPostTest(ftString, 10);
+end;
+
+procedure TPostTest.PostTest_WideString_20;
+begin
+ RunPostTest(ftWideString, 20);
+end;
+
+procedure TPostTest.PostTest_WideString_10;
+begin
+ RunPostTest(ftWideString, 10);
+end;
+
+procedure TPostTest.SetUp;
+begin
+ DataFileName := GetTempDir + FILE_NAME;
+end;
+
+procedure TPostTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+
+initialization
+ RegisterTest(TPostTest);
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/readfieldstestunit.pas b/components/fpspreadsheet/unit-tests/dataset/readfieldstestunit.pas
new file mode 100644
index 000000000..be94711e2
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/readfieldstestunit.pas
@@ -0,0 +1,442 @@
+unit ReadFieldsTestUnit;
+
+{$mode objfpc}{$H+}
+
+{$IF FPC_FullVersion >= 30300}
+ {$DEFINE TEST_BYTE_FIELD}
+{$IFEND}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testutils, testregistry,
+ DB,
+ fpspreadsheet, fpstypes, fpsdataset;
+
+type
+
+ TReadFieldsTest= class(TTestCase)
+ private
+ function CreateAndOpenDataset(AutoFieldDefs: Boolean): TsWorksheetDataset;
+ procedure ReadFieldTest(Col: Integer; FieldName: String; AutoFieldDefs: Boolean);
+ protected
+ procedure SetUp; override;
+ procedure TearDown; override;
+ published
+ procedure ReadIntegerField;
+ {$IFDEF TEST_BYTE_FIELD}
+ procedure ReadByteField;
+ {$IFEND}
+ procedure ReadWordField;
+ procedure ReadFloatField;
+ procedure ReadCurrencyField;
+ procedure ReadBCDField;
+ procedure ReadFmtBCDField;
+ procedure ReadStringField;
+ procedure ReadMemoField;
+ procedure ReadBoolField;
+ procedure ReadDateField;
+ procedure ReadTimeField;
+ procedure ReadDateTimeField;
+
+ procedure ReadIntegerField_AutoFieldDefs;
+ procedure ReadByteField_AutoFieldDefs;
+ procedure ReadWordField_AutoFieldDefs;
+ procedure ReadFloatField_AutoFieldDefs;
+ procedure ReadCurrencyField_AutoFieldDefs;
+ procedure ReadStringField_AutoFieldDefs;
+ procedure ReadMemoField_AutoFieldDefs;
+ procedure ReadBoolField_AutoFieldDefs;
+ procedure ReadDateField_AutoFieldDefs;
+ procedure ReadTimeField_AutoFieldDefs;
+ procedure ReadDateTimeField_AutoFieldDefs;
+
+ end;
+
+implementation
+
+const
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+
+ INT_COL = 0;
+ BYTE_COL = 1;
+ WORD_COL = 2;
+ FLOAT_COL = 3;
+ CURRENCY_COL = 4;
+ BCD_COL = 5;
+ FMTBCD_COL = 6;
+ STRING_COL = 7;
+ BOOL_COL = 8;
+ DATE_COL = 9;
+ TIME_COL = 10;
+ DATETIME_COL = 11;
+ MEMO_COL = 12;
+
+ TestText: array[0..3] of string = (
+ 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua',
+ 'At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet',
+ 'Статья 1 Все люди рождаются свободными и равными в своем достоинстве и правах.',
+ 'ϰαὶ τότ'' ἐγὼ Κύϰλωπα προσηύδων ἄγχι παραστάς, '
+ );
+
+
+var
+ DataFileName: String;
+
+function TReadFieldsTest.CreateAndOpenDataset(AutoFieldDefs: Boolean): TsWorksheetDataset;
+begin
+ Result := TsWorksheetDataset.Create(nil);
+ Result.AutoFieldDefs:= true;
+ Result.FileName := DataFileName;
+ Result.SheetName := SHEET_NAME;
+ Result.AutoFieldDefs := AutoFieldDefs;
+ if not AutoFieldDefs then
+ begin
+ Result.AddFieldDef('IntCol', ftInteger);
+ {$IFDEF TEST_BYTE_FIELD}
+ Result.AddFieldDef('ByteCol', ftByte);
+ {$ELSE}
+ Result.AddFieldDef('ByteCol', ftInteger); // No ftByte in too old FPC
+ {$ENDIF}
+ Result.AddFieldDef('WordCol', ftWord);
+ Result.AddFieldDef('FloatCol', ftFloat);
+ Result.AddFieldDef('CurrencyCol', ftCurrency);
+ Result.AddFieldDef('BCDCol', ftBCD);
+ Result.AddFieldDef('FmtBCDCol', ftFmtBCD);
+ Result.AddFieldDef('StringCol', ftString, 30);
+ Result.AddFieldDef('BoolCol', ftBoolean);
+ Result.AddFieldDef('DateCol', ftDate);
+ Result.AddFieldDef('TimeCol', ftTime);
+ Result.AddFieldDef('DateTimeCol', ftDateTime);
+ Result.AddFieldDef('MemoCol', ftMemo);
+ Result.CreateTable;
+ end;
+ Result.Open;
+end;
+
+procedure TReadFieldsTest.SetUp;
+const
+ NumRows = 10;
+var
+ r: Integer;
+ s: String;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+begin
+ // Create test spreadsheet file
+ workbook := TsWorkbook.Create;
+ try
+ // Create worksheet
+ worksheet := workbook.AddWorkSheet(SHEET_NAME);
+ // Write headers (= field names)
+ worksheet.WriteText(0, INT_COL, 'IntCol');
+ worksheet.WriteText(0, BYTE_COL, 'ByteCol');
+ worksheet.WriteText(0, WORD_COL, 'WordCol');
+ worksheet.WriteText(0, FLOAT_COL, 'FloatCol');
+ worksheet.WriteText(0, CURRENCY_COL, 'CurrencyCol');
+ worksheet.WriteText(0, BCD_COL, 'BCDCol');
+ worksheet.WriteText(0, FMTBCD_Col, 'FmtBCDCol');
+ worksheet.WriteText(0, STRING_COL, 'StringCol');
+ worksheet.WriteText(0, BOOL_COL, 'BoolCol');
+ worksheet.WriteText(0, DATE_COL, 'DateCol');
+ worksheet.WriteText(0, TIME_COL, 'TimeCol');
+ worksheet.WriteText(0, DATETIME_COL, 'DateTimeCol');
+ worksheet.Writetext(0, MEMO_COL, 'MemoCol');
+ for r := 1 to NumRows do begin
+ // Write values to IntCol
+ worksheet.WriteNumber(r, INT_COL, r*120- 50, nfFixed, 0);
+ // Write values to ByteCol
+ worksheet.WriteNumber(r, BYTE_COL, r*2, nfFixed, 0);
+ //Write values to WordCol
+ worksheet.WriteNumber(r, WORD_COL, r*3, nfFixed, 0);
+ // Write values to FloatCol
+ worksheet.WriteNumber(r, FLOAT_COL, r*1.1-5.1, nfFixed, 2);
+ // Write values to CurrencyCol
+ worksheet.WriteCurrency(r, CURRENCY_COL, r*1000, nfCurrency);
+ // Write values to BCDcol
+ worksheet.WriteNumber(r, BCD_COL, r*1.2-3);
+ // Write values to FmtBCDCol
+ worksheet.WriteNumber(r, FMTBCD_COL, r*12.3-60);
+ // Write values to StringCol
+ case r of
+ 1: s := 'Статья';
+ 2: s := 'Λορεμ ιπσθμ δολορ σιτ αμετ';
+ else s := char(ord('A') + r-1) + char(ord('b') + r-1) + char(ord('c') + r-1);
+ end;
+ worksheet.WriteText(r, STRING_COL, s);
+ // Write values to BoolCol
+ worksheet.WriteBoolValue(r, BOOL_COL, odd(r));
+ // Write values to DateCol
+ worksheet.WriteDateTime(r, DATE_COL, EncodeDate(2021, 8, 1) + r-1, nfShortDate);
+ // Write values to TimeCol
+ worksheet.WriteDateTime(r, TIME_COL, EncodeTime(8, 0, 0, 0) + (r-1) / (24*60), nfShortTime);
+ // Write value to DateTimeCol
+ worksheet.WriteDateTime(r, DATETIME_COL, EncodeDate(2021, 8, 1) + EncodeTime(8, 0, 0, 0) + (r-1) + (r-1)/24, nfShortDateTime);
+ // Write value to MemoCol
+ worksheet.WriteText(r, MEMO_COL, TestText[r mod Length(TestText)]);
+ end;
+
+ // Save
+ DataFileName := GetTempDir + FILE_NAME;
+ workbook.WriteToFile(DataFileName, true);
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TReadFieldsTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+procedure TReadFieldsTest.ReadFieldTest(Col: Integer; FieldName: String;
+ AutoFieldDefs: Boolean);
+const
+ FLOAT_EPS = 1E-9;
+var
+ dataset: TDataset;
+ row: Integer;
+ f: TField;
+ dt: TDateTime;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+ n: Integer;
+begin
+ dataset := CreateAndOpenDataset(AutoFieldDefs);
+ try
+ workbook := TsWorkbook.Create;
+ try
+ workbook.ReadFromFile(DataFileName);
+ worksheet := workbook.GetFirstWorksheet;
+
+ f := dataset.FieldByName(FieldName);
+
+ CheckEquals(
+ worksheet.ReadAsText(0, col),
+ f.FieldName,
+ 'Column header / FieldName mismatch'
+ );
+
+ CheckEquals(
+ col,
+ f.FieldNo-1,
+ 'Field number mismatch'
+ );
+
+ CheckEquals(
+ worksheet.GetLastRowIndex(true),
+ dataset.RecordCount,
+ 'Row count / record count mismatch'
+ );
+
+ dataset.First;
+ row := 1;
+ while not dataset.EoF do
+ begin
+ if (f.DataType in [ftString, ftWideString, ftMemo]) then
+ CheckEquals(
+ worksheet.ReadAsText(row, col),
+ f.AsString,
+ 'Text mismatch in row ' + IntToStr(row)
+ )
+ else
+ if (f.DataType in [
+ ftInteger, {$IFDEF TEST_BYTE_FIELD}ftByte, {$ENDIF}
+ ftWord, ftSmallInt, ftLargeInt])
+ then
+ CheckEquals(
+ round(worksheet.ReadAsNumber(row, col)),
+ f.AsInteger,
+ 'Integer value mismatch in row ' + IntToStr(row)
+ )
+ else if (f.DataType in [ftFloat, ftCurrency, ftBCD, ftFmtBCD]) then
+ CheckEquals(
+ worksheet.ReadAsNumber(row, col),
+ f.AsFloat,
+ FLOAT_EPS,
+ 'Float value mismatch in row ' + IntToStr(row)
+ )
+ else if (f.DataType = ftDate) then
+ begin
+ CheckEquals(
+ true,
+ worksheet.ReadAsDateTime(row, col, dt),
+ 'Invalid date in row ' + IntToStr(row)
+ );
+ CheckEquals(
+ dt,
+ f.AsDateTime,
+ FLOAT_EPS,
+ 'Date value mismatch in row ' + IntToStr(row)
+ )
+ end
+ else if (f.DataType = ftTime) then
+ begin
+ CheckEquals(
+ true,
+ worksheet.ReadAsDateTime(row, col, dt),
+ 'Invalid time in row ' + IntToStr(row)
+ );
+ CheckEquals(
+ dt,
+ f.AsDateTime,
+ FLOAT_EPS,
+ 'Time value mismatch in row ' + IntToStr(row)
+ )
+ end
+ else if (f.DataType = ftDateTime) then
+ begin
+ CheckEquals(
+ true,
+ worksheet.ReadAsDateTime(row, col, dt),
+ 'Invalid date/time in row ' + IntToStr(row)
+ );
+ CheckEquals(
+ dt,
+ f.AsDateTime,
+ FLOAT_EPS,
+ 'Date/time value mismatch in row ' + IntToStr(row)
+ );
+ end;
+ inc(row);
+ dataset.Next;
+ end;
+ finally
+ workbook.Free;
+ end;
+ finally
+ dataset.Free;
+ end;
+end;
+
+
+procedure TReadFieldsTest.ReadIntegerField_AutoFieldDefs;
+begin
+ ReadFieldTest(INT_COL, 'IntCol', true);
+end;
+
+procedure TReadFieldsTest.ReadByteField_AutoFieldDefs;
+begin
+ ReadFieldTest(BYTE_COL, 'ByteCol', true);
+end;
+
+procedure TReadFieldsTest.ReadWordField_AutoFieldDefs;
+begin
+ ReadFieldTest(WORD_COL, 'WordCol', true);
+end;
+
+procedure TReadFieldsTest.ReadFloatField_AutoFieldDefs;
+begin
+ ReadFieldTest(FLOAT_COL, 'FloatCol', true);
+end;
+
+procedure TReadFieldsTest.ReadCurrencyField_AutoFieldDefs;
+begin
+ ReadFieldTest(CURRENCY_COL, 'CurrencyCol', true);
+end;
+
+procedure TReadFieldsTest.ReadStringField_AutoFieldDefs;
+begin
+ ReadFieldTest(STRING_COL, 'StringCol', true);
+end;
+
+procedure TReadFieldsTest.ReadMemoField_AutoFieldDefs;
+begin
+ ReadFieldTest(MEMO_COL, 'MemoCol', true);
+end;
+
+procedure TReadFieldsTest.ReadBoolField_AutoFieldDefs;
+begin
+ ReadFieldTest(BOOL_COL, 'BoolCol', true);
+end;
+
+procedure TReadFieldsTest.ReadDateField_AutoFieldDefs;
+begin
+ ReadFieldTest(DATE_COL, 'DateCol', true);
+end;
+
+procedure TReadFieldsTest.ReadTimeField_AutoFieldDefs;
+begin
+ ReadFieldTest(TIME_COL, 'TimeCol', true);
+end;
+
+procedure TReadFieldsTest.ReadDateTimeField_AutoFieldDefs;
+begin
+ ReadFieldTest(DATETIME_COL, 'DateTimeCol', true);
+end;
+
+
+procedure TReadFieldsTest.ReadIntegerField;
+begin
+ ReadFieldTest(INT_COL, 'IntCol', false);
+end;
+
+{$IFDEF TEST_BYTE_FIELD}
+procedure TReadFieldsTest.ReadByteField;
+begin
+ ReadFieldTest(BYTE_COL, 'ByteCol', false);
+end;
+{$ENDIF}
+
+procedure TReadFieldsTest.ReadWordField;
+begin
+ ReadFieldTest(WORD_COL, 'WordCol', false);
+end;
+
+procedure TReadFieldsTest.ReadFloatField;
+begin
+ ReadFieldTest(FLOAT_COL, 'FloatCol', false);
+end;
+
+procedure TReadFieldsTest.ReadCurrencyField;
+begin
+ ReadFieldTest(CURRENCY_COL, 'CurrencyCol', false);
+end;
+
+procedure TReadFieldsTest.ReadBCDField;
+begin
+ ReadFieldTest(BCD_COL, 'BCDCol', false);
+end;
+
+procedure TReadFieldsTest.ReadFmtBCDField;
+begin
+ ReadFieldTest(FMTBCD_COL, 'FmtBCDCol', false);
+end;
+
+procedure TReadFieldsTest.ReadStringField;
+begin
+ ReadFieldTest(STRING_COL, 'StringCol', false);
+end;
+
+procedure TReadFieldsTest.ReadMemoField;
+begin
+ ReadFieldTest(MEMO_COL, 'MemoCol', false);
+end;
+
+procedure TReadFieldsTest.ReadBoolField;
+begin
+ ReadFieldTest(BOOL_COL, 'BoolCol', false);
+end;
+
+procedure TReadFieldsTest.ReadDateField;
+begin
+ ReadFieldTest(DATE_COL, 'DateCol', false);
+end;
+
+procedure TReadFieldsTest.ReadTimeField;
+begin
+ ReadFieldTest(TIME_COL, 'TimeCol', false);
+end;
+
+procedure TReadFieldsTest.ReadDateTimeField;
+begin
+ ReadFieldTest(DATETIME_COL, 'DateTimeCol', false);
+end;
+
+
+initialization
+ RegisterTest(TReadFieldsTest);
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/searchtestunit.pas b/components/fpspreadsheet/unit-tests/dataset/searchtestunit.pas
new file mode 100644
index 000000000..9faa5a264
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/searchtestunit.pas
@@ -0,0 +1,456 @@
+unit SearchTestUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testutils, testregistry,
+ DB,
+ fpspreadsheet, fpsTypes, fpsDataset;
+
+type
+
+ TSearchTest = class(TTestCase)
+ private
+ function CreateAndOpenDataset: TsWorksheetDataset;
+ procedure LocateTest(SearchInField: String; SearchValue: Variant;
+ ExpectedRecNo: Integer; Options: TLocateOptions = []);
+ procedure LookupTest(SearchInField: String; SearchValue: Variant;
+ ResultFields: String; ExpectedValues: Variant);
+
+ protected
+ procedure SetUp; override;
+ procedure TearDown; override;
+
+ published
+ procedure LocateTest_Int_Found;
+ procedure LocateTest_Int_NotFound;
+ procedure LocateTest_String_Found;
+ procedure LocateTest_String_Found_CaseInsensitive;
+ procedure LocateTest_String_NotFound;
+ procedure LocateTest_NonASCIIString_Found;
+ procedure LocateTest_NonASCIIString_Found_CaseInsensitive;
+ procedure LocateTest_NonASCIIString_NotFound;
+ procedure LocateTest_WideString_Found;
+ procedure LocateTest_WideString_Found_CaseInsensitive;
+ procedure LocateTest_WideString_NotFound;
+ procedure LocateTest_NonASCIIWideString_Found;
+ procedure LocateTest_NonASCIIWideString_Found_CaseInsensitive;
+ procedure LocateTest_NonASCIIWideString_NotFound;
+
+ procedure LookupTest_Int_Found;
+ procedure LookupTest_Int_NotFound;
+ procedure LookupTest_String_Found;
+ procedure LookupTest_String_NotFound;
+ procedure LookupTest_NonASCIIString_Found;
+ procedure LookupTest_NonASCIIString_NotFound;
+ procedure LookupTest_WideString_Found;
+ procedure LookupTest_WideString_NotFound;
+ procedure LookupTest_NonASCIIWideString_Found;
+ procedure LookupTest_NonASCIIWideString_NotFound;
+
+ end;
+
+implementation
+
+uses
+ Variants, LazUTF8;
+
+const
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+ INT_COL = 0;
+ STRING_COL = 1;
+ WIDESTRING_COL = 2;
+ INT_FIELD = 'IntCol';
+ STRING_FIELD = 'StringCol';
+ WIDESTRING_FIELD = 'WideStringCol';
+
+var
+ DataFileName: String;
+
+const
+ NUM_ROWS = 5;
+var
+ INT_VALUES: array[1..NUM_ROWS] of Integer = (
+ 12, 20, -10, 83, 3
+ );
+ STRING_VALUES: array[1..NUM_ROWS] of String = (
+ 'abc', 'a', 'Hallo', 'ijk', 'äöüαβγ'
+ );
+ WIDESTRING_VALUES: array[1..NUM_ROWS] of String = ( // Strings are converted to wide at runtime
+ 'ABC', 'A', 'Test', 'ÄöüΓ', 'xyz'
+ );
+
+function TSearchTest.CreateAndOpenDataset: TsWorksheetDataset;
+begin
+ Result := TsWorksheetDataset.Create(nil);
+ Result.FileName := DataFileName;
+ Result.SheetName := SHEET_NAME;
+ Result.AutoFieldDefs := false;
+ Result.AddFieldDef(INT_FIELD, ftInteger);
+ Result.AddFieldDef(STRING_FIELD, ftString, 20);
+ Result.AddFieldDef(WIDESTRING_FIELD, ftWideString, 20);
+ Result.Open;
+end;
+
+procedure TSearchTest.LocateTest(SearchInField: String; SearchValue: Variant;
+ ExpectedRecNo: Integer; Options: TLocateOptions = []);
+var
+ dataset: TsWorksheetDataset;
+ actualRecNo: Integer;
+ found: Boolean;
+ f: TField;
+begin
+ dataset := CreateAndOpenDataset;
+ try
+ found := dataset.Locate(SearchInField, SearchValue, options);
+
+ if ExpectedRecNo = -1 then
+ CheckEquals(
+ false,
+ found,
+ 'Record found unexpectedly.'
+ )
+ else
+ CheckEquals(
+ true,
+ found,
+ 'Existing record not found.'
+ );
+
+ if found then
+ begin
+ actualRecNo := dataset.RecNo;
+ CheckEquals(
+ ExpectedRecNo,
+ actualRecNo,
+ 'Mismatch of found RecNo.'
+ );
+
+ for f in dataset.Fields do
+ case f.FieldName of
+ INT_FIELD:
+ CheckEquals(
+ INT_VALUES[actualRecNo],
+ f.AsInteger,
+ 'Value mismatch in integer field'
+ );
+ STRING_FIELD:
+ CheckEquals(
+ STRING_VALUES[actualRecNo],
+ f.AsString,
+ 'Value mismatch in string field'
+ );
+ WIDESTRING_FIELD:
+ CheckEquals(
+ UTF8ToUTF16(WIDESTRING_VALUES[actualRecNo]),
+ f.AsWideString,
+ 'Value mismatch in widestring field'
+ );
+ end;
+ end;
+ finally
+ dataset.Free;
+ end;
+end;
+
+procedure TSearchTest.LocateTest_Int_Found;
+begin
+ LocateTest(INT_FIELD, -10, 3);
+end;
+
+procedure TSearchTest.LocateTest_Int_NotFound;
+begin
+ LocateTest(INT_FIELD, 1000, -1);
+end;
+
+procedure TSearchTest.LocateTest_String_Found;
+begin
+ LocateTest(STRING_FIELD, 'a', 2);
+end;
+
+procedure TSearchTest.LocateTest_String_Found_CaseInsensitive;
+begin
+ LocateTest(STRING_FIELD, 'ABC', 1, [loCaseInsensitive]);
+end;
+
+procedure TSearchTest.LocateTest_String_NotFound;
+begin
+ LocateTest(STRING_FIELD, 'ttt', -1);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIString_Found;
+begin
+ LocateTest(STRING_FIELD, 'äöüαβγ', 5);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIString_Found_CaseInsensitive;
+begin
+ LocateTest(STRING_FIELD, 'ÄöÜαβΓ', 5, [loCaseInsensitive]);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIString_NotFound;
+begin
+ LocateTest(STRING_FIELD, 'ä', -1);
+end;
+
+procedure TSearchTest.LocateTest_WideString_Found;
+begin
+ LocateTest(WIDESTRING_FIELD, WideString('ABC'), 1);
+end;
+
+procedure TSearchTest.LocateTest_WideString_Found_CaseInsensitive;
+begin
+ LocateTest(WIDESTRING_FIELD, WideString('Abc'), 1, [loCaseInsensitive]);
+end;
+
+procedure TSearchTest.LocateTest_WideString_NotFound;
+begin
+ LocateTest(WIDESTRING_FIELD, WideString('abc'), -1);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIWideString_Found;
+var
+ ws: WideString;
+begin
+ ws := UTF8ToUTF16('ÄöüΓ');
+ LocateTest(WIDESTRING_FIELD, ws, 4);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIWideString_Found_CaseInsensitive;
+var
+ ws: Widestring;
+begin
+ ws := UTF8ToUTF16('Äöüγ');
+ LocateTest(WIDESTRING_FIELD, ws, 4, [loCaseInsensitive]);
+end;
+
+procedure TSearchTest.LocateTest_NonASCIIWideString_NotFound;
+var
+ ws: WideString;
+begin
+ ws := UTF8ToUTF16('ä-α');
+ LocateTest(WIDESTRING_FIELD, ws, -1);
+end;
+
+// -----------------------------------------------------------------------------
+
+procedure TSearchTest.LookupTest(SearchInField: String; SearchValue: Variant;
+ ResultFields: String; ExpectedValues: Variant);
+var
+ dataset: TsWorksheetDataset;
+ savedRecNo: Integer;
+ i, j: Integer;
+ actualValues: Variant;
+ expectedInt, actualInt: Integer;
+ expectedStr, actualStr: String;
+ expectedWideStr, actualWideStr: WideString;
+ L: TStringList;
+begin
+ dataset := CreateAndOpenDataset;
+ try
+ savedRecNo := dataset.RecNo;
+ actualValues := dataset.Lookup(SearchInField, SearchValue, ResultFields);
+
+ // The active record position must not be changed
+ CheckEquals(
+ savedRecNo,
+ dataset.RecNo,
+ 'Lookup must not move the active record.'
+ );
+
+ // Compare count of elements in value arrays
+ CheckEquals(
+ VarArrayDimCount(ExpectedValues),
+ VarArrayDimCount(actualValues),
+ 'Mismatch in found field values.'
+ );
+
+ if VarIsNull(ExpectedValues) then
+ begin
+ CheckEquals(
+ true,
+ varIsNull(actualValues),
+ 'Record found but not expected.'
+ );
+ exit;
+ end;
+
+ if not VarIsNull(ExpectedValues) then
+ CheckEquals(
+ false,
+ varIsNull(actualValues),
+ 'Record expected but not found.'
+ );
+
+ L := TStringList.Create;
+ L.StrictDelimiter := true;
+ L.Delimiter := ';';
+ L.DelimitedText := ResultFields;
+
+ // Compare lookup values with expected values
+ for i := 0 to dataset.Fields.Count-1 do
+ begin
+ j := L.IndexOf(dataset.Fields[i].FieldName);
+ if j = -1 then
+ continue;
+
+ case dataset.Fields[i].DataType of
+ ftInteger:
+ begin
+ expectedInt := ExpectedValues[j];
+ actualInt := actualvalues[j];
+ CheckEquals(
+ expectedInt,
+ actualInt,
+ 'Integer field lookup value mismatch'
+ );
+ end;
+ ftString:
+ begin
+ expectedStr := VarToStr(ExpectedValues[j]);
+ actualStr := VarToStr(actualValues[j]);
+ CheckEquals(
+ expectedStr,
+ actualStr,
+ 'String field lookup value mismatch'
+ );
+ end;
+ ftWideString:
+ begin
+ expectedWideStr := VarToWideStr(ExpectedValues[j]);
+ actualWideStr := VarToWideStr(actualValues[j]);
+ CheckEquals(
+ ExpectedWideStr,
+ actualWideStr,
+ 'Widestring field lookup value mismatch'
+ );
+ end;
+ else
+ raise Exception.Create('Unsupported field type in LookupTest');
+ end;
+ end;
+ L.Free;
+ finally
+ dataset.Free;
+ end;
+end;
+
+procedure TSearchTest.LookupTest_Int_Found;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16(WIDESTRING_VALUES[2]);
+ LookupTest(INT_FIELD, 20, STRING_FIELD+';'+WIDESTRING_FIELD, VarArrayOf(['a', ws]));
+end;
+
+procedure TSearchTest.LookupTest_Int_NotFound;
+begin
+ LookupTest(INT_FIELD, 200, STRING_FIELD+';'+WIDESTRING_FIELD, Null);
+end;
+
+procedure TSearchTest.LookupTest_String_Found;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16(WIDESTRING_VALUES[3]);
+ LookupTest(STRING_FIELD, 'Hallo', INT_FIELD+';'+WIDESTRING_FIELD, VarArrayOf([-10, ws]));
+end;
+
+procedure TSearchTest.LookupTest_String_NotFound;
+begin
+ LookupTest(STRING_FIELD, 'Halloooo', INT_FIELD+';'+WIDESTRING_FIELD, Null);
+end;
+
+procedure TSearchTest.LookupTest_NonASCIIString_Found;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16('xyz');
+ LookupTest(STRING_FIELD, 'äöüαβγ', INT_FIELD+';'+WIDESTRING_FIELD, VarArrayOf([3, ws]));
+end;
+
+procedure TSearchTest.LookupTest_NonASCIIString_NotFound;
+begin
+ LookupTest(STRING_FIELD, 'ÄÄÄÄα', INT_FIELD+';'+WIDESTRING_FIELD, Null);
+end;
+
+procedure TSearchTest.LookupTest_WideString_Found;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16('ABC');
+ LookupTest(WIDESTRING_FIELD, ws, INT_FIELD+';'+STRING_FIELD, VarArrayOf([12, 'abc']));
+end;
+
+procedure TSearchTest.LookupTest_WideString_NotFound;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16('ABCD');
+ LookupTest(WIDESTRING_FIELD, ws, INT_FIELD+';'+STRING_FIELD, null);
+end;
+
+procedure TSearchTest.LookupTest_NonASCIIWideString_Found;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16('ÄöüΓ');
+ LookupTest(WIDESTRING_FIELD, ws, INT_FIELD+';'+STRING_FIELD, VarArrayOf([83, 'ijk']));
+end;
+
+procedure TSearchTest.LookupTest_NonASCIIWideString_NotFound;
+var
+ ws: wideString;
+begin
+ ws := UTF8ToUTF16('Äöαβ');
+ LookupTest(WIDESTRING_FIELD, ws, INT_FIELD+';'+STRING_FIELD, null);
+end;
+
+// -----------------------------------------------------------------------------
+
+procedure TSearchTest.SetUp;
+var
+ r: Integer;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+begin
+ // Create test spreadsheet file
+ workbook := TsWorkbook.Create;
+ try
+ // Create worksheet
+ worksheet := workbook.AddWorkSheet(SHEET_NAME);
+
+ // Write headers (= field names)
+ worksheet.WriteText(0, INT_COL, INT_FIELD);
+ worksheet.WriteText(0, STRING_COL, STRING_FIELD);
+ worksheet.WriteText(0, WIDESTRING_COL, WIDESTRING_FIELD);
+
+ // Write values
+ for r := 1 to NUM_ROWS do
+ begin
+ worksheet.WriteNumber(r, INT_COL, INT_VALUES[r], nfFixed, 0);
+ worksheet.WriteText(r, STRING_COL, STRING_VALUES[r]);
+ worksheet.WriteText(r, WIDESTRING_COL, WIDESTRING_VALUES[r]);
+ end;
+
+ // Save
+ DataFileName := GetTempDir + FILE_NAME;
+ workbook.WriteToFile(DataFileName, true);
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TSearchTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+initialization
+ RegisterTest(TSearchTest);
+
+end.
+
diff --git a/components/fpspreadsheet/unit-tests/dataset/sorttestunit.pas b/components/fpspreadsheet/unit-tests/dataset/sorttestunit.pas
new file mode 100644
index 000000000..69520b0b1
--- /dev/null
+++ b/components/fpspreadsheet/unit-tests/dataset/sorttestunit.pas
@@ -0,0 +1,231 @@
+unit SortTestUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, fpcunit, testregistry,
+ DB,
+ fpspreadsheet, fpstypes, fpsutils, fpsdataset;
+
+type
+
+ TSortTest= class(TTestCase)
+ private
+ function CreateAndOpenDataset: TsWorksheetDataset;
+ protected
+ procedure SetUp; override;
+ procedure TearDown; override;
+ procedure SortTest(SortField: String; Descending, CaseInsensitive: Boolean);
+ published
+ procedure SortTest_IntField_Ascending;
+ procedure SortTest_IntField_Descending;
+ procedure SortTest_TextField_Ascending_CaseSensitive;
+ procedure SortTest_TextField_Descending_CaseSensitive;
+ procedure SortTest_TextField_Ascending_CaseInsensitive;
+ procedure SortTest_TextField_Descending_CaseInsensitive;
+ end;
+
+implementation
+
+const
+ FILE_NAME = 'testfile.xlsx';
+ SHEET_NAME = 'Sheet';
+ INT_COL = 0;
+ TEXT_COL = 1;
+ INT_FIELD = 'IntCol';
+ TEXT_FIELD = 'TextCol';
+
+var
+ DataFileName: String;
+
+type
+ TTestRow = record
+ IntValue: Integer;
+ TextValue: String;
+ end;
+
+const
+ // Unsorted test values
+ UNSORTED: array[0..4] of TTestRow = ( // Index
+ (IntValue: 10; TextValue: 'abc'), // 0
+ (IntValue: 1; TextValue: 'ABC'), // 1
+ (IntValue: 1; TextValue: 'a'), // 2
+ (IntValue: 2; TextValue: 'A'), // 3
+ (IntValue: -1; TextValue: 'xyz') // 4
+ );
+
+ // These are the indexes into the UNSORTED array after sorting
+ SORTED_BY_INT_ASCENDING: array[0..4] of Integer = (4, 1, 2, 3, 0);
+ SORTED_BY_INT_DESCENDING: array[0..4] of Integer = (0, 3, 2, 1, 4);
+ SORTED_BY_TEXT_ASCENDING_CASESENS: array[0..4] of Integer = (2, 0, 3, 1, 4);
+ SORTED_BY_TEXT_DESCENDING_CASESENS: array[0..4] of Integer = (4, 1, 3, 0, 2);
+ SORTED_BY_TEXT_ASCENDING_CASEINSENS: array[0..4] of Integer = (3, 2, 1, 0, 4);
+ SORTED_BY_TEXT_DESCENDING_CASEINSENS: array[0..4] of Integer = (4, 1, 0, 3, 2);
+ // Note on case-insensitive sorting: Depending on implementation of the
+ // sorting algorithms different results can be obtained for which the
+ // uppercased texts are the same. Therefore, Excel yields different result
+ // than FPSpreadsheet. Above indices are for FPSpreadsheet.
+
+
+function TSortTest.CreateAndOpenDataset: TsWorksheetDataset;
+begin
+ Result := TsWorksheetDataset.Create(nil);
+ Result.FileName := DataFileName;
+ Result.SheetName := SHEET_NAME;
+ Result.Open;
+end;
+
+procedure TSortTest.SortTest(SortField: String; Descending, CaseInsensitive: Boolean);
+var
+ dataset: TsWorksheetDataset;
+ options: TsSortOptions;
+ intField: TField;
+ textField: TField;
+ actualInt: Integer;
+ actualText: String;
+ expectedInt: Integer;
+ expectedText: String;
+ i, sortedIdx: Integer;
+begin
+ options := [];
+ if Descending then Include(options, ssoDescending);
+ if CaseInsensitive then Include(options, ssoCaseInsensitive);
+
+ dataset := CreateAndOpenDataset;
+ try
+ dataset.SortOnField(SortField, options);
+
+ // For debugging
+ dataset.Close; // to write the worksheet to file
+ dataset.Open;
+
+ intField := dataset.FieldByName(INT_FIELD);
+ textField := dataset.FieldByName(TEXT_FIELD);
+
+ dataset.First;
+ i := 0;
+ while not dataset.EOF do
+ begin
+ if SortField = INT_FIELD then
+ begin
+ if Descending then
+ sortedIdx := SORTED_BY_INT_DESCENDING[i]
+ else
+ sortedIdx := SORTED_BY_INT_ASCENDING[i];
+ end else
+ if SortField = TEXT_FIELD then
+ begin
+ if Descending then
+ begin
+ if CaseInsensitive then
+ sortedIdx := SORTED_BY_TEXT_DESCENDING_CASEINSENS[i]
+ else
+ sortedIdx := SORTED_BY_TEXT_DESCENDING_CASESENS[i];
+ end else
+ begin
+ if CaseInsensitive then
+ sortedIdx := SORTED_BY_TEXT_ASCENDING_CASEINSENS[i]
+ else
+ sortedIdx := SORTED_BY_TEXT_ASCENDING_CASESENS[i];
+ end;
+ end;
+
+ expectedInt := UNSORTED[sortedIdx].IntValue;
+ expectedText := UNSORTED[sortedIdx].TextValue;
+ actualInt := intField.AsInteger;
+ actualText := textField.AsString;
+
+ CheckEquals(
+ expectedInt,
+ actualInt,
+ 'Integer field value mismatch in row ' + IntToStr(i)
+ );
+ CheckEquals(
+ expectedText,
+ actualText,
+ 'Text field value mismatch in row ' + IntToStr(i)
+ );
+
+ inc(i);
+ dataset.Next;
+ end;
+
+ finally
+ dataset.Free;
+ end;
+end;
+
+procedure TSortTest.SortTest_IntField_Ascending;
+begin
+ SortTest(INT_FIELD, false, false);
+end;
+
+procedure TSortTest.SortTest_IntField_Descending;
+begin
+ SortTest(INT_FIELD, true, false);
+end;
+
+procedure TSortTest.SortTest_TextField_Ascending_CaseSensitive;
+begin
+ SortTest(TEXT_FIELD, false, false);
+end;
+
+procedure TSortTest.SortTest_TextField_Descending_CaseSensitive;
+begin
+ SortTest(TEXT_FIELD, true, false);
+end;
+
+procedure TSortTest.SortTest_TextField_Ascending_CaseInsensitive;
+begin
+ SortTest(TEXT_FIELD, false, true);
+end;
+procedure TSortTest.SortTest_TextField_Descending_CaseInsensitive;
+begin
+ SortTest(TEXT_FIELD, true, true);
+end;
+
+procedure TSortTest.SetUp;
+var
+ i, r: Integer;
+ workbook: TsWorkbook;
+ worksheet: TsWorksheet;
+begin
+ // Create test spreadsheet file
+ workbook := TsWorkbook.Create;
+ try
+ // Create worksheet
+ worksheet := workbook.AddWorkSheet(SHEET_NAME);
+
+ // Write headers (= field names)
+ worksheet.WriteText(0, INT_COL, INT_FIELD);
+ worksheet.WriteText(0, TEXT_COL, TEXT_FIELD);
+
+ // Write values
+ for i := Low(UNSORTED) to High(UNSORTED) do
+ begin
+ r := 1 + (i - Low(UNSORTED));
+ worksheet.WriteNumber(r, INT_COL, UNSORTED[i].IntValue, nfFixed, 0);
+ worksheet.WriteText(r, TEXT_COL, UNSORTED[i].TextValue);
+ end;
+
+ // Save
+ DataFileName := GetTempDir + FILE_NAME;
+ workbook.WriteToFile(DataFileName, true);
+ finally
+ workbook.Free;
+ end;
+end;
+
+procedure TSortTest.TearDown;
+begin
+ if FileExists(DataFileName) then DeleteFile(DataFileName);
+end;
+
+
+initialization
+ RegisterTest(TSortTest);
+
+end.
+