5483e65197
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6119 8e941d3f-bd1b-0410-a28a-d453659cc2b4
3942 lines
117 KiB
ObjectPascal
3942 lines
117 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2013 by Joost van der Sluis and other members of the
|
|
Free Pascal development team
|
|
|
|
ZMBufDataset implementation
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
unit ZMBufDataset;
|
|
|
|
{$mode objfpc}
|
|
{$h+}
|
|
|
|
interface
|
|
|
|
uses Classes, Sysutils, db, ZMBufDataset_parser;
|
|
|
|
type
|
|
TZMCustomBufDataset = Class;
|
|
|
|
TResolverErrorEvent = procedure(Sender: TObject; DataSet: TZMCustomBufDataset; E: EUpdateError;
|
|
UpdateKind: TUpdateKind; var Response: TResolverResponse) of object;
|
|
|
|
{ TBufBlobStream }
|
|
|
|
PBlobBuffer = ^TBlobBuffer;
|
|
TBlobBuffer = record
|
|
FieldNo : integer;
|
|
OrgBufID: integer;
|
|
Buffer : pointer;
|
|
Size : ptrint;
|
|
end;
|
|
|
|
TBufBlobStream = class(TStream)
|
|
private
|
|
FField : TBlobField;
|
|
FDataSet : TZMCustomBufDataset;
|
|
FBlobBuffer : PBlobBuffer;
|
|
FPosition : ptrint;
|
|
FModified : boolean;
|
|
protected
|
|
function Seek(Offset: Longint; Origin: Word): Longint; override;
|
|
function Read(var Buffer; Count: Longint): Longint; override;
|
|
function Write(const Buffer; Count: Longint): Longint; override;
|
|
public
|
|
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TZMCustomBufDataset }
|
|
|
|
PBufRecLinkItem = ^TBufRecLinkItem;
|
|
TBufRecLinkItem = record
|
|
prior : PBufRecLinkItem;
|
|
next : PBufRecLinkItem;
|
|
end;
|
|
|
|
PBufBookmark = ^TBufBookmark;
|
|
TBufBookmark = record
|
|
BookmarkData : PBufRecLinkItem;
|
|
BookmarkInt : integer;
|
|
BookmarkFlag : TBookmarkFlag;
|
|
end;
|
|
|
|
TRecUpdateBuffer = record
|
|
UpdateKind : TUpdateKind;
|
|
{ BookMarkData:
|
|
- Is -1 if the update has canceled out. For example: an appended record has been deleted again
|
|
- If UpdateKind is ukInsert, it contains a bookmark to the newly created record
|
|
- If UpdateKind is ukModify, it contains a bookmark to the record with the new data
|
|
- If UpdateKind is ukDelete, it contains a bookmark to the deleted record (ie: the record is still there)
|
|
}
|
|
BookmarkData : TBufBookmark;
|
|
{ NextBookMarkData:
|
|
- If UpdateKind is ukDelete, it contains a bookmark to the record just after the deleted record
|
|
}
|
|
NextBookmarkData : TBufBookmark;
|
|
{ OldValuesBuffer:
|
|
- If UpdateKind is ukModify, it contains a record buffer which contains the old data
|
|
- If UpdateKind is ukDelete, it contains a record buffer with the data of the deleted record
|
|
}
|
|
OldValuesBuffer : TRecordBuffer;
|
|
end;
|
|
TRecordsUpdateBuffer = array of TRecUpdateBuffer;
|
|
|
|
PBufBlobField = ^TBufBlobField;
|
|
TBufBlobField = record
|
|
ConnBlobBuffer : array[0..11] of byte; // DB specific data is stored here
|
|
BlobBuffer : PBlobBuffer;
|
|
end;
|
|
|
|
TCompareFunc = function(subValue, aValue: pointer; options: TLocateOptions): int64;
|
|
|
|
TDBCompareRec = record
|
|
Comparefunc : TCompareFunc;
|
|
Off1,Off2 : PtrInt;
|
|
FieldInd1,
|
|
FieldInd2 : longint;
|
|
NullBOff1,
|
|
NullBOff2 : PtrInt;
|
|
Options : TLocateOptions;
|
|
Desc : Boolean;
|
|
end;
|
|
TDBCompareStruct = array of TDBCompareRec;
|
|
|
|
{ TBufIndex }
|
|
|
|
TBufIndex = class(TObject)
|
|
private
|
|
FDataset : TZMCustomBufDataset;
|
|
protected
|
|
function GetBookmarkSize: integer; virtual; abstract;
|
|
function GetCurrentBuffer: Pointer; virtual; abstract;
|
|
function GetCurrentRecord: TRecordBuffer; virtual; abstract;
|
|
function GetIsInitialized: boolean; virtual; abstract;
|
|
function GetSpareBuffer: TRecordBuffer; virtual; abstract;
|
|
function GetSpareRecord: TRecordBuffer; virtual; abstract;
|
|
public
|
|
DBCompareStruct : TDBCompareStruct;
|
|
Name : String;
|
|
FieldsName : String;
|
|
CaseinsFields : String;
|
|
DescFields : String;
|
|
Options : TIndexOptions;
|
|
IndNr : integer;
|
|
constructor Create(const ADataset : TZMCustomBufDataset); virtual;
|
|
function ScrollBackward : TGetResult; virtual; abstract;
|
|
function ScrollForward : TGetResult; virtual; abstract;
|
|
function GetCurrent : TGetResult; virtual; abstract;
|
|
function ScrollFirst : TGetResult; virtual; abstract;
|
|
procedure ScrollLast; virtual; abstract;
|
|
|
|
procedure SetToFirstRecord; virtual; abstract;
|
|
procedure SetToLastRecord; virtual; abstract;
|
|
|
|
procedure StoreCurrentRecord; virtual; abstract;
|
|
procedure RestoreCurrentRecord; virtual; abstract;
|
|
|
|
function CanScrollForward : Boolean; virtual; abstract;
|
|
procedure DoScrollForward; virtual; abstract;
|
|
|
|
procedure StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark); virtual; abstract;
|
|
procedure StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark); virtual; abstract;
|
|
procedure GotoBookmark(const ABookmark : PBufBookmark); virtual; abstract;
|
|
function BookmarkValid(const ABookmark: PBufBookmark): boolean; virtual;
|
|
|
|
procedure InitialiseIndex; virtual; abstract;
|
|
|
|
procedure InitialiseSpareRecord(const ASpareRecord : TRecordBuffer); virtual; abstract;
|
|
procedure ReleaseSpareRecord; virtual; abstract;
|
|
|
|
procedure BeginUpdate; virtual; abstract;
|
|
// Adds a record to the end of the index as the new last record (spare record)
|
|
// Normally only used in GetNextPacket
|
|
procedure AddRecord; virtual; abstract;
|
|
// Inserts a record before the current record, or if the record is sorted,
|
|
// inserts it in the proper position
|
|
procedure InsertRecordBeforeCurrentRecord(Const ARecord : TRecordBuffer); virtual; abstract;
|
|
procedure RemoveRecordFromIndex(const ABookmark : TBufBookmark); virtual; abstract;
|
|
procedure OrderCurrentRecord; virtual; abstract;
|
|
procedure EndUpdate; virtual; abstract;
|
|
|
|
function CompareBookmarks(const ABookmark1, ABookmark2 : PBufBookmark) : boolean; virtual;
|
|
Function GetRecNo(const ABookmark : PBufBookmark) : integer; virtual; abstract;
|
|
|
|
property SpareRecord : TRecordBuffer read GetSpareRecord;
|
|
property SpareBuffer : TRecordBuffer read GetSpareBuffer;
|
|
property CurrentRecord : TRecordBuffer read GetCurrentRecord;
|
|
property CurrentBuffer : Pointer read GetCurrentBuffer;
|
|
property IsInitialized : boolean read GetIsInitialized;
|
|
property BookmarkSize : integer read GetBookmarkSize;
|
|
end;
|
|
|
|
{ TDoubleLinkedBufIndex }
|
|
|
|
TDoubleLinkedBufIndex = class(TBufIndex)
|
|
private
|
|
FCursOnFirstRec : boolean;
|
|
|
|
FStoredRecBuf : PBufRecLinkItem;
|
|
FCurrentRecBuf : PBufRecLinkItem;
|
|
protected
|
|
function GetBookmarkSize: integer; override;
|
|
function GetCurrentBuffer: Pointer; override;
|
|
function GetCurrentRecord: TRecordBuffer; override;
|
|
function GetIsInitialized: boolean; override;
|
|
function GetSpareBuffer: TRecordBuffer; override;
|
|
function GetSpareRecord: TRecordBuffer; override;
|
|
public
|
|
FLastRecBuf : PBufRecLinkItem;
|
|
FFirstRecBuf : PBufRecLinkItem;
|
|
FNeedScroll : Boolean;
|
|
function ScrollBackward : TGetResult; override;
|
|
function ScrollForward : TGetResult; override;
|
|
function GetCurrent : TGetResult; override;
|
|
function ScrollFirst : TGetResult; override;
|
|
procedure ScrollLast; override;
|
|
|
|
procedure SetToFirstRecord; override;
|
|
procedure SetToLastRecord; override;
|
|
|
|
procedure StoreCurrentRecord; override;
|
|
procedure RestoreCurrentRecord; override;
|
|
|
|
function CanScrollForward : Boolean; override;
|
|
procedure DoScrollForward; override;
|
|
|
|
procedure StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure GotoBookmark(const ABookmark : PBufBookmark); override;
|
|
|
|
procedure InitialiseIndex; override;
|
|
|
|
procedure InitialiseSpareRecord(const ASpareRecord : TRecordBuffer); override;
|
|
procedure ReleaseSpareRecord; override;
|
|
|
|
Function GetRecNo(const ABookmark : PBufBookmark) : integer; override;
|
|
|
|
procedure BeginUpdate; override;
|
|
procedure AddRecord; override;
|
|
procedure InsertRecordBeforeCurrentRecord(Const ARecord : TRecordBuffer); override;
|
|
procedure RemoveRecordFromIndex(const ABookmark : TBufBookmark); override;
|
|
procedure OrderCurrentRecord; override;
|
|
procedure EndUpdate; override;
|
|
end;
|
|
|
|
{ TUniDirectionalBufIndex }
|
|
|
|
TUniDirectionalBufIndex = class(TBufIndex)
|
|
private
|
|
FSPareBuffer: TRecordBuffer;
|
|
protected
|
|
function GetBookmarkSize: integer; override;
|
|
function GetCurrentBuffer: Pointer; override;
|
|
function GetCurrentRecord: TRecordBuffer; override;
|
|
function GetIsInitialized: boolean; override;
|
|
function GetSpareBuffer: TRecordBuffer; override;
|
|
function GetSpareRecord: TRecordBuffer; override;
|
|
public
|
|
function ScrollBackward : TGetResult; override;
|
|
function ScrollForward : TGetResult; override;
|
|
function GetCurrent : TGetResult; override;
|
|
function ScrollFirst : TGetResult; override;
|
|
procedure ScrollLast; override;
|
|
|
|
procedure SetToFirstRecord; override;
|
|
procedure SetToLastRecord; override;
|
|
|
|
procedure StoreCurrentRecord; override;
|
|
procedure RestoreCurrentRecord; override;
|
|
|
|
function CanScrollForward : Boolean; override;
|
|
procedure DoScrollForward; override;
|
|
|
|
procedure StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure GotoBookmark(const ABookmark : PBufBookmark); override;
|
|
|
|
procedure InitialiseIndex; override;
|
|
procedure InitialiseSpareRecord(const ASpareRecord : TRecordBuffer); override;
|
|
procedure ReleaseSpareRecord; override;
|
|
|
|
Function GetRecNo(const ABookmark : PBufBookmark) : integer; override;
|
|
|
|
procedure BeginUpdate; override;
|
|
procedure AddRecord; override;
|
|
procedure InsertRecordBeforeCurrentRecord(Const ARecord : TRecordBuffer); override;
|
|
procedure RemoveRecordFromIndex(const ABookmark : TBufBookmark); override;
|
|
procedure OrderCurrentRecord; override;
|
|
procedure EndUpdate; override;
|
|
end;
|
|
|
|
|
|
{ TArrayBufIndex }
|
|
|
|
TArrayBufIndex = class(TBufIndex)
|
|
private
|
|
FStoredRecBuf : integer;
|
|
|
|
FInitialBuffers,
|
|
FGrowBuffer : integer;
|
|
Function GetRecordFromBookmark(ABookmark: TBufBookmark) : integer;
|
|
protected
|
|
function GetBookmarkSize: integer; override;
|
|
function GetCurrentBuffer: Pointer; override;
|
|
function GetCurrentRecord: TRecordBuffer; override;
|
|
function GetIsInitialized: boolean; override;
|
|
function GetSpareBuffer: TRecordBuffer; override;
|
|
function GetSpareRecord: TRecordBuffer; override;
|
|
public
|
|
FCurrentRecInd : integer;
|
|
FRecordArray : array of Pointer;
|
|
FLastRecInd : integer;
|
|
FNeedScroll : Boolean;
|
|
constructor Create(const ADataset: TZMCustomBufDataset); override;
|
|
function ScrollBackward : TGetResult; override;
|
|
function ScrollForward : TGetResult; override;
|
|
function GetCurrent : TGetResult; override;
|
|
function ScrollFirst : TGetResult; override;
|
|
procedure ScrollLast; override;
|
|
|
|
procedure SetToFirstRecord; override;
|
|
procedure SetToLastRecord; override;
|
|
|
|
procedure StoreCurrentRecord; override;
|
|
procedure RestoreCurrentRecord; override;
|
|
|
|
function CanScrollForward : Boolean; override;
|
|
procedure DoScrollForward; override;
|
|
|
|
procedure StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark); override;
|
|
procedure GotoBookmark(const ABookmark : PBufBookmark); override;
|
|
|
|
procedure InitialiseIndex; override;
|
|
|
|
procedure InitialiseSpareRecord(const ASpareRecord : TRecordBuffer); override;
|
|
procedure ReleaseSpareRecord; override;
|
|
|
|
Function GetRecNo(const ABookmark : PBufBookmark) : integer; override;
|
|
|
|
procedure BeginUpdate; override;
|
|
procedure AddRecord; override;
|
|
procedure InsertRecordBeforeCurrentRecord(Const ARecord : TRecordBuffer); override;
|
|
procedure RemoveRecordFromIndex(const ABookmark : TBufBookmark); override;
|
|
procedure EndUpdate; override;
|
|
end;
|
|
|
|
|
|
{ TZMBufDatasetReader }
|
|
|
|
type
|
|
TRowStateValue = (rsvOriginal, rsvDeleted, rsvInserted, rsvUpdated, rsvDetailUpdates);
|
|
TRowState = set of TRowStateValue;
|
|
|
|
type
|
|
|
|
{ TDataPacketReader }
|
|
|
|
TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny);
|
|
|
|
TDatapacketReaderClass = class of TDatapacketReader;
|
|
TDataPacketReader = class(TObject)
|
|
FDataSet: TZMCustomBufDataset;
|
|
FStream : TStream;
|
|
protected
|
|
class function RowStateToByte(const ARowState : TRowState) : byte;
|
|
class function ByteToRowState(const AByte : Byte) : TRowState;
|
|
procedure RestoreBlobField(AField: TField; ASource: pointer; ASize: integer);
|
|
property DataSet: TZMCustomBufDataset read FDataSet;
|
|
property Stream: TStream read FStream;
|
|
public
|
|
constructor Create(ADataSet: TZMCustomBufDataset; AStream : TStream); virtual;
|
|
// Load a dataset from stream:
|
|
// Load the field definitions from a stream.
|
|
procedure LoadFieldDefs(var AnAutoIncValue : integer); virtual; abstract;
|
|
// Is called before the records are loaded
|
|
procedure InitLoadRecords; virtual; abstract;
|
|
// Returns if there is at least one more record available in the stream
|
|
function GetCurrentRecord : boolean; virtual; abstract;
|
|
// Return the RowState of the current record, and the order of the update
|
|
function GetRecordRowState(out AUpdOrder : Integer) : TRowState; virtual; abstract;
|
|
// Store a record from stream in the current record buffer
|
|
procedure RestoreRecord; virtual; abstract;
|
|
// Move the stream to the next record
|
|
procedure GotoNextRecord; virtual; abstract;
|
|
|
|
// Store a dataset to stream:
|
|
// Save the field definitions to a stream.
|
|
procedure StoreFieldDefs(AnAutoIncValue : integer); virtual; abstract;
|
|
// Save a record from the current record buffer to the stream
|
|
procedure StoreRecord(ARowState : TRowState; AUpdOrder : integer = 0); virtual; abstract;
|
|
// Is called after all records are stored
|
|
procedure FinalizeStoreRecords; virtual; abstract;
|
|
// Checks if the provided stream is of the right format for this class
|
|
class function RecognizeStream(AStream : TStream) : boolean; virtual; abstract;
|
|
end;
|
|
|
|
{ TFpcBinaryDatapacketReader }
|
|
|
|
{ Data layout:
|
|
Header section:
|
|
Identification: 13 bytes: 'BinZMBufDataset'
|
|
Version: 1 byte
|
|
Columns section:
|
|
Number of Fields: 2 bytes
|
|
For each FieldDef: Name, DisplayName, Size: 2 bytes, DataType: 2 bytes, ReadOnlyAttr: 1 byte
|
|
Parameter section:
|
|
AutoInc Value: 4 bytes
|
|
Rows section:
|
|
Row header: each row begins with $fe: 1 byte
|
|
row state: 1 byte (original, deleted, inserted, modified)
|
|
update order: 4 bytes
|
|
null bitmap: 1 byte per each 8 fields (if field is null corresponding bit is 1)
|
|
Row data: variable length data are prefixed with 4 byte length indicator
|
|
null fields are not stored (see: null bitmap)
|
|
}
|
|
|
|
TFpcBinaryDatapacketReader = class(TDataPacketReader)
|
|
private
|
|
const
|
|
FpcBinaryIdent1 = 'BinBufDataset1'; // Old version 1; support for transient period;
|
|
FpcBinaryIdent2 = 'BinBufDataset';
|
|
StringFieldTypes = [ftString,ftFixedChar,ftWideString,ftFixedWideChar];
|
|
BlobFieldTypes = [ftBlob,ftMemo,ftGraphic,ftWideMemo];
|
|
VarLenFieldTypes = StringFieldTypes + BlobFieldTypes + [ftBytes,ftVarBytes];
|
|
var
|
|
FNullBitmapSize: integer;
|
|
FNullBitmap: TBytes;
|
|
protected
|
|
var
|
|
FVersion: byte;
|
|
public
|
|
constructor Create(ADataSet: TZMCustomBufDataset; AStream : TStream); override;
|
|
procedure LoadFieldDefs(var AnAutoIncValue : integer); override;
|
|
procedure StoreFieldDefs(AnAutoIncValue : integer); override;
|
|
procedure InitLoadRecords; override;
|
|
function GetCurrentRecord : boolean; override;
|
|
function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override;
|
|
procedure RestoreRecord; override;
|
|
procedure GotoNextRecord; override;
|
|
procedure StoreRecord(ARowState : TRowState; AUpdOrder : integer = 0); override;
|
|
procedure FinalizeStoreRecords; override;
|
|
class function RecognizeStream(AStream : TStream) : boolean; override;
|
|
end;
|
|
|
|
|
|
TZMCustomBufDataset = class(TDBDataSet)
|
|
private
|
|
FFileName: string;
|
|
FReadFromFile : boolean;
|
|
FFileStream : TFileStream;
|
|
FDatasetReader : TDataPacketReader;
|
|
|
|
FIndexes : array of TBufIndex;
|
|
FMaxIndexesCount: integer;
|
|
FIndexesCount : integer;
|
|
FCurrentIndex : TBufIndex;
|
|
|
|
FFilterBuffer : TRecordBuffer;
|
|
FBRecordCount : integer;
|
|
FReadOnly : Boolean;
|
|
|
|
FSavedState : TDatasetState;
|
|
FPacketRecords : integer;
|
|
FRecordSize : Integer;
|
|
FNullmaskSize : byte;
|
|
FOpen : Boolean;
|
|
FUpdateBuffer : TRecordsUpdateBuffer;
|
|
FCurrentUpdateBuffer : integer;
|
|
FAutoIncValue : longint;
|
|
FAutoIncField : TAutoIncField;
|
|
|
|
FIndexDefs : TIndexDefs;
|
|
|
|
FParser : TZMBufDatasetParser;
|
|
|
|
FFieldBufPositions : array of longint;
|
|
|
|
FAllPacketsFetched : boolean;
|
|
FOnUpdateError : TResolverErrorEvent;
|
|
|
|
FBlobBuffers : array of PBlobBuffer;
|
|
FUpdateBlobBuffers: array of PBlobBuffer;
|
|
|
|
procedure FetchAll;
|
|
procedure ProcessFieldsToCompareStruct(const AFields, ADescFields, ACInsFields: TList;
|
|
const AIndexOptions: TIndexOptions; const ALocateOptions: TLocateOptions; out ACompareStruct: TDBCompareStruct);
|
|
function BufferOffset: integer;
|
|
function GetIndexDefs : TIndexDefs;
|
|
function GetCurrentBuffer: TRecordBuffer;
|
|
procedure CalcRecordSize;
|
|
function GetIndexFieldNames: String;
|
|
function GetIndexName: String;
|
|
function GetBufUniDirectional: boolean;
|
|
function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader;
|
|
function LoadBuffer(Buffer : TRecordBuffer): TGetResult;
|
|
function GetFieldSize(FieldDef : TFieldDef) : longint;
|
|
function GetRecordUpdateBuffer(const ABookmark : TBufBookmark; IncludePrior : boolean = false; AFindNext : boolean = false) : boolean;
|
|
function GetRecordUpdateBufferCached(const ABookmark : TBufBookmark; IncludePrior : boolean = false) : boolean;
|
|
function GetActiveRecordUpdateBuffer : boolean;
|
|
procedure SetIndexFieldNames(const AValue: String);
|
|
procedure SetIndexName(AValue: String);
|
|
procedure SetMaxIndexesCount(const AValue: Integer);
|
|
procedure SetPacketRecords(aValue : integer);
|
|
function IntAllocRecordBuffer: TRecordBuffer;
|
|
procedure ParseFilter(const AFilter: string);
|
|
procedure IntLoadFielddefsFromFile;
|
|
procedure IntLoadRecordsFromFile;
|
|
procedure CurrentRecordToBuffer(Buffer: TRecordBuffer);
|
|
procedure SetBufUniDirectional(const AValue: boolean);
|
|
// indexes handling
|
|
procedure InitDefaultIndexes;
|
|
procedure BuildIndex(var AIndex : TBufIndex);
|
|
procedure BuildIndexes;
|
|
procedure RemoveRecordFromIndexes(const ABookmark : TBufBookmark);
|
|
protected
|
|
function GetNewBlobBuffer : PBlobBuffer;
|
|
function GetNewWriteBlobBuffer : PBlobBuffer;
|
|
procedure FreeBlobBuffer(var ABlobBuffer: PBlobBuffer);
|
|
procedure UpdateIndexDefs; override;
|
|
procedure SetRecNo(Value: Longint); override;
|
|
function GetRecNo: Longint; override;
|
|
function GetChangeCount: integer; virtual;
|
|
function AllocRecordBuffer: TRecordBuffer; override;
|
|
procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override;
|
|
procedure ClearCalcFields(Buffer: TRecordBuffer); override;
|
|
procedure InternalInitRecord(Buffer: TRecordBuffer); override;
|
|
function GetCanModify: Boolean; override;
|
|
function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
|
|
procedure DoBeforeClose; override;
|
|
procedure InternalOpen; override;
|
|
procedure InternalClose; override;
|
|
function getnextpacket : integer;
|
|
function GetRecordSize: Word; override;
|
|
procedure InternalAddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string;
|
|
const ACaseInsFields: string); virtual;
|
|
procedure InternalPost; override;
|
|
procedure InternalCancel; Override;
|
|
procedure InternalDelete; override;
|
|
procedure InternalFirst; override;
|
|
procedure InternalLast; override;
|
|
procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
|
|
procedure InternalGotoBookmark(ABookmark: Pointer); override;
|
|
procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
|
|
procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
|
|
procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
|
|
function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override;
|
|
function IsCursorOpen: Boolean; override;
|
|
function GetRecordCount: Longint; override;
|
|
procedure ApplyRecUpdate(UpdateKind : TUpdateKind); virtual;
|
|
procedure SetOnUpdateError(const AValue: TResolverErrorEvent);
|
|
procedure SetFilterText(const Value: String); override; {virtual;}
|
|
procedure SetFiltered(Value: Boolean); override; {virtual;}
|
|
procedure InternalRefresh; override;
|
|
procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
|
|
procedure BeforeRefreshOpenCursor; virtual;
|
|
procedure DoFilterRecord(out Acceptable: Boolean); virtual;
|
|
procedure SetReadOnly(AValue: Boolean); virtual;
|
|
{abstracts, must be overidden by descendents}
|
|
function Fetch : boolean; virtual;
|
|
function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual;
|
|
procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); virtual; abstract;
|
|
function IsReadFromPacket : Boolean;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
function GetFieldData(Field: TField; Buffer: Pointer;
|
|
NativeFormat: Boolean): Boolean; override;
|
|
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
|
|
procedure SetFieldData(Field: TField; Buffer: Pointer;
|
|
NativeFormat: Boolean); override;
|
|
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
|
|
procedure ApplyUpdates; virtual; overload;
|
|
procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
|
|
procedure MergeChangeLog;
|
|
procedure CancelUpdates; virtual;
|
|
destructor Destroy; 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;
|
|
function UpdateStatus: TUpdateStatus; override;
|
|
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
|
|
procedure AddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string = '';
|
|
const ACaseInsFields: string = ''); virtual;
|
|
|
|
procedure SetDatasetPacket(AReader : TDataPacketReader);
|
|
procedure GetDatasetPacket(AWriter : TDataPacketReader);
|
|
procedure LoadFromStream(AStream : TStream; Format: TDataPacketFormat = dfAny);
|
|
procedure SaveToStream(AStream : TStream; Format: TDataPacketFormat = dfBinary);
|
|
procedure LoadFromFile(AFileName: string = ''; Format: TDataPacketFormat = dfAny);
|
|
procedure SaveToFile(AFileName: string = ''; Format: TDataPacketFormat = dfBinary);
|
|
procedure CreateDataset;
|
|
function BookmarkValid(ABookmark: TBookmark): Boolean; override;
|
|
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override;
|
|
|
|
property ChangeCount : Integer read GetChangeCount;
|
|
property MaxIndexesCount : Integer read FMaxIndexesCount write SetMaxIndexesCount default 2;
|
|
property ReadOnly : Boolean read FReadOnly write SetReadOnly default false;
|
|
published
|
|
property FileName : string read FFileName write FFileName;
|
|
property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
|
|
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
|
|
property IndexDefs : TIndexDefs read GetIndexDefs;
|
|
property IndexName : String read GetIndexName write SetIndexName;
|
|
property IndexFieldNames : String read GetIndexFieldNames write SetIndexFieldNames;
|
|
property UniDirectional: boolean read GetBufUniDirectional write SetBufUniDirectional default False;
|
|
end;
|
|
|
|
TZMBufDataset = class(TZMCustomBufDataset)
|
|
published
|
|
property MaxIndexesCount;
|
|
// TDataset stuff
|
|
property FieldDefs;
|
|
Property Active;
|
|
Property AutoCalcFields;
|
|
Property Filter;
|
|
Property Filtered;
|
|
Property ReadOnly;
|
|
Property AfterCancel;
|
|
Property AfterClose;
|
|
Property AfterDelete;
|
|
Property AfterEdit;
|
|
Property AfterInsert;
|
|
Property AfterOpen;
|
|
Property AfterPost;
|
|
Property AfterScroll;
|
|
Property BeforeCancel;
|
|
Property BeforeClose;
|
|
Property BeforeDelete;
|
|
Property BeforeEdit;
|
|
Property BeforeInsert;
|
|
Property BeforeOpen;
|
|
Property BeforePost;
|
|
Property BeforeScroll;
|
|
Property OnCalcFields;
|
|
Property OnDeleteError;
|
|
Property OnEditError;
|
|
Property OnFilterRecord;
|
|
Property OnNewRecord;
|
|
Property OnPostError;
|
|
end;
|
|
|
|
|
|
procedure RegisterDatapacketReader(ADatapacketReaderClass : TDatapacketReaderClass; AFormat : TDataPacketFormat);
|
|
|
|
implementation
|
|
|
|
uses variants, dbconst, FmtBCD;
|
|
|
|
Type TDatapacketReaderRegistration = record
|
|
ReaderClass : TDatapacketReaderClass;
|
|
Format : TDataPacketFormat;
|
|
end;
|
|
|
|
var RegisteredDatapacketReaders : Array of TDatapacketReaderRegistration;
|
|
|
|
procedure RegisterDatapacketReader(ADatapacketReaderClass : TDatapacketReaderClass; AFormat : TDataPacketFormat);
|
|
begin
|
|
setlength(RegisteredDatapacketReaders,length(RegisteredDatapacketReaders)+1);
|
|
with RegisteredDatapacketReaders[length(RegisteredDatapacketReaders)-1] do
|
|
begin
|
|
Readerclass := ADatapacketReaderClass;
|
|
Format := AFormat;
|
|
end;
|
|
end;
|
|
|
|
function GetRegisterDatapacketReader(AStream : TStream; AFormat : TDataPacketFormat; var ADataReaderClass : TDatapacketReaderRegistration) : boolean;
|
|
var i : integer;
|
|
begin
|
|
Result := False;
|
|
for i := 0 to length(RegisteredDatapacketReaders)-1 do if ((AFormat=dfAny) or (AFormat=RegisteredDatapacketReaders[i].Format)) then
|
|
begin
|
|
if (AStream=nil) or (RegisteredDatapacketReaders[i].ReaderClass.RecognizeStream(AStream)) then
|
|
begin
|
|
ADataReaderClass := RegisteredDatapacketReaders[i];
|
|
Result := True;
|
|
if (AStream <> nil) then AStream.Seek(0,soFromBeginning);
|
|
break;
|
|
end;
|
|
AStream.Seek(0,soFromBeginning);
|
|
end;
|
|
end;
|
|
|
|
function DBCompareText(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
begin
|
|
if [loCaseInsensitive,loPartialKey]=options then
|
|
Result := AnsiStrLIComp(pchar(subValue),pchar(aValue),length(pchar(subValue)))
|
|
else if [loPartialKey] = options then
|
|
Result := AnsiStrLComp(pchar(subValue),pchar(aValue),length(pchar(subValue)))
|
|
else if [loCaseInsensitive] = options then
|
|
Result := AnsiCompareText(pchar(subValue),pchar(aValue))
|
|
else
|
|
Result := AnsiCompareStr(pchar(subValue),pchar(aValue));
|
|
end;
|
|
|
|
function DBCompareWideText(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
begin
|
|
if [loCaseInsensitive,loPartialKey]=options then
|
|
Result := WideCompareText(pwidechar(subValue),LeftStr(pwidechar(aValue), Length(pwidechar(subValue))))
|
|
else if [loPartialKey] = options then
|
|
Result := WideCompareStr(pwidechar(subValue),LeftStr(pwidechar(aValue), Length(pwidechar(subValue))))
|
|
else if [loCaseInsensitive] = options then
|
|
Result := WideCompareText(pwidechar(subValue),pwidechar(aValue))
|
|
else
|
|
Result := WideCompareStr(pwidechar(subValue),pwidechar(aValue));
|
|
end;
|
|
|
|
function DBCompareByte(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
Result := PByte(subValue)^-PByte(aValue)^;
|
|
end;
|
|
|
|
function DBCompareSmallInt(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
Result := PSmallInt(subValue)^-PSmallInt(aValue)^;
|
|
end;
|
|
|
|
function DBCompareInt(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
Result := PInteger(subValue)^-PInteger(aValue)^;
|
|
end;
|
|
|
|
function DBCompareLargeInt(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
// A simple subtraction doesn't work, since it could be that the result
|
|
// doesn't fit into a LargeInt
|
|
if PLargeInt(subValue)^ < PLargeInt(aValue)^ then
|
|
result := -1
|
|
else if PLargeInt(subValue)^ > PLargeInt(aValue)^ then
|
|
result := 1
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function DBCompareWord(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
Result := PWord(subValue)^-PWord(aValue)^;
|
|
end;
|
|
|
|
function DBCompareQWord(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
|
|
begin
|
|
// A simple subtraction doesn't work, since it could be that the result
|
|
// doesn't fit into a LargeInt
|
|
if PQWord(subValue)^ < PQWord(aValue)^ then
|
|
result := -1
|
|
else if PQWord(subValue)^ > PQWord(aValue)^ then
|
|
result := 1
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function DBCompareDouble(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
begin
|
|
// A simple subtraction doesn't work, since it could be that the result
|
|
// doesn't fit into a LargeInt
|
|
if PDouble(subValue)^ < PDouble(aValue)^ then
|
|
result := -1
|
|
else if PDouble(subValue)^ > PDouble(aValue)^ then
|
|
result := 1
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function DBCompareBCD(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
|
|
begin
|
|
result:=BCDCompare(PBCD(subValue)^, PBCD(aValue)^);
|
|
end;
|
|
|
|
procedure unSetFieldIsNull(NullMask : pbyte;x : longint); //inline;
|
|
begin
|
|
NullMask[x div 8] := (NullMask[x div 8]) and not (1 shl (x mod 8));
|
|
end;
|
|
|
|
procedure SetFieldIsNull(NullMask : pbyte;x : longint); //inline;
|
|
begin
|
|
NullMask[x div 8] := (NullMask[x div 8]) or (1 shl (x mod 8));
|
|
end;
|
|
|
|
function GetFieldIsNull(NullMask : pbyte;x : longint) : boolean; //inline;
|
|
begin
|
|
result := ord(NullMask[x div 8]) and (1 shl (x mod 8)) > 0
|
|
end;
|
|
|
|
function IndexCompareRecords(Rec1,Rec2 : pointer; ADBCompareRecs : TDBCompareStruct) : LargeInt;
|
|
var IndexFieldNr : Integer;
|
|
IsNull1, IsNull2 : boolean;
|
|
begin
|
|
for IndexFieldNr:=0 to length(ADBCompareRecs)-1 do with ADBCompareRecs[IndexFieldNr] do
|
|
begin
|
|
IsNull1:=GetFieldIsNull(rec1+NullBOff1,FieldInd1);
|
|
IsNull2:=GetFieldIsNull(rec2+NullBOff2,FieldInd2);
|
|
if IsNull1 and IsNull2 then
|
|
result := 0
|
|
else if IsNull1 then
|
|
result := -1
|
|
else if IsNull2 then
|
|
result := 1
|
|
else
|
|
Result := Comparefunc(Rec1+Off1,Rec2+Off2,Options);
|
|
|
|
if Result <> 0 then
|
|
begin
|
|
if Desc then
|
|
Result := -Result;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ---------------------------------------------------------------------
|
|
TZMCustomBufDataset
|
|
---------------------------------------------------------------------}
|
|
|
|
constructor TZMCustomBufDataset.Create(AOwner : TComponent);
|
|
var i:Integer;
|
|
begin
|
|
Inherited Create(AOwner);
|
|
FMaxIndexesCount:=2;
|
|
FIndexesCount:=0;
|
|
|
|
FIndexDefs := TIndexDefs.Create(Self);
|
|
FAutoIncValue:=-1;
|
|
|
|
SetLength(FUpdateBuffer,0);
|
|
SetLength(FBlobBuffers,0);
|
|
SetLength(FUpdateBlobBuffers,0);
|
|
FParser := nil;
|
|
FPacketRecords := 10;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetPacketRecords(aValue : integer);
|
|
begin
|
|
if (aValue = -1) or (aValue > 0) then FPacketRecords := aValue
|
|
else DatabaseError(SInvPacketRecordsValue);
|
|
end;
|
|
|
|
destructor TZMCustomBufDataset.Destroy;
|
|
|
|
Var
|
|
I : Integer;
|
|
begin
|
|
if Active then Close;
|
|
SetLength(FUpdateBuffer,0);
|
|
SetLength(FBlobBuffers,0);
|
|
SetLength(FUpdateBlobBuffers,0);
|
|
For I:=0 to Length(FIndexes)-1 do
|
|
FreeAndNil(Findexes[I]);
|
|
SetLength(FIndexes,0);
|
|
FreeAndNil(FIndexDefs);
|
|
inherited destroy;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.FetchAll;
|
|
begin
|
|
repeat
|
|
until (getnextpacket < FPacketRecords) or (FPacketRecords = -1);
|
|
end;
|
|
|
|
{
|
|
// Code to dump raw dataset data, including indexes information, useful for debugging
|
|
procedure DumpRawMem(const Data: pointer; ALength: PtrInt);
|
|
var
|
|
b: integer;
|
|
s1,s2: string;
|
|
begin
|
|
s1 := '';
|
|
s2 := '';
|
|
for b := 0 to ALength-1 do
|
|
begin
|
|
s1 := s1 + ' ' + hexStr(pbyte(Data)[b],2);
|
|
if pchar(Data)[b] in ['a'..'z','A'..'Z','1'..'9',' '..'/',':'..'@'] then
|
|
s2 := s2 + pchar(Data)[b]
|
|
else
|
|
s2 := s2 + '.';
|
|
if length(s2)=16 then
|
|
begin
|
|
write(' ',s1,' ');
|
|
writeln(s2);
|
|
s1 := '';
|
|
s2 := '';
|
|
end;
|
|
end;
|
|
write(' ',s1,' ');
|
|
writeln(s2);
|
|
end;
|
|
|
|
procedure DumpRecord(Dataset: TZMCustomBufDataset; RecBuf: PBufRecLinkItem; RawData: boolean = false);
|
|
var ptr: pointer;
|
|
NullMask: pointer;
|
|
FieldData: pointer;
|
|
NullMaskSize: integer;
|
|
i: integer;
|
|
begin
|
|
if RawData then
|
|
DumpRawMem(RecBuf,Dataset.RecordSize)
|
|
else
|
|
begin
|
|
ptr := RecBuf;
|
|
NullMask:= ptr + (sizeof(TBufRecLinkItem)*Dataset.MaxIndexesCount);
|
|
NullMaskSize := 1+(Dataset.Fields.Count-1) div 8;
|
|
FieldData:= ptr + (sizeof(TBufRecLinkItem)*Dataset.MaxIndexesCount) +NullMaskSize;
|
|
write('record: $',hexstr(ptr),' nullmask: $');
|
|
for i := 0 to NullMaskSize-1 do
|
|
write(hexStr(byte((NullMask+i)^),2));
|
|
write('=');
|
|
for i := 0 to NullMaskSize-1 do
|
|
write(binStr(byte((NullMask+i)^),8));
|
|
writeln('%');
|
|
for i := 0 to Dataset.MaxIndexesCount-1 do
|
|
writeln(' ','Index ',inttostr(i),' Prior rec: ' + hexstr(pointer((ptr+(i*2)*sizeof(ptr))^)) + ' Next rec: ' + hexstr(pointer((ptr+((i*2)+1)*sizeof(ptr))^)));
|
|
DumpRawMem(FieldData,Dataset.RecordSize-((sizeof(TBufRecLinkItem)*Dataset.MaxIndexesCount) +NullMaskSize));
|
|
end;
|
|
end;
|
|
|
|
procedure DumpDataset(AIndex: TBufIndex;RawData: boolean = false);
|
|
var RecBuf: PBufRecLinkItem;
|
|
begin
|
|
writeln('Dump records, order based on index ',AIndex.IndNr);
|
|
writeln('Current record:',hexstr(AIndex.CurrentRecord));
|
|
|
|
RecBuf:=(AIndex as TDoubleLinkedBufIndex).FFirstRecBuf;
|
|
while RecBuf<>(AIndex as TDoubleLinkedBufIndex).FLastRecBuf do
|
|
begin
|
|
DumpRecord(AIndex.FDataset,RecBuf,RawData);
|
|
RecBuf:=RecBuf[(AIndex as TDoubleLinkedBufIndex).IndNr].next;
|
|
end;
|
|
end;
|
|
}
|
|
|
|
procedure TZMCustomBufDataset.BuildIndex(var AIndex: TBufIndex);
|
|
|
|
var PCurRecLinkItem : PBufRecLinkItem;
|
|
p,l,q : PBufRecLinkItem;
|
|
i,k,psize,qsize : integer;
|
|
MergeAmount : integer;
|
|
PlaceQRec : boolean;
|
|
|
|
IndexFields : TList;
|
|
DescIndexFields : TList;
|
|
CInsIndexFields : TList;
|
|
|
|
Index0,
|
|
DblLinkIndex : TDoubleLinkedBufIndex;
|
|
|
|
procedure PlaceNewRec(var e: PBufRecLinkItem; var esize: integer);
|
|
begin
|
|
if DblLinkIndex.FFirstRecBuf=nil then
|
|
begin
|
|
DblLinkIndex.FFirstRecBuf:=e;
|
|
e[DblLinkIndex.IndNr].prior:=nil;
|
|
l:=e;
|
|
end
|
|
else
|
|
begin
|
|
l[DblLinkIndex.IndNr].next:=e;
|
|
e[DblLinkIndex.IndNr].prior:=l;
|
|
l:=e;
|
|
end;
|
|
e := e[DblLinkIndex.IndNr].next;
|
|
dec(esize);
|
|
end;
|
|
|
|
begin
|
|
// Build the DBCompareStructure
|
|
// One AS is enough, and makes debugging easier.
|
|
DblLinkIndex:=(AIndex as TDoubleLinkedBufIndex);
|
|
Index0:=(FIndexes[0] as TDoubleLinkedBufIndex);
|
|
with DblLinkIndex do
|
|
begin
|
|
IndexFields := TList.Create;
|
|
DescIndexFields := TList.Create;
|
|
CInsIndexFields := TList.Create;
|
|
try
|
|
GetFieldList(IndexFields,FieldsName);
|
|
GetFieldList(DescIndexFields,DescFields);
|
|
GetFieldList(CInsIndexFields,CaseinsFields);
|
|
if IndexFields.Count=0 then
|
|
DatabaseError(SNoIndexFieldNameGiven);
|
|
ProcessFieldsToCompareStruct(IndexFields, DescIndexFields, CInsIndexFields, Options, [], DBCompareStruct);
|
|
finally
|
|
CInsIndexFields.Free;
|
|
DescIndexFields.Free;
|
|
IndexFields.Free;
|
|
end;
|
|
end;
|
|
|
|
// This simply copies the index...
|
|
PCurRecLinkItem:=Index0.FFirstRecBuf;
|
|
PCurRecLinkItem[DblLinkIndex.IndNr].next := PCurRecLinkItem[0].next;
|
|
PCurRecLinkItem[DblLinkIndex.IndNr].prior := PCurRecLinkItem[0].prior;
|
|
|
|
if PCurRecLinkItem <> Index0.FLastRecBuf then
|
|
begin
|
|
while PCurRecLinkItem^.next<>Index0.FLastRecBuf do
|
|
begin
|
|
PCurRecLinkItem:=PCurRecLinkItem^.next;
|
|
|
|
PCurRecLinkItem[DblLinkIndex.IndNr].next := PCurRecLinkItem[0].next;
|
|
PCurRecLinkItem[DblLinkIndex.IndNr].prior := PCurRecLinkItem[0].prior;
|
|
end;
|
|
end
|
|
else
|
|
// Empty dataset
|
|
Exit;
|
|
|
|
// Set FirstRecBuf and FCurrentRecBuf
|
|
DblLinkIndex.FFirstRecBuf:=Index0.FFirstRecBuf;
|
|
DblLinkIndex.FCurrentRecBuf:=DblLinkIndex.FFirstRecBuf;
|
|
// Link in the FLastRecBuf that belongs to this index
|
|
PCurRecLinkItem[DblLinkIndex.IndNr].next:=DblLinkIndex.FLastRecBuf;
|
|
DblLinkIndex.FLastRecBuf[DblLinkIndex.IndNr].prior:=PCurRecLinkItem;
|
|
|
|
// Mergesort. Used the algorithm as described here by Simon Tatham
|
|
// http://www.chiark.greenend.org.uk/~sgtatham/algorithms/listsort.html
|
|
// The comments in the code are from this website.
|
|
|
|
// In each pass, we are merging lists of size K into lists of size 2K.
|
|
// (Initially K equals 1.)
|
|
k:=1;
|
|
|
|
repeat
|
|
|
|
// So we start by pointing a temporary pointer p at the head of the list,
|
|
// and also preparing an empty list L which we will add elements to the end
|
|
// of as we finish dealing with them.
|
|
p := DblLinkIndex.FFirstRecBuf;
|
|
DblLinkIndex.FFirstRecBuf := nil;
|
|
q := p;
|
|
MergeAmount := 0;
|
|
|
|
// Then:
|
|
// * If p is null, terminate this pass.
|
|
while p <> DblLinkIndex.FLastRecBuf do
|
|
begin
|
|
|
|
// * Otherwise, there is at least one element in the next pair of length-K
|
|
// lists, so increment the number of merges performed in this pass.
|
|
inc(MergeAmount);
|
|
|
|
// * Point another temporary pointer, q, at the same place as p. Step q along
|
|
// the list by K places, or until the end of the list, whichever comes
|
|
// first. Let psize be the number of elements you managed to step q past.
|
|
i:=0;
|
|
while (i<k) and (q<>DblLinkIndex.FLastRecBuf) do
|
|
begin
|
|
inc(i);
|
|
q := q[DblLinkIndex.IndNr].next;
|
|
end;
|
|
psize :=i;
|
|
|
|
// * Let qsize equal K. Now we need to merge a list starting at p, of length
|
|
// psize, with a list starting at q of length at most qsize.
|
|
qsize:=k;
|
|
|
|
// * So, as long as either the p-list is non-empty (psize > 0) or the q-list
|
|
// is non-empty (qsize > 0 and q points to something non-null):
|
|
while (psize>0) or ((qsize>0) and (q <> DblLinkIndex.FLastRecBuf)) do
|
|
begin
|
|
// * Choose which list to take the next element from. If either list
|
|
// is empty, we must choose from the other one. (By assumption, at
|
|
// least one is non-empty at this point.) If both lists are
|
|
// non-empty, compare the first element of each and choose the lower
|
|
// one. If the first elements compare equal, choose from the p-list.
|
|
// (This ensures that any two elements which compare equal are never
|
|
// swapped, so stability is guaranteed.)
|
|
if (psize=0) then
|
|
PlaceQRec := true
|
|
else if (qsize=0) or (q = DblLinkIndex.FLastRecBuf) then
|
|
PlaceQRec := False
|
|
else if IndexCompareRecords(p,q,DblLinkIndex.DBCompareStruct) <= 0 then
|
|
PlaceQRec := False
|
|
else
|
|
PlaceQRec := True;
|
|
|
|
// * Remove that element, e, from the start of its list, by advancing
|
|
// p or q to the next element along, and decrementing psize or qsize.
|
|
// * Add e to the end of the list L we are building up.
|
|
if PlaceQRec then
|
|
PlaceNewRec(q,qsize)
|
|
else
|
|
PlaceNewRec(p,psize);
|
|
end;
|
|
|
|
// * Now we have advanced p until it is where q started out, and we have
|
|
// advanced q until it is pointing at the next pair of length-K lists to
|
|
// merge. So set p to the value of q, and go back to the start of this loop.
|
|
p:=q;
|
|
end;
|
|
|
|
// As soon as a pass like this is performed and only needs to do one merge, the
|
|
// algorithm terminates, and the output list L is sorted. Otherwise, double the
|
|
// value of K, and go back to the beginning.
|
|
|
|
l[DblLinkIndex.IndNr].next:=DblLinkIndex.FLastRecBuf;
|
|
|
|
k:=k*2;
|
|
|
|
until MergeAmount = 1;
|
|
DblLinkIndex.FLastRecBuf[DblLinkIndex.IndNr].next:=DblLinkIndex.FFirstRecBuf;
|
|
DblLinkIndex.FLastRecBuf[DblLinkIndex.IndNr].prior:=l;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.BuildIndexes;
|
|
var i: integer;
|
|
begin
|
|
for i:=1 to FIndexesCount-1 do
|
|
if (i<>1) or (FIndexes[i]=FCurrentIndex) then
|
|
BuildIndex(FIndexes[i]);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.RemoveRecordFromIndexes(const ABookmark: TBufBookmark);
|
|
var i: integer;
|
|
begin
|
|
for i:=0 to FIndexesCount-1 do
|
|
if (i<>1) or (FIndexes[i]=FCurrentIndex) then
|
|
FIndexes[i].RemoveRecordFromIndex(ABookmark);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetIndexDefs : TIndexDefs;
|
|
|
|
begin
|
|
Result := FIndexDefs;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.UpdateIndexDefs;
|
|
var i : integer;
|
|
begin
|
|
FIndexDefs.Clear;
|
|
for i := 0 to high(FIndexes) do with FIndexDefs.AddIndexDef do
|
|
begin
|
|
Name := FIndexes[i].Name;
|
|
Fields := FIndexes[i].FieldsName;
|
|
DescFields:= FIndexes[i].DescFields;
|
|
CaseInsFields:=FIndexes[i].CaseinsFields;
|
|
Options:=FIndexes[i].Options;
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetCanModify: Boolean;
|
|
begin
|
|
Result:=not (UniDirectional or ReadOnly);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.BufferOffset: integer;
|
|
begin
|
|
// Returns the offset of data buffer in ZMBufDataset record
|
|
Result := sizeof(TBufRecLinkItem) * FMaxIndexesCount;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.IntAllocRecordBuffer: TRecordBuffer;
|
|
begin
|
|
// Note: Only the internal buffers of TDataset provide bookmark information
|
|
result := AllocMem(FRecordSize+BufferOffset);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.AllocRecordBuffer: TRecordBuffer;
|
|
begin
|
|
result := AllocMem(FRecordSize + BookmarkSize + CalcFieldsSize);
|
|
// The records are initialised, or else the fields of an empty, just-opened dataset
|
|
// are not null
|
|
InitRecord(result);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.FreeRecordBuffer(var Buffer: TRecordBuffer);
|
|
begin
|
|
ReAllocMem(Buffer,0);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.ClearCalcFields(Buffer: TRecordBuffer);
|
|
begin
|
|
if CalcFieldsSize > 0 then
|
|
FillByte((Buffer+RecordSize)^,CalcFieldsSize,0);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalOpen;
|
|
|
|
var IndexNr : integer;
|
|
i : integer;
|
|
|
|
begin
|
|
FAutoIncField:=nil;
|
|
if not Assigned(FDatasetReader) and (FileName<>'') then
|
|
begin
|
|
FFileStream := TFileStream.Create(FileName,fmOpenRead);
|
|
FDatasetReader := GetPacketReader(dfAny, FFileStream);
|
|
end;
|
|
if assigned(FDatasetReader) then
|
|
begin
|
|
FReadFromFile := True;
|
|
IntLoadFielddefsFromFile;
|
|
end;
|
|
|
|
// This checks if the dataset is actually created (by calling CreateDataset,
|
|
// or reading from a stream in some other way implemented by a descendent)
|
|
// If there are less fields than FieldDefs we know for sure that the dataset
|
|
// is not (correctly) created.
|
|
|
|
// If there are constant expressions in the select statement (for PostgreSQL)
|
|
// they are of type ftUnknown (in FieldDefs), and are not created (in Fields).
|
|
// So Fields.Count < FieldDefs.Count in this case
|
|
// See mantis #22030
|
|
|
|
// if Fields.Count<FieldDefs.Count then
|
|
if Fields.Count = 0 then
|
|
DatabaseError(SErrNoDataset);
|
|
|
|
// If there is a field with FieldNo=0 then the fields are not found to the
|
|
// FieldDefs which is a sign that there is no dataset created. (Calculated and
|
|
// lookup fields have FieldNo=-1)
|
|
for i := 0 to Fields.Count-1 do
|
|
if Fields[i].FieldNo=0 then
|
|
begin
|
|
{ TODO : To find a way to set FieldNo for persistent fields. }
|
|
//Here is the problem with persisten fields, because FieldNo is read-only property and is not published, neither streamed....
|
|
DatabaseError(SErrNoDataset);
|
|
end
|
|
else
|
|
if (FAutoIncValue>-1) and (Fields[i] is TAutoIncField) and not assigned(FAutoIncField) then
|
|
FAutoIncField := TAutoIncField(Fields[i]);
|
|
|
|
InitDefaultIndexes;
|
|
CalcRecordSize;
|
|
|
|
FBRecordcount := 0;
|
|
|
|
for IndexNr:=0 to FIndexesCount-1 do with FIndexes[IndexNr] do
|
|
InitialiseSpareRecord(IntAllocRecordBuffer);
|
|
|
|
FAllPacketsFetched := False;
|
|
|
|
FOpen:=True;
|
|
|
|
// parse filter expression
|
|
ParseFilter(Filter);
|
|
|
|
if assigned(FDatasetReader) then IntLoadRecordsFromFile;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalClose;
|
|
|
|
var r : integer;
|
|
iGetResult : TGetResult;
|
|
pc : TRecordBuffer;
|
|
|
|
begin
|
|
FOpen:=False;
|
|
if FIndexesCount>0 then with FIndexes[0] do if IsInitialized then
|
|
begin
|
|
iGetResult:=ScrollFirst;
|
|
while iGetResult = grOK do
|
|
begin
|
|
pc := pointer(CurrentRecord);
|
|
iGetResult:=ScrollForward;
|
|
FreeRecordBuffer(pc);
|
|
end;
|
|
end;
|
|
|
|
for r := 0 to FIndexesCount-1 do with FIndexes[r] do if IsInitialized then
|
|
begin
|
|
pc := SpareRecord;
|
|
ReleaseSpareRecord;
|
|
FreeRecordBuffer(pc);
|
|
end;
|
|
|
|
if Length(FUpdateBuffer) > 0 then
|
|
begin
|
|
for r := 0 to length(FUpdateBuffer)-1 do with FUpdateBuffer[r] do
|
|
begin
|
|
if assigned(OldValuesBuffer) then
|
|
FreeRecordBuffer(OldValuesBuffer);
|
|
if (UpdateKind = ukDelete) and assigned(BookmarkData.BookmarkData) then
|
|
FreeRecordBuffer(TRecordBuffer(BookmarkData.BookmarkData));
|
|
end;
|
|
end;
|
|
SetLength(FUpdateBuffer,0);
|
|
|
|
for r := 0 to High(FBlobBuffers) do
|
|
FreeBlobBuffer(FBlobBuffers[r]);
|
|
for r := 0 to High(FUpdateBlobBuffers) do
|
|
FreeBlobBuffer(FUpdateBlobBuffers[r]);
|
|
|
|
SetLength(FBlobBuffers,0);
|
|
SetLength(FUpdateBlobBuffers,0);
|
|
|
|
SetLength(FFieldBufPositions,0);
|
|
|
|
FAutoIncValue:=-1;
|
|
|
|
if assigned(FParser) then FreeAndNil(FParser);
|
|
FReadFromFile:=false;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalFirst;
|
|
begin
|
|
with FCurrentIndex do
|
|
// if FCurrentRecBuf = FLastRecBuf then the dataset is just opened and empty
|
|
// in which case InternalFirst should do nothing (bug 7211)
|
|
SetToFirstRecord;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalLast;
|
|
begin
|
|
FetchAll;
|
|
with FCurrentIndex do
|
|
SetToLastRecord;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetBookmarkSize: integer;
|
|
begin
|
|
Result:=sizeof(TBufBookmark);
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetCurrentBuffer: Pointer;
|
|
begin
|
|
Result := pointer(FCurrentRecBuf) + FDataset.BufferOffset;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetCurrentRecord: TRecordBuffer;
|
|
begin
|
|
Result := TRecordBuffer(FCurrentRecBuf);
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetIsInitialized: boolean;
|
|
begin
|
|
Result := (FFirstRecBuf<>nil);
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetSpareBuffer: TRecordBuffer;
|
|
begin
|
|
Result := pointer(FLastRecBuf) + FDataset.BufferOffset;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetSpareRecord: TRecordBuffer;
|
|
begin
|
|
Result := TRecordBuffer(FLastRecBuf);
|
|
end;
|
|
|
|
constructor TBufIndex.Create(const ADataset: TZMCustomBufDataset);
|
|
begin
|
|
inherited create;
|
|
FDataset := ADataset;
|
|
end;
|
|
|
|
function TBufIndex.BookmarkValid(const ABookmark: PBufBookmark): boolean;
|
|
begin
|
|
Result := assigned(ABookmark) and assigned(ABookmark^.BookmarkData);
|
|
end;
|
|
|
|
function TBufIndex.CompareBookmarks(const ABookmark1, ABookmark2: PBufBookmark): boolean;
|
|
begin
|
|
result := (ABookmark1^.BookmarkData=ABookmark2^.BookmarkData);
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.ScrollBackward: TGetResult;
|
|
begin
|
|
if not assigned(FCurrentRecBuf[IndNr].prior) then
|
|
begin
|
|
Result := grBOF;
|
|
end
|
|
else
|
|
begin
|
|
Result := grOK;
|
|
FCurrentRecBuf := FCurrentRecBuf[IndNr].prior;
|
|
end;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.ScrollForward: TGetResult;
|
|
begin
|
|
if (FCurrentRecBuf = FLastRecBuf) or // just opened
|
|
(FCurrentRecBuf[IndNr].next = FLastRecBuf) then
|
|
result := grEOF
|
|
else
|
|
begin
|
|
FCurrentRecBuf := FCurrentRecBuf[IndNr].next;
|
|
Result := grOK;
|
|
end;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetCurrent: TGetResult;
|
|
begin
|
|
if FFirstRecBuf = FLastRecBuf then
|
|
Result := grError
|
|
else
|
|
begin
|
|
Result := grOK;
|
|
if FCurrentRecBuf = FLastRecBuf then
|
|
FCurrentRecBuf:=FLastRecBuf[IndNr].prior;
|
|
end;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.ScrollFirst: TGetResult;
|
|
begin
|
|
FCurrentRecBuf:=FFirstRecBuf;
|
|
if (FCurrentRecBuf = FLastRecBuf) then
|
|
result := grEOF
|
|
else
|
|
result := grOK;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.ScrollLast;
|
|
begin
|
|
FCurrentRecBuf:=FLastRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.SetToFirstRecord;
|
|
begin
|
|
FLastRecBuf[IndNr].next:=FFirstRecBuf;
|
|
FCurrentRecBuf := FLastRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.SetToLastRecord;
|
|
begin
|
|
if FLastRecBuf <> FFirstRecBuf then FCurrentRecBuf := FLastRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.StoreCurrentRecord;
|
|
begin
|
|
FStoredRecBuf:=FCurrentRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.RestoreCurrentRecord;
|
|
begin
|
|
FCurrentRecBuf:=FStoredRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.DoScrollForward;
|
|
begin
|
|
FCurrentRecBuf := FCurrentRecBuf[IndNr].next;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark);
|
|
begin
|
|
ABookmark^.BookmarkData:=FCurrentRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.StoreSpareRecIntoBookmark(
|
|
const ABookmark: PBufBookmark);
|
|
begin
|
|
ABookmark^.BookmarkData:=FLastRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.GotoBookmark(const ABookmark : PBufBookmark);
|
|
begin
|
|
FCurrentRecBuf := ABookmark^.BookmarkData;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.InitialiseIndex;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.CanScrollForward: Boolean;
|
|
begin
|
|
if (FCurrentRecBuf[IndNr].next = FLastRecBuf) then
|
|
Result := False
|
|
else
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.InitialiseSpareRecord(const ASpareRecord : TRecordBuffer);
|
|
begin
|
|
FFirstRecBuf := pointer(ASpareRecord);
|
|
FLastRecBuf := FFirstRecBuf;
|
|
FLastRecBuf[IndNr].prior:=nil;
|
|
FLastRecBuf[IndNr].next:=FLastRecBuf;
|
|
FCurrentRecBuf := FLastRecBuf;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.ReleaseSpareRecord;
|
|
begin
|
|
FFirstRecBuf:= nil;
|
|
end;
|
|
|
|
function TDoubleLinkedBufIndex.GetRecNo(const ABookmark: PBufBookmark): integer;
|
|
Var TmpRecBuffer : PBufRecLinkItem;
|
|
recnr : integer;
|
|
begin
|
|
TmpRecBuffer := FFirstRecBuf;
|
|
recnr := 1;
|
|
while TmpRecBuffer <> ABookmark^.BookmarkData do
|
|
begin
|
|
inc(recnr);
|
|
TmpRecBuffer := TmpRecBuffer[IndNr].next;
|
|
end;
|
|
Result := recnr;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.BeginUpdate;
|
|
begin
|
|
if FCurrentRecBuf = FLastRecBuf then
|
|
FCursOnFirstRec := True
|
|
else
|
|
FCursOnFirstRec := False;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.AddRecord;
|
|
var ARecord: TRecordBuffer;
|
|
begin
|
|
ARecord := FDataset.IntAllocRecordBuffer;
|
|
FLastRecBuf[IndNr].next := pointer(ARecord);
|
|
FLastRecBuf[IndNr].next[IndNr].prior := FLastRecBuf;
|
|
|
|
FLastRecBuf := FLastRecBuf[IndNr].next;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.InsertRecordBeforeCurrentRecord(const ARecord: TRecordBuffer);
|
|
var ANewRecord : PBufRecLinkItem;
|
|
begin
|
|
ANewRecord:=PBufRecLinkItem(ARecord);
|
|
ANewRecord[IndNr].prior:=FCurrentRecBuf[IndNr].prior;
|
|
ANewRecord[IndNr].Next:=FCurrentRecBuf;
|
|
|
|
if FCurrentRecBuf=FFirstRecBuf then
|
|
begin
|
|
FFirstRecBuf:=ANewRecord;
|
|
ANewRecord[IndNr].prior:=nil;
|
|
end
|
|
else
|
|
ANewRecord[IndNr].Prior[IndNr].next:=ANewRecord;
|
|
ANewRecord[IndNr].next[IndNr].prior:=ANewRecord;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.RemoveRecordFromIndex(const ABookmark : TBufBookmark);
|
|
var ARecord : PBufRecLinkItem;
|
|
begin
|
|
ARecord := ABookmark.BookmarkData;
|
|
if ARecord = FCurrentRecBuf then DoScrollForward;
|
|
if ARecord <> FFirstRecBuf then
|
|
ARecord[IndNr].prior[IndNr].next := ARecord[IndNr].next
|
|
else
|
|
begin
|
|
FFirstRecBuf := ARecord[IndNr].next;
|
|
FLastRecBuf[IndNr].next := FFirstRecBuf;
|
|
end;
|
|
ARecord[IndNr].next[IndNr].prior := ARecord[IndNr].prior;
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.OrderCurrentRecord;
|
|
var ARecord: PBufRecLinkItem;
|
|
ABookmark: TBufBookmark;
|
|
begin
|
|
// all records except current are already sorted
|
|
// check prior records
|
|
ARecord := FCurrentRecBuf;
|
|
repeat
|
|
ARecord := ARecord[IndNr].prior;
|
|
until not assigned(ARecord) or (IndexCompareRecords(ARecord, FCurrentRecBuf, DBCompareStruct) <= 0);
|
|
if assigned(ARecord) then
|
|
ARecord := ARecord[IndNr].next
|
|
else
|
|
ARecord := FFirstRecBuf;
|
|
if ARecord = FCurrentRecBuf then
|
|
begin
|
|
// prior record is less equal than current
|
|
// check next records
|
|
repeat
|
|
ARecord := ARecord[IndNr].next;
|
|
until (ARecord=FLastRecBuf) or (IndexCompareRecords(ARecord, FCurrentRecBuf, DBCompareStruct) >= 0);
|
|
if ARecord = FCurrentRecBuf[IndNr].next then
|
|
Exit; // current record is on proper position
|
|
end;
|
|
StoreCurrentRecIntoBookmark(@ABookmark);
|
|
RemoveRecordFromIndex(ABookmark);
|
|
FCurrentRecBuf := ARecord;
|
|
InsertRecordBeforeCurrentRecord(TRecordBuffer(ABookmark.BookmarkData));
|
|
GotoBookmark(@ABookmark);
|
|
end;
|
|
|
|
procedure TDoubleLinkedBufIndex.EndUpdate;
|
|
begin
|
|
FLastRecBuf[IndNr].next := FFirstRecBuf;
|
|
if FCursOnFirstRec then FCurrentRecBuf:=FLastRecBuf;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.CurrentRecordToBuffer(Buffer: TRecordBuffer);
|
|
var ABookMark : PBufBookmark;
|
|
begin
|
|
with FCurrentIndex do
|
|
begin
|
|
move(CurrentBuffer^,buffer^,FRecordSize);
|
|
ABookMark:=PBufBookmark(Buffer + FRecordSize);
|
|
ABookmark^.BookmarkFlag:=bfCurrent;
|
|
StoreCurrentRecIntoBookmark(ABookMark);
|
|
end;
|
|
|
|
GetCalcFields(Buffer);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetBufUniDirectional(const AValue: boolean);
|
|
begin
|
|
CheckInactive;
|
|
if (AValue<>IsUniDirectional) then
|
|
begin
|
|
SetUniDirectional(AValue);
|
|
SetLength(FIndexes,0);
|
|
FPacketRecords := 1; // temporary
|
|
FIndexesCount:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetReadOnly(AValue: Boolean);
|
|
begin
|
|
FReadOnly:=AValue;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
|
|
|
|
var Acceptable : Boolean;
|
|
SaveState : TDataSetState;
|
|
|
|
begin
|
|
Result := grOK;
|
|
with FCurrentIndex do
|
|
begin
|
|
repeat
|
|
Acceptable := True;
|
|
case GetMode of
|
|
gmPrior : Result := ScrollBackward;
|
|
gmCurrent : Result := GetCurrent;
|
|
gmNext : begin
|
|
if not CanScrollForward and (getnextpacket = 0) then result := grEOF
|
|
else
|
|
begin
|
|
result := grOK;
|
|
DoScrollForward;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if Result = grOK then
|
|
begin
|
|
CurrentRecordToBuffer(buffer);
|
|
|
|
if Filtered then
|
|
begin
|
|
FFilterBuffer := Buffer;
|
|
SaveState := SetTempState(dsFilter);
|
|
DoFilterRecord(Acceptable);
|
|
if (GetMode = gmCurrent) and not Acceptable then
|
|
begin
|
|
Acceptable := True;
|
|
Result := grError;
|
|
end;
|
|
RestoreState(SaveState);
|
|
end;
|
|
end
|
|
else if (Result = grError) and doCheck then
|
|
DatabaseError('No record');
|
|
until Acceptable;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.DoBeforeClose;
|
|
begin
|
|
inherited DoBeforeClose;
|
|
if FFileName<>'' then
|
|
SaveToFile(FFileName);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetActiveRecordUpdateBuffer : boolean;
|
|
|
|
var ABookmark : TBufBookmark;
|
|
|
|
begin
|
|
GetBookmarkData(ActiveBuffer,@ABookmark);
|
|
result := GetRecordUpdateBufferCached(ABookmark);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.ProcessFieldsToCompareStruct(const AFields, ADescFields, ACInsFields: TList;
|
|
const AIndexOptions: TIndexOptions; const ALocateOptions: TLocateOptions; out ACompareStruct: TDBCompareStruct);
|
|
var i: integer;
|
|
AField: TField;
|
|
ACompareRec: TDBCompareRec;
|
|
begin
|
|
SetLength(ACompareStruct, AFields.Count);
|
|
for i:=0 to high(ACompareStruct) do
|
|
begin
|
|
AField := TField(AFields[i]);
|
|
|
|
case AField.DataType of
|
|
ftString, ftFixedChar : ACompareRec.Comparefunc := @DBCompareText;
|
|
ftWideString, ftFixedWideChar: ACompareRec.Comparefunc := @DBCompareWideText;
|
|
ftSmallint : ACompareRec.Comparefunc := @DBCompareSmallInt;
|
|
ftInteger, ftBCD, ftAutoInc : ACompareRec.Comparefunc :=
|
|
@DBCompareInt;
|
|
ftWord : ACompareRec.Comparefunc := @DBCompareWord;
|
|
ftBoolean : ACompareRec.Comparefunc := @DBCompareByte;
|
|
ftFloat, ftCurrency : ACompareRec.Comparefunc := @DBCompareDouble;
|
|
ftDateTime, ftDate, ftTime : ACompareRec.Comparefunc :=
|
|
@DBCompareDouble;
|
|
ftLargeint : ACompareRec.Comparefunc := @DBCompareLargeInt;
|
|
ftFmtBCD : ACompareRec.Comparefunc := @DBCompareBCD;
|
|
else
|
|
DatabaseErrorFmt(SErrIndexBasedOnInvField, [AField.FieldName,Fieldtypenames[AField.DataType]]);
|
|
end;
|
|
|
|
ACompareRec.Off1:=BufferOffset + FFieldBufPositions[AField.FieldNo-1];
|
|
ACompareRec.Off2:=ACompareRec.Off1;
|
|
|
|
ACompareRec.FieldInd1:=AField.FieldNo-1;
|
|
ACompareRec.FieldInd2:=ACompareRec.FieldInd1;
|
|
|
|
ACompareRec.NullBOff1:=BufferOffset;
|
|
ACompareRec.NullBOff2:=ACompareRec.NullBOff1;
|
|
|
|
ACompareRec.Desc := ixDescending in AIndexOptions;
|
|
if assigned(ADescFields) then
|
|
ACompareRec.Desc := ACompareRec.Desc or (ADescFields.IndexOf(AField)>-1);
|
|
|
|
ACompareRec.Options := ALocateOptions;
|
|
if assigned(ACInsFields) and (ACInsFields.IndexOf(AField)>-1) then
|
|
ACompareRec.Options := ACompareRec.Options + [loCaseInsensitive];
|
|
|
|
ACompareStruct[i] := ACompareRec;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InitDefaultIndexes;
|
|
begin
|
|
if FIndexesCount=0 then
|
|
begin
|
|
InternalAddIndex('DEFAULT_ORDER','',[],'','');
|
|
FCurrentIndex:=FIndexes[0];
|
|
if not IsUniDirectional then
|
|
InternalAddIndex('','',[],'','');
|
|
BookmarkSize := FCurrentIndex.BookmarkSize;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.AddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string = '';
|
|
const ACaseInsFields: string = '');
|
|
begin
|
|
CheckBiDirectional;
|
|
if AFields='' then DatabaseError(SNoIndexFieldNameGiven);
|
|
|
|
if FIndexesCount=0 then
|
|
InitDefaultIndexes;
|
|
|
|
if Active and (FIndexesCount=FMaxIndexesCount) then
|
|
DatabaseError(SMaxIndexes);
|
|
|
|
// If not all packets are fetched, you can not sort properly.
|
|
if not Active then
|
|
FPacketRecords:=-1;
|
|
InternalAddIndex(AName,AFields,AOptions,ADescFields,ACaseInsFields);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalAddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string;
|
|
const ACaseInsFields: string);
|
|
var StoreIndNr : Integer;
|
|
begin
|
|
if Active then FetchAll;
|
|
if FIndexesCount>0 then
|
|
StoreIndNr:=FCurrentIndex.IndNr
|
|
else
|
|
StoreIndNr:=0;
|
|
inc(FIndexesCount);
|
|
setlength(FIndexes,FIndexesCount); // This invalidates the currentindex! -> not anymore
|
|
FCurrentIndex:=FIndexes[StoreIndNr];
|
|
|
|
if IsUniDirectional then
|
|
FIndexes[FIndexesCount-1] := TUniDirectionalBufIndex.Create(self)
|
|
else
|
|
FIndexes[FIndexesCount-1] := TDoubleLinkedBufIndex.Create(self);
|
|
// FIndexes[FIndexesCount-1] := TArrayBufIndex.Create(self);
|
|
with FIndexes[FIndexesCount-1] do
|
|
begin
|
|
InitialiseIndex;
|
|
IndNr:=FIndexesCount-1;
|
|
Name:=AName;
|
|
FieldsName:=AFields;
|
|
DescFields:=ADescFields;
|
|
CaseinsFields:=ACaseInsFields;
|
|
Options:=AOptions;
|
|
end;
|
|
|
|
if Active then
|
|
begin
|
|
FIndexes[FIndexesCount-1].InitialiseSpareRecord(IntAllocRecordBuffer);
|
|
BuildIndex(FIndexes[FIndexesCount-1]);
|
|
end
|
|
else if FIndexesCount>FMaxIndexesCount then
|
|
FMaxIndexesCount := FIndexesCount;
|
|
|
|
FIndexDefs.Updated:=false;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetIndexFieldNames(const AValue: String);
|
|
begin
|
|
if AValue<>'' then
|
|
begin
|
|
if FIndexesCount=0 then
|
|
InitDefaultIndexes;
|
|
FIndexes[1].FieldsName:=AValue;
|
|
FCurrentIndex:=FIndexes[1];
|
|
if Active then
|
|
begin
|
|
FetchAll;
|
|
BuildIndex(FIndexes[1]);
|
|
Resync([rmCenter]);
|
|
end;
|
|
FIndexDefs.Updated:=false;
|
|
end
|
|
else
|
|
SetIndexName('');
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetIndexName(AValue: String);
|
|
var i : integer;
|
|
begin
|
|
if AValue='' then AValue := 'DEFAULT_ORDER';
|
|
for i := 0 to FIndexesCount-1 do
|
|
if SameText(FIndexes[i].Name,AValue) then
|
|
begin
|
|
(FIndexes[i] as TDoubleLinkedBufIndex).FCurrentRecBuf:=(FCurrentIndex as TDoubleLinkedBufIndex).FCurrentRecBuf;
|
|
FCurrentIndex:=FIndexes[i];
|
|
if Active then Resync([rmCenter]);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetMaxIndexesCount(const AValue: Integer);
|
|
begin
|
|
CheckInactive;
|
|
if AValue > 1 then
|
|
FMaxIndexesCount:=AValue
|
|
else
|
|
DatabaseError(SMinIndexes);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalSetToRecord(Buffer: TRecordBuffer);
|
|
begin
|
|
FCurrentIndex.GotoBookmark(PBufBookmark(Buffer+FRecordSize));
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
|
|
begin
|
|
PBufBookmark(Buffer + FRecordSize)^ := PBufBookmark(Data)^;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag);
|
|
begin
|
|
PBufBookmark(Buffer + FRecordSize)^.BookmarkFlag := Value;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
|
|
begin
|
|
PBufBookmark(Data)^ := PBufBookmark(Buffer + FRecordSize)^;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
|
|
begin
|
|
Result := PBufBookmark(Buffer + FRecordSize)^.BookmarkFlag;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalGotoBookmark(ABookmark: Pointer);
|
|
begin
|
|
// note that ABookMark should be a PBufBookmark. But this way it can also be
|
|
// a pointer to a TBufRecLinkItem
|
|
FCurrentIndex.GotoBookmark(ABookmark);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.getnextpacket : integer;
|
|
|
|
var i : integer;
|
|
pb : TRecordBuffer;
|
|
|
|
begin
|
|
if FAllPacketsFetched then
|
|
begin
|
|
result := 0;
|
|
exit;
|
|
end;
|
|
|
|
FCurrentIndex.BeginUpdate;
|
|
|
|
i := 0;
|
|
pb := FIndexes[0].SpareBuffer;
|
|
while ((i < FPacketRecords) or (FPacketRecords = -1)) and (LoadBuffer(pb) = grOk) do
|
|
begin
|
|
with FIndexes[0] do
|
|
begin
|
|
AddRecord;
|
|
pb := SpareBuffer;
|
|
end;
|
|
inc(i);
|
|
end;
|
|
|
|
FCurrentIndex.EndUpdate;
|
|
FBRecordCount := FBRecordCount + i;
|
|
result := i;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetFieldSize(FieldDef : TFieldDef) : longint;
|
|
|
|
begin
|
|
case FieldDef.DataType of
|
|
ftUnknown : result := 0;
|
|
ftString,
|
|
ftGuid,
|
|
ftFixedChar: result := FieldDef.Size + 1;
|
|
ftFixedWideChar,
|
|
ftWideString:result := (FieldDef.Size + 1)*2;
|
|
ftSmallint,
|
|
ftInteger,
|
|
ftAutoInc,
|
|
ftword : result := sizeof(longint);
|
|
ftBoolean : result := sizeof(wordbool);
|
|
ftBCD : result := sizeof(currency);
|
|
ftFmtBCD : result := sizeof(TBCD);
|
|
ftFloat,
|
|
ftCurrency : result := sizeof(double);
|
|
ftLargeInt : result := sizeof(largeint);
|
|
ftTime,
|
|
ftDate,
|
|
ftDateTime : result := sizeof(TDateTime);
|
|
ftBytes : result := FieldDef.Size;
|
|
ftVarBytes : result := FieldDef.Size + 2;
|
|
ftVariant : result := sizeof(variant);
|
|
ftBlob,
|
|
ftMemo,
|
|
ftGraphic,
|
|
ftFmtMemo,
|
|
ftParadoxOle,
|
|
ftDBaseOle,
|
|
ftTypedBinary,
|
|
ftOraBlob,
|
|
ftOraClob,
|
|
ftWideMemo : result := sizeof(TBufBlobField)
|
|
else
|
|
DatabaseErrorFmt(SUnsupportedFieldType,[Fieldtypenames[FieldDef.DataType]]);
|
|
end;
|
|
{$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
result:=Align(result,4);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecordUpdateBuffer(const ABookmark : TBufBookmark; IncludePrior : boolean = false; AFindNext : boolean = false): boolean;
|
|
|
|
var x : integer;
|
|
StartBuf : integer;
|
|
|
|
begin
|
|
if AFindNext then
|
|
StartBuf := FCurrentUpdateBuffer + 1
|
|
else
|
|
StartBuf := 0;
|
|
Result := False;
|
|
for x := StartBuf to high(FUpdateBuffer) do
|
|
if FCurrentIndex.CompareBookmarks(@FUpdateBuffer[x].BookmarkData,@ABookmark) or
|
|
(IncludePrior and (FUpdateBuffer[x].UpdateKind=ukDelete) and FCurrentIndex.CompareBookmarks(@FUpdateBuffer[x].NextBookmarkData,@ABookmark)) then
|
|
begin
|
|
FCurrentUpdateBuffer := x;
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecordUpdateBufferCached(const ABookmark: TBufBookmark;
|
|
IncludePrior: boolean): boolean;
|
|
begin
|
|
// if the current update buffer matches, immediately return true
|
|
if (FCurrentUpdateBuffer < length(FUpdateBuffer)) and (
|
|
FCurrentIndex.CompareBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData,@ABookmark) or
|
|
(IncludePrior
|
|
and (FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind=ukDelete)
|
|
and FCurrentIndex.CompareBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData,@ABookmark))) then
|
|
begin
|
|
Result := True;
|
|
end
|
|
else
|
|
Result := GetRecordUpdateBuffer(ABookmark,IncludePrior);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.LoadBuffer(Buffer : TRecordBuffer): TGetResult;
|
|
|
|
var NullMask : pbyte;
|
|
x : longint;
|
|
CreateBlobField : boolean;
|
|
BufBlob : PBufBlobField;
|
|
|
|
begin
|
|
if not Fetch then
|
|
begin
|
|
Result := grEOF;
|
|
FAllPacketsFetched := True;
|
|
// This code has to be placed elsewhere. At least it should also run when
|
|
// the datapacket is loaded from file ... see IntLoadRecordsFromFile
|
|
BuildIndexes;
|
|
Exit;
|
|
end;
|
|
|
|
NullMask := pointer(buffer);
|
|
fillchar(Nullmask^,FNullmaskSize,0);
|
|
inc(buffer,FNullmaskSize);
|
|
|
|
for x := 0 to FieldDefs.Count-1 do
|
|
begin
|
|
if not LoadField(FieldDefs[x],buffer,CreateBlobField) then
|
|
SetFieldIsNull(NullMask,x)
|
|
else if CreateBlobField then
|
|
begin
|
|
BufBlob := PBufBlobField(Buffer);
|
|
BufBlob^.BlobBuffer := GetNewBlobBuffer;
|
|
LoadBlobIntoBuffer(FieldDefs[x],BufBlob);
|
|
end;
|
|
inc(buffer,GetFieldSize(FieldDefs[x]));
|
|
end;
|
|
Result := grOK;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetCurrentBuffer: TRecordBuffer;
|
|
begin
|
|
case State of
|
|
dsFilter: Result := FFilterBuffer;
|
|
dsCalcFields: Result := CalcBuffer;
|
|
else Result := ActiveBuffer;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TZMCustomBufDataset.GetFieldData(Field: TField; Buffer: Pointer;
|
|
NativeFormat: Boolean): Boolean;
|
|
begin
|
|
Result := GetFieldData(Field, Buffer);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
|
|
|
|
var CurrBuff : TRecordBuffer;
|
|
|
|
begin
|
|
Result := False;
|
|
if State = dsOldValue then
|
|
begin
|
|
if FSavedState = dsInsert then
|
|
CurrBuff := nil // old values = null
|
|
else if GetActiveRecordUpdateBuffer then
|
|
CurrBuff := FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer
|
|
else
|
|
// There is no UpdateBuffer for ActiveRecord, so there are no explicit old values available
|
|
// then we can assume, that old values = current values
|
|
CurrBuff := FCurrentIndex.CurrentBuffer;
|
|
end
|
|
else
|
|
CurrBuff := GetCurrentBuffer;
|
|
|
|
if not assigned(CurrBuff) then Exit;
|
|
|
|
If Field.FieldNo > 0 then // If =-1, then calculated/lookup field or =0 unbound field
|
|
begin
|
|
if GetFieldIsNull(pbyte(CurrBuff),Field.FieldNo-1) then
|
|
Exit;
|
|
if assigned(buffer) then
|
|
begin
|
|
inc(CurrBuff,FFieldBufPositions[Field.FieldNo-1]);
|
|
Move(CurrBuff^, Buffer^, GetFieldSize(FieldDefs[Field.FieldNo-1]));
|
|
end;
|
|
Result := True;
|
|
end
|
|
else
|
|
begin
|
|
Inc(CurrBuff, GetRecordSize + Field.Offset);
|
|
Result := Boolean(CurrBuff^);
|
|
if result and assigned(Buffer) then
|
|
begin
|
|
inc(CurrBuff);
|
|
Move(CurrBuff^, Buffer^, Field.DataSize);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetFieldData(Field: TField; Buffer: Pointer;
|
|
NativeFormat: Boolean);
|
|
begin
|
|
SetFieldData(Field,Buffer);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetFieldData(Field: TField; Buffer: Pointer);
|
|
|
|
var CurrBuff : pointer;
|
|
NullMask : pbyte;
|
|
|
|
begin
|
|
if not (State in dsWriteModes) then
|
|
DatabaseError(SNotEditing, Self);
|
|
CurrBuff := GetCurrentBuffer;
|
|
If Field.FieldNo > 0 then // If =-1, then calculated/lookup field or =0 unbound field
|
|
begin
|
|
if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then
|
|
DatabaseErrorFmt(SReadOnlyField, [Field.DisplayName]);
|
|
if State in [dsEdit, dsInsert, dsNewValue] then
|
|
Field.Validate(Buffer);
|
|
NullMask := CurrBuff;
|
|
|
|
inc(CurrBuff,FFieldBufPositions[Field.FieldNo-1]);
|
|
if assigned(buffer) then
|
|
begin
|
|
Move(Buffer^, CurrBuff^, GetFieldSize(FieldDefs[Field.FieldNo-1]));
|
|
unSetFieldIsNull(NullMask,Field.FieldNo-1);
|
|
end
|
|
else
|
|
SetFieldIsNull(NullMask,Field.FieldNo-1);
|
|
end
|
|
else
|
|
begin
|
|
Inc(CurrBuff, GetRecordSize + Field.Offset);
|
|
Boolean(CurrBuff^) := Buffer <> nil;
|
|
inc(CurrBuff);
|
|
if assigned(Buffer) then
|
|
Move(Buffer^, CurrBuff^, Field.DataSize);
|
|
end;
|
|
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
|
|
DataEvent(deFieldChange, Ptrint(Field));
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalDelete;
|
|
var i : Integer;
|
|
RemRec : pointer;
|
|
RemRecBookmrk : TBufBookmark;
|
|
begin
|
|
InternalSetToRecord(ActiveBuffer);
|
|
// Remove the record from all active indexes
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(@RemRecBookmrk);
|
|
RemRec := FCurrentIndex.CurrentBuffer;
|
|
RemoveRecordFromIndexes(RemRecBookmrk);
|
|
|
|
if not GetActiveRecordUpdateBuffer then
|
|
begin
|
|
FCurrentUpdateBuffer := length(FUpdateBuffer);
|
|
SetLength(FUpdateBuffer,FCurrentUpdateBuffer+1);
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := IntAllocRecordBuffer;
|
|
move(RemRec^, FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer^,FRecordSize);
|
|
end
|
|
else
|
|
begin
|
|
if FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind <> ukModify then
|
|
begin
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := nil; //this 'disables' the updatebuffer
|
|
// Do NOT release record buffer (pointed to by RemRecBookmrk.BookmarkData) here
|
|
// - When record is inserted and deleted (and memory released) and again inserted then the same memory block can be returned
|
|
// which leads to confusion, because we get the same BookmarkData for distinct records
|
|
// - In CancelUpdates when records are restored, it is expected that deleted records still exist in memory
|
|
// There also could be record(s) in the update buffer that is linked to this record.
|
|
end;
|
|
end;
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData);
|
|
FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData := RemRecBookmrk;
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukDelete;
|
|
dec(FBRecordCount);
|
|
end;
|
|
|
|
|
|
procedure TZMCustomBufDataset.ApplyRecUpdate(UpdateKind : TUpdateKind);
|
|
|
|
begin
|
|
raise EDatabaseError.Create(SApplyRecNotSupported);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.CancelUpdates;
|
|
var StoreRecBM : TBufBookmark;
|
|
procedure CancelUpdBuffer(var AUpdBuffer : TRecUpdateBuffer);
|
|
var
|
|
TmpBuf : TRecordBuffer;
|
|
StoreUpdBuf : integer;
|
|
Bm : TBufBookmark;
|
|
begin
|
|
with AUpdBuffer do
|
|
begin
|
|
if Not assigned(BookmarkData.BookmarkData) then
|
|
exit;// this is used to exclude buffers which are already handled
|
|
Case UpdateKind of
|
|
ukModify:
|
|
begin
|
|
FCurrentIndex.GotoBookmark(@BookmarkData);
|
|
move(TRecordBuffer(OldValuesBuffer)^,TRecordBuffer(FCurrentIndex.CurrentBuffer)^,FRecordSize);
|
|
FreeRecordBuffer(OldValuesBuffer);
|
|
end;
|
|
ukDelete:
|
|
if (assigned(OldValuesBuffer)) then
|
|
begin
|
|
FCurrentIndex.GotoBookmark(@NextBookmarkData);
|
|
FCurrentIndex.InsertRecordBeforeCurrentRecord(TRecordBuffer(BookmarkData.BookmarkData));
|
|
FCurrentIndex.ScrollBackward;
|
|
move(TRecordBuffer(OldValuesBuffer)^,TRecordBuffer(FCurrentIndex.CurrentBuffer)^,FRecordSize);
|
|
|
|
{for x := length(FUpdateBuffer)-1 downto 0 do
|
|
begin
|
|
if (FUpdateBuffer[x].UpdateKind=ukDelete) and FCurrentIndex.CompareBookmarks(@FUpdateBuffer[x].NextBookmarkData,@BookmarkData) then
|
|
CancelUpdBuffer(FUpdateBuffer[x]);
|
|
end;}
|
|
FreeRecordBuffer(OldValuesBuffer);
|
|
inc(FBRecordCount);
|
|
end ;
|
|
ukInsert:
|
|
begin
|
|
// Process all update buffers linked to this record before this record is removed
|
|
StoreUpdBuf:=FCurrentUpdateBuffer;
|
|
Bm := BookmarkData;
|
|
BookmarkData.BookmarkData:=nil; // Avoid infinite recursion...
|
|
if GetRecordUpdateBuffer(Bm,True,False) then
|
|
begin
|
|
repeat
|
|
if (FCurrentUpdateBuffer<>StoreUpdBuf) then
|
|
CancelUpdBuffer(FUpdateBuffer[FCurrentUpdateBuffer]);
|
|
until not GetRecordUpdateBuffer(Bm,True,True);
|
|
end;
|
|
FCurrentUpdateBuffer:=StoreUpdBuf;
|
|
|
|
FCurrentIndex.GotoBookmark(@Bm);
|
|
TmpBuf:=FCurrentIndex.CurrentRecord;
|
|
// resync won't work if the currentbuffer is freed...
|
|
if FCurrentIndex.CompareBookmarks(@Bm,@StoreRecBM) then with FCurrentIndex do
|
|
begin
|
|
GotoBookmark(@StoreRecBM);
|
|
if ScrollForward = grEOF then
|
|
if ScrollBackward = grBOF then
|
|
ScrollLast; // last record will be removed from index, so move to spare record
|
|
StoreCurrentRecIntoBookmark(@StoreRecBM);
|
|
end;
|
|
RemoveRecordFromIndexes(Bm);
|
|
FreeRecordBuffer(TmpBuf);
|
|
dec(FBRecordCount);
|
|
end;
|
|
end;
|
|
BookmarkData.BookmarkData:=nil;
|
|
end;
|
|
end;
|
|
|
|
var r : Integer;
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
|
|
if Length(FUpdateBuffer) > 0 then
|
|
begin
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(@StoreRecBM);
|
|
for r := Length(FUpdateBuffer) - 1 downto 0 do
|
|
CancelUpdBuffer(FUpdateBuffer[r]);
|
|
|
|
SetLength(FUpdateBuffer,0);
|
|
|
|
FCurrentIndex.GotoBookmark(@StoreRecBM);
|
|
|
|
Resync([]);
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetOnUpdateError(const AValue: TResolverErrorEvent);
|
|
|
|
begin
|
|
FOnUpdateError := AValue;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.ApplyUpdates; // For backward compatibility
|
|
|
|
begin
|
|
ApplyUpdates(0);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.ApplyUpdates(MaxErrors: Integer);
|
|
|
|
var r : Integer;
|
|
FailedCount : integer;
|
|
Response : TResolverResponse;
|
|
StoreCurrRec : TBufBookmark;
|
|
AUpdateErr : EUpdateError;
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(@StoreCurrRec);
|
|
|
|
r := 0;
|
|
FailedCount := 0;
|
|
Response := rrApply;
|
|
DisableControls;
|
|
try
|
|
while (r < Length(FUpdateBuffer)) and (Response <> rrAbort) do
|
|
begin
|
|
// If the record is first inserted and afterwards deleted, do nothing
|
|
if not ((FUpdateBuffer[r].UpdateKind=ukDelete) and not (assigned(FUpdateBuffer[r].OldValuesBuffer))) then
|
|
begin
|
|
FCurrentIndex.GotoBookmark(@FUpdateBuffer[r].BookmarkData);
|
|
// Synchronise the Currentbuffer to the ActiveBuffer
|
|
CurrentRecordToBuffer(ActiveBuffer);
|
|
Response := rrApply;
|
|
try
|
|
ApplyRecUpdate(FUpdateBuffer[r].UpdateKind);
|
|
except
|
|
on E: EDatabaseError do
|
|
begin
|
|
Inc(FailedCount);
|
|
if FailedCount > word(MaxErrors) then Response := rrAbort
|
|
else Response := rrSkip;
|
|
if assigned(FOnUpdateError) then
|
|
begin
|
|
AUpdateErr := EUpdateError.Create(SOnUpdateError,E.Message,0,0,Exception(AcquireExceptionObject));
|
|
FOnUpdateError(Self,Self,AUpdateErr,FUpdateBuffer[r].UpdateKind,Response);
|
|
AUpdateErr.Free;
|
|
if Response in [rrApply, rrIgnore] then dec(FailedCount);
|
|
if Response = rrApply then dec(r);
|
|
end
|
|
else if Response = rrAbort then
|
|
Raise EUpdateError.Create(SOnUpdateError,E.Message,0,0,Exception(AcquireExceptionObject));
|
|
end
|
|
else
|
|
raise;
|
|
end;
|
|
if response in [rrApply, rrIgnore] then
|
|
begin
|
|
FreeRecordBuffer(FUpdateBuffer[r].OldValuesBuffer);
|
|
if FUpdateBuffer[r].UpdateKind = ukDelete then
|
|
FreeRecordBuffer( TRecordBuffer(FUpdateBuffer[r].BookmarkData.BookmarkData));
|
|
FUpdateBuffer[r].BookmarkData.BookmarkData := nil;
|
|
end
|
|
end;
|
|
inc(r);
|
|
end;
|
|
finally
|
|
if FailedCount = 0 then
|
|
MergeChangeLog;
|
|
|
|
InternalGotoBookmark(@StoreCurrRec);
|
|
Resync([]);
|
|
EnableControls;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.MergeChangeLog;
|
|
|
|
var r : Integer;
|
|
|
|
begin
|
|
for r:=0 to length(FUpdateBuffer)-1 do
|
|
if assigned(FUpdateBuffer[r].OldValuesBuffer) then
|
|
FreeMem(FUpdateBuffer[r].OldValuesBuffer);
|
|
SetLength(FUpdateBuffer,0);
|
|
|
|
if assigned(FUpdateBlobBuffers) then for r:=0 to length(FUpdateBlobBuffers)-1 do
|
|
if assigned(FUpdateBlobBuffers[r]) then
|
|
begin
|
|
// update blob buffer is already referenced from record buffer (see InternalPost)
|
|
if FUpdateBlobBuffers[r]^.OrgBufID >= 0 then
|
|
begin
|
|
FreeBlobBuffer(FBlobBuffers[FUpdateBlobBuffers[r]^.OrgBufID]);
|
|
FBlobBuffers[FUpdateBlobBuffers[r]^.OrgBufID] := FUpdateBlobBuffers[r];
|
|
end
|
|
else
|
|
begin
|
|
setlength(FBlobBuffers,length(FBlobBuffers)+1);
|
|
FUpdateBlobBuffers[r]^.OrgBufID := high(FBlobBuffers);
|
|
FBlobBuffers[high(FBlobBuffers)] := FUpdateBlobBuffers[r];
|
|
end;
|
|
end;
|
|
SetLength(FUpdateBlobBuffers,0);
|
|
end;
|
|
|
|
|
|
procedure TZMCustomBufDataset.InternalCancel;
|
|
|
|
Var i : integer;
|
|
|
|
begin
|
|
if assigned(FUpdateBlobBuffers) then for i:=0 to length(FUpdateBlobBuffers)-1 do
|
|
if assigned(FUpdateBlobBuffers[i]) and (FUpdateBlobBuffers[i]^.FieldNo>0) then
|
|
FreeBlobBuffer(FUpdateBlobBuffers[i]);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalPost;
|
|
|
|
Var ABuff : TRecordBuffer;
|
|
i : integer;
|
|
blobbuf : tbufblobfield;
|
|
NullMask : pbyte;
|
|
ABookmark : PBufBookmark;
|
|
|
|
begin
|
|
inherited InternalPost;
|
|
if assigned(FUpdateBlobBuffers) then for i:=0 to length(FUpdateBlobBuffers)-1 do
|
|
if assigned(FUpdateBlobBuffers[i]) and (FUpdateBlobBuffers[i]^.FieldNo>0) then
|
|
begin
|
|
blobbuf.BlobBuffer := FUpdateBlobBuffers[i];
|
|
ABuff := ActiveBuffer;
|
|
NullMask := PByte(ABuff);
|
|
|
|
inc(ABuff,FFieldBufPositions[blobbuf.BlobBuffer^.FieldNo-1]);
|
|
Move(blobbuf, ABuff^, GetFieldSize(FieldDefs[blobbuf.BlobBuffer^.FieldNo-1]));
|
|
if blobbuf.BlobBuffer^.Size = 0 then
|
|
SetFieldIsNull(NullMask, blobbuf.BlobBuffer^.FieldNo-1)
|
|
else
|
|
unSetFieldIsNull(NullMask, blobbuf.BlobBuffer^.FieldNo-1);
|
|
|
|
blobbuf.BlobBuffer^.FieldNo := -1;
|
|
end;
|
|
|
|
if State = dsInsert then
|
|
begin
|
|
if assigned(FAutoIncField) then
|
|
begin
|
|
FAutoIncField.AsInteger := FAutoIncValue;
|
|
inc(FAutoIncValue);
|
|
end;
|
|
// The active buffer is the newly created TDataset record,
|
|
// from which the bookmark is set to the record where the new record should be
|
|
// inserted
|
|
ABookmark := PBufBookmark(ActiveBuffer + FRecordSize);
|
|
// Create the new record buffer
|
|
ABuff := IntAllocRecordBuffer;
|
|
|
|
// Add new record to all active indexes
|
|
for i := 0 to FIndexesCount-1 do
|
|
if (i<>1) or (FIndexes[i]=FCurrentIndex) then
|
|
begin
|
|
if ABookmark^.BookmarkFlag = bfEOF then
|
|
// append (at end)
|
|
FIndexes[i].ScrollLast
|
|
else
|
|
// insert (before current record)
|
|
FIndexes[i].GotoBookmark(ABookmark);
|
|
|
|
FIndexes[i].InsertRecordBeforeCurrentRecord(ABuff);
|
|
// newly inserted record becomes current record
|
|
FIndexes[i].ScrollBackward;
|
|
end;
|
|
|
|
// Link the newly created record buffer to the newly created TDataset record
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(ABookmark);
|
|
ABookmark^.BookmarkFlag := bfInserted;
|
|
|
|
inc(FBRecordCount);
|
|
end
|
|
else
|
|
InternalSetToRecord(ActiveBuffer);
|
|
|
|
// If there is no updatebuffer already, add one
|
|
if not GetActiveRecordUpdateBuffer then
|
|
begin
|
|
// Add a new updatebuffer
|
|
FCurrentUpdateBuffer := length(FUpdateBuffer);
|
|
SetLength(FUpdateBuffer,FCurrentUpdateBuffer+1);
|
|
|
|
// Store a bookmark of the current record into the updatebuffer's bookmark
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
|
|
|
|
if State = dsEdit then
|
|
begin
|
|
// Create an oldvalues buffer with the old values of the record
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := IntAllocRecordBuffer;
|
|
with FCurrentIndex do
|
|
// Move only the real data
|
|
move(CurrentBuffer^,FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer^,FRecordSize);
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukModify;
|
|
end
|
|
else
|
|
begin
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukInsert;
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := nil;
|
|
end;
|
|
end;
|
|
|
|
move(ActiveBuffer^,FCurrentIndex.CurrentBuffer^,FRecordSize);
|
|
|
|
// new data are now in current record so reorder current record if needed
|
|
for i := 1 to FIndexesCount-1 do
|
|
if (i<>1) or (FIndexes[i]=FCurrentIndex) then
|
|
FIndexes[i].OrderCurrentRecord;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.CalcRecordSize;
|
|
|
|
var x : longint;
|
|
|
|
begin
|
|
FNullmaskSize := (FieldDefs.Count+7) div 8;
|
|
{$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
|
|
FNullmaskSize:=Align(FNullmaskSize,4);
|
|
{$ENDIF}
|
|
FRecordSize := FNullmaskSize;
|
|
SetLength(FFieldBufPositions,FieldDefs.count);
|
|
for x := 0 to FieldDefs.count-1 do
|
|
begin
|
|
FFieldBufPositions[x] := FRecordSize;
|
|
inc(FRecordSize, GetFieldSize(FieldDefs[x]));
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetIndexFieldNames: String;
|
|
begin
|
|
if (FIndexesCount=0) or (FCurrentIndex<>FIndexes[1]) then
|
|
result := ''
|
|
else
|
|
result := FCurrentIndex.FieldsName;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetIndexName: String;
|
|
begin
|
|
if FIndexesCount>0 then
|
|
result := FCurrentIndex.Name
|
|
else
|
|
result := '';
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetBufUniDirectional: boolean;
|
|
begin
|
|
result := IsUniDirectional;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader;
|
|
|
|
var APacketReader: TDataPacketReader;
|
|
APacketReaderReg: TDatapacketReaderRegistration;
|
|
|
|
begin
|
|
if GetRegisterDatapacketReader(AStream, format, APacketReaderReg) then
|
|
APacketReader := APacketReaderReg.ReaderClass.Create(Self, AStream)
|
|
else if TFpcBinaryDatapacketReader.RecognizeStream(AStream) then
|
|
begin
|
|
AStream.Seek(0, soFromBeginning);
|
|
APacketReader := TFpcBinaryDatapacketReader.Create(Self, AStream)
|
|
end
|
|
else
|
|
DatabaseError(SStreamNotRecognised);
|
|
Result:=APacketReader;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecordSize : Word;
|
|
|
|
begin
|
|
result := FRecordSize + BookmarkSize;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetChangeCount: integer;
|
|
|
|
begin
|
|
result := length(FUpdateBuffer);
|
|
end;
|
|
|
|
|
|
procedure TZMCustomBufDataset.InternalInitRecord(Buffer: TRecordBuffer);
|
|
|
|
begin
|
|
FillChar(Buffer^, FRecordSize, #0);
|
|
|
|
fillchar(Buffer^,FNullmaskSize,255);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetRecNo(Value: Longint);
|
|
|
|
var
|
|
recnr : integer;
|
|
TmpRecBuffer : PBufRecLinkItem;
|
|
|
|
begin
|
|
CheckBrowseMode;
|
|
if value > RecordCount then
|
|
begin
|
|
repeat until (getnextpacket < FPacketRecords) or (value <= RecordCount) or (FPacketRecords = -1);
|
|
if value > RecordCount then
|
|
begin
|
|
DatabaseError(SNoSuchRecord,self);
|
|
exit;
|
|
end;
|
|
end;
|
|
TmpRecBuffer := (FCurrentIndex as TDoubleLinkedBufIndex).FFirstRecBuf;
|
|
for recnr := 1 to value-1 do
|
|
TmpRecBuffer := TmpRecBuffer[FCurrentIndex.IndNr].next;
|
|
GotoBookmark(@TmpRecBuffer);
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecNo: Longint;
|
|
|
|
Var abuf : TRecordBuffer;
|
|
|
|
begin
|
|
abuf := GetCurrentBuffer;
|
|
// If abuf isn't assigned, the recordset probably isn't opened.
|
|
if assigned(abuf) and (FBRecordCount>0) and (State <> dsInsert) then
|
|
Result:=FCurrentIndex.GetRecNo(PBufBookmark(abuf+FRecordSize))
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.IsCursorOpen: Boolean;
|
|
|
|
begin
|
|
Result := FOpen;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetRecordCount: Longint;
|
|
|
|
begin
|
|
Result := FBRecordCount;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.UpdateStatus: TUpdateStatus;
|
|
|
|
begin
|
|
Result:=usUnmodified;
|
|
if GetActiveRecordUpdateBuffer then
|
|
case FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind of
|
|
ukModify : Result := usModified;
|
|
ukInsert : Result := usInserted;
|
|
ukDelete : Result := usDeleted;
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetNewBlobBuffer : PBlobBuffer;
|
|
|
|
var ABlobBuffer : PBlobBuffer;
|
|
|
|
begin
|
|
setlength(FBlobBuffers,length(FBlobBuffers)+1);
|
|
new(ABlobBuffer);
|
|
fillbyte(ABlobBuffer^,sizeof(ABlobBuffer^),0);
|
|
ABlobBuffer^.OrgBufID := high(FBlobBuffers);
|
|
FBlobBuffers[high(FBlobBuffers)] := ABlobBuffer;
|
|
result := ABlobBuffer;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.GetNewWriteBlobBuffer : PBlobBuffer;
|
|
|
|
var ABlobBuffer : PBlobBuffer;
|
|
|
|
begin
|
|
setlength(FUpdateBlobBuffers,length(FUpdateBlobBuffers)+1);
|
|
new(ABlobBuffer);
|
|
fillbyte(ABlobBuffer^,sizeof(ABlobBuffer^),0);
|
|
FUpdateBlobBuffers[high(FUpdateBlobBuffers)] := ABlobBuffer;
|
|
result := ABlobBuffer;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.FreeBlobBuffer(var ABlobBuffer: PBlobBuffer);
|
|
|
|
begin
|
|
if not Assigned(ABlobBuffer) then Exit;
|
|
FreeMem(ABlobBuffer^.Buffer, ABlobBuffer^.Size);
|
|
Dispose(ABlobBuffer);
|
|
ABlobBuffer := Nil;
|
|
end;
|
|
|
|
{ TBufBlobStream }
|
|
|
|
function TBufBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
|
|
|
|
begin
|
|
Case Origin of
|
|
soFromBeginning : FPosition:=Offset;
|
|
soFromEnd : FPosition:=FBlobBuffer^.Size+Offset;
|
|
soFromCurrent : FPosition:=FPosition+Offset;
|
|
end;
|
|
Result:=FPosition;
|
|
end;
|
|
|
|
|
|
function TBufBlobStream.Read(var Buffer; Count: Longint): Longint;
|
|
|
|
var ptr : pointer;
|
|
|
|
begin
|
|
if FPosition + count > FBlobBuffer^.Size then
|
|
count := FBlobBuffer^.Size-FPosition;
|
|
ptr := FBlobBuffer^.Buffer+FPosition;
|
|
move(ptr^,buffer,count);
|
|
inc(FPosition,count);
|
|
result := count;
|
|
end;
|
|
|
|
function TBufBlobStream.Write(const Buffer; Count: Longint): Longint;
|
|
|
|
var ptr : pointer;
|
|
|
|
begin
|
|
ReAllocMem(FBlobBuffer^.Buffer,FPosition+Count);
|
|
ptr := FBlobBuffer^.Buffer+FPosition;
|
|
move(buffer,ptr^,count);
|
|
inc(FBlobBuffer^.Size,count);
|
|
inc(FPosition,count);
|
|
FModified := True;
|
|
Result := count;
|
|
end;
|
|
|
|
constructor TBufBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
|
|
var bufblob : TBufBlobField;
|
|
|
|
begin
|
|
FField := Field;
|
|
FDataSet := Field.DataSet as TZMCustomBufDataset;
|
|
with FDataSet do
|
|
if Mode = bmRead then
|
|
begin
|
|
if not Field.GetData(@bufblob) then
|
|
DatabaseError(SFieldIsNull);
|
|
if not assigned(bufblob.BlobBuffer) then
|
|
begin
|
|
FBlobBuffer := GetNewBlobBuffer;
|
|
bufblob.BlobBuffer := FBlobBuffer;
|
|
LoadBlobIntoBuffer(FieldDefs[Field.FieldNo-1],@bufblob);
|
|
end
|
|
else
|
|
FBlobBuffer := bufblob.BlobBuffer;
|
|
end
|
|
else if Mode=bmWrite then
|
|
begin
|
|
FBlobBuffer := GetNewWriteBlobBuffer;
|
|
FBlobBuffer^.FieldNo := Field.FieldNo;
|
|
if (Field.GetData(@bufblob)) and assigned(bufblob.BlobBuffer) then
|
|
FBlobBuffer^.OrgBufID := bufblob.BlobBuffer^.OrgBufID
|
|
else
|
|
FBlobBuffer^.OrgBufID := -1;
|
|
FModified := True;
|
|
end;
|
|
end;
|
|
|
|
destructor TBufBlobStream.Destroy;
|
|
begin
|
|
if FModified then
|
|
begin
|
|
// if TBufBlobStream was requested, but no data was written, then Size = 0;
|
|
// used by TBlobField.Clear, so in this case set Field to null in InternalPost
|
|
//FField.Modified := True; // should be set to True, but TBlobField.Modified is never reset
|
|
|
|
if not (FDataSet.State in [dsFilter, dsCalcFields, dsNewValue]) then
|
|
FDataSet.DataEvent(deFieldChange, Ptrint(FField));
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
|
|
|
|
var bufblob : TBufBlobField;
|
|
|
|
begin
|
|
result := nil;
|
|
if Mode = bmRead then
|
|
begin
|
|
if not Field.GetData(@bufblob) then
|
|
exit;
|
|
|
|
result := TBufBlobStream.Create(Field as TBlobField, bmRead);
|
|
end
|
|
else if Mode = bmWrite then
|
|
begin
|
|
if not (State in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
|
|
DatabaseErrorFmt(SNotEditing,[Name],self);
|
|
|
|
result := TBufBlobStream.Create(Field as TBlobField, bmWrite);
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SetDatasetPacket(AReader: TDataPacketReader);
|
|
begin
|
|
FDatasetReader := AReader;
|
|
try
|
|
Open;
|
|
finally
|
|
FDatasetReader := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
|
|
|
|
procedure StoreUpdateBuffer(AUpdBuffer : TRecUpdateBuffer; var ARowState: TRowState);
|
|
var AThisRowState : TRowState;
|
|
AStoreUpdBuf : Integer;
|
|
begin
|
|
if AUpdBuffer.UpdateKind = ukModify then
|
|
begin
|
|
AThisRowState := [rsvOriginal];
|
|
ARowState:=[rsvUpdated];
|
|
end
|
|
else if AUpdBuffer.UpdateKind = ukDelete then
|
|
begin
|
|
AStoreUpdBuf:=FCurrentUpdateBuffer;
|
|
if GetRecordUpdateBuffer(AUpdBuffer.BookmarkData,True,False) then
|
|
begin
|
|
repeat
|
|
if FCurrentIndex.CompareBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData, @AUpdBuffer.BookmarkData) then
|
|
StoreUpdateBuffer(FUpdateBuffer[FCurrentUpdateBuffer], ARowState);
|
|
until not GetRecordUpdateBuffer(AUpdBuffer.BookmarkData,True,True)
|
|
end;
|
|
FCurrentUpdateBuffer:=AStoreUpdBuf;
|
|
AThisRowState := [rsvDeleted];
|
|
end
|
|
else // ie: UpdateKind = ukInsert
|
|
ARowState := [rsvInserted];
|
|
|
|
FFilterBuffer:=AUpdBuffer.OldValuesBuffer;
|
|
// OldValuesBuffer is nil if the record is either inserted or inserted and then deleted
|
|
if assigned(FFilterBuffer) then
|
|
FDatasetReader.StoreRecord(AThisRowState,FCurrentUpdateBuffer);
|
|
end;
|
|
|
|
procedure HandleUpdateBuffersFromRecord(AFirstCall : boolean;ARecBookmark : TBufBookmark; var ARowState: TRowState);
|
|
var StoreUpdBuf1,StoreUpdBuf2 : Integer;
|
|
begin
|
|
if AFirstCall then ARowState:=[];
|
|
if GetRecordUpdateBuffer(ARecBookmark,True,not AFirstCall) then
|
|
begin
|
|
if FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind=ukDelete then
|
|
begin
|
|
StoreUpdBuf1:=FCurrentUpdateBuffer;
|
|
HandleUpdateBuffersFromRecord(False,ARecBookmark,ARowState);
|
|
StoreUpdBuf2:=FCurrentUpdateBuffer;
|
|
FCurrentUpdateBuffer:=StoreUpdBuf1;
|
|
StoreUpdateBuffer(FUpdateBuffer[StoreUpdBuf1], ARowState);
|
|
FCurrentUpdateBuffer:=StoreUpdBuf2;
|
|
end
|
|
else
|
|
begin
|
|
StoreUpdateBuffer(FUpdateBuffer[FCurrentUpdateBuffer], ARowState);
|
|
HandleUpdateBuffersFromRecord(False,ARecBookmark,ARowState);
|
|
end;
|
|
end
|
|
end;
|
|
|
|
var ScrollResult : TGetResult;
|
|
StoreDSState : TDataSetState;
|
|
ABookMark : PBufBookmark;
|
|
ATBookmark : TBufBookmark;
|
|
RowState : TRowState;
|
|
|
|
begin
|
|
FDatasetReader := AWriter;
|
|
try
|
|
// CheckActive;
|
|
ABookMark:=@ATBookmark;
|
|
FDatasetReader.StoreFieldDefs(FAutoIncValue);
|
|
|
|
StoreDSState:=SetTempState(dsFilter);
|
|
ScrollResult:=FCurrentIndex.ScrollFirst;
|
|
while ScrollResult=grOK do
|
|
begin
|
|
RowState:=[];
|
|
FCurrentIndex.StoreCurrentRecIntoBookmark(ABookmark);
|
|
HandleUpdateBuffersFromRecord(True,ABookmark^,RowState);
|
|
FFilterBuffer:=FCurrentIndex.CurrentBuffer;
|
|
if RowState=[] then
|
|
FDatasetReader.StoreRecord([])
|
|
else
|
|
FDatasetReader.StoreRecord(RowState,FCurrentUpdateBuffer);
|
|
|
|
ScrollResult:=FCurrentIndex.ScrollForward;
|
|
if ScrollResult<>grOK then
|
|
begin
|
|
if getnextpacket>0 then
|
|
ScrollResult := FCurrentIndex.ScrollForward;
|
|
end;
|
|
end;
|
|
// There could be an update buffer linked to the last (spare) record
|
|
FCurrentIndex.StoreSpareRecIntoBookmark(ABookmark);
|
|
HandleUpdateBuffersFromRecord(True,ABookmark^,RowState);
|
|
|
|
RestoreState(StoreDSState);
|
|
|
|
FDatasetReader.FinalizeStoreRecords;
|
|
finally
|
|
FDatasetReader := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.LoadFromStream(AStream: TStream; Format: TDataPacketFormat);
|
|
var APacketReader : TDataPacketReader;
|
|
begin
|
|
CheckBiDirectional;
|
|
APacketReader:=GetPacketReader(Format, AStream);
|
|
try
|
|
SetDatasetPacket(APacketReader);
|
|
finally
|
|
APacketReader.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SaveToStream(AStream: TStream; Format: TDataPacketFormat);
|
|
var APacketReaderReg : TDatapacketReaderRegistration;
|
|
APacketWriter : TDataPacketReader;
|
|
begin
|
|
CheckBiDirectional;
|
|
if GetRegisterDatapacketReader(Nil,format,APacketReaderReg) then
|
|
APacketWriter := APacketReaderReg.ReaderClass.Create(Self, AStream)
|
|
else if Format = dfBinary then
|
|
APacketWriter := TFpcBinaryDatapacketReader.Create(Self, AStream)
|
|
else
|
|
DatabaseError(SNoReaderClassRegistered);
|
|
try
|
|
GetDatasetPacket(APacketWriter);
|
|
finally
|
|
APacketWriter.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.LoadFromFile(AFileName: string; Format: TDataPacketFormat);
|
|
var AFileStream : TFileStream;
|
|
begin
|
|
if AFileName='' then AFileName := FFileName;
|
|
AFileStream := TFileStream.Create(AFileName,fmOpenRead);
|
|
try
|
|
LoadFromStream(AFileStream, Format);
|
|
finally
|
|
AFileStream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.SaveToFile(AFileName: string;
|
|
Format: TDataPacketFormat);
|
|
var AFileStream : TFileStream;
|
|
begin
|
|
if AFileName='' then AFileName := FFileName;
|
|
AFileStream := TFileStream.Create(AFileName,fmCreate);
|
|
try
|
|
SaveToStream(AFileStream, Format);
|
|
finally
|
|
AFileStream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.CreateDataset;
|
|
var AStoreFileName: string;
|
|
begin
|
|
CheckInactive;
|
|
if ((FieldCount=0) or (FieldDefs.Count=0)) then
|
|
begin
|
|
if (FieldDefs.Count>0) then
|
|
CreateFields
|
|
else if (Fields.Count>0) then
|
|
begin
|
|
InitFieldDefsFromFields;
|
|
BindFields(True);
|
|
end
|
|
else
|
|
raise Exception.Create(SErrNoFieldsDefined);
|
|
FAutoIncValue:=1;
|
|
end;
|
|
// When a FileName is set, do not read from this file
|
|
AStoreFileName:=FFileName;
|
|
FFileName := '';
|
|
try
|
|
Open;
|
|
finally
|
|
FFileName:=AStoreFileName;
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
|
|
begin
|
|
Result:=assigned(FCurrentIndex) and FCurrentIndex.BookmarkValid(pointer(ABookmark));
|
|
end;
|
|
|
|
function TZMCustomBufDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark
|
|
): Longint;
|
|
begin
|
|
if Assigned(FCurrentIndex) and FCurrentIndex.CompareBookmarks(pointer(Bookmark1),pointer(Bookmark2)) then
|
|
Result := 0
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.IntLoadFielddefsFromFile;
|
|
|
|
begin
|
|
FieldDefs.Clear;
|
|
FDatasetReader.LoadFieldDefs(FAutoIncValue);
|
|
if DefaultFields then
|
|
CreateFields
|
|
else
|
|
BindFields(true);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.IntLoadRecordsFromFile;
|
|
|
|
var StoreState : TDataSetState;
|
|
AddRecordBuffer : boolean;
|
|
ARowState : TRowState;
|
|
AUpdOrder : integer;
|
|
x : integer;
|
|
|
|
begin
|
|
CheckBiDirectional;
|
|
FDatasetReader.InitLoadRecords;
|
|
StoreState:=SetTempState(dsFilter);
|
|
|
|
while FDatasetReader.GetCurrentRecord do
|
|
begin
|
|
ARowState := FDatasetReader.GetRecordRowState(AUpdOrder);
|
|
if rsvOriginal in ARowState then
|
|
begin
|
|
if length(FUpdateBuffer) < (AUpdOrder+1) then
|
|
SetLength(FUpdateBuffer,AUpdOrder+1);
|
|
|
|
FCurrentUpdateBuffer:=AUpdOrder;
|
|
|
|
FFilterBuffer:=IntAllocRecordBuffer;
|
|
fillchar(FFilterBuffer^,FNullmaskSize,0);
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := FFilterBuffer;
|
|
FDatasetReader.RestoreRecord;
|
|
|
|
FDatasetReader.GotoNextRecord;
|
|
if not FDatasetReader.GetCurrentRecord then
|
|
DatabaseError(SStreamNotRecognised);
|
|
ARowState := FDatasetReader.GetRecordRowState(AUpdOrder);
|
|
if rsvUpdated in ARowState then
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind:= ukModify
|
|
else
|
|
DatabaseError(SStreamNotRecognised);
|
|
|
|
FFilterBuffer:=FIndexes[0].SpareBuffer;
|
|
FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
|
|
fillchar(FFilterBuffer^,FNullmaskSize,0);
|
|
|
|
FDatasetReader.RestoreRecord;
|
|
FIndexes[0].AddRecord;
|
|
inc(FBRecordCount);
|
|
|
|
AddRecordBuffer:=False;
|
|
|
|
end
|
|
else if rsvDeleted in ARowState then
|
|
begin
|
|
if length(FUpdateBuffer) < (AUpdOrder+1) then
|
|
SetLength(FUpdateBuffer,AUpdOrder+1);
|
|
|
|
FCurrentUpdateBuffer:=AUpdOrder;
|
|
|
|
FFilterBuffer:=IntAllocRecordBuffer;
|
|
fillchar(FFilterBuffer^,FNullmaskSize,0);
|
|
|
|
FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := FFilterBuffer;
|
|
FDatasetReader.RestoreRecord;
|
|
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind:= ukDelete;
|
|
FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
|
|
FIndexes[0].AddRecord;
|
|
FIndexes[0].RemoveRecordFromIndex(FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
|
|
FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData);
|
|
|
|
for x := FCurrentUpdateBuffer+1 to length(FUpdateBuffer)-1 do
|
|
if Findexes[0].CompareBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData,@FUpdateBuffer[x].NextBookmarkData) then
|
|
FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[x].NextBookmarkData);
|
|
|
|
AddRecordBuffer:=False;
|
|
end
|
|
else
|
|
AddRecordBuffer:=True;
|
|
|
|
if AddRecordBuffer then
|
|
begin
|
|
FFilterBuffer:=FIndexes[0].SpareBuffer;
|
|
fillchar(FFilterBuffer^,FNullmaskSize,0);
|
|
|
|
FDatasetReader.RestoreRecord;
|
|
|
|
if rsvInserted in ARowState then
|
|
begin
|
|
if length(FUpdateBuffer) < (AUpdOrder+1) then
|
|
SetLength(FUpdateBuffer,AUpdOrder+1);
|
|
FCurrentUpdateBuffer:=AUpdOrder;
|
|
FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind:= ukInsert;
|
|
FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
|
|
end;
|
|
|
|
FIndexes[0].AddRecord;
|
|
inc(FBRecordCount);
|
|
end;
|
|
|
|
FDatasetReader.GotoNextRecord;
|
|
end;
|
|
|
|
RestoreState(StoreState);
|
|
FIndexes[0].SetToFirstRecord;
|
|
FAllPacketsFetched:=True;
|
|
if assigned(FFileStream) then
|
|
begin
|
|
FreeAndNil(FFileStream);
|
|
FreeAndNil(FDatasetReader);
|
|
end;
|
|
|
|
// rebuild indexes
|
|
BuildIndexes;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.DoFilterRecord(out Acceptable: Boolean);
|
|
begin
|
|
Acceptable := true;
|
|
// check user filter
|
|
if Assigned(OnFilterRecord) then
|
|
OnFilterRecord(Self, Acceptable);
|
|
|
|
// check filtertext
|
|
if Acceptable and (Length(Filter) > 0) then
|
|
Acceptable := Boolean((FParser.ExtractFromBuffer(GetCurrentBuffer))^);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.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 TZMCustomBufDataset.SetFiltered(Value: Boolean); {override;}
|
|
begin
|
|
if Value = Filtered then
|
|
exit;
|
|
|
|
// pass on to ancestor
|
|
inherited;
|
|
|
|
// only refresh if active
|
|
if IsCursorOpen then
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.InternalRefresh;
|
|
var StoreDefaultFields: boolean;
|
|
begin
|
|
if length(FUpdateBuffer)>0 then
|
|
DatabaseError(SErrApplyUpdBeforeRefresh);
|
|
StoreDefaultFields:=DefaultFields;
|
|
SetDefaultFields(False);
|
|
FreeFieldBuffers;
|
|
ClearBuffers;
|
|
InternalClose;
|
|
BeforeRefreshOpenCursor;
|
|
InternalOpen;
|
|
SetDefaultFields(StoreDefaultFields);
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.BeforeRefreshOpenCursor;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.DataEvent(Event: TDataEvent; Info: Ptrint);
|
|
begin
|
|
if Event = deUpdateState then
|
|
// Save DataSet.State set by DataSet.SetState (filter out State set by DataSet.SetTempState)
|
|
FSavedState := State;
|
|
inherited;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.Fetch: boolean;
|
|
begin
|
|
// Empty procedure to make it possible to use TZMCustomBufDataset as a memory dataset
|
|
Result := False;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.LoadField(FieldDef: TFieldDef; buffer: pointer; out
|
|
CreateBlob: boolean): boolean;
|
|
begin
|
|
// Empty procedure to make it possible to use TZMCustomBufDataset as a memory dataset
|
|
CreateBlob := False;
|
|
Result := False;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.IsReadFromPacket: Boolean;
|
|
begin
|
|
Result := (FDatasetReader<>nil) or (FFileName<>'') or FReadFromFile;
|
|
end;
|
|
|
|
procedure TZMCustomBufDataset.ParseFilter(const AFilter: string);
|
|
begin
|
|
// parser created?
|
|
if Length(AFilter) > 0 then
|
|
begin
|
|
if (FParser = nil) and IsCursorOpen then
|
|
begin
|
|
FParser := TZMBufDatasetParser.Create(Self);
|
|
end;
|
|
// 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;
|
|
|
|
function TZMCustomBufDataset.Locate(const KeyFields: string;
|
|
const KeyValues: Variant; Options: TLocateOptions): boolean;
|
|
|
|
var CurrLinkItem : PBufRecLinkItem;
|
|
bm : TBufBookmark;
|
|
SearchFields : TList;
|
|
DBCompareStruct : TDBCompareStruct;
|
|
StoreDSState : TDataSetState;
|
|
FilterRecord : TRecordBuffer;
|
|
FiltAcceptable : boolean;
|
|
|
|
begin
|
|
// Call inherited to make sure the dataset is bi-directional
|
|
Result := inherited;
|
|
CheckActive;
|
|
if IsEmpty then exit;
|
|
|
|
// Build the DBCompare structure
|
|
SearchFields := TList.Create;
|
|
try
|
|
GetFieldList(SearchFields,KeyFields);
|
|
if SearchFields.Count=0 then exit;
|
|
ProcessFieldsToCompareStruct(SearchFields, nil, nil, [], Options, DBCompareStruct);
|
|
finally
|
|
SearchFields.Free;
|
|
end;
|
|
|
|
// Set the filter buffer
|
|
StoreDSState:=SetTempState(dsFilter);
|
|
FFilterBuffer:=FCurrentIndex.SpareBuffer;
|
|
SetFieldValues(KeyFields,KeyValues);
|
|
FilterRecord:=IntAllocRecordBuffer;
|
|
move(FCurrentIndex.SpareRecord^, FilterRecord^, FRecordSize+BufferOffset);
|
|
|
|
// Iterate through the records until a match is found
|
|
CurrLinkItem := (FCurrentIndex as TDoubleLinkedBufIndex).FFirstRecBuf;
|
|
while (CurrLinkItem <> (FCurrentIndex as TDoubleLinkedBufIndex).FLastRecBuf) do
|
|
begin
|
|
if (IndexCompareRecords(FilterRecord,CurrLinkItem,DBCompareStruct) = 0) then
|
|
begin
|
|
if Filtered then
|
|
begin
|
|
FFilterBuffer:=pointer(CurrLinkItem)+BufferOffset;
|
|
// The dataset state is still dsFilter at this point, so we don't have to set it.
|
|
DoFilterRecord(FiltAcceptable);
|
|
if FiltAcceptable then
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
CurrLinkItem := CurrLinkItem[(FCurrentIndex as TDoubleLinkedBufIndex).IndNr].next;
|
|
if CurrLinkItem = (FCurrentIndex as TDoubleLinkedBufIndex).FLastRecBuf then
|
|
getnextpacket;
|
|
end;
|
|
|
|
RestoreState(StoreDSState);
|
|
FreeRecordBuffer(FilterRecord);
|
|
|
|
// If a match is found, jump to the found record
|
|
if Result then
|
|
begin
|
|
bm.BookmarkData := CurrLinkItem;
|
|
bm.BookmarkFlag := bfCurrent;
|
|
GotoBookmark(@bm);
|
|
end;
|
|
end;
|
|
|
|
function TZMCustomBufDataset.Lookup(const KeyFields: string;
|
|
const KeyValues: Variant; const ResultFields: string): Variant;
|
|
var
|
|
bm:TBookmark;
|
|
begin
|
|
result:=Null;
|
|
bm:=GetBookmark;
|
|
DisableControls;
|
|
try
|
|
if Locate(KeyFields,KeyValues,[]) then
|
|
begin
|
|
// CalculateFields(ActiveBuffer); // not needed, done by Locate more than once
|
|
result:=FieldValues[ResultFields];
|
|
end;
|
|
GotoBookmark(bm);
|
|
FreeBookmark(bm);
|
|
finally
|
|
EnableControls;
|
|
end;
|
|
end;
|
|
|
|
{ TArrayBufIndex }
|
|
|
|
function TArrayBufIndex.GetBookmarkSize: integer;
|
|
begin
|
|
Result:=Sizeof(TBufBookmark);
|
|
end;
|
|
|
|
function TArrayBufIndex.GetCurrentBuffer: Pointer;
|
|
begin
|
|
Result:=TRecordBuffer(FRecordArray[FCurrentRecInd]);
|
|
end;
|
|
|
|
function TArrayBufIndex.GetCurrentRecord: TRecordBuffer;
|
|
begin
|
|
Result:=GetCurrentBuffer;
|
|
end;
|
|
|
|
function TArrayBufIndex.GetIsInitialized: boolean;
|
|
begin
|
|
Result:=Length(FRecordArray)>0;
|
|
end;
|
|
|
|
function TArrayBufIndex.GetSpareBuffer: TRecordBuffer;
|
|
begin
|
|
if FLastRecInd>-1 then
|
|
Result:= TRecordBuffer(FRecordArray[FLastRecInd])
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TArrayBufIndex.GetSpareRecord: TRecordBuffer;
|
|
begin
|
|
Result := GetSpareBuffer;
|
|
end;
|
|
|
|
constructor TArrayBufIndex.Create(const ADataset: TZMCustomBufDataset);
|
|
begin
|
|
Inherited create(ADataset);
|
|
FInitialBuffers:=10000;
|
|
FGrowBuffer:=1000;
|
|
end;
|
|
|
|
function TArrayBufIndex.ScrollBackward: TGetResult;
|
|
begin
|
|
if FCurrentRecInd>0 then
|
|
begin
|
|
dec(FCurrentRecInd);
|
|
Result := grOK;
|
|
end
|
|
else
|
|
Result := grBOF;
|
|
end;
|
|
|
|
function TArrayBufIndex.ScrollForward: TGetResult;
|
|
begin
|
|
if FCurrentRecInd = FLastRecInd-1 then
|
|
result := grEOF
|
|
else
|
|
begin
|
|
Result:=grOK;
|
|
inc(FCurrentRecInd);
|
|
end;
|
|
end;
|
|
|
|
function TArrayBufIndex.GetCurrent: TGetResult;
|
|
begin
|
|
if FLastRecInd=0 then
|
|
Result := grError
|
|
else
|
|
begin
|
|
Result := grOK;
|
|
if FCurrentRecInd = FLastRecInd then
|
|
dec(FCurrentRecInd);
|
|
end;
|
|
end;
|
|
|
|
function TArrayBufIndex.ScrollFirst: TGetResult;
|
|
begin
|
|
FCurrentRecInd:=0;
|
|
if (FCurrentRecInd = FLastRecInd) then
|
|
result := grEOF
|
|
else
|
|
result := grOk;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.ScrollLast;
|
|
begin
|
|
FCurrentRecInd:=FLastRecInd;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.SetToFirstRecord;
|
|
begin
|
|
// if FCurrentRecBuf = FLastRecBuf then the dataset is just opened and empty
|
|
// in which case InternalFirst should do nothing (bug 7211)
|
|
if FCurrentRecInd <> FLastRecInd then
|
|
FCurrentRecInd := -1;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.SetToLastRecord;
|
|
begin
|
|
if FLastRecInd <> 0 then FCurrentRecInd := FLastRecInd;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.StoreCurrentRecord;
|
|
begin
|
|
FStoredRecBuf := FCurrentRecInd;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.RestoreCurrentRecord;
|
|
begin
|
|
FCurrentRecInd := FStoredRecBuf;
|
|
end;
|
|
|
|
function TArrayBufIndex.CanScrollForward: Boolean;
|
|
begin
|
|
Result := (FCurrentRecInd < FLastRecInd-1);
|
|
end;
|
|
|
|
procedure TArrayBufIndex.DoScrollForward;
|
|
begin
|
|
inc(FCurrentRecInd);
|
|
end;
|
|
|
|
procedure TArrayBufIndex.StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark);
|
|
begin
|
|
with ABookmark^ do
|
|
begin
|
|
BookmarkInt := FCurrentRecInd;
|
|
BookmarkData := FRecordArray[FCurrentRecInd];
|
|
end;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark
|
|
);
|
|
begin
|
|
with ABookmark^ do
|
|
begin
|
|
BookmarkInt := FLastRecInd;
|
|
BookmarkData := FRecordArray[FLastRecInd];
|
|
end;
|
|
end;
|
|
|
|
function TArrayBufIndex.GetRecordFromBookmark(ABookMark: TBufBookmark) : integer;
|
|
begin
|
|
// ABookmark.BookMarkBuf is nil if SetRecNo calls GotoBookmark
|
|
if (ABookmark.BookmarkData<>nil) and (FRecordArray[ABookmark.BookmarkInt]<>ABookmark.BookmarkData) then
|
|
begin
|
|
// Start searching two records before the expected record
|
|
if ABookmark.BookmarkInt > 2 then
|
|
Result := ABookmark.BookmarkInt-2
|
|
else
|
|
Result := 0;
|
|
|
|
while (Result<FLastRecInd) do
|
|
begin
|
|
if (FRecordArray[Result] = ABookmark.BookmarkData) then exit;
|
|
inc(Result);
|
|
end;
|
|
|
|
Result:=0;
|
|
while (Result<ABookmark.BookmarkInt) do
|
|
begin
|
|
if (FRecordArray[Result] = ABookmark.BookmarkData) then exit;
|
|
inc(Result);
|
|
end;
|
|
|
|
DatabaseError(SInvalidBookmark)
|
|
end
|
|
else
|
|
Result := ABookmark.BookmarkInt;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.GotoBookmark(const ABookmark : PBufBookmark);
|
|
begin
|
|
FCurrentRecInd:=GetRecordFromBookmark(ABookmark^);
|
|
end;
|
|
|
|
procedure TArrayBufIndex.InitialiseIndex;
|
|
begin
|
|
// FRecordArray:=nil;
|
|
setlength(FRecordArray,FInitialBuffers);
|
|
FCurrentRecInd:=-1;
|
|
FLastRecInd:=-1;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.InitialiseSpareRecord(const ASpareRecord: TRecordBuffer);
|
|
begin
|
|
FLastRecInd := 0;
|
|
// FCurrentRecInd := 0;
|
|
FRecordArray[0] := ASpareRecord;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.ReleaseSpareRecord;
|
|
begin
|
|
SetLength(FRecordArray,FInitialBuffers);
|
|
end;
|
|
|
|
function TArrayBufIndex.GetRecNo(const ABookmark: PBufBookmark): integer;
|
|
begin
|
|
Result := GetRecordFromBookmark(ABookmark^)+1;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.InsertRecordBeforeCurrentRecord(const ARecord: TRecordBuffer);
|
|
begin
|
|
inc(FLastRecInd);
|
|
if FLastRecInd >= length(FRecordArray) then
|
|
SetLength(FRecordArray,length(FRecordArray)+FGrowBuffer);
|
|
|
|
Move(FRecordArray[FCurrentRecInd],FRecordArray[FCurrentRecInd+1],sizeof(Pointer)*(FLastRecInd-FCurrentRecInd));
|
|
FRecordArray[FCurrentRecInd]:=ARecord;
|
|
inc(FCurrentRecInd);
|
|
end;
|
|
|
|
procedure TArrayBufIndex.RemoveRecordFromIndex(const ABookmark : TBufBookmark);
|
|
var ARecordInd : integer;
|
|
begin
|
|
ARecordInd:=GetRecordFromBookmark(ABookmark);
|
|
Move(FRecordArray[ARecordInd+1],FRecordArray[ARecordInd],sizeof(Pointer)*(FLastRecInd-ARecordInd));
|
|
dec(FLastRecInd);
|
|
end;
|
|
|
|
procedure TArrayBufIndex.BeginUpdate;
|
|
begin
|
|
// inherited BeginUpdate;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.AddRecord;
|
|
var ARecord: TRecordBuffer;
|
|
begin
|
|
ARecord := FDataset.IntAllocRecordBuffer;
|
|
inc(FLastRecInd);
|
|
if FLastRecInd >= length(FRecordArray) then
|
|
SetLength(FRecordArray,length(FRecordArray)+FGrowBuffer);
|
|
FRecordArray[FLastRecInd]:=ARecord;
|
|
end;
|
|
|
|
procedure TArrayBufIndex.EndUpdate;
|
|
begin
|
|
// inherited EndUpdate;
|
|
end;
|
|
|
|
|
|
{ TDataPacketReader }
|
|
|
|
class function TDataPacketReader.RowStateToByte(const ARowState: TRowState
|
|
): byte;
|
|
var RowStateInt : Byte;
|
|
begin
|
|
RowStateInt:=0;
|
|
if rsvOriginal in ARowState then RowStateInt := RowStateInt+1;
|
|
if rsvDeleted in ARowState then RowStateInt := RowStateInt+2;
|
|
if rsvInserted in ARowState then RowStateInt := RowStateInt+4;
|
|
if rsvUpdated in ARowState then RowStateInt := RowStateInt+8;
|
|
Result := RowStateInt;
|
|
end;
|
|
|
|
class function TDataPacketReader.ByteToRowState(const AByte: Byte): TRowState;
|
|
begin
|
|
result := [];
|
|
if (AByte and 1)=1 then Result := Result+[rsvOriginal];
|
|
if (AByte and 2)=2 then Result := Result+[rsvDeleted];
|
|
if (AByte and 4)=4 then Result := Result+[rsvInserted];
|
|
if (AByte and 8)=8 then Result := Result+[rsvUpdated];
|
|
end;
|
|
|
|
procedure TDataPacketReader.RestoreBlobField(AField: TField; ASource: pointer; ASize: integer);
|
|
var
|
|
ABufBlobField: TBufBlobField;
|
|
begin
|
|
ABufBlobField.BlobBuffer:=FDataSet.GetNewBlobBuffer;
|
|
ABufBlobField.BlobBuffer^.Size:=ASize;
|
|
ReAllocMem(ABufBlobField.BlobBuffer^.Buffer, ASize);
|
|
move(ASource^, ABufBlobField.BlobBuffer^.Buffer^, ASize);
|
|
AField.SetData(@ABufBlobField);
|
|
end;
|
|
|
|
constructor TDataPacketReader.Create(ADataSet: TZMCustomBufDataset; AStream: TStream);
|
|
begin
|
|
FDataSet := ADataSet;
|
|
FStream := AStream;
|
|
end;
|
|
|
|
|
|
{ TFpcBinaryDatapacketReader }
|
|
|
|
constructor TFpcBinaryDatapacketReader.Create(ADataSet: TZMCustomBufDataset; AStream: TStream);
|
|
begin
|
|
inherited;
|
|
FVersion := 20; // default version 2.0
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.LoadFieldDefs(var AnAutoIncValue: integer);
|
|
|
|
var FldCount : word;
|
|
i : integer;
|
|
s : string;
|
|
|
|
begin
|
|
// Identify version
|
|
SetLength(s, 13);
|
|
if (Stream.Read(s[1], 13) = 13) then
|
|
case s of
|
|
FpcBinaryIdent1:
|
|
FVersion := 10;
|
|
FpcBinaryIdent2:
|
|
FVersion := Stream.ReadByte;
|
|
else
|
|
DatabaseError(SStreamNotRecognised);
|
|
end;
|
|
|
|
// Read FieldDefs
|
|
FldCount := Stream.ReadWord;
|
|
DataSet.FieldDefs.Clear;
|
|
for i := 0 to FldCount - 1 do with TFieldDef.Create(DataSet.FieldDefs) do
|
|
begin
|
|
Name := Stream.ReadAnsiString;
|
|
Displayname := Stream.ReadAnsiString;
|
|
Size := Stream.ReadWord;
|
|
DataType := TFieldType(Stream.ReadWord);
|
|
|
|
if Stream.ReadByte = 1 then
|
|
Attributes := Attributes + [faReadonly];
|
|
end;
|
|
Stream.ReadBuffer(i,sizeof(i));
|
|
AnAutoIncValue := i;
|
|
|
|
FNullBitmapSize := (FldCount + 7) div 8;
|
|
SetLength(FNullBitmap, FNullBitmapSize);
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.StoreFieldDefs(AnAutoIncValue: integer);
|
|
var i : integer;
|
|
begin
|
|
Stream.Write(FpcBinaryIdent2[1], length(FpcBinaryIdent2));
|
|
Stream.WriteByte(FVersion);
|
|
|
|
Stream.WriteWord(DataSet.FieldDefs.Count);
|
|
for i := 0 to DataSet.FieldDefs.Count - 1 do with DataSet.FieldDefs[i] do
|
|
begin
|
|
Stream.WriteAnsiString(Name);
|
|
Stream.WriteAnsiString(DisplayName);
|
|
Stream.WriteWord(Size);
|
|
Stream.WriteWord(ord(DataType));
|
|
|
|
if faReadonly in Attributes then
|
|
Stream.WriteByte(1)
|
|
else
|
|
Stream.WriteByte(0);
|
|
end;
|
|
i := AnAutoIncValue;
|
|
Stream.WriteBuffer(i,sizeof(i));
|
|
|
|
FNullBitmapSize := (DataSet.FieldDefs.Count + 7) div 8;
|
|
SetLength(FNullBitmap, FNullBitmapSize);
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.InitLoadRecords;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
function TFpcBinaryDatapacketReader.GetCurrentRecord: boolean;
|
|
var Buf : byte;
|
|
begin
|
|
Result := (Stream.Read(Buf,1)=1) and (Buf=$fe);
|
|
end;
|
|
|
|
function TFpcBinaryDatapacketReader.GetRecordRowState(out AUpdOrder : Integer) : TRowState;
|
|
var Buf : byte;
|
|
begin
|
|
Stream.Read(Buf,1);
|
|
Result := ByteToRowState(Buf);
|
|
if Result<>[] then
|
|
Stream.ReadBuffer(AUpdOrder,sizeof(integer))
|
|
else
|
|
AUpdOrder := 0;
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.GotoNextRecord;
|
|
begin
|
|
// Do Nothing
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.RestoreRecord;
|
|
var
|
|
AField: TField;
|
|
i: integer;
|
|
L: cardinal;
|
|
B: TBytes;
|
|
begin
|
|
with DataSet do
|
|
case FVersion of
|
|
10:
|
|
Stream.ReadBuffer(GetCurrentBuffer^, FRecordSize); // Ugly because private members of ADataset are used...
|
|
20:
|
|
begin
|
|
// Restore field's Null bitmap
|
|
Stream.ReadBuffer(FNullBitmap[0], FNullBitmapSize);
|
|
// Restore field's data
|
|
for i:=0 to FieldDefs.Count-1 do
|
|
begin
|
|
AField := Fields.FieldByNumber(FieldDefs[i].FieldNo);
|
|
if AField=nil then continue;
|
|
if GetFieldIsNull(PByte(FNullBitmap), i) then
|
|
AField.SetData(nil)
|
|
else if AField.DataType in StringFieldTypes then
|
|
AField.AsString := Stream.ReadAnsiString
|
|
else
|
|
begin
|
|
if AField.DataType in VarLenFieldTypes then
|
|
L := Stream.ReadDWord
|
|
else
|
|
L := AField.DataSize;
|
|
SetLength(B, L);
|
|
if L > 0 then
|
|
Stream.ReadBuffer(B[0], L);
|
|
if AField.DataType in BlobFieldTypes then
|
|
RestoreBlobField(AField, @B[0], L)
|
|
else
|
|
AField.SetData(@B[0], False); // set it to the FilterBuffer
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.StoreRecord(ARowState: TRowState; AUpdOrder : integer);
|
|
var
|
|
AField: TField;
|
|
i: integer;
|
|
L: cardinal;
|
|
B: TBytes;
|
|
begin
|
|
// Record header
|
|
Stream.WriteByte($fe);
|
|
Stream.WriteByte(RowStateToByte(ARowState));
|
|
if ARowState<>[] then
|
|
Stream.WriteBuffer(AUpdOrder,sizeof(integer));
|
|
|
|
// Record data
|
|
with DataSet do
|
|
case FVersion of
|
|
10:
|
|
Stream.WriteBuffer(GetCurrentBuffer^, FRecordSize); // Old 1.0 version
|
|
20:
|
|
begin
|
|
// store fields Null bitmap
|
|
FillByte(FNullBitmap[0], FNullBitmapSize, 0);
|
|
for i:=0 to FieldDefs.Count-1 do
|
|
begin
|
|
AField := Fields.FieldByNumber(FieldDefs[i].FieldNo);
|
|
if assigned(AField) and AField.IsNull then
|
|
SetFieldIsNull(PByte(FNullBitmap), i);
|
|
end;
|
|
Stream.WriteBuffer(FNullBitmap[0], FNullBitmapSize);
|
|
|
|
for i:=0 to FieldDefs.Count-1 do
|
|
begin
|
|
AField := Fields.FieldByNumber(FieldDefs[i].FieldNo);
|
|
if not assigned(AField) or AField.IsNull then continue;
|
|
if AField.DataType in StringFieldTypes then
|
|
Stream.WriteAnsiString(AField.AsString)
|
|
else
|
|
begin
|
|
B := AField.AsBytes;
|
|
L := length(B);
|
|
if AField.DataType in VarLenFieldTypes then
|
|
Stream.WriteDWord(L);
|
|
if L > 0 then
|
|
Stream.WriteBuffer(B[0], L);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TFpcBinaryDatapacketReader.FinalizeStoreRecords;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
class function TFpcBinaryDatapacketReader.RecognizeStream(AStream: TStream): boolean;
|
|
var s : string;
|
|
begin
|
|
SetLength(s, 13);
|
|
if (AStream.Read(s[1], 13) = 13) then
|
|
case s of
|
|
FpcBinaryIdent1,
|
|
FpcBinaryIdent2:
|
|
Result := True;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
{ TUniDirectionalBufIndex }
|
|
|
|
function TUniDirectionalBufIndex.GetBookmarkSize: integer;
|
|
begin
|
|
// In principle there are no bookmarks, and the size should be 0.
|
|
// But there is quite some code in TZMCustomBufDataset that relies on
|
|
// an existing bookmark of the TBufBookmark type.
|
|
// This code could be moved to the TBufIndex but that would make things
|
|
// more complicated and probably slower. So use a 'fake' bookmark of
|
|
// size TBufBookmark.
|
|
// When there are other TBufIndexes which also need special bookmark code
|
|
// this can be adapted.
|
|
Result:=sizeof(TBufBookmark);
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetCurrentBuffer: Pointer;
|
|
begin
|
|
result := FSPareBuffer;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetCurrentRecord: TRecordBuffer;
|
|
begin
|
|
// Result:=inherited GetCurrentRecord;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetIsInitialized: boolean;
|
|
begin
|
|
Result := Assigned(FSPareBuffer);
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetSpareBuffer: TRecordBuffer;
|
|
begin
|
|
result := FSPareBuffer;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetSpareRecord: TRecordBuffer;
|
|
begin
|
|
result := FSPareBuffer;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.ScrollBackward: TGetResult;
|
|
begin
|
|
result := grError;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.ScrollForward: TGetResult;
|
|
begin
|
|
result := grOk;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetCurrent: TGetResult;
|
|
begin
|
|
result := grOk;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.ScrollFirst: TGetResult;
|
|
begin
|
|
Result:=grError;
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.ScrollLast;
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.SetToFirstRecord;
|
|
begin
|
|
// for UniDirectional datasets should be [Internal]First valid method call
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.SetToLastRecord;
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.StoreCurrentRecord;
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.RestoreCurrentRecord;
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.CanScrollForward: Boolean;
|
|
begin
|
|
// should return true if next record is already fetched
|
|
result := false;
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.DoScrollForward;
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.StoreCurrentRecIntoBookmark(const ABookmark: PBufBookmark);
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark);
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.GotoBookmark(const ABookmark: PBufBookmark);
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.InitialiseIndex;
|
|
begin
|
|
// do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.InitialiseSpareRecord(const ASpareRecord: TRecordBuffer);
|
|
begin
|
|
FSPareBuffer:=ASpareRecord;
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.ReleaseSpareRecord;
|
|
begin
|
|
FSPareBuffer:=nil;
|
|
end;
|
|
|
|
function TUniDirectionalBufIndex.GetRecNo(const ABookmark: PBufBookmark): integer;
|
|
begin
|
|
result := -1;
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.BeginUpdate;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.AddRecord;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.InsertRecordBeforeCurrentRecord(const ARecord: TRecordBuffer);
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.RemoveRecordFromIndex(const ABookmark: TBufBookmark);
|
|
begin
|
|
DatabaseError(SUniDirectional);
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.OrderCurrentRecord;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
procedure TUniDirectionalBufIndex.EndUpdate;
|
|
begin
|
|
// Do nothing
|
|
end;
|
|
|
|
|
|
initialization
|
|
setlength(RegisteredDatapacketReaders,0);
|
|
finalization
|
|
setlength(RegisteredDatapacketReaders,0);
|
|
end.
|