4649 lines
144 KiB
ObjectPascal
4649 lines
144 KiB
ObjectPascal
unit uDAMemDataset;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ Data Abstract Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 6 and up }
|
|
{ platform: Win32 }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the Data Abstract }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I DataAbstract.inc}
|
|
|
|
interface
|
|
{.$DEFINE MEMDATASET_DEBUG}
|
|
{$DEFINE CHECK_RANGE}
|
|
{$DEFINE USE_REALLOC}
|
|
// defer to .XX
|
|
{.$DEFINE MEM_PACKETRECORDS}
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}Windows,{$ENDIF}
|
|
Classes, DB, uDAExpressionEvaluator;
|
|
|
|
type
|
|
{$IFDEF DELPHI2008UP}
|
|
Dataset_PAnsiChar = PByte;
|
|
{$ELSE}
|
|
Dataset_PAnsiChar = PAnsiChar;
|
|
{$ENDIF}
|
|
|
|
|
|
{$IFDEF DELPHI2008UP}
|
|
TMemBookmarkData = TBookmarkData;
|
|
{$ELSE}
|
|
TMemBookmarkData = TBookmarkStr;
|
|
{$ENDIF}
|
|
|
|
TDAMemoryDataset = class;
|
|
PBookmarkData = ^TBookmarkData;
|
|
TBookmarkData = Pointer;
|
|
PRecInfo = ^TRecInfo;
|
|
TRecInfo = packed record
|
|
Bookmark: TBookmarkData;
|
|
BookmarkFlag: TBookmarkFlag;
|
|
end;
|
|
|
|
TOffsetArray = array of Cardinal;
|
|
PBLOBRecord = ^TBLOBRecord;
|
|
TBLOBRecord = packed record
|
|
size: Cardinal;
|
|
Data: WideChar;
|
|
end;
|
|
|
|
TSortRecord = record
|
|
data: PAnsiChar;
|
|
position: integer;
|
|
end;
|
|
|
|
PSortRecordList = ^TSortRecordList;
|
|
TSortRecordList = array[0..MaxListSize - 1] of TSortRecord;
|
|
|
|
// these operators are used in Assign and go beyond simply copying
|
|
// mlaCopy = dest becomes a copy of the source
|
|
// mlaAnd = intersection of the two lists
|
|
// mlaOr = union of the two lists
|
|
// mlaXor = only those not in both lists
|
|
// the last two operators can actually be thought of as binary operators but
|
|
// their implementation has been optimized over their binary equivalent.
|
|
// mlaSrcUnique = only those unique to source (same as mlaAnd followed by mlaXor)
|
|
// mlaDestUnique = only those unique to dest (same as mlaOr followed by mlaXor)
|
|
TMemListAssignOp = (mlaCopy, mlaAnd, mlaOr, mlaXor, mlaSrcUnique, mlaDestUnique);
|
|
|
|
TMemList = class(TObject)
|
|
private
|
|
FList: PPointerList;
|
|
FSortList:PSortRecordList;
|
|
FCount: Integer;
|
|
FCapacity: Integer;
|
|
FNeedRefresh: boolean;
|
|
procedure QuickSort(L, R: Integer);
|
|
procedure Sort;
|
|
function intIndexOf(Item: PAnsiChar): Integer;
|
|
protected
|
|
function Get(Index: Integer): Pointer;
|
|
procedure Grow; virtual;
|
|
procedure Put(Index: Integer; Item: Pointer);
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
procedure SetCount(NewCount: Integer);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add(Item: Pointer): Integer;
|
|
procedure Clear; virtual;
|
|
procedure Delete(Index: Integer);
|
|
class procedure Error(const Msg: string; Data: Integer); overload; virtual;
|
|
class procedure Error(Msg: PResStringRec; Data: Integer); overload;
|
|
procedure Exchange(Index1, Index2: Integer);
|
|
function Expand: TMemList;
|
|
function Extract(Item: Pointer): Pointer;
|
|
function First: Pointer;
|
|
function IndexOf(Item: Pointer): Integer;
|
|
procedure Insert(Index: Integer; Item: Pointer);
|
|
function Last: Pointer;
|
|
procedure Move(CurIndex, NewIndex: Integer);
|
|
function Remove(Item: Pointer): Integer;
|
|
procedure Pack;
|
|
procedure Assign(ListA: TMemList; AOperator: TMemListAssignOp = mlaCopy; ListB: TMemList = nil);
|
|
property Capacity: Integer read FCapacity write SetCapacity;
|
|
property Count: Integer read FCount write SetCount;
|
|
property Items[Index: Integer]: Pointer read Get write Put; default;
|
|
property List: PPointerList read FList;
|
|
end;
|
|
|
|
TThreadMemList = class
|
|
private
|
|
FList: TMemList;
|
|
FLock: TRTLCriticalSection;
|
|
FReadLock: Integer;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Add(Item: Pointer);
|
|
procedure Clear;
|
|
function LockListForReading: TMemList;
|
|
function LockListForWriting: TMemList;
|
|
procedure Remove(Item: Pointer);
|
|
procedure UnlockListForReading;
|
|
procedure UnlockListForWriting;
|
|
end;
|
|
|
|
TMemDataSetNotification = (mdnInsert, mdnModify, mdnDelete, mdnBatchAdding);
|
|
|
|
TDAValueStruct = packed record
|
|
Value: variant;
|
|
AsAnsiString: AnsiString;
|
|
AsWideString: WideString;
|
|
end;
|
|
|
|
TMemKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart, kiCurRangeEnd, kiSave);
|
|
|
|
PMemKeyBuffer = ^TMemKeyBuffer;
|
|
TMemKeyBuffer = record
|
|
Modified: Boolean;
|
|
Exclusive: Boolean;
|
|
FieldCount: Integer;
|
|
Data: record end; // native bin2 format
|
|
end;
|
|
|
|
{$IFDEF BDS4UP}{$REGION 'MEM_PACKETRECORDS'}{$ENDIF BDS4UP}
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
|
|
TMemPackedRecords = class;
|
|
|
|
TMemPackedRecord = class
|
|
private
|
|
fBuffer: PAnsiChar;
|
|
FOwner: TMemPackedRecords;
|
|
function GetValues(Index: Integer): Variant;
|
|
procedure SetValues(Index: Integer; const Value: Variant);
|
|
function GetIsNull(Index: Integer): Boolean;
|
|
procedure SetIsNull(Index: Integer; const Value: Boolean);
|
|
function GetValuesByFieldName(AName: string): Variant;
|
|
procedure SetValuesByFieldName(AName: string; const Value: Variant);
|
|
public
|
|
constructor Create(AOwner: TMemPackedRecords);
|
|
destructor Destroy; override;
|
|
property isNull[Index: Integer]: Boolean read GetIsNull write SetIsNull;
|
|
property Values[Index: Integer]: Variant read GetValues write SetValues;
|
|
property ValuesByFieldName[AName: string]: Variant read GetValuesByFieldName write SetValuesByFieldName;
|
|
end;
|
|
|
|
TMemPackedRecords = class
|
|
private
|
|
fOwner: TDAMemoryDataset;
|
|
fList: TList;
|
|
function GetCount: Integer;
|
|
function GetItems(Index: Integer): TMemPackedRecord;
|
|
public
|
|
constructor Create(AOwner: TDAMemoryDataset);
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
function Add: TMemPackedRecord;
|
|
procedure Delete(aIndex: integer);
|
|
property Items[Index: Integer]: TMemPackedRecord read GetItems;
|
|
property Count: Integer read GetCount;
|
|
end;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
|
|
{$IFDEF BDS4UP}{$ENDREGION}{$ENDIF BDS4UP}
|
|
TDAMemIndex = class
|
|
private
|
|
FOwner: TDAMemoryDataset;
|
|
FSortDescMode: Boolean;
|
|
FIndexCaseInsList: TList;
|
|
FIndexDescFields: TList;
|
|
FIndexFieldNameList: TList;
|
|
FDataList: TMemList;
|
|
FInitFromIndexDef: Boolean;
|
|
FLastSorted: TDateTime;
|
|
FIndexDef_Options: TIndexOptions;
|
|
FIndexDef_Fields: string;
|
|
FIndexDef_DescFields: string;
|
|
FIndexDef_CaseInsFields: String;
|
|
FInit_FieldNames: String;
|
|
FInit_CaseInsFields: String;
|
|
FInit_DescFields: String;
|
|
procedure Init(const AFieldNames: string; const CaseInsFields: string = ''; const DescFields: string='');overload;
|
|
procedure Init(const Fields: string; CaseInsensitive, Descending: Boolean);overload;
|
|
procedure Init(AIndexDef: TIndexDef); overload;
|
|
function GetDataList: TMemList;
|
|
procedure Clear;
|
|
function IsValid: boolean;
|
|
procedure UpdateIndex(AIndexDef: TIndexDef);
|
|
function isCanUsed(const Fields: string; CaseInsensitive: Boolean): boolean;
|
|
property IndexFieldNameList: TList read FIndexFieldNameList;
|
|
property IndexCaseInsList: TList read FIndexCaseInsList;
|
|
property IndexDescFields: TList read FIndexDescFields;
|
|
property SortDescMode : Boolean read FSortDescMode;
|
|
property DataList: TMemList read GetDataList;
|
|
property LastSorted: TDateTime read FLastSorted write FLastSorted;
|
|
public
|
|
constructor Create(AOwner: TDAMemoryDataset);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
PMemLocateStruct = ^TMemLocateStruct;
|
|
TMemLocateStruct = record
|
|
lWorkList: TMemList;
|
|
lFields: TList;
|
|
lFieldIndexes: array of integer;
|
|
lOffsets: array of cardinal;
|
|
lValues: array of TDAValueStruct;
|
|
lDatatypes: array of TFieldType;
|
|
lnull: array of boolean;
|
|
ldesc: array of boolean;
|
|
lcaseIns: array of boolean;
|
|
end;
|
|
|
|
TmrMode = (mrEmpty, mrBin2Style, mrBin3Style);
|
|
|
|
{BitMask: AnsiChar;
|
|
offsetDataSize: byte;
|
|
case integer of
|
|
1:( byteOffset: array [0..0] of byte);
|
|
2:( WordOffset: array [0..0] of word);
|
|
4:( CardinalOffset: array [0..0] of Cardinal);
|
|
}
|
|
PMemDatasetrecord_Native = ^TMemDatasetrecord_Native;
|
|
TMemDatasetrecord_Native = packed record
|
|
Ident: TmrMode;
|
|
Data: Dataset_PAnsiChar;
|
|
end;
|
|
|
|
PMemDatasetrecord = ^TMemDatasetrecord;
|
|
TMemDatasetrecord = packed record
|
|
Ident: TmrMode;
|
|
Data: Dataset_PAnsiChar;
|
|
BookmarkData: TRecInfo;
|
|
CalcData: byte;
|
|
// FBookMarkOffset := FNativeRecordSize;
|
|
// FCalculatedOffset := FBookMarkOffset + SizeOf(TRecInfo);
|
|
// FDatasetBufferSize := FCalculatedOffset + CalcFieldsSize;
|
|
end;
|
|
|
|
TMemLocateCompare = function (buf1: pointer; aValue:TDAValueStruct; aDataType: TFieldType;aSortCaseInsensitive:Boolean; abin2: boolean): boolean of Object;
|
|
TDAMemDatasetCompare = function(p1, p2: PMemDatasetrecord_Native; AIndex: TDAMemIndex): Integer of object;
|
|
|
|
{ TDAMemoryDataset }
|
|
TDAMemoryDataset = class(TDataset)
|
|
private
|
|
FRecordsList: TThreadMemList;
|
|
FDataList: TMemList;
|
|
FRecordPos: integer;
|
|
FActive: Boolean;
|
|
FOffsets: TOffsetArray; // FOffset[0] = FNullMask
|
|
FDataSizeArray:TOffsetArray;
|
|
FNativeRecordSize: Cardinal;
|
|
// FBookMarkOffset: Integer; // = FNativeRecordSize
|
|
// FCalculatedOffset: Integer; // FBookMarkOffset + BookMark data size
|
|
FDatasetBufferSize: Cardinal; // FCalculatedOffset+ Calc fields size
|
|
FNullMaskSize: Cardinal;
|
|
FMasterDataLink: TMasterDataLink;
|
|
FFilterBuffer: Dataset_PAnsiChar;
|
|
FIndexName: string;
|
|
FDataTypeArray: array of TFieldType;
|
|
FStoreStringsAsReference: boolean;
|
|
FExpressionEvaluator: TDAExpressionEvaluator;
|
|
FExpressionBuffer: PMemDatasetrecord_Native;
|
|
{$IFDEF MSWINDOWS}
|
|
FSortLocale: LCID;
|
|
{$ENDIF MSWINDOWS}
|
|
FFieldsIndex: Boolean;
|
|
FIndexDefs: TIndexDefs;
|
|
FCloneSource: TDAMemoryDataset;
|
|
FCloneClientList:TThreadList;
|
|
FReadOnly: Boolean;
|
|
FDetailFields: string;
|
|
FDetailsFieldNameList: TList;
|
|
FRangeActive: boolean;
|
|
fUseIndexinLocate: Boolean;
|
|
// FNeedRefreshIndexConditional: Boolean;
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
fPackedMode: Boolean;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
FHasReferencedFields: boolean;
|
|
FLastUpdate: TDateTime;
|
|
f_DefaultIndexRecord: TDAMemIndex;
|
|
FIndexList: TList;
|
|
FAutoCompactRecords: Boolean;
|
|
procedure ConvertBin3ToBin2Record(Buffer: PMemDatasetrecord_Native);
|
|
procedure ConvertBin2ToBin3Record(ASource : PMemDatasetrecord_Native);
|
|
function Bin2ToBin3(ASource: Dataset_PAnsiChar): Dataset_PAnsiChar;
|
|
function CalcFieldLen(aDataType: TFieldType; aSize: Integer): integer;
|
|
procedure CalculateOffsets;
|
|
procedure ClearRecords;
|
|
procedure ClearFieldByFieldType(FieldBuffer: pointer; ADataType: TFieldType);
|
|
procedure ClearBin2Field(Buffer: Dataset_PAnsiChar; AField: TField);
|
|
function IsReferencedField(ADataType: TFieldType):Boolean;
|
|
function GetNullMask(Buffer: Dataset_PAnsiChar; const AIndex: Integer): boolean;
|
|
function IntFindRecordID(Buf: pointer): Integer;
|
|
function GetActiveRecBuf(var RecBuf: Dataset_PAnsiChar): Boolean;
|
|
procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
|
|
procedure IntAssignRecord(Source, Dest: PMemDatasetrecord_Native);
|
|
procedure SetBlobData(Field: TField; Buffer: PMemDatasetrecord_Native; Value: PBLOBRecord);
|
|
function GetMasterFields: string;
|
|
procedure SetDataSource(const Value: TDataSource);
|
|
procedure SetMasterFields(const Value: string);
|
|
function GetIndexFieldNames: string;
|
|
procedure SetIndexFieldNames(const Value: string);
|
|
function InternalGetRecord(Buffer: PMemDatasetRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult;
|
|
procedure DoSort(AIndex: TDAMemIndex);
|
|
procedure QuickSort(L, R: Integer; SCompare: TDAMemDatasetCompare; AIndex: TDAMemIndex);
|
|
function Compare(i1, i2: PMemDatasetrecord_Native;AIndex: TDAMemIndex): Integer;
|
|
function CompareValues(buf1, buf2: pointer; aDataType: TFieldType;aSortCaseInsensitive:Boolean; aBin2_1, aBin2_2: Boolean): integer;
|
|
function CompareValues2(buf1: pointer; aValue: TDAValueStruct; aDataType: TFieldType;aSortCaseInsensitive:Boolean; aBin2: boolean): integer;
|
|
function CompareValues2_full(buf1: pointer; aValue: TDAValueStruct; aDataType: TFieldType;aSortCaseInsensitive:Boolean; abin2: boolean): boolean;
|
|
function CompareValues2_partial(buf1: pointer; aValue: TDAValueStruct; aDataType: TFieldType;aSortCaseInsensitive: Boolean; abin2: boolean): boolean;
|
|
function CompareValues_Range(buf: PMemDatasetrecord_Native; keybuffer: PMemKeyBuffer): integer;
|
|
procedure DoFilterRecords;
|
|
function ApplyMasterFilter: boolean;
|
|
procedure ApplyRangeFilter;
|
|
function FilterRecord(buf: PMemDatasetrecord_Native; AUseEvent: Boolean):Boolean;
|
|
procedure SetStoreStringAsReference(const Value: Boolean);
|
|
procedure EEGetValue(Sender: TDAExpressionEvaluator; const aIdentifier: string; out aValue: Variant);
|
|
function GetVarValueFromBuffer(Buffer: pointer; Field: TField;abin2: boolean):variant;
|
|
function IsActiveFilter: Boolean;
|
|
function GetIndexDefs: TIndexDefs;
|
|
procedure SetIndexDefs(const Value: TIndexDefs);
|
|
function GetIndexName: string;
|
|
procedure SetIndexName(const Value: string);
|
|
procedure SetIndex(const Value: string; FieldsIndex: Boolean);
|
|
procedure ValidateFieldForIndex(aField: TField);
|
|
function IntGetRecordList: TThreadMemList;
|
|
procedure RegisterClient(const AClient: TDAMemoryDataset);
|
|
procedure UnregisterClient(const AClient: TDAMemoryDataset);
|
|
procedure UnregisterAllClients;
|
|
procedure DetachFromSource;
|
|
procedure NotifyClients(Buf: PMemDatasetrecord_Native; Operation: TMemDataSetNotification; ASender: TDAMemoryDataset);
|
|
procedure RecordNotification(Buf: PMemDatasetrecord_Native; Operation: TMemDataSetNotification);
|
|
procedure IntInsertBuffer(Buffer: PMemDatasetrecord_Native; ASender: TDAMemoryDataset=nil);
|
|
procedure IntRemoveBuffer(Buffer: PMemDatasetrecord_Native; ASender: TDAMemoryDataset = nil);
|
|
procedure IntUpdateBuffer(Buffer: PMemDatasetrecord_Native; ASender: TDAMemoryDataset = nil);
|
|
procedure SetReadOnly(const Value: Boolean);
|
|
procedure SetDetailsFields(const Value: string);
|
|
procedure InitDetailFieldNamesList;
|
|
function GetIndexFields: string;
|
|
function internalGotoKey(const KeyBuffer: PMemKeyBuffer;isNearest: Boolean):Boolean;
|
|
procedure RefreshIndexConditional;
|
|
procedure MemList_ClearRecords(aMemList: TMemList);
|
|
procedure IndexList_Clear;
|
|
function LocateWithIndex(const LocateStruct: PMemLocateStruct; Buffer: PMemDatasetrecord): boolean;
|
|
procedure UpdateMemIndexes(AIndex: integer = -1);
|
|
procedure LocalBufferToDatasetBuffer(LocalBuf: PMemDatasetrecord_Native; DatasetBuffer: PMemDatasetrecord);
|
|
function LocateRecordByIndex(const aIndexName: string; const KeyValues: Variant; SyncCursor: Boolean): Boolean;
|
|
function intLocateRecordByIndex(aIndex: TDAMemIndex; const KeyValues: Variant; SyncCursor: Boolean): Boolean;
|
|
procedure InitMemLocateStruct(AStruct: PMemLocateStruct; const KeyValues: Variant);
|
|
function CreateBin3Struct(const ASize:Cardinal): Dataset_PAnsiChar;
|
|
function GetBin3Offset(Buffer: Dataset_PAnsiChar;const aFieldNo:integer):cardinal;
|
|
Procedure FreeBin3Buffer(Buffer: Dataset_PAnsiChar);
|
|
procedure SetAutoPackRecords(const Value: boolean);
|
|
private
|
|
{ Set range }
|
|
FKeyBuffers: array[TMemKeyIndex] of PMemKeyBuffer;
|
|
FKeyBuffer: PMemKeyBuffer;
|
|
procedure AllocKeyBuffers;
|
|
procedure FreeKeyBuffers;
|
|
procedure SetKeyBuffer(KeyIndex: TMemKeyIndex; Clear: Boolean);
|
|
procedure SetKeyFields(KeyIndex: TMemKeyIndex; const Values: array of const);
|
|
function InitKeyBuffer(Buffer: PMemKeyBuffer): PMemKeyBuffer;
|
|
protected
|
|
function CreateMemDatasetRecord(const AType:TmrMode; ABin3Size: Cardinal = 0; ADatasetCompatible: Boolean =False):PMemDatasetrecord_Native;
|
|
procedure FreeMemDatasetRecord(Buffer: PMemDatasetrecord_Native);
|
|
protected
|
|
// for IDAMemDatasetBatchAdding
|
|
procedure SetNullMask(Buffer: Dataset_PAnsiChar; const AIndex: Integer; const Value: boolean);
|
|
function IntFindFieldData(Buffer: PMemDatasetrecord_Native; Field: TField): Pointer; overload;
|
|
function IntFindFieldData(Buffer: Dataset_PAnsiChar; Field: TField; aBin2: Boolean): Pointer; overload;
|
|
function MakeBlobFromString(Blob: AnsiString):PBLOBRecord;
|
|
function GetBin2FieldOffset(const aFieldNo:integer):cardinal;
|
|
procedure SetAnsiString(NativeBuf: Pointer; Field: TField; const Value: Ansistring);
|
|
procedure SetWideString(NativeBuf: Pointer; Field: TField; const Value: Widestring);
|
|
procedure ProcessFilter;
|
|
procedure AddRecordsfromList(AList: TList);
|
|
procedure ClearBin2Buffer(Buffer: Dataset_PAnsiChar);
|
|
Procedure FreeBin2Buffer(Buffer: Dataset_PAnsiChar);
|
|
function CreateBin2Struct: Dataset_PAnsiChar;
|
|
protected
|
|
procedure DuplicateBuffer(Source, Dest: PMemDatasetrecord_Native; ACanPack:boolean);
|
|
procedure RecordToBuffer(RecNo: integer; Buffer: PMemDatasetRecord);
|
|
property MasterDataLink: TMasterDataLink read FMasterDataLink;
|
|
procedure MasterChanged(Sender: TObject); virtual;
|
|
procedure MasterDisabled(Sender: TObject); virtual;
|
|
function LocateRecord(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions; SyncCursor: Boolean): Boolean;
|
|
protected // tdataset
|
|
{ IProviderSupport }
|
|
function PSGetIndexDefs(IndexTypes: TIndexOptions): TIndexDefs; {$IFNDEF FPC}override;{$ENDIF}
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
protected
|
|
procedure PostKeyBuffer(Commit: Boolean);
|
|
function GetIsIndexField(Field: TField): Boolean; override;
|
|
procedure DoOnNewRecord; override;
|
|
function GetRecord(Buffer: Dataset_PAnsiChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
|
|
procedure InternalClose; override;
|
|
procedure InternalHandleException; override;
|
|
procedure InternalInitFieldDefs; override;
|
|
procedure InternalOpen; override;
|
|
function IsCursorOpen: Boolean; override;
|
|
function AllocRecordBuffer: Dataset_PAnsiChar; override;
|
|
procedure FreeRecordBuffer(var Buffer: Dataset_PAnsiChar); override;
|
|
procedure GetBookmarkData(Buffer: Dataset_PAnsiChar; Data: Pointer); override;
|
|
function GetBookmarkFlag(Buffer: Dataset_PAnsiChar): TBookmarkFlag; override;
|
|
function GetRecordSize: Word; override;
|
|
procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
|
|
procedure InternalDelete; override;
|
|
procedure InternalFirst; override;
|
|
procedure InternalGotoBookmark(Bookmark: Pointer); override;
|
|
procedure InternalInitRecord(Buffer: Dataset_PAnsiChar); override;
|
|
procedure InternalLast; override;
|
|
procedure InternalPost; override;
|
|
procedure InternalSetToRecord(Buffer: Dataset_PAnsiChar); override;
|
|
procedure SetBookmarkFlag(Buffer: Dataset_PAnsiChar; Value: TBookmarkFlag); override;
|
|
procedure SetBookmarkData(Buffer: Dataset_PAnsiChar; Data: Pointer); override;
|
|
procedure SetFieldData(Field: TField; Buffer: Pointer); overload; override;
|
|
function GetRecordCount: Integer; override;
|
|
function GetRecNo: Integer; override;
|
|
procedure SetRecNo(Value: Integer); override;
|
|
procedure OpenCursor(InfoQuery: Boolean); override;
|
|
procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override;
|
|
function GetDataSource: TDataSource; override;
|
|
procedure SetFiltered(Value: Boolean); override;
|
|
procedure SetFilterOptions(Value: TFilterOptions); override;
|
|
procedure SetFilterText(const Value: string); override;
|
|
procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
|
|
procedure DoAfterOpen; override;
|
|
procedure UpdateIndexDefs; override;
|
|
procedure DefChanged(Sender: TObject); {$IFNDEF FPC}override;{$ENDIF}
|
|
procedure intInsertRecord(Buf: PMemDatasetrecord_Native);
|
|
function GetCanModify: Boolean; override;
|
|
protected
|
|
procedure SwitchToIndex(const IndexName: string);
|
|
property RangeActive:boolean read FRangeActive;
|
|
public //from TDataset `
|
|
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
|
|
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
|
|
// procedure GetDetailLinkFields(MasterFields, DetailFields: TList); {$IFNDEF FPC}override;{$ENDIF}
|
|
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 LocateByIndex(const aIndexName: string; const KeyValues: Variant): Boolean;
|
|
function LookupByIndex(const aIndexName: string; const KeyValues: Variant; const ResultFields: string): Variant;
|
|
procedure PrepareIndexForSorting(const aIndexName: string = '');
|
|
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
|
|
function BookmarkValid(Bookmark: TBookmark): Boolean; override;
|
|
{$IFNDEF MEMDATASET_DEBUG}
|
|
protected // postponed to .31
|
|
{$ENDIF MEMDATASET_DEBUG}
|
|
property UseIndexinLocate: Boolean read fUseIndexinLocate write fUseIndexinLocate;
|
|
procedure SortOnFields(AIndex: TDAMemIndex);overload;
|
|
Function CalculateRecordsSize: Cardinal;
|
|
procedure CompactRecords;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure SortOnFields(const Fields: string; CaseInsensitive: Boolean = False; Descending: Boolean = False);overload;
|
|
procedure SortOnFields(const Fields, CaseInsFields, DescFields: string);overload;
|
|
procedure SortOnFields;overload;
|
|
procedure GetIndexNames(List: TStrings);
|
|
procedure AddIndex(const Name, Fields: string; const DescFields: string = ''; const CaseInsFields: string = '');
|
|
procedure DeleteIndex(const Name: string);
|
|
procedure CloneCursor(Source: TDAMemoryDataset; Reset: Boolean; KeepSettings: Boolean = False); virtual;
|
|
property StoreStringAsReference: Boolean read FStoreStringsAsReference write SetStoreStringAsReference;
|
|
property CloneSource: TDAMemoryDataset read FCloneSource;
|
|
procedure Post; override;
|
|
procedure Cancel; override;
|
|
{$IFDEF MSWINDOWS}
|
|
property SortLocale: LCID read FSortLocale write FSortLocale;
|
|
{$ENDIF MSWINDOWS}
|
|
property AutoCompactRecords: boolean read FAutoCompactRecords write SetAutoPackRecords;
|
|
{$IFDEF BDS4UP}{$REGION 'MEM_PACKETRECORDS'}{$ENDIF BDS4UP}
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
// packed adding
|
|
protected
|
|
function GetPackedMode: Boolean;
|
|
procedure SetPackedMode(const Value: Boolean);
|
|
Property PackedMode: Boolean read GetPackedMode write SetPackedMode;
|
|
procedure PackedRecordListClear;
|
|
public
|
|
Procedure StartPackedMode;
|
|
Procedure CommitPackedMode;
|
|
Procedure CancelPackedMode;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
{$IFDEF BDS4UP}{$ENDREGION}{$ENDIF BDS4UP}
|
|
public { Set range }
|
|
procedure ApplyRange;
|
|
procedure CancelRange;
|
|
procedure SetRange(const StartValues, EndValues: array of const);
|
|
procedure EditRangeEnd;
|
|
procedure EditRangeStart;
|
|
procedure SetRangeEnd;
|
|
procedure SetRangeStart;
|
|
//
|
|
procedure SetKey;
|
|
procedure EditKey;
|
|
function FindKey(const KeyValues: array of const): Boolean;
|
|
procedure FindNearest(const KeyValues: array of const);
|
|
function GotoKey: Boolean;
|
|
procedure GotoNearest;
|
|
published
|
|
property Active;
|
|
property FieldDefs;
|
|
property OnFilterRecord;
|
|
property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
|
|
property IndexName: string read GetIndexName write SetIndexName;
|
|
property IndexDefs: TIndexDefs read GetIndexDefs write SetIndexDefs;
|
|
property MasterFields: string read GetMasterFields write SetMasterFields;
|
|
property MasterSource: TDataSource read GetDataSource write SetDataSource;
|
|
property DetailFields: string read FDetailFields write SetDetailsFields;
|
|
property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
|
|
property Filter;
|
|
property Filtered;
|
|
property BeforeOpen;
|
|
property AfterOpen;
|
|
property BeforeClose;
|
|
property AfterClose;
|
|
property BeforeInsert;
|
|
property AfterInsert;
|
|
property BeforeEdit;
|
|
property AfterEdit;
|
|
property BeforePost;
|
|
property AfterPost;
|
|
property BeforeCancel;
|
|
property AfterCancel;
|
|
property BeforeDelete;
|
|
property AfterDelete;
|
|
property BeforeScroll;
|
|
property AfterScroll;
|
|
property BeforeRefresh;
|
|
property AfterRefresh;
|
|
property OnCalcFields;
|
|
property OnDeleteError;
|
|
property OnEditError;
|
|
property OnNewRecord;
|
|
property OnPostError;
|
|
end;
|
|
|
|
TDABlobStream = class(TMemoryStream)
|
|
private
|
|
FField: TBlobField;
|
|
FDataSet: TDAMemoryDataset;
|
|
FBuffer: PMemDatasetrecord_Native;
|
|
FMode: TBlobStreamMode;
|
|
FOpened: Boolean;
|
|
FModified: Boolean;
|
|
FPosition: Longint;
|
|
FCached: Boolean;
|
|
function GetBlobSize: Longint;
|
|
procedure GetBLOBRecordFromRecord(Field: TField; out aLocked:Boolean; out blob_size: integer; out blob_data: pointer);
|
|
function GetBLOBRecordFromBuffer(Buffer: PMemDatasetrecord_Native; Field: TField; out blob_size: integer; out blob_data: pointer): PBLOBRecord;
|
|
procedure Truncate;
|
|
public
|
|
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
destructor Destroy; override;
|
|
function Read(var Buffer; Count: Longint): Longint; override;
|
|
function Write(const Buffer; Count: Longint): Longint; override;
|
|
function Seek(Offset: Longint; Origin: Word): Longint; override;
|
|
end;
|
|
|
|
var
|
|
MaxStringSizeInline : integer = 4096;
|
|
|
|
implementation
|
|
uses
|
|
uROClasses, uROBinaryHelpers,
|
|
Variants, SysUtils,{$IFDEF FPC}dbconst,{$ELSE}DBConsts,{$ENDIF}
|
|
{$IFNDEF FPC}Forms, SqlTimSt,{$ENDIF} FMTBcd, RTLConsts, Math;
|
|
|
|
const
|
|
guidsize = 38; { Length(GuidString) }
|
|
|
|
resourcestring
|
|
SNoDetailFilter = 'Filter property cannot be used for detail tables';
|
|
const
|
|
ft_Inline = [ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
|
|
ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc,
|
|
ftLargeint, {$IFNDEF FPC}ftTimeStamp,{$ENDIF} ftBCD, ftFMTBCD, ftGuid];
|
|
ft_BlobTypes = [ftBlob, ftMemo,{$IFDEF DA_WideMemoSupport}ftWideMemo,{$ENDIF DA_WideMemoSupport} ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob];
|
|
ft_Strings = [ftString, ftWideString, ftFixedChar];
|
|
ft_AnsiStringValues = [ftString, ftFixedChar, ftGuid];
|
|
ft_WideStringValues = [ftWideString];
|
|
ft_Supported = ft_Inline + ft_BlobTypes + ft_Strings;
|
|
// ft_UnSupported = [ftADT, ftArray, ftReference, ftDataSet, ftBytes, ftVarBytes] + [ftVariant];
|
|
type
|
|
PCardinalArray = ^TCardinalArray;
|
|
TCardinalArray = array [0..MaxListSize - 1] of Cardinal;
|
|
|
|
function CreateBlobRecord(ASize: cardinal = 0; AInit: Boolean = False): PBlobRecord;
|
|
begin
|
|
{$IFDEF FPC}
|
|
Result := nil;
|
|
{$ENDIF FPC}
|
|
GetMem(Result, ASize + SizeOf(TBLOBRecord));
|
|
FillChar(Result^, sizeof(TBLOBRecord), 0);
|
|
Result.size:=ASize;
|
|
if AInit then FillChar(Result.Data, Asize, 0);
|
|
end;
|
|
|
|
procedure FreeBlobRecord(buf: Pointer);
|
|
begin
|
|
// if buf = nil then Exit;
|
|
FreeMem(buf);
|
|
end;
|
|
|
|
{ TMemList }
|
|
|
|
destructor TMemList.Destroy;
|
|
begin
|
|
Clear;
|
|
end;
|
|
|
|
function TMemList.Add(Item: Pointer): Integer;
|
|
begin
|
|
Result := FCount;
|
|
if Result = FCapacity then Grow;
|
|
FList^[Result] := Item;
|
|
Inc(FCount);
|
|
FNeedRefresh:=True;
|
|
end;
|
|
|
|
procedure TMemList.Clear;
|
|
begin
|
|
SetCount(0);
|
|
SetCapacity(0);
|
|
ReallocMem(FSortList,0);
|
|
FNeedRefresh:=True;
|
|
end;
|
|
|
|
procedure TMemList.Delete(Index: Integer);
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
|
|
Dec(FCount);
|
|
if Index < FCount then
|
|
System.Move(FList^[Index + 1], FList^[Index],(FCount - Index) * SizeOf(Pointer));
|
|
fNeedRefresh:=True;
|
|
end;
|
|
|
|
class procedure TMemList.Error(const Msg: string; Data: Integer);
|
|
{$IFNDEF FPC}
|
|
function ReturnAddr: Pointer;
|
|
asm
|
|
MOV EAX,[EBP+4]
|
|
end;
|
|
{$ENDIF}
|
|
begin
|
|
raise EListError.CreateFmt(Msg, [Data]) at {$IFNDEF FPC}ReturnAddr{$ELSE}get_caller_addr(get_frame){$ENDIF};
|
|
end;
|
|
|
|
class procedure TMemList.Error(Msg: PResStringRec; Data: Integer);
|
|
begin
|
|
TMemList.Error(LoadResString(Msg), Data);
|
|
end;
|
|
|
|
procedure TMemList.Exchange(Index1, Index2: Integer);
|
|
var
|
|
Item: Pointer;
|
|
begin
|
|
if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1);
|
|
if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2);
|
|
Item := FList^[Index1];
|
|
FList^[Index1] := FList^[Index2];
|
|
FList^[Index2] := Item;
|
|
FNeedRefresh:=True;
|
|
end;
|
|
|
|
function TMemList.Expand: TMemList;
|
|
begin
|
|
if FCount = FCapacity then Grow;
|
|
Result := Self;
|
|
end;
|
|
|
|
function TMemList.First: Pointer;
|
|
begin
|
|
Result := Get(0);
|
|
end;
|
|
|
|
function TMemList.Get(Index: Integer): Pointer;
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
|
|
Result := FList^[Index];
|
|
end;
|
|
|
|
procedure TMemList.Grow;
|
|
var
|
|
Delta: Integer;
|
|
begin
|
|
if FCapacity > 64 then
|
|
Delta := FCapacity div 4
|
|
else
|
|
if FCapacity > 8 then
|
|
Delta := 16
|
|
else
|
|
Delta := 4;
|
|
SetCapacity(FCapacity + Delta);
|
|
end;
|
|
|
|
function TMemList.IndexOf(Item: Pointer): Integer;
|
|
begin
|
|
Sort;
|
|
Result := intIndexOf(Item);
|
|
if Result > -1 then Result:= FSortList^[Result].position;
|
|
end;
|
|
|
|
procedure TMemList.Insert(Index: Integer; Item: Pointer);
|
|
begin
|
|
if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index);
|
|
if FCount = FCapacity then Grow;
|
|
if Index < FCount then
|
|
System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(Pointer));
|
|
FList^[Index] := Item;
|
|
Inc(FCount);
|
|
fNeedRefresh:=True;
|
|
end;
|
|
|
|
function TMemList.Last: Pointer;
|
|
begin
|
|
Result := Get(FCount - 1);
|
|
end;
|
|
|
|
procedure TMemList.Move(CurIndex, NewIndex: Integer);
|
|
var
|
|
Item: Pointer;
|
|
begin
|
|
if CurIndex <> NewIndex then
|
|
begin
|
|
if (NewIndex < 0) or (NewIndex >= FCount) then Error(@SListIndexError, NewIndex);
|
|
Item := Get(CurIndex);
|
|
FList^[CurIndex] := nil;
|
|
Delete(CurIndex);
|
|
Insert(NewIndex, nil);
|
|
FList^[NewIndex] := Item;
|
|
FNeedRefresh:=True;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemList.Put(Index: Integer; Item: Pointer);
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
|
|
if Item <> FList^[Index] then
|
|
begin
|
|
FList^[Index] := Item;
|
|
fNeedRefresh:=True;
|
|
end;
|
|
end;
|
|
|
|
function TMemList.Remove(Item: Pointer): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result >= 0 then begin
|
|
Delete(Result);
|
|
FNeedRefresh:=True;
|
|
end
|
|
end;
|
|
|
|
procedure TMemList.Pack;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := FCount - 1 downto 0 do
|
|
if Items[I] = nil then
|
|
Delete(I);
|
|
FNeedRefresh:=True;
|
|
end;
|
|
|
|
procedure TMemList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error(@SListCapacityError, NewCapacity);
|
|
if NewCapacity <> FCapacity then
|
|
begin
|
|
ReallocMem(FList, NewCapacity * SizeOf(Pointer));
|
|
FCapacity := NewCapacity;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemList.SetCount(NewCount: Integer);
|
|
begin
|
|
if (NewCount < 0) or (NewCount > MaxListSize) then Error(@SListCountError, NewCount);
|
|
if NewCount > FCapacity then SetCapacity(NewCount);
|
|
if NewCount > FCount then FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
|
|
FCount := NewCount;
|
|
FNeedRefresh:=True;
|
|
end;
|
|
|
|
procedure TMemList.QuickSort(L, R: Integer);
|
|
var
|
|
I, J, P : integer;
|
|
k: TSortRecord;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
P := (L + R) shr 1;
|
|
repeat
|
|
while FSortList^[i].Data < FSortList^[P].Data do Inc(I);
|
|
while FSortList^[J].Data > FSortList^[P].Data do Dec(J);
|
|
if I <= J then
|
|
begin
|
|
k:= FSortList^[i];
|
|
FSortList^[i]:=FSortList^[j];
|
|
FSortList^[j]:=k;
|
|
if P = I then P := J
|
|
else if P = J then P := I;
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
until I > J;
|
|
if L < J then QuickSort(L, J);
|
|
L := I;
|
|
until I >= R;
|
|
end;
|
|
|
|
procedure TMemList.Sort;
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FNeedRefresh and (FList <> nil) and (Count > 0) then begin
|
|
ReallocMem(FSortList, Capacity * SizeOf(TSortRecord));
|
|
For i:=0 to Count -1 do begin
|
|
FSortList^[i].data:= FList^[I];
|
|
FSortList^[i].position:= i;
|
|
end;
|
|
QuickSort(0, Count - 1);
|
|
FNeedRefresh:=False;
|
|
end;
|
|
end;
|
|
|
|
function TMemList.Extract(Item: Pointer): Pointer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := nil;
|
|
I := IndexOf(Item);
|
|
if I >= 0 then
|
|
begin
|
|
Result := Item;
|
|
FList^[I] := nil;
|
|
Delete(I);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TMemList.Assign(ListA: TMemList; AOperator: TMemListAssignOp; ListB: TMemList);
|
|
var
|
|
I: Integer;
|
|
LTemp, LSource: TMemList;
|
|
begin
|
|
FNeedRefresh:=True;
|
|
// ListB given?
|
|
if ListB <> nil then
|
|
begin
|
|
LSource := ListB;
|
|
Assign(ListA);
|
|
end
|
|
else
|
|
LSource := ListA;
|
|
|
|
// on with the show
|
|
case AOperator of
|
|
|
|
// 12345, 346 = 346 : only those in the new list
|
|
mlaCopy:
|
|
begin
|
|
Clear;
|
|
Capacity := LSource.Capacity;
|
|
for I := 0 to LSource.Count - 1 do
|
|
Add(LSource[I]);
|
|
end;
|
|
|
|
// 12345, 346 = 34 : intersection of the two lists
|
|
mlaAnd:
|
|
for I := Count - 1 downto 0 do
|
|
if LSource.IndexOf(Items[I]) = -1 then
|
|
Delete(I);
|
|
|
|
// 12345, 346 = 123456 : union of the two lists
|
|
mlaOr:
|
|
for I := 0 to LSource.Count - 1 do
|
|
if IndexOf(LSource[I]) = -1 then
|
|
Add(LSource[I]);
|
|
|
|
// 12345, 346 = 1256 : only those not in both lists
|
|
mlaXor:
|
|
begin
|
|
LTemp := TMemList.Create; // Temp holder of 4 byte values
|
|
try
|
|
LTemp.Capacity := LSource.Count;
|
|
for I := 0 to LSource.Count - 1 do
|
|
if IndexOf(LSource[I]) = -1 then
|
|
LTemp.Add(LSource[I]);
|
|
for I := Count - 1 downto 0 do
|
|
if LSource.IndexOf(Items[I]) <> -1 then
|
|
Delete(I);
|
|
I := Count + LTemp.Count;
|
|
if Capacity < I then
|
|
Capacity := I;
|
|
for I := 0 to LTemp.Count - 1 do
|
|
Add(LTemp[I]);
|
|
finally
|
|
LTemp.Free;
|
|
end;
|
|
end;
|
|
|
|
// 12345, 346 = 125 : only those unique to source
|
|
mlaSrcUnique:
|
|
for I := Count - 1 downto 0 do
|
|
if LSource.IndexOf(Items[I]) <> -1 then
|
|
Delete(I);
|
|
|
|
// 12345, 346 = 6 : only those unique to dest
|
|
mlaDestUnique:
|
|
begin
|
|
LTemp := TMemList.Create;
|
|
try
|
|
LTemp.Capacity := LSource.Count;
|
|
for I := LSource.Count - 1 downto 0 do
|
|
if IndexOf(LSource[I]) = -1 then
|
|
LTemp.Add(LSource[I]);
|
|
Assign(LTemp);
|
|
finally
|
|
LTemp.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TMemList.intIndexOf(Item: PAnsiChar): Integer;
|
|
var
|
|
L, H, I, C : integer;
|
|
Res : boolean;
|
|
begin
|
|
Res := False;
|
|
L := 0;
|
|
H := FCount - 1;
|
|
while L <= H do
|
|
begin
|
|
I := (L + H) shr 1;
|
|
C := FSortList^[i].Data - Item;
|
|
if C < 0 then
|
|
L := I + 1
|
|
else
|
|
begin
|
|
H := I - 1;
|
|
if C = 0 then Res := True;
|
|
end;
|
|
end;
|
|
if Res then
|
|
Result := L
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
constructor TMemList.Create;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
{ TDAMemoryDataset }
|
|
|
|
function TDAMemoryDataset.AllocRecordBuffer: Dataset_PAnsiChar;
|
|
begin
|
|
Result:= Dataset_PAnsiChar(CreateMemDatasetRecord(mrEmpty, 0, True));
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CalculateOffsets;
|
|
var
|
|
i: integer;
|
|
lField: TField;
|
|
llen: cardinal;
|
|
begin
|
|
if not FStoreStringsAsReference then begin
|
|
for i := 0 to FieldCount - 1 do
|
|
with Fields[i] do
|
|
if (DataType in ft_Strings) and (Size >= MaxStringSizeInline) then begin
|
|
FStoreStringsAsReference := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
SetLength(FOffsets, FieldCount + 1);
|
|
SetLength(FDataSizeArray,FieldCount);
|
|
SetLength(FDataTypeArray,FieldCount);
|
|
// FOffsets[FieldCount+1] = BookMarkOffset
|
|
FNullMaskSize := (FieldCount + 7) div 8;
|
|
FOffsets[0] := FNullMaskSize;
|
|
FHasReferencedFields := FStoreStringsAsReference;
|
|
for i := 0 to FieldCount - 1 do begin
|
|
lField := Fields[i];
|
|
FDataTypeArray[i]:=lField.DataType;
|
|
llen:=CalcFieldLen(lField.DataType,lField.Size);
|
|
FDataSizeArray[i] := llen;
|
|
FOffsets[i + 1] := FOffsets[i] + llen;
|
|
FHasReferencedFields := FHasReferencedFields or IsReferencedField(lField.DataType);
|
|
end;
|
|
FNativeRecordSize := FOffsets[FieldCount];
|
|
|
|
//
|
|
|
|
// FBookMarkOffset := FNativeRecordSize;
|
|
// FCalculatedOffset := FBookMarkOffset + SizeOf(TRecInfo);
|
|
// FDatasetBufferSize := FCalculatedOffset + CalcFieldsSize;
|
|
FDatasetBufferSize := SizeOf(TMemDatasetrecord)+CalcFieldsSize;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ClearFieldByFieldType(FieldBuffer: pointer; ADataType: TFieldType);
|
|
begin
|
|
case ADataType of
|
|
ftString, ftFixedChar: begin
|
|
PAnsiString(FieldBuffer)^ := '';
|
|
PPointer(FieldBuffer)^ := nil;
|
|
end;
|
|
ftWideString: begin
|
|
PWideString(FieldBuffer)^ := '';
|
|
PPointer(FieldBuffer)^ := nil;
|
|
end;
|
|
else
|
|
if ADataType in ft_BlobTypes then begin
|
|
FreeBlobRecord(PPointer(FieldBuffer)^);
|
|
PPointer(FieldBuffer)^ := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ClearBin2Field(Buffer: Dataset_PAnsiChar; AField: TField);
|
|
begin
|
|
if GetNullMask(Buffer, AField.Index) then Exit;
|
|
if IsReferencedField(AField.DataType) then
|
|
ClearFieldByFieldType(IntFindFieldData(Buffer, AField, True), AField.DataType);
|
|
SetNullMask(Buffer, AField.Index, True);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ClearRecords;
|
|
var
|
|
aList: TMemList;
|
|
begin
|
|
FDataList.Clear;
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
PackedRecordListClear;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
UnregisterAllClients;
|
|
AList := FRecordsList.LockListForWriting;
|
|
try
|
|
MemList_ClearRecords(aList);
|
|
finally
|
|
FRecordsList.UnlockListForWriting;
|
|
end;
|
|
end;
|
|
|
|
constructor TDAMemoryDataset.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
fPackedMode := False;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
FRecordsList := TThreadMemList.Create;
|
|
FDataList := TMemList.Create;
|
|
FMasterDataLink := TMasterDataLink.Create(Self);
|
|
FMasterDataLink.OnMasterChange := MasterChanged;
|
|
FMasterDataLink.OnMasterDisable := MasterDisabled;
|
|
f_DefaultIndexRecord := TDAMemIndex.Create(Self);
|
|
// FIndexFieldNameList := TList.Create;
|
|
// FIndexCaseInsList := TList.Create;
|
|
// FIndexDescFields := TList.Create;
|
|
FDetailsFieldNameList := TList.Create;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
FSortLocale := LOCALE_USER_DEFAULT;
|
|
{$ENDIF MSWINDOWS}
|
|
FStoreStringsAsReference:=False;
|
|
FExpressionEvaluator:= TDAStdExpressionEvaluator.Create;
|
|
FExpressionEvaluator.OnGetValue := EEGetValue;
|
|
FExpressionEvaluator.UseWildcardsInEqual:= True; // FilterOptions = []
|
|
FExpressionEvaluator.StringCaseInsensitive:= False; // FilterOptions = []
|
|
fUseIndexinLocate:=True;
|
|
FIndexList := TList.Create;
|
|
FAutoCompactRecords := False;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CreateBlobStream(Field: TField;
|
|
Mode: TBlobStreamMode): TStream;
|
|
begin
|
|
Result := TDABlobStream.Create(TBlobField(Field), Mode);
|
|
end;
|
|
|
|
destructor TDAMemoryDataset.Destroy;
|
|
begin
|
|
inherited;
|
|
IndexList_Clear;
|
|
FDetailsFieldNameList.Free;
|
|
FExpressionEvaluator.Free;
|
|
// FIndexFieldNameList.Free;
|
|
// FIndexCaseInsList.Free;
|
|
// FIndexDescFields.Free;
|
|
f_DefaultIndexRecord.Free;
|
|
FMasterDataLink.Free;
|
|
FIndexList.Free;
|
|
FDataList.Free;
|
|
FRecordsList.Free;
|
|
FIndexDefs.Free;
|
|
if FCloneClientList <> nil then FCloneClientList.Free;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DuplicateBuffer(Source, Dest: PMemDatasetrecord_Native;ACanPack:boolean);
|
|
var
|
|
i: Cardinal;
|
|
p, p2: PBlobRecord;
|
|
lbin3: Dataset_PAnsiChar;
|
|
begin
|
|
{$IFDEF MEMDATASET_DEBUG}
|
|
// if not ((Source.Ident in [mrEmpty..mrBin3Style]) and(Dest.Ident in [mrEmpty..mrBin3Style])) then DatabaseError('TDAMemoryDataset.DuplicateBuffer: Data are damaged');
|
|
{$ENDIF MEMDATASET_DEBUG}
|
|
case Source.Ident of
|
|
mrEmpty: begin
|
|
case Dest.Ident of
|
|
mrEmpty :;
|
|
mrBin2Style: FreeBin2Buffer(Dest.Data);
|
|
mrBin3Style: FreeBin3Buffer(Dest.Data);
|
|
end;
|
|
Dest.Data := nil;
|
|
Dest.Ident := mrEmpty;
|
|
end;
|
|
mrBin3Style: begin
|
|
I := GetBin3Offset(Source.Data, FieldCount);
|
|
{$IFDEF USE_REALLOC}
|
|
case Dest.Ident of
|
|
mrEmpty : Dest.Data := CreateBin3Struct(i);
|
|
mrBin2Style: begin
|
|
ClearBin2Buffer(Dest.Data);
|
|
if i < FNativeRecordSize then begin
|
|
ReallocMem(Dest.Data,i);
|
|
end
|
|
else begin
|
|
FreeMem(Dest.Data);
|
|
Dest.Data := CreateBin3Struct(i);
|
|
end;
|
|
end;
|
|
mrBin3Style: begin
|
|
if i <= GetBin3Offset(Dest.Data, FieldCount) then begin
|
|
ReallocMem(Dest.Data,i)
|
|
end
|
|
else begin
|
|
FreeMem(Dest.Data);
|
|
Dest.Data := CreateBin3Struct(i);
|
|
end;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
case Dest.Ident of
|
|
mrBin2Style: FreeBin2Buffer(Dest.Data);
|
|
mrBin3Style: FreeBin3Buffer(Dest.Data);
|
|
end;
|
|
Dest.Data := CreateBin3Struct(i);
|
|
{$ENDIF}
|
|
Move(pointer(Source.Data)^, pointer(Dest.Data)^, i);
|
|
Dest.Ident := mrBin3Style;
|
|
end;
|
|
mrBin2Style: begin
|
|
if Dest.Ident = mrBin3Style then FreeBin3Buffer(Dest.Data);
|
|
if ACanPack and FAutoCompactRecords then
|
|
lbin3 := Bin2ToBin3(Source.Data)
|
|
else
|
|
lbin3 := nil;
|
|
if lbin3 <> nil then begin
|
|
if Dest.Ident = mrBin2Style then FreeBin2Buffer(Dest.Data);
|
|
Dest.Ident := mrBin3Style;
|
|
Dest.Data := lbin3;
|
|
end
|
|
else begin
|
|
if Dest.Ident = mrBin2Style then
|
|
ClearBin2Buffer(Dest.Data)
|
|
else
|
|
Dest.Data := CreateBin2Struct;
|
|
Dest.Ident := mrBin2Style;
|
|
if not FHasReferencedFields then begin
|
|
Move(pointer(Source.Data)^, pointer(Dest.Data)^, FNativeRecordSize);
|
|
end
|
|
else begin
|
|
Move(pointer(Source.Data)^, pointer(Dest.Data)^, FNullMaskSize);
|
|
|
|
for I := 0 to FieldCount - 1 do begin
|
|
if (not GetNullMask(Source.Data, i)) then begin
|
|
if not IsReferencedField(FDataTypeArray[i]) then begin
|
|
Move(pointer(Source.Data + FOffsets[i])^, pointer(Dest.Data + FOffsets[i])^, FDataSizeArray[i])
|
|
end
|
|
else begin
|
|
case FDataTypeArray[i] of
|
|
ftString,ftFixedChar: PAnsiString(Dest.Data + FOffsets[i])^ := PAnsiString(Source.Data + FOffsets[i])^;
|
|
ftWideString: PWideString(Dest.Data + FOffsets[i])^ := PWideString(Source.Data + FOffsets[i])^;
|
|
else
|
|
if FDataTypeArray[i] in ft_BlobTypes then begin
|
|
p := PPointer(Source.Data + FOffsets[i])^;
|
|
if p <> nil then begin
|
|
p2 := CreateBlobRecord(PBlobRecord(p)^.size);
|
|
Move(pointer(p)^, pointer(p2)^, p^.size + SizeOf(TBlobRecord));
|
|
PPointer(Dest.Data + FOffsets[i])^ := p2;
|
|
end
|
|
else begin
|
|
SetNullMask(Dest.Data, i, True);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.EEGetValue(Sender: TDAExpressionEvaluator; const aIdentifier: string; out aValue: Variant);
|
|
begin
|
|
aValue:= GetVarValueFromBuffer(FExpressionBuffer^.Data, FieldByName(aIdentifier), FExpressionBuffer^.Ident = mrBin2Style);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ProcessFilter;
|
|
begin
|
|
CheckBrowseMode;
|
|
DoFilterRecords;
|
|
end;
|
|
|
|
function TDAMemoryDataset.FilterRecord(buf: PMemDatasetrecord_Native; AUseEvent: Boolean): Boolean;
|
|
begin
|
|
Result:=True;
|
|
if FRangeActive then begin
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
Result := (CompareValues_Range(buf,FKeyBuffers[kiCurRangeStart]) >=0) and
|
|
(CompareValues_Range(buf,FKeyBuffers[kiCurRangeEnd]) <=0);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
if Result and (Filter <> '') then begin
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
FExpressionBuffer:=buf;
|
|
Result := FExpressionEvaluator.Evaluate(Filter);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
if Result and AUseEvent and Assigned(OnFilterRecord) then OnFilterRecord(Self, Result);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FreeRecordBuffer(var Buffer: Dataset_PAnsiChar);
|
|
begin
|
|
FreeMemDatasetRecord(pointer(Buffer));
|
|
Buffer := nil;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetActiveRecBuf(var RecBuf: Dataset_PAnsiChar): Boolean;
|
|
begin
|
|
case State of
|
|
dsBrowse:
|
|
if IsEmpty then
|
|
RecBuf := nil
|
|
else
|
|
RecBuf := ActiveBuffer;
|
|
dsEdit, dsInsert, dsNewValue: RecBuf := ActiveBuffer;
|
|
dsCalcFields: RecBuf := CalcBuffer;
|
|
dsFilter: RecBuf := FFilterBuffer;
|
|
dsSetKey: RecBuf := Dataset_PAnsiChar(FKeyBuffer) + SizeOf(TMemKeyBuffer);
|
|
else
|
|
RecBuf := nil;
|
|
end;
|
|
Result := RecBuf <> nil;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.GetBookmarkData(Buffer: Dataset_PAnsiChar; Data: Pointer);
|
|
begin
|
|
Move(PMemDatasetrecord(Buffer)^.BookmarkData.Bookmark, Data^, SizeOf(TBookmarkData));
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetBookmarkFlag(Buffer: Dataset_PAnsiChar): TBookmarkFlag;
|
|
begin
|
|
Result := PMemDatasetrecord(Buffer)^.BookmarkData.BookmarkFlag;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
|
|
var
|
|
RecBuf: Dataset_PAnsiChar;
|
|
Data: Dataset_PAnsiChar;
|
|
// VarData : Variant;
|
|
Len: integer;
|
|
k,k1: Cardinal;
|
|
begin
|
|
Result := False;
|
|
{$IFDEF FPC}
|
|
RecBuf := nil;
|
|
{$ENDIF FPC}
|
|
if not GetActiveRecBuf(RecBuf) then Exit;
|
|
Result := (PMemDatasetrecord_Native(RecBuf)^.Ident in [mrBin2Style, mrBin3Style]) and
|
|
(Field.DataType in ft_Supported) and
|
|
not GetNullMask(PMemDatasetrecord_Native(RecBuf)^.Data, Field.Index);
|
|
if Result and (Buffer <> nil) then begin
|
|
case PMemDatasetrecord_Native(RecBuf)^.Ident of
|
|
mrBin2Style: begin
|
|
Data := PMemDatasetrecord_Native(RecBuf)^.Data + FOffsets[Field.Index];
|
|
if Data = nil then begin
|
|
Result:=False;
|
|
Exit;
|
|
end;
|
|
{if Field.DataType = ftVariant then
|
|
begin
|
|
VarData := PVariant(Data)^;
|
|
PVariant(Buffer)^ := VarData;
|
|
end
|
|
else}
|
|
if not IsReferencedField(Field.DataType) then begin
|
|
Move(Data^, Buffer^, FDataSizeArray[Field.Index])
|
|
end else begin
|
|
case Field.DataType of
|
|
ftString,ftFixedChar: begin
|
|
len := Length(PAnsiString(Data)^);
|
|
if Len > Field.Size then Len := Field.Size;
|
|
Move(pointer(PAnsiString(Data)^)^, buffer^, len*SizeOf(AnsiChar));
|
|
PAnsiChar(buffer)[Len] := #0;
|
|
end;
|
|
ftWideString: begin
|
|
len := Length(PWideString(Data)^);
|
|
if Len > Field.Size then Len := Field.Size;
|
|
Move(pointer(PWideString(Data)^)^, buffer^, len * sizeOf(WideChar));
|
|
PWideChar(buffer)[Len] := #0;
|
|
end;
|
|
else
|
|
if Field.DataType in ft_BlobTypes then DatabaseError('GetFieldData: BlobType');
|
|
end;
|
|
end;
|
|
end;
|
|
mrBin3Style: begin
|
|
Data :=PMemDatasetrecord_Native(RecBuf)^.Data;
|
|
k := GetBin3Offset(Data,Field.Index);
|
|
k1 := GetBin3Offset(Data,Field.Index+1);
|
|
Move((Data+k)^, buffer^, k1-k);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetRecNo: Integer;
|
|
begin
|
|
UpdateCursorPos;
|
|
if (FRecordPos = -1) and (RecordCount > 0) then
|
|
Result := 1
|
|
else
|
|
Result := FRecordPos + 1;
|
|
end;
|
|
|
|
function TDAMemoryDataset.InternalGetRecord(Buffer: PMemDatasetRecord; GetMode: TGetMode;
|
|
DoCheck: Boolean): TGetResult;
|
|
begin
|
|
if Buffer = nil then begin
|
|
Result := grError;
|
|
Exit;
|
|
end;
|
|
|
|
Result := grOk;
|
|
case GetMode of
|
|
gmCurrent: begin
|
|
if (FRecordPos = -1) and (RecordCount > 0) then FRecordPos := 0;
|
|
if (FRecordPos < 0) or (FRecordPos >= RecordCount) then Result := grError;
|
|
end;
|
|
gmPrior:
|
|
if FRecordPos <= 0 then begin
|
|
Result := grBOF;
|
|
FRecordPos := -1;
|
|
end
|
|
else
|
|
Dec(FRecordPos);
|
|
gmNext:
|
|
if FRecordPos >= RecordCount - 1 then
|
|
Result := grEOF
|
|
else
|
|
Inc(FRecordPos);
|
|
end;
|
|
if Result = grOk then begin
|
|
RecordToBuffer(FRecordPos, Buffer);
|
|
GetCalcFields(Dataset_PAnsiChar(Buffer));
|
|
end
|
|
else if (Result = grError) and DoCheck then
|
|
DatabaseError('No data found');
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetRecordCount: Integer;
|
|
begin
|
|
Result := FDataList.Count;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetRecordSize: Word;
|
|
begin
|
|
Result := FDatasetBufferSize;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetVarValueFromBuffer(Buffer: pointer; Field: TField; abin2: boolean): variant;
|
|
var
|
|
buf: PAnsiChar;
|
|
p: pointer;
|
|
lLen: cardinal;
|
|
begin
|
|
if GetNullMask(Buffer,Field.Index) then begin
|
|
Result := Null;
|
|
end
|
|
else begin
|
|
buf := IntFindFieldData(Buffer,Field,aBin2);
|
|
case Field.DataType of
|
|
ftString, ftFixedChar: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
Result := PAnsistring(Buf)^
|
|
else
|
|
Result := Ansistring(PAnsiChar(Buf));
|
|
end;
|
|
ftWideString: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
Result := PWidestring(Buf)^
|
|
else
|
|
Result := WideString(PWideChar(Buf))
|
|
end;
|
|
ftSmallint: Result := PSmallint(buf)^;
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Result := PInteger(buf)^;
|
|
ftWord: Result := PWord(buf)^;
|
|
ftBoolean: Result := PWordBool(buf)^;
|
|
ftFloat, ftCurrency: Result := PDouble(Buf)^;
|
|
ftDateTime: Result := TimeStampToDateTime(MSecsToTimeStamp({$IFDEF FPC}Trunc{$ENDIF}( PDateTime(Buf)^)));
|
|
ftBcd: Result := PCurrency(buf)^;
|
|
ftFMTBCD: Result := BCDToVariant(PBcd(buf)^);
|
|
ftLargeint: Result := PInt64(Buf)^;
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := VarSQLTimeStampCreate(PSQLTimeStamp(Buf)^);
|
|
{$ENDIF FPC}
|
|
ftGuid: Result:= AnsiString(PAnsiChar(Buf));
|
|
else
|
|
if abin2 then
|
|
lLen:=PBLOBRecord(buf)^.size
|
|
else
|
|
lLen := GetBin3Offset(Buffer, Field.Index+1)-GetBin3Offset(Buffer, Field.Index);
|
|
Result := VarArrayCreate([0,lLen-1],varByte);
|
|
p := VarArrayLock(Result);
|
|
try
|
|
if abin2 then
|
|
move(PBLOBRecord(buf)^.Data, p^,PBLOBRecord(buf)^.size)
|
|
else
|
|
Move(buf^, p^, lLen);
|
|
finally
|
|
VarArrayUnlock(Result);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IntAssignRecord(Source, Dest: PMemDatasetrecord_Native);
|
|
begin
|
|
if State = dsFilter then DatabaseError(SNotEditing);
|
|
DuplicateBuffer(Source, Dest,True);
|
|
end;
|
|
|
|
|
|
procedure TDAMemoryDataset.InternalAddRecord(Buffer: Pointer; Append: Boolean);
|
|
var
|
|
RecPos: Integer;
|
|
Rec: PMemDatasetrecord_Native;
|
|
begin
|
|
Rec := CreateMemDatasetRecord(mrEmpty,0,False);
|
|
if Append then
|
|
RecPos := FDataList.Add(Rec)
|
|
else begin
|
|
if FRecordPos = -1 then
|
|
RecPos := 0
|
|
else
|
|
RecPos := FRecordPos;
|
|
FDataList.Insert(RecNo, Rec);
|
|
end;
|
|
FRecordPos := RecPos;
|
|
// SetAutoIncFields(Buffer);
|
|
IntAssignRecord(Buffer, Rec);
|
|
IntInsertBuffer(Rec);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalClose;
|
|
var
|
|
i: integer;
|
|
begin
|
|
f_DefaultIndexRecord.Clear;
|
|
For i:=0 to FIndexList.Count-1 do
|
|
TDAMemIndex(FIndexList[i]).Clear;
|
|
|
|
// FIndexFieldNameList.Clear;
|
|
// FIndexCaseInsList.Clear;
|
|
// FIndexDescFields.Clear;
|
|
UnregisterClient(Self);
|
|
ClearRecords;
|
|
FreeKeyBuffers;
|
|
FCloneSource := nil;
|
|
BindFields(False);
|
|
if DefaultFields then DestroyFields;
|
|
SetLength(FDataTypeArray,0);
|
|
SetLength(FOffsets, 0);
|
|
SetLength(FDataSizeArray,0);
|
|
FActive := False;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalDelete;
|
|
var
|
|
f: boolean;
|
|
begin
|
|
IntRemoveBuffer(FDataList.Items[FRecordPos]);
|
|
f := f_DefaultIndexRecord.LastSorted > FLastUpdate;
|
|
FLastUpdate := Now;
|
|
if f then f_DefaultIndexRecord.LastSorted :=Now;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalFirst;
|
|
begin
|
|
FRecordPos := -1;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalGotoBookmark(Bookmark: Pointer);
|
|
var
|
|
lRecNo: Integer;
|
|
begin
|
|
lRecNo := IntFindRecordID(TBookMarkData(PPointer(Bookmark)^));
|
|
if lRecNo <> -1 then
|
|
FRecordPos := lRecNo
|
|
else
|
|
DatabaseError('Bookmark not found');
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalHandleException;
|
|
begin
|
|
{$IFDEF FPC}
|
|
inherited;
|
|
{$ELSE}
|
|
Application.HandleException(Self);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalInitFieldDefs;
|
|
begin
|
|
// inherited InternalInitFieldDefs;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalInitRecord(Buffer: Dataset_PAnsiChar);
|
|
begin
|
|
with PMemDatasetrecord_Native(Buffer)^ do begin
|
|
case Ident of
|
|
mrEmpty:;
|
|
mrBin2Style: FreeBin2Buffer(Data);
|
|
mrBin3Style: FreeBin3Buffer(Data);
|
|
end;
|
|
Ident := mrEmpty;
|
|
Data := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalLast;
|
|
begin
|
|
FRecordPos := RecordCount;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalOpen;
|
|
begin
|
|
BookmarkSize := SizeOf(TBookmarkData);
|
|
FieldDefs.Update;
|
|
IndexDefs.Updated := False;
|
|
if DefaultFields then CreateFields;
|
|
BindFields(True);
|
|
CalculateOffsets;
|
|
RegisterClient(Self);
|
|
AllocKeyBuffers;
|
|
FLastUpdate:=Now;
|
|
if FDetailFields <> '' then InitDetailFieldNamesList;
|
|
if FIndexName <> '' then f_DefaultIndexRecord.Init(GetIndexFields);
|
|
DoFilterRecords;
|
|
InternalFirst;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalPost;
|
|
var
|
|
Rec: Pointer;
|
|
begin
|
|
{$IFDEF DELPHI6UP}
|
|
inherited InternalPost;
|
|
{$ENDIF}
|
|
if State = dsEdit then begin
|
|
Rec:=FDataList[FRecordPos];
|
|
IntGetRecordList.LockListForWriting;
|
|
try
|
|
IntAssignRecord(pointer(ActiveBuffer), Rec);
|
|
finally
|
|
IntGetRecordList.UnlockListForWriting;
|
|
end;
|
|
IntUpdateBuffer(Rec);
|
|
end
|
|
else begin
|
|
// if State in [dsInsert] then SetAutoIncFields(ActiveBuffer);
|
|
Rec := CreateMemDatasetRecord(mrEmpty,0,False);
|
|
IntAssignRecord(Pointer(ActiveBuffer), Rec);
|
|
intInsertRecord(Rec);
|
|
IntInsertBuffer(Rec);
|
|
end;
|
|
FLastUpdate := now;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalSetFieldData(Field: TField; Buffer: Pointer);
|
|
var
|
|
RecBuf: Dataset_PAnsiChar;
|
|
Data: PAnsiChar;
|
|
nativeData: Dataset_PAnsiChar;
|
|
begin
|
|
{$IFDEF FPC}
|
|
RecBuf := nil;
|
|
{$ENDIF FPC}
|
|
GetActiveRecBuf(RecBuf);
|
|
ConvertBin3ToBin2Record(PMemDatasetrecord_Native(RecBuf));
|
|
with Field do begin
|
|
if State = dsSetKey then
|
|
nativeData := RecBuf
|
|
else
|
|
nativeData := PMemDatasetrecord_Native(RecBuf)^.Data;
|
|
Data := IntFindFieldData(nativeData, Field, True);
|
|
if Data <> nil then begin
|
|
{
|
|
if DataType = ftVariant then begin
|
|
if Buffer <> nil then
|
|
VarData := PVariant(Buffer)^
|
|
else
|
|
VarData := EmptyParam;
|
|
PVariant(Data)^ := VarData;
|
|
end else
|
|
}
|
|
if not IsReferencedField(DataType) then begin
|
|
if Buffer <> nil then begin
|
|
Move(Buffer^, Data^, FDataSizeArray[Field.Index]);
|
|
SetNullMask(nativeData, Index, False);
|
|
end
|
|
else
|
|
SetNullMask(nativeData, Index, True);
|
|
end
|
|
else begin
|
|
if Buffer <> nil then begin
|
|
if DataType in [ftString,ftFixedChar] then begin
|
|
PAnsiString(Data)^ := PAnsiChar(buffer);
|
|
SetNullMask(nativeData, Index, False);
|
|
end
|
|
else if DataType = ftWideString then begin
|
|
PWideString(Data)^ := PWideChar(buffer);
|
|
SetNullMask(nativeData, Index, False);
|
|
end;
|
|
end
|
|
else
|
|
SetNullMask(nativeData, Index, True);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalSetToRecord(Buffer: Dataset_PAnsiChar);
|
|
begin
|
|
InternalGotoBookmark(@PMemDatasetRecord(Buffer)^.BookmarkData.Bookmark);
|
|
end;
|
|
|
|
function TDAMemoryDataset.IntFindFieldData(Buffer: Dataset_PAnsiChar;
|
|
Field: TField; aBin2: Boolean): Pointer;
|
|
begin
|
|
if (Buffer <> nil) and (Field.DataType in ft_Supported) then begin
|
|
if aBin2 then
|
|
Result := (Buffer + FOffsets[Field.Index])
|
|
else
|
|
Result := Buffer + GetBin3Offset(Buffer,Field.Index);
|
|
end
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TDAMemoryDataset.IntFindFieldData(Buffer: PMemDatasetrecord_Native;Field: TField): Pointer;
|
|
begin
|
|
if (Buffer <> nil) then
|
|
Result := IntFindFieldData(Buffer^.Data,Field, Buffer^.Ident = mrBin2Style)
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TDAMemoryDataset.IntFindRecordID(Buf: pointer): Integer;
|
|
begin
|
|
Result := FDataList.IndexOf(Buf);
|
|
end;
|
|
|
|
function TDAMemoryDataset.IsActiveFilter: Boolean;
|
|
begin
|
|
Result := (Filtered and (Filter <> '')) or FRangeActive;
|
|
end;
|
|
|
|
function TDAMemoryDataset.IsCursorOpen: Boolean;
|
|
begin
|
|
Result := FActive;
|
|
end;
|
|
|
|
function TDAMemoryDataset.IsReferencedField(ADataType: TFieldType): Boolean;
|
|
begin
|
|
Result:= (FStoreStringsAsReference and (ADataType in ft_Strings)) or
|
|
(ADataType in ft_BlobTypes);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.OpenCursor(InfoQuery: Boolean);
|
|
var
|
|
i: integer;
|
|
lfld, lfld2: TField;
|
|
begin
|
|
if not InfoQuery then begin
|
|
if FCloneSource <> nil then begin
|
|
Fields.Clear;
|
|
// creating
|
|
FieldDefs.Assign(FCloneSource.FieldDefs);
|
|
for i:=0 to FieldDefs.Count-1 do
|
|
FieldDefs[i].CreateField(Self).DataSet := Self;
|
|
// creating lookups
|
|
For i:=0 to FCloneSource.Fields.Count-1 do begin
|
|
lfld2 := FCloneSource.Fields[i];
|
|
if lfld2.FieldKind in [fkCalculated,fkLookup] then begin
|
|
lfld := TField(lfld2.NewInstance).Create(Self);
|
|
lfld.Name := Self.Name + lfld2.FieldName;
|
|
lfld.FieldName := lfld2.FieldName;
|
|
lfld.DataSet := Self;
|
|
if (lfld2 is TStringField) or (lfld2 is TWideStringField) then lfld.Size := lfld2.Size;
|
|
lfld.FieldKind := lfld2.FieldKind;
|
|
lfld.Required := lfld2.Required;
|
|
{$IFNDEF FPC}
|
|
lfld.Lookup := lfld2.Lookup;
|
|
{$ENDIF}
|
|
lfld.LookupDataSet := lfld2.LookupDataSet;
|
|
lfld.LookupKeyFields := lfld2.LookupKeyFields;
|
|
lfld.LookupCache := lfld2.LookupCache;
|
|
lfld.LookupResultField := lfld2.LookupResultField;
|
|
lfld.KeyFields := lfld2.KeyFields;
|
|
end;
|
|
end;
|
|
for i := 0 to FCloneSource.Fields.Count-1 do
|
|
FieldByName(FCloneSource.Fields[i].FieldName).Index := i + 1;
|
|
end
|
|
else begin
|
|
if FieldCount > 0 then FieldDefs.Clear;
|
|
InitFieldDefsFromFields;
|
|
end;
|
|
FExpressionEvaluator.UseTrueFalseinVariableName:=False;
|
|
For i:=0 to Fields.Count-1 do begin
|
|
// eugene: 20080407 - SameText
|
|
if SameText(Fields[i].FieldName,'True') or SameText(Fields[i].FieldName,'False') then begin
|
|
FExpressionEvaluator.UseTrueFalseinVariableName:=True;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
FActive := True;
|
|
inherited OpenCursor(InfoQuery);
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetNullMask(Buffer: Dataset_PAnsiChar; const AIndex: Integer): boolean;
|
|
begin
|
|
Result := (ord(Buffer[AIndex shr 3]) shr (AIndex and 7)) and 1 = 1;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.RecordToBuffer(RecNo: integer; Buffer: PMemDatasetRecord);
|
|
begin
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
with Buffer^.BookmarkData do begin
|
|
Bookmark := TBookmarkData(FDataList[RecNo]);
|
|
BookmarkFlag := bfCurrent;
|
|
end;
|
|
DuplicateBuffer(FDataList[RecNo], Pointer(Buffer),False);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetAnsiString(NativeBuf: Pointer; Field: TField;
|
|
const Value: Ansistring);
|
|
var
|
|
len: integer;
|
|
begin
|
|
if FStoreStringsAsReference then
|
|
PAnsiString(NativeBuf)^:=Value
|
|
else begin
|
|
len := Length(Value);
|
|
if Len > Field.Size then len:= Field.Size;
|
|
move(Pointer(Value)^,NativeBuf^,len*SizeOf(AnsiChar));
|
|
PAnsiChar(NativeBuf)[len]:=#0;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetBlobData(Field: TField; Buffer: PMemDatasetrecord_Native;
|
|
Value: PBLOBRecord);
|
|
begin
|
|
ConvertBin3ToBin2Record(Buffer);
|
|
if PPointer(Buffer.Data + FOffsets[Field.Index])^ <> Value then begin
|
|
FreeBlobRecord(PPointer(Buffer.Data + FOffsets[Field.Index])^);
|
|
PPointer(Buffer.Data + FOffsets[Field.Index])^ := Value;
|
|
SetNullMask(Buffer.Data, Field.Index, False);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetBookmarkData(Buffer: Dataset_PAnsiChar; Data: Pointer);
|
|
begin
|
|
Move(Data^, PMemDatasetRecord(Buffer)^.BookmarkData.Bookmark, SizeOf(TBookmarkData));
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetBookmarkFlag(Buffer: Dataset_PAnsiChar; Value: TBookmarkFlag);
|
|
begin
|
|
PMemDatasetRecord(Buffer)^.BookmarkData.BookmarkFlag := Value;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetFieldData(Field: TField; Buffer: Pointer);
|
|
begin
|
|
if (State = dsSetKey) and ((Field.FieldNo < 0) or f_DefaultIndexRecord.IsValid and not Field.IsIndexField) then DatabaseErrorFmt(SNotIndexField, [Field.DisplayName]);
|
|
if not (State in dsWriteModes) then DatabaseError(SNotEditing);
|
|
with Field do begin
|
|
if FieldNo > 0 then begin
|
|
if State in [dsCalcFields, dsFilter] then DatabaseError(SNotEditing);
|
|
if ReadOnly and not (State in [dsSetKey, dsFilter]) then DatabaseErrorFmt({$IFDEF FPC}SReadOnlyField{$ELSE}SFieldReadOnly{$ENDIF}, [DisplayName]);
|
|
Validate(Buffer);
|
|
end;
|
|
if FieldKind <> fkInternalCalc then begin
|
|
InternalSetFieldData(Field, Buffer);
|
|
end;
|
|
if not (State in [dsCalcFields, dsInternalCalc, dsFilter, dsNewValue]) then DataEvent(deFieldChange, Longint(Field));
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetNullMask(Buffer: Dataset_PAnsiChar; const AIndex: Integer; const Value: boolean);
|
|
var
|
|
i: byte;
|
|
begin
|
|
i := AIndex shr 3;
|
|
if Value then
|
|
Buffer[I] := {$IFNDEF DELPHI2008UP}AnsiChar{$ENDIF}(ord(Buffer[I]) or (1 shl (AIndex and 7)))
|
|
else
|
|
Buffer[I] := {$IFNDEF DELPHI2008UP}AnsiChar{$ENDIF}(ord(Buffer[I]) and not (1 shl (AIndex and 7)))
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetOnFilterRecord(const Value: TFilterRecordEvent);
|
|
begin
|
|
inherited;
|
|
if Active and Filtered then First;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetRecNo(Value: Integer);
|
|
begin
|
|
if (Value > 0) and (Value <= RecordCount) then begin
|
|
DoBeforeScroll;
|
|
FRecordPos := Value - 1;
|
|
Resync([]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DataConvert(Field: TField; Source,
|
|
Dest: Pointer; ToNative: Boolean);
|
|
{$IFNDEF DELPHI10UP}
|
|
var
|
|
len: integer;
|
|
{$ENDIF DELPHI10UP}
|
|
begin
|
|
Case Field.Datatype of
|
|
ftBCD: PCurrency(Dest)^ := PCurrency(Source)^;
|
|
{$IFNDEF DELPHI10UP}
|
|
ftWideString: begin
|
|
if ToNative then begin
|
|
len := Length(PWideString(Source)^);
|
|
Move(PWideChar(Source^)^, PWideChar(Dest)^, len * SizeOf(WideChar));
|
|
PWideChar(Dest)[Len] := #0;
|
|
end
|
|
else begin
|
|
len := Length(PWideChar(Source));
|
|
SetString(WideString(Dest^), PWideChar(Source), Len);
|
|
end;
|
|
end
|
|
{$ENDIF DELPHI10UP}
|
|
else
|
|
inherited DataConvert(Field, Source, Dest, ToNative);
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetDataSource: TDataSource;
|
|
begin
|
|
Result := MasterDataLink.DataSource;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetMasterFields: string;
|
|
begin
|
|
Result := MasterDataLink.FieldNames;
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
const
|
|
SCircularDataLink = 'Circular datalinks are not allowed';
|
|
{$ENDIF}
|
|
procedure TDAMemoryDataset.SetDataSource(const Value: TDataSource);
|
|
begin
|
|
if IsLinkedTo(Value) then DatabaseError(SCircularDataLink, Self);
|
|
if MasterDataLink.DataSource <> Value then DataEvent(dePropertyChange, 0);
|
|
MasterDataLink.DataSource := Value;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetMasterFields(const Value: string);
|
|
begin
|
|
if (Value <> '') and (Filter <> '') then DatabaseError(SNoDetailFilter, Self);
|
|
if MasterDataLink.FieldNames <> Value then DataEvent(dePropertyChange, 0);
|
|
MasterDataLink.FieldNames := Value;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetIndexFieldNames: string;
|
|
begin
|
|
if FFieldsIndex then Result := FIndexName else Result := '';
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetIndexFieldNames(const Value: string);
|
|
begin
|
|
SetIndex(Value, True);
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetRecord(Buffer: Dataset_PAnsiChar; GetMode: TGetMode;
|
|
DoCheck: Boolean): TGetResult;
|
|
var
|
|
Accept: Boolean;
|
|
SaveState: TDataSetState;
|
|
begin
|
|
if Filtered and Assigned(OnFilterRecord) then begin
|
|
FFilterBuffer := Buffer;
|
|
SaveState := SetTempState(dsFilter);
|
|
try
|
|
Accept := True;
|
|
repeat
|
|
Result := InternalGetRecord(Pointer(Buffer), GetMode, DoCheck);
|
|
if Result = grOK then begin
|
|
OnFilterRecord(Self, Accept);
|
|
if not Accept and (GetMode = gmCurrent) then
|
|
Result := grError;
|
|
end;
|
|
until Accept or (Result <> grOK);
|
|
except
|
|
ApplicationHandleException(Self);
|
|
Result := grError;
|
|
end;
|
|
RestoreState(SaveState);
|
|
end else
|
|
Result := InternalGetRecord(Pointer(Buffer), GetMode, DoCheck)
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetFiltered(Value: Boolean);
|
|
begin
|
|
if Active and (Value <> Filtered) then begin
|
|
inherited;
|
|
if (Filter <> '') then
|
|
ProcessFilter
|
|
else if Assigned(OnFilterRecord) then First;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetFilterOptions(Value: TFilterOptions);
|
|
begin
|
|
if (Value <> FilterOptions) then begin
|
|
inherited;
|
|
FExpressionEvaluator.StringCaseInsensitive := foCaseInsensitive in FilterOptions;
|
|
FExpressionEvaluator.UseWildcardsInEqual := not (foNoPartialCompare in FilterOptions);
|
|
if Active and Filtered then ProcessFilter;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetFilterText(const Value: string);
|
|
begin
|
|
if Active and Filtered and (Value <> Filter) then begin
|
|
inherited;
|
|
ProcessFilter;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DoSort(AIndex: TDAMemIndex);
|
|
var
|
|
pos: TBookmarkData;
|
|
lRecList:TThreadMemList;
|
|
LList:TMemList;
|
|
lflag: boolean;
|
|
loldRangeActive: Boolean;
|
|
begin
|
|
if Active and (FieldCount > 0) and (FDataList.Count <> 0) then begin
|
|
if AIndex = f_DefaultIndexRecord then begin
|
|
loldRangeActive := FRangeActive;
|
|
FRangeActive := False;
|
|
try
|
|
if (FRecordPos<>-1) and (FRecordPos >= FDataList.Count) then
|
|
pos := FDataList[FRecordPos]
|
|
else
|
|
pos := nil;
|
|
try
|
|
lRecList:=IntGetRecordList;
|
|
LList:=lRecList.LockListForReading;
|
|
try
|
|
lflag:=(not AIndex.IsValid) and (FDataList.Count = LList.Count);
|
|
if lFlag then
|
|
FDataList.Assign(LList)
|
|
else begin
|
|
QuickSort(0, FDataList.Count - 1, Compare, AIndex);
|
|
end;
|
|
finally
|
|
lRecList.UnlockListForReading;
|
|
end;
|
|
AIndex.LastSorted := Now;
|
|
SetBufListSize(0);
|
|
try
|
|
SetBufListSize(BufferCount + 1);
|
|
except
|
|
SetState(dsInactive);
|
|
CloseCursor;
|
|
raise;
|
|
end;
|
|
{$IFDEF FPC}
|
|
RecalcBufListSize;
|
|
{$ENDIF}
|
|
finally
|
|
if pos = nil then
|
|
FRecordPos := -1
|
|
else
|
|
FRecordPos := IntFindRecordID(pos);
|
|
if (FRecordPos = -1) and (RecordCount > 0) then FRecordPos := 0;
|
|
end;
|
|
finally
|
|
FRangeActive := loldRangeActive;
|
|
end;
|
|
Resync([]);
|
|
end
|
|
else begin
|
|
if AIndex.IsValid then begin
|
|
if FLastUpdate > AIndex.LastSorted then begin
|
|
AIndex.DataList.Assign(FDataList);
|
|
QuickSort(0, AIndex.DataList.Count - 1, Compare, AIndex);
|
|
AIndex.LastSorted := Now;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.QuickSort(L, R: Integer; SCompare: TDAMemDatasetCompare;AIndex: TDAMemIndex);
|
|
var
|
|
I, J: Integer;
|
|
P: pointer;
|
|
llist: TMemList;
|
|
begin
|
|
lList := AIndex.DataList;
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
P := lList[(L + R) shr 1];
|
|
repeat
|
|
while SCompare(lList[I], P, AIndex) < 0 do Inc(I);
|
|
while SCompare(lList[j], P, AIndex) > 0 do Dec(J);
|
|
if I <= J then begin
|
|
lList.Exchange(I, J);
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
until I > J;
|
|
if L < J then QuickSort(L, J, SCompare, AIndex);
|
|
L := I;
|
|
until I >= R;
|
|
end;
|
|
|
|
function TDAMemoryDataset.Compare(i1, i2: PMemDatasetrecord_Native; AIndex: TDAMemIndex): Integer;
|
|
var
|
|
buf1, buf2: Dataset_PAnsiChar;
|
|
i: integer;
|
|
Field: TField;
|
|
p1, p2: PAnsiChar;
|
|
lList: TMemList;
|
|
lbin2_1,lbin2_2: Boolean;
|
|
begin
|
|
buf1 := i1^.Data;
|
|
buf2 := i2^.Data;
|
|
Result := 0;
|
|
if AIndex.IsValid then begin
|
|
lbin2_1 := i1^.Ident = mrBin2Style;
|
|
lbin2_2 := i2^.Ident = mrBin2Style;
|
|
for i := 0 to AIndex.IndexFieldNameList.Count - 1 do begin
|
|
Field := AIndex.IndexFieldNameList[i];
|
|
if not GetNullMask(buf1, Field.Index) then
|
|
p1 := intFindFieldData(buf1, Field, lbin2_1)
|
|
else
|
|
p1 := nil;
|
|
if not GetNullMask(buf2, Field.Index) then
|
|
p2 := intFindFieldData(buf2, Field, lbin2_2)
|
|
else
|
|
p2 := nil;
|
|
if (p1 <> nil) and (p2 <> nil) then begin
|
|
Result := CompareValues(p1, p2, Field.DataType, AIndex.IndexCaseInsList[i] <> nil, lBin2_1, lBin2_2)
|
|
end
|
|
else
|
|
if p1 <> nil then Result := 1
|
|
else if p2 <> nil then Result := -1
|
|
else continue;
|
|
if AIndex.IndexDescFields[i] <> nil then Result := -Result;
|
|
if Result <> 0 then Exit;
|
|
end;
|
|
end;
|
|
if Result = 0 then begin
|
|
lList:=IntGetRecordList.LockListForReading;
|
|
try
|
|
Result := lList.IndexOf(buf1) - lList.IndexOf(buf2);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
if AIndex.SortDescMode then Result := -Result;
|
|
end;
|
|
end;
|
|
|
|
function WordBoolCompare(val1, val2: WordBool): integer;
|
|
begin
|
|
if val2 and not val1 then Result := -1
|
|
else if val1 and not val2 then Result := 1
|
|
else Result := 0;
|
|
end;
|
|
|
|
function Int64Compare(val1, val2: Int64): integer;
|
|
begin
|
|
if val1 > val2 then Result := 1
|
|
else if val2 > val1 then Result := -1
|
|
else Result := 0;
|
|
end;
|
|
|
|
function IntegerCompare(val1, val2: integer): integer;
|
|
begin
|
|
if val1 > val2 then Result := 1
|
|
else if val2 > val1 then Result := -1
|
|
else Result := 0;
|
|
end;
|
|
|
|
function DoubleCompare(val1, val2: double): integer;
|
|
begin
|
|
if val1 > val2 then Result := 1
|
|
else if val2 > val1 then Result := -1
|
|
else Result := 0;
|
|
end;
|
|
|
|
function TDateTimeCompare(val1, val2: TDateTime): integer;
|
|
begin
|
|
if val1 > val2 then Result := 1
|
|
else if val2 > val1 then Result := -1
|
|
else Result := 0;
|
|
end;
|
|
|
|
function CurrencyCompare(val1, val2: Currency): integer;
|
|
begin
|
|
if val1 > val2 then Result := 1
|
|
else if val2 > val1 then Result := -1
|
|
else Result := 0;
|
|
end;
|
|
|
|
|
|
function TDAMemoryDataset.CompareValues(buf1, buf2: pointer;aDataType: TFieldType;aSortCaseInsensitive:Boolean; aBin2_1, aBin2_2: Boolean): integer;
|
|
begin
|
|
Result := 0;
|
|
case aDataType of
|
|
ftString, ftFixedChar: begin
|
|
if FStoreStringsAsReference then begin
|
|
case (ord(aBin2_1) shl 1) or ord(aBin2_2) of
|
|
0 { 00b }: Result:= ROAnsiCompare(PAnsiChar(Buf1),PAnsiChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
1 { 01b }: Result:= ROAnsiCompare(PAnsiChar(Buf1),PAnsiString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
2 { 10b }: Result:= ROAnsiCompare(PAnsiString(Buf1)^,PAnsiChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
3 { 11b }: Result:= ROAnsiCompare(PAnsiString(Buf1)^,PAnsiString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
end
|
|
else begin
|
|
Result:= ROAnsiCompare(PAnsiChar(Buf1),PAnsiChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
end;
|
|
ftWideString: begin
|
|
if FStoreStringsAsReference then begin
|
|
case (ord(aBin2_1) shl 1) OR ord(aBin2_2) of
|
|
0 { 00b }: Result:= ROWideCompare(PWideChar(Buf1),PWideChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
1 { 01b }: Result:= ROWideCompare(PWideChar(Buf1),PWideString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
2 { 10b }: Result:= ROWideCompare(PWideString(Buf1)^,PWideChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
3 { 11b }: Result:= ROWideCompare(PWideString(Buf1)^,PWideString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
end
|
|
else begin
|
|
Result:= ROWideCompare(PWideChar(Buf1),PWideChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
end;
|
|
ftGuid: Result := StrLIComp(PAnsiChar(Buf1), PAnsiChar(Buf2),guidsize);
|
|
ftSmallint: Result := IntegerCompare(PSmallInt(buf1)^, PSmallInt(buf2)^);
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Result := IntegerCompare(PInteger(buf1)^, PInteger(buf2)^);
|
|
ftWord: Result := IntegerCompare(PWord(buf1)^, PWord(buf2)^);
|
|
ftBoolean: Result := WordBoolCompare(PWordBool(buf1)^, PWordBool(buf2)^);
|
|
ftFloat, ftCurrency: Result := DoubleCompare(PDouble(Buf1)^, PDouble(Buf2)^);
|
|
ftDateTime: Result := TDateTimeCompare(PDateTime(Buf1)^, PDateTime(Buf2)^);
|
|
ftBcd: Result := CurrencyCompare(PCurrency(Buf1)^, PCurrency(Buf2)^);
|
|
ftFMTBCD: Result := BcdCompare(PBcd(buf1)^, PBcd(buf2)^);
|
|
ftLargeint: Result := Int64Compare(PInt64(Buf1)^, PInt64(Buf2)^);
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := DoubleCompare(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^), SQLTimeStampToDateTime(PSQLTimeStamp(Buf2)^));
|
|
{$ENDIF FPC}
|
|
else
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SortOnFields(const Fields: string;
|
|
CaseInsensitive, Descending: Boolean);
|
|
begin
|
|
if FActive then begin
|
|
if (Fields = '') and (FIndexName <> '') then begin
|
|
// default sorting
|
|
if FFieldsIndex then
|
|
SortOnFields(IndexFieldNames)
|
|
else
|
|
SwitchToIndex(IndexName);
|
|
f_DefaultIndexRecord.LastSorted := Now;
|
|
end
|
|
else begin
|
|
if Fields = '' then
|
|
f_DefaultIndexRecord.Init(IndexFieldNames, CaseInsensitive, Descending)
|
|
else
|
|
f_DefaultIndexRecord.Init(Fields, CaseInsensitive, Descending);
|
|
SortOnFields(f_DefaultIndexRecord);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetStoreStringAsReference(const Value: Boolean);
|
|
begin
|
|
CheckInactive;
|
|
FStoreStringsAsReference := Value;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetWideString(NativeBuf: Pointer; Field: TField;
|
|
const Value: Widestring);
|
|
var
|
|
len: integer;
|
|
begin
|
|
if FStoreStringsAsReference then
|
|
PWideString(NativeBuf)^:=Value
|
|
else begin
|
|
len := Length(Value);
|
|
if Len > Field.Size then len:= Field.Size;
|
|
move(Pointer(Value)^,NativeBuf^,len*Sizeof(WideChar));
|
|
PWideChar(NativeBuf)[len]:=#0;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DoAfterOpen;
|
|
begin
|
|
if not IsEmpty then SortOnFields();
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.MasterChanged(Sender: TObject);
|
|
begin
|
|
ProcessFilter;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.MasterDisabled(Sender: TObject);
|
|
begin
|
|
DataEvent(dePropertyChange, 0);
|
|
DoFilterRecords;
|
|
end;
|
|
(*
|
|
procedure TDAMemoryDataset.GetDetailLinkFields(MasterFields,
|
|
DetailFields: TList);
|
|
begin
|
|
{ TODO : GetDetailLinkFields }
|
|
inherited GetDetailLinkFields(MasterFields, DetailFields);
|
|
end;
|
|
*)
|
|
|
|
procedure TDAMemoryDataset.DoFilterRecords;
|
|
var
|
|
i: integer;
|
|
pos: TBookmarkData;
|
|
begin
|
|
if (FDataList.Count > 0) and (FRecordPos <> -1) and (FRecordPos < FDataList.Count) then
|
|
pos := FDataList[FRecordPos]
|
|
else
|
|
pos := nil;
|
|
//==============================
|
|
if ApplyMasterFilter then pos := nil;
|
|
if FRangeActive then begin
|
|
ApplyRangeFilter;
|
|
pos := nil;
|
|
end;
|
|
// apply filters
|
|
if IsActiveFilter then begin
|
|
for i := FDataList.Count-1 downto 0 do
|
|
if not FilterRecord(FDataList.List[i], False) then
|
|
FDataList.Delete(i);
|
|
end;
|
|
//==============================
|
|
if FIndexName <> '' then SortOnFields;
|
|
if Active then begin
|
|
if pos = nil then
|
|
FRecordPos := -1
|
|
else
|
|
FRecordPos := IntFindRecordID(pos);
|
|
if (FRecordPos = -1) then First;
|
|
if (RecordCount > 0) then FRecordPos := 0;
|
|
Resync([]);
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.MakeBlobFromString(Blob: AnsiString): PBLOBRecord;
|
|
var
|
|
s: integer;
|
|
begin
|
|
s:= Length(blob);
|
|
Result:=CreateBlobRecord(s);
|
|
Move(Pointer(blob)^, PBlobRecord(Result)^.Data, s * SizeOf(AnsiChar));
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IntInsertBuffer(Buffer: PMemDatasetrecord_Native;ASender: TDAMemoryDataset);
|
|
begin
|
|
if ASender = nil then ASender:=Self;
|
|
if FCloneSource <> nil then
|
|
FCloneSource.IntInsertBuffer(Buffer, aSender)
|
|
else begin
|
|
FRecordsList.Add(Buffer);
|
|
NotifyClients(Buffer, mdnInsert, ASender);
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetBin2FieldOffset(
|
|
const aFieldNo: integer): cardinal;
|
|
begin
|
|
if aFieldNo < FieldCount then
|
|
Result:=FOffsets[aFieldNo]
|
|
else
|
|
Result:=0;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DoOnNewRecord;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
if FMasterDataLink.Active and (FMasterDataLink.Fields.Count > 0) then
|
|
for I := 0 to FMasterDataLink.Fields.Count - 1 do
|
|
if FDetailsFieldNameList.Count > i then
|
|
TField(FDetailsFieldNameList[I]).Assign(TField(FMasterDataLink.Fields[I]));
|
|
inherited;
|
|
end;
|
|
|
|
function TDAMemoryDataset.Locate(const KeyFields: string;
|
|
const KeyValues: Variant; Options: TLocateOptions): Boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
Result := LocateRecord(KeyFields, KeyValues, Options, True);
|
|
if Result then
|
|
begin
|
|
Resync([rmExact, rmCenter]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.LocateRecord(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions; SyncCursor: Boolean): Boolean;
|
|
var
|
|
Buffer: PMemDatasetrecord;
|
|
lLocateStr: TMemLocateStruct;
|
|
|
|
function LocateWithOutIndex: boolean;
|
|
var
|
|
i,j: integer;
|
|
k: boolean;
|
|
lCaseInsensitive: boolean;
|
|
f: TMemLocateCompare;
|
|
buf: Dataset_PAnsiChar;
|
|
lBin2: Boolean;
|
|
begin
|
|
if loPartialKey in Options then
|
|
f := CompareValues2_partial
|
|
else
|
|
f := CompareValues2_full;
|
|
lCaseInsensitive:= loCaseInsensitive in Options;
|
|
with lLocateStr do begin
|
|
Result:=False;
|
|
For i:= 0 to lWorkList.Count - 1 do begin
|
|
k := False;
|
|
buf := PMemDatasetrecord_Native(lWorkList[i])^.Data;
|
|
lBin2 := PMemDatasetrecord_Native(lWorkList[i])^.Ident = mrBin2Style;
|
|
For j:=0 to lFields.Count-1 do begin
|
|
if ((buf = nil) or GetNullMask(buf,lFieldIndexes[j])) = lnull[j] then begin
|
|
if lnull[j] then
|
|
k := True // null | null
|
|
else
|
|
if lBin2 then
|
|
k := f(buf+lOffsets[j], lValues[j], lDatatypes[j], lCaseInsensitive, True)
|
|
else
|
|
k := f(buf+GetBin3Offset(buf,lFieldIndexes[j]), lValues[j], lDatatypes[j], lCaseInsensitive, False);
|
|
end
|
|
else
|
|
k:=False;
|
|
if not k then Break;
|
|
end;
|
|
if k then begin
|
|
RecordToBuffer(i, Buffer);
|
|
Result:=True;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function SearchIndex_Direct: TDAMemIndex;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result := f_DefaultIndexRecord;
|
|
if Result.isCanUsed(KeyFields,loCaseInsensitive in Options) then Exit;
|
|
for i:= 0 to FIndexList.Count - 1 do begin
|
|
Result := TDAMemIndex(FIndexList[i]);
|
|
if Result.isCanUsed(KeyFields,loCaseInsensitive in Options) then Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
var
|
|
lBookmark: TMemBookmarkData;
|
|
lLocalIndex: TDAMemIndex;
|
|
begin
|
|
Result := False;
|
|
|
|
// try to use indexes
|
|
if not (loPartialKey in Options) then begin
|
|
UpdateMemIndexes(-1);
|
|
// try to use indexes
|
|
lLocalIndex := SearchIndex_Direct;
|
|
if lLocalIndex <> nil then begin
|
|
Result := intLocateRecordByIndex(lLocalIndex,KeyValues,SyncCursor);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
SetLength(lBookmark, BookmarkSize);
|
|
FillChar(lBookmark, BookmarkSize, 0);
|
|
if Self.State <> dsBrowse then CheckBrowseMode;
|
|
CursorPosChanged;
|
|
Buffer := Pointer(TempBuffer);
|
|
if IsEmpty then Exit;
|
|
FillChar(lLocateStr, SizeOf(TMemLocateStruct),0);
|
|
try
|
|
lLocateStr.lFields := TList.Create;
|
|
try
|
|
GetFieldList(lLocateStr.lFields,KeyFields);
|
|
if lLocateStr.lFields.Count = 0 then Exit;
|
|
InitMemLocateStruct(@lLocateStr, KeyValues);
|
|
lLocateStr.lWorkList:= FDataList;
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
result:= LocateWithOutIndex;
|
|
if Result then begin
|
|
SetLength(lBookmark, BookmarkSize);
|
|
GetBookmarkData(Pointer(Buffer), Pointer(lBookmark));
|
|
end;
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
finally
|
|
lLocateStr.lFields.Free;
|
|
end;
|
|
finally
|
|
if Result then
|
|
if SyncCursor then begin
|
|
Bookmark := lBookmark;
|
|
UpdateCursorPos;
|
|
if EOF or BOF then Result := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.Lookup(const KeyFields: string;
|
|
const KeyValues: Variant; const ResultFields: string): Variant;
|
|
begin
|
|
Result := Null;
|
|
if LocateRecord(KeyFields, KeyValues, [], False) then
|
|
begin
|
|
SetTempState(dsCalcFields);
|
|
try
|
|
CalculateFields(TempBuffer);
|
|
Result := FieldValues[ResultFields];
|
|
finally
|
|
RestoreState(dsBrowse);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CompareValues2(buf1: pointer; aValue: TDAValueStruct; aDataType: TFieldType; aSortCaseInsensitive: Boolean;aBin2: boolean): integer;
|
|
var
|
|
str1: Ansistring;
|
|
wstr1: WideString;
|
|
begin
|
|
Result := 0;
|
|
case aDataType of
|
|
ftString, ftFixedChar: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
str1:=PAnsiString(Buf1)^
|
|
else
|
|
str1:=PAnsiChar(Buf1);
|
|
Result:= ROAnsiCompare(str1, aValue.AsAnsiString, aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
ftWideString: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
wstr1:=PWideString(Buf1)^
|
|
else
|
|
wstr1:=PWideChar(Buf1);
|
|
Result:= ROWideCompare(wstr1, aValue.AsWideString, aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS});
|
|
end;
|
|
ftGuid: begin
|
|
SetString(str1, PAnsiChar(buf1), guidsize);
|
|
Result := ROAnsiCompare(str1, aValue.AsAnsiString, True);
|
|
end;
|
|
ftSmallint: Result := IntegerCompare(PSmallInt(buf1)^, aValue.value);
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Result := IntegerCompare(PInteger(buf1)^, aValue.Value);
|
|
ftWord: Result := IntegerCompare(PWord(buf1)^, aValue.Value);
|
|
ftBoolean: Result := WordBoolCompare(PWordBool(buf1)^, aValue.Value);
|
|
ftFloat, ftCurrency: Result := DoubleCompare(PDouble(Buf1)^, aValue.Value);
|
|
ftDateTime: Result := TDateTimeCompare(PDateTime(Buf1)^, TimeStampToMSecs(DateTimeToTimeStamp(aValue.Value)));
|
|
ftBcd: Result := CurrencyCompare(PCurrency(buf1)^,aValue.Value);
|
|
ftFMTBCD: Result := BcdCompare(PBcd(buf1)^, VariantToBCD(aValue.Value));
|
|
ftLargeint: Result := Int64Compare(PInt64(Buf1)^, aValue.Value);
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := DoubleCompare(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^), SQLTimeStampToDateTime(VarToSQLTimeStamp(aValue.Value)));
|
|
{$ENDIF FPC}
|
|
else
|
|
end;
|
|
end;
|
|
|
|
|
|
function TDAMemoryDataset.CompareBookmarks(Bookmark1,
|
|
Bookmark2: TBookmark): Integer;
|
|
var
|
|
idx1, idx2: integer;
|
|
begin
|
|
if (Bookmark1 = nil) and (BookMark2 = nil) then
|
|
Result:=0
|
|
else if (Bookmark1 <> nil) and (BookMark2 = nil) then
|
|
Result := 1
|
|
else if (Bookmark1 = nil) and (BookMark2 <> nil) then
|
|
Result := -1
|
|
else begin
|
|
idx1 := IntFindRecordID(TBookMarkData(PPointer(Bookmark1)^));
|
|
idx2 := IntFindRecordID(TBookMarkData(PPointer(Bookmark2)^));
|
|
if idx1 > idx2 then
|
|
Result := 1
|
|
else if idx1 < idx2 then
|
|
Result := -1
|
|
else
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.BookmarkValid(Bookmark: TBookmark): Boolean;
|
|
begin
|
|
Result := IntFindRecordID(TBookMarkData(PPointer(Bookmark)^)) <> -1;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetIndexDefs: TIndexDefs;
|
|
begin
|
|
if FIndexDefs = nil then
|
|
FIndexDefs := TIndexDefs.Create(Self);
|
|
Result := FIndexDefs;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetIndexDefs(const Value: TIndexDefs);
|
|
begin
|
|
IndexDefs.Assign(Value);
|
|
end;
|
|
|
|
function TDAMemoryDataset.PSGetIndexDefs(
|
|
IndexTypes: TIndexOptions): TIndexDefs;
|
|
begin
|
|
Result := inherited GetIndexDefs(IndexDefs, IndexTypes);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.UpdateIndexDefs;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetIndexName: string;
|
|
begin
|
|
if FFieldsIndex then Result := '' else Result := FIndexName;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetIndexName(const Value: string);
|
|
begin
|
|
SetIndex(Value, Value = '');
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetIndex(const Value: string;
|
|
FieldsIndex: Boolean);
|
|
begin
|
|
if FActive then begin
|
|
CheckBrowseMode;
|
|
UpdateCursorPos;
|
|
if (FIndexName <> Value) or (FFieldsIndex <> FieldsIndex) then begin
|
|
FIndexName := Value;
|
|
FFieldsIndex := FieldsIndex;
|
|
if FieldsIndex or (Value = '') then begin
|
|
SortOnFields(Value, False, False);
|
|
end
|
|
else
|
|
SwitchToIndex(Value);
|
|
end;
|
|
end;
|
|
FIndexName := Value;
|
|
FFieldsIndex := FieldsIndex;
|
|
f_DefaultIndexRecord.LastSorted := Now;
|
|
end;
|
|
|
|
|
|
procedure TDAMemoryDataset.SwitchToIndex(const IndexName: string);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FActive then begin
|
|
i:= IndexDefs.IndexOf(IndexName);
|
|
if i = -1 then DatabaseErrorFmt(SIndexNotFound,[IndexName]);
|
|
f_DefaultIndexRecord.Init(IndexDefs[i]);
|
|
f_DefaultIndexRecord.FInitFromIndexDef:= False;
|
|
SortOnFields(f_DefaultIndexRecord);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.GetIndexNames(List: TStrings);
|
|
begin
|
|
IndexDefs.Update;
|
|
IndexDefs.GetItemNames(List);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.AddIndex(const Name, Fields, DescFields,
|
|
CaseInsFields: string);
|
|
var
|
|
lIndexDef: TIndexDef;
|
|
begin
|
|
lIndexDef := IndexDefs.AddIndexDef;
|
|
lIndexDef.Name := Name;
|
|
lIndexDef.Fields := Fields;
|
|
lIndexDef.DescFields := DescFields;
|
|
lIndexDef.CaseInsFields := CaseInsFields;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DeleteIndex(const Name: string);
|
|
var
|
|
i: integer;
|
|
begin
|
|
i:=IndexDefs.IndexOf(Name);
|
|
if i <> -1 then IndexDefs.Delete(i);
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
const
|
|
SInvalidCalcType = 'Field ''%s'' cannot be a calculated or lookup field';
|
|
{$ENDIF}
|
|
|
|
procedure TDAMemoryDataset.ValidateFieldForIndex(aField: TField);
|
|
begin
|
|
if not ((aField.FieldKind =fkData) and (aField.DataType in ft_Supported - ft_BlobTypes)) then
|
|
DatabaseErrorFmt(SInvalidCalcType, [aField.DisplayName]);
|
|
end;
|
|
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF DELPHI10UP}
|
|
procedure TDAMemoryDataset.SortOnFields(const Fields, CaseInsFields, DescFields: string);
|
|
begin
|
|
if FActive then begin
|
|
f_DefaultIndexRecord.Init(Fields,CaseInsFields,DescFields);
|
|
SortOnFields(f_DefaultIndexRecord);
|
|
end;
|
|
end;
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED ON}
|
|
{$ENDIF DELPHI10UP}
|
|
|
|
procedure TDAMemoryDataset.SortOnFields;
|
|
begin
|
|
SortOnFields('');
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DefChanged(Sender: TObject);
|
|
begin
|
|
{$IFNDEF FPC}
|
|
inherited;
|
|
{$ENDIF}
|
|
if Sender = FIndexDefs then
|
|
UpdateMemIndexes;
|
|
if (not FFieldsIndex) and (FIndexName <> '') then begin
|
|
if FIndexDefs.Count = 0 then FIndexName:='';
|
|
SortOnFields;
|
|
end;
|
|
end;
|
|
|
|
function CompareAnsiStrPartial(const aStr1, aStr2: AnsiString; aSortCaseInsensitive:Boolean): boolean;
|
|
var
|
|
l1: integer;
|
|
l2: Integer;
|
|
k: AnsiString;
|
|
begin
|
|
l1 := Length(aStr1);
|
|
l2 := Length(aStr2);
|
|
if (l1 > l2) or (l1 = 0) then
|
|
Result := False
|
|
else begin
|
|
if l1 = l2 then
|
|
k := aStr2
|
|
else
|
|
SetString(k,PAnsiChar(aStr2), l1);
|
|
Result := ROAnsiCompare(aStr1, k , aSortCaseInsensitive) = 0;
|
|
end;
|
|
end;
|
|
|
|
function CompareWideStrPartial(const aStr1, aStr2: WideString; aSortCaseInsensitive:Boolean): boolean;
|
|
var
|
|
l1: integer;
|
|
l2: Integer;
|
|
k: WideString;
|
|
begin
|
|
l1 := Length(aStr1);
|
|
l2 := Length(aStr2);
|
|
if (l1 > l2) or (l1 = 0) then
|
|
Result := False
|
|
else begin
|
|
if l1 = l2 then
|
|
k := aStr2
|
|
else
|
|
SetString(k, PWideChar(aStr2), l1);
|
|
Result := ROWideCompare(aStr1, k , aSortCaseInsensitive) = 0;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CompareValues2_partial(buf1: pointer; aValue: TDAValueStruct; aDataType: TFieldType; aSortCaseInsensitive:Boolean;abin2: boolean): boolean;
|
|
var
|
|
str1: AnsiString;
|
|
wstr1: widestring;
|
|
begin
|
|
Result := False;
|
|
case aDataType of
|
|
ftString, ftFixedChar: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
str1 := PAnsiString(Buf1)^
|
|
else
|
|
str1 := PAnsiChar(Buf1);
|
|
Result := CompareAnsiStrPartial(aValue.AsAnsiString, str1, aSortCaseInsensitive);
|
|
end;
|
|
ftWideString: begin
|
|
if abin2 and FStoreStringsAsReference then
|
|
wstr1 := PWideString(Buf1)^
|
|
else
|
|
wstr1 := PWideChar(Buf1);
|
|
Result := CompareWideStrPartial(aValue.AsWideString, wstr1, aSortCaseInsensitive);
|
|
end;
|
|
ftGuid: begin
|
|
SetString(str1, PAnsiChar(buf1), guidsize);
|
|
Result := CompareAnsiStrPartial(aValue.AsAnsiString, str1, aSortCaseInsensitive);
|
|
end;
|
|
ftSmallint: Result := pos(VarToStr(aValue.Value), IntToStr(PSmallInt(buf1)^)) = 1;
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Result := pos(VarToStr(aValue.Value), IntToStr(PInteger(buf1)^)) = 1;
|
|
ftWord: Result := pos(VarToStr(aValue.Value), IntToStr(PWord(buf1)^)) = 1;
|
|
ftBoolean: Result:= PWordBool(buf1)^ = aValue.Value;
|
|
ftFloat, ftCurrency: Result := pos(VarToStr(aValue.Value), FloatToStr(PDouble(buf1)^)) = 1;
|
|
ftDateTime: Result := pos(VarToStr(aValue.Value), DateToStr(TimeStampToDateTime(MSecsToTimeStamp({$IFDEF FPC}Trunc{$ENDIF}(PDateTime(buf1)^))))) = 1;
|
|
ftBcd: Result := Pos(VarToStr(aValue.Value), CurrToStr(PCurrency(Buf1)^)) = 1;
|
|
ftFMTBCD: Result :=pos(VarToStr(aValue.Value), BcdToStr(PBcd(buf1)^)) = 1;
|
|
ftLargeint: Result := pos(VarToStr(aValue.Value), IntToStr(PInt64(buf1)^)) = 1;
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := pos(VarToStr(aValue.Value), DateTimeToStr(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^))) = 1;
|
|
{$ENDIF FPC}
|
|
else
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.Notification(AComponent: TComponent;
|
|
Operation: TOperation);
|
|
begin
|
|
inherited;
|
|
if (Operation = opRemove) and (AComponent = FCloneSource) then
|
|
DetachFromSource;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CloneCursor(Source: TDAMemoryDataset; Reset: Boolean; KeepSettings: Boolean = False);
|
|
begin
|
|
Source.CheckActive;
|
|
Close;
|
|
Source.UpdateCursorPos;
|
|
FCloneSource := Source;
|
|
if Reset then begin
|
|
Filtered := False;
|
|
Filter := '';
|
|
OnFilterRecord := nil;
|
|
IndexDefs.Clear;
|
|
IndexName := '';
|
|
MasterSource := nil;
|
|
MasterFields := '';
|
|
DetailFields := '';
|
|
ReadOnly := False;
|
|
end
|
|
else if not KeepSettings then begin
|
|
Filter := Source.Filter;
|
|
OnFilterRecord := Source.OnFilterRecord;
|
|
Filtered := Source.Filtered;
|
|
IndexDefs.Assign(Source.IndexDefs);
|
|
if Source.IndexName <> '' then
|
|
IndexName := Source.IndexName
|
|
else
|
|
IndexFieldNames := Source.IndexFieldNames;
|
|
MasterSource := Source.MasterSource;
|
|
MasterFields := Source.MasterFields;
|
|
DetailFields := Source.DetailFields;
|
|
ReadOnly := Source.ReadOnly;
|
|
end;
|
|
Open;
|
|
if Reset then Resync([]);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IntRemoveBuffer(Buffer: PMemDatasetrecord_Native; ASender: TDAMemoryDataset);
|
|
begin
|
|
if FCloneSource <> nil then
|
|
FCloneSource.IntRemoveBuffer(Buffer,ASender)
|
|
else begin
|
|
NotifyClients(Buffer,mdnDelete,ASender);
|
|
with FRecordsList.LockListForWriting do try
|
|
Remove(Buffer);
|
|
FreeMemDatasetRecord(Buffer);
|
|
finally
|
|
FRecordsList.UnlockListForWriting;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.IntGetRecordList: TThreadMemList;
|
|
begin
|
|
if FCloneSource <> nil then
|
|
Result:= FCloneSource.IntGetRecordList
|
|
else
|
|
Result:=FRecordsList;
|
|
end;
|
|
|
|
|
|
procedure TDAMemoryDataset.RegisterClient(const AClient: TDAMemoryDataset);
|
|
begin
|
|
if FCloneSource <> nil then begin
|
|
FCloneSource.RegisterClient(AClient);
|
|
end
|
|
else begin
|
|
if FCloneClientList = nil then FCloneClientList:=TThreadList.Create;
|
|
FCloneClientList.Add(AClient);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.UnregisterClient(const AClient: TDAMemoryDataset);
|
|
begin
|
|
if FCloneSource <> nil then begin
|
|
FCloneSource.UnregisterClient(AClient);
|
|
end
|
|
else begin
|
|
if FCloneClientList <> nil then
|
|
FCloneClientList.Remove(AClient);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.UnregisterAllClients;
|
|
var
|
|
i: integer;
|
|
lList: TList;
|
|
lClient: TDAMemoryDataset;
|
|
begin
|
|
if FCloneClientList <> nil then begin
|
|
lList:= FCloneClientList.LockList;
|
|
try
|
|
for i:= lList.Count-1 downto 0 do begin
|
|
lClient:= TDAMemoryDataset(lList[i]);
|
|
if Assigned(lClient) then lClient.DetachFromSource;
|
|
end;
|
|
lList.Clear;
|
|
finally
|
|
FCloneClientList.UnlockList;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DetachFromSource;
|
|
begin
|
|
FDataList.Clear;
|
|
FCloneSource := nil;
|
|
InternalFirst;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.NotifyClients(Buf: PMemDatasetrecord_Native; Operation: TMemDataSetNotification;ASender: TDAMemoryDataset);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FCloneClientList <> nil then
|
|
with FCloneClientList.LockList do try
|
|
For i:=0 to Count -1 do
|
|
if ASender <> TDAMemoryDataset(Items[i]) then
|
|
TDAMemoryDataset(Items[i]).RecordNotification(Buf,Operation);
|
|
finally
|
|
FCloneClientList.UnlockList;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TDAMemoryDataset.RecordNotification(Buf: PMemDatasetrecord_Native; Operation: TMemDataSetNotification);
|
|
var
|
|
i: integer;
|
|
begin
|
|
case Operation of
|
|
mdnInsert:
|
|
begin
|
|
intInsertRecord(Buf);
|
|
end;
|
|
mdnModify:
|
|
if IsActiveFilter and not FilterRecord(Buf, True) then begin
|
|
i := FDataList.Remove(buf);
|
|
if (i <> -1) and (i = FRecordPos) and (FRecordPos >= RecordCount) then Dec(FRecordPos);
|
|
end;
|
|
mdnDelete:
|
|
begin
|
|
i := FDataList.Remove(buf);
|
|
if (i <> -1) and (i = FRecordPos) and (FRecordPos >= RecordCount) then Dec(FRecordPos);
|
|
end;
|
|
mdnBatchAdding:
|
|
begin
|
|
ProcessFilter;
|
|
end;
|
|
end;
|
|
DataEvent(deUpdateState, 0);
|
|
// Refresh;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IntUpdateBuffer(Buffer: PMemDatasetrecord_Native; ASender: TDAMemoryDataset);
|
|
begin
|
|
if ASender = nil then ASender:=Self;
|
|
if FCloneSource <> nil then
|
|
FCloneSource.IntUpdateBuffer(Buffer, ASender)
|
|
else begin
|
|
NotifyClients(Buffer,mdnModify,ASender);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.intInsertRecord(Buf: PMemDatasetrecord_Native);
|
|
var
|
|
lCount: integer;
|
|
RecPos: integer;
|
|
begin
|
|
if not IsActiveFilter or FilterRecord(Buf, True) then begin
|
|
if State = dsInsert then begin
|
|
lCount:= IntGetRecordList.lockListForReading.Count;
|
|
IntGetRecordList.UnlockListForReading;
|
|
if FRecordPos >= lCount then begin
|
|
FDataList.Add(Buf);
|
|
FRecordPos := RecordCount - 1;
|
|
end
|
|
else begin
|
|
if FRecordPos = -1 then
|
|
RecPos := 0
|
|
else
|
|
RecPos := FRecordPos;
|
|
FDataList.Insert(RecPos, Buf);
|
|
FRecordPos := RecPos;
|
|
end;
|
|
end
|
|
else begin
|
|
FDataList.Add(Buf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.AddRecordsfromList(AList: TList);
|
|
var
|
|
old_count: integer;
|
|
i: integer;
|
|
begin
|
|
with IntGetRecordList.LockListForWriting do try
|
|
old_count:=Count;
|
|
Count:=old_count+AList.Count;
|
|
System.Move(AList.List^, PAnsiChar(List^[old_Count]), AList.Count*SizeOf(Pointer));
|
|
if FAutoCompactRecords then
|
|
For i := old_count to Count -1 do
|
|
ConvertBin2ToBin3Record(List^[i]);
|
|
finally
|
|
IntGetRecordList.UnlockListForWriting;
|
|
end;
|
|
if (AList.Count > 0) then FLastUpdate := Now;
|
|
AList.Clear;
|
|
NotifyClients(nil, mdnBatchAdding, nil);
|
|
end;
|
|
|
|
function TDAMemoryDataset.CalcFieldLen(aDataType: TFieldType;
|
|
aSize: Integer): integer;
|
|
begin
|
|
if not (aDataType in ft_Supported) then
|
|
Result := 0
|
|
else if IsReferencedField(aDataType) then
|
|
Result := sizeof(Pointer)
|
|
else case aDataType of
|
|
ftSmallint: Result := SizeOf(Smallint);
|
|
ftInteger, ftAutoInc: Result := SizeOf(Integer);
|
|
ftWord: Result := SizeOf(Word);
|
|
ftBoolean: Result := SizeOf(WordBool);
|
|
ftFloat, ftCurrency: Result := SizeOf(Double);
|
|
ftDate, ftTime: Result := SizeOf(Integer);
|
|
ftDateTime: Result := SizeOf(TDateTime);
|
|
ftLargeint: Result := SizeOf(Largeint);
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := SizeOf(TSQLTimeStamp);
|
|
{$ENDIF}
|
|
ftFMTBCD: Result := SizeOf(TBcd);
|
|
ftBCD: Result := SizeOf(Currency);
|
|
ftGuid: Result := GuidSize+1;
|
|
ftString,ftFixedChar: Result := (aSize + 1)* Sizeof(AnsiChar);
|
|
ftWideString: Result := (aSize + 1) * Sizeof(WideChar);
|
|
else
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetReadOnly(const Value: Boolean);
|
|
begin
|
|
FReadOnly := Value;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetCanModify: Boolean;
|
|
begin
|
|
Result := not FReadOnly;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ApplyRange;
|
|
begin
|
|
CheckBrowseMode;
|
|
if not (BuffersEqual(FKeyBuffers[kiRangeStart], FKeyBuffers[kiCurRangeStart], SizeOf(TMemKeyBuffer) + FNativeRecordSize) and
|
|
BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd], SizeOf(TMemKeyBuffer) + FNativeRecordSize)) then begin
|
|
Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
FRangeActive:=(FKeyBuffers[kiCurRangeStart]<>nil) and (FKeyBuffers[kiCurRangeEnd]<>nil);
|
|
RefreshIndexConditional;
|
|
InternalFirst;
|
|
DoFilterRecords;
|
|
First;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CancelRange;
|
|
begin
|
|
CheckBrowseMode;
|
|
UpdateCursorPos;
|
|
FRangeActive := False;
|
|
if FKeyBuffers[kiCurRangeStart].Modified or FKeyBuffers[kiCurRangeEnd].Modified then begin
|
|
InitKeyBuffer(FKeyBuffers[kiCurRangeStart]);
|
|
InitKeyBuffer(FKeyBuffers[kiCurRangeEnd]);
|
|
end;
|
|
DoFilterRecords;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.EditRangeEnd;
|
|
begin
|
|
SetKeyBuffer(kiRangeEnd, False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.EditRangeStart;
|
|
begin
|
|
SetKeyBuffer(kiRangeStart, False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetRange(const StartValues,
|
|
EndValues: array of const);
|
|
begin
|
|
CheckBrowseMode;
|
|
SetKeyFields(kiRangeStart, StartValues);
|
|
SetKeyFields(kiRangeEnd, EndValues);
|
|
ApplyRange;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetRangeEnd;
|
|
begin
|
|
SetKeyBuffer(kiRangeEnd, True);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetRangeStart;
|
|
begin
|
|
SetKeyBuffer(kiRangeStart, True);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetKeyBuffer(KeyIndex: TMemKeyIndex; Clear: Boolean);
|
|
begin
|
|
CheckBrowseMode;
|
|
RefreshIndexConditional;
|
|
FKeyBuffer := FKeyBuffers[KeyIndex];
|
|
Move(FKeyBuffer^, FKeyBuffers[kiSave]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
if Clear then InitKeyBuffer(FKeyBuffer);
|
|
FKeyBuffer.FieldCount:= f_DefaultIndexRecord.IndexFieldNameList.Count;
|
|
SetState(dsSetKey);
|
|
SetModified(FKeyBuffer.Modified);
|
|
DataEvent(deDataSetChange, 0);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetKeyFields(KeyIndex: TMemKeyIndex; const Values: array of const);
|
|
var
|
|
I: Integer;
|
|
k: integer;
|
|
SaveState: TDataSetState;
|
|
begin
|
|
RefreshIndexConditional;
|
|
if f_DefaultIndexRecord.IndexFieldNameList.Count = 0 then DatabaseError(SNoFieldIndexes, Self);
|
|
SaveState := SetTempState(dsSetKey);
|
|
try
|
|
if f_DefaultIndexRecord.IndexFieldNameList.Count >= High(Values)-Low(Values)+1 then
|
|
k:= High(Values)-Low(Values)+1
|
|
else begin
|
|
k:= f_DefaultIndexRecord.IndexFieldNameList.Count;
|
|
{$IFDEF CHECK_RANGE}
|
|
DatabaseError('Can''t assign values: array size is larger than possible',Self);
|
|
{$ENDIF CHECK_RANGE}
|
|
end;
|
|
FKeyBuffer := InitKeyBuffer(FKeyBuffers[KeyIndex]);
|
|
for I := 0 to k-1 do
|
|
TField(f_DefaultIndexRecord.IndexFieldNameList[i]).AssignValue(Values[I]);
|
|
FKeyBuffer^.FieldCount := High(Values) + 1;
|
|
FKeyBuffer^.Modified := Modified;
|
|
finally
|
|
RestoreState(SaveState);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.AllocKeyBuffers;
|
|
var
|
|
KeyIndex: TMemKeyIndex;
|
|
begin
|
|
try
|
|
for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do
|
|
FKeyBuffers[KeyIndex] := AllocMem(SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
if Assigned(FCloneSource) then
|
|
for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do
|
|
Move(FCloneSource.FKeyBuffers[KeyIndex]^, FKeyBuffers[KeyIndex]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
except
|
|
FreeKeyBuffers;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FreeKeyBuffers;
|
|
var
|
|
KeyIndex: TMemKeyIndex;
|
|
begin
|
|
for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do
|
|
DisposeMem(FKeyBuffers[KeyIndex], SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
end;
|
|
|
|
function TDAMemoryDataset.InitKeyBuffer(Buffer: PMemKeyBuffer): PMemKeyBuffer;
|
|
begin
|
|
FillChar(Buffer^, SizeOf(TMemKeyBuffer) + FNativeRecordSize, 0);
|
|
Result := Buffer;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetDetailsFields(const Value: string);
|
|
begin
|
|
if FDetailFields <> Value then begin
|
|
FDetailFields := Value;
|
|
if Active then begin
|
|
InitDetailFieldNamesList;
|
|
DoFilterRecords;
|
|
end;
|
|
DataEvent(dePropertyChange, 0);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF DELPHI10UP}
|
|
procedure TDAMemoryDataset.InitDetailFieldNamesList;
|
|
var
|
|
pos1: integer;
|
|
fld: TField;
|
|
begin
|
|
FDetailsFieldNameList.Clear;
|
|
if FDetailFields = '' then Exit;;
|
|
Pos1 := 1;
|
|
while Pos1 <= Length(FDetailFields) do begin
|
|
Fld := FieldByName(ExtractFieldName(FDetailFields, Pos1));
|
|
ValidateFieldForIndex(Fld);
|
|
FDetailsFieldNameList.Add(Fld);
|
|
end;
|
|
end;
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED ON}
|
|
{$ENDIF DELPHI10UP}
|
|
|
|
function TDAMemoryDataset.ApplyMasterFilter:boolean;
|
|
var
|
|
i, j: integer;
|
|
MasterArray: array of TDAValueStruct;
|
|
buf: PAnsiChar;
|
|
flag: boolean;
|
|
fld_cnt: integer;
|
|
str: Ansistring;
|
|
lList: TMemList;
|
|
ldata: Dataset_PAnsiChar;
|
|
lBin2: Boolean;
|
|
begin
|
|
FDataList.Clear;
|
|
if (MasterSource = nil) or (MasterSource.DataSet = nil) or
|
|
(not MasterSource.DataSet.Active) or (MasterDataLink.Fields.Count = 0) or
|
|
(FDetailsFieldNameList.Count = 0) then begin
|
|
// not filtered!
|
|
lList:=IntGetRecordList.LockListForReading;
|
|
try
|
|
FDataList.Assign(LList);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
SortOnFields;
|
|
Result := False;
|
|
end
|
|
else begin
|
|
fld_cnt := MasterDataLink.Fields.Count;
|
|
if FDetailsFieldNameList.Count < fld_cnt then fld_cnt := FDetailsFieldNameList.Count;
|
|
SetLength(MasterArray, fld_cnt);
|
|
for i := 0 to fld_cnt - 1 do begin
|
|
if TField(MasterDataLink.Fields[i]).DataType in ft_AnsiStringValues then
|
|
MasterArray[i].AsAnsiString := TField(MasterDataLink.Fields[i]).{$IFDEF DELPHI2008UP}asAnsiString{$ELSE}asString{$ENDIF}
|
|
else if TField(MasterDataLink.Fields[i]).DataType in ft_WideStringValues then
|
|
MasterArray[i].AsWideString := TWideStringField(MasterDataLink.Fields[i]).Value
|
|
else
|
|
MasterArray[i].Value := TField(MasterDataLink.Fields[i]).Value;
|
|
end;
|
|
lList:= IntGetRecordList.LockListForReading;
|
|
try
|
|
FDataList.Capacity := lList.Count;
|
|
for i := 0 to LList.Count - 1 do begin
|
|
flag := true;
|
|
ldata := PMemDatasetrecord_Native(LList.FList^[i])^.Data;
|
|
lBin2 := PMemDatasetrecord_Native(LList.FList^[i])^.Ident = mrBin2Style;
|
|
for j := 0 to fld_cnt - 1 do begin
|
|
buf := IntFindFieldData(ldata, TField(FDetailsFieldNameList[j]), lBin2);
|
|
if (buf <> nil) then
|
|
case TField(FDetailsFieldNameList[j]).DataType of
|
|
ftString, ftFixedChar: begin
|
|
if lBin2 and FStoreStringsAsReference then
|
|
flag := ROAnsiCompare(PAnsistring(Buf)^, MasterArray[j].AsAnsiString, True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0
|
|
else
|
|
flag := ROAnsiCompare(PAnsiChar(Buf), MasterArray[j].AsAnsiString, True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0
|
|
end;
|
|
ftWideString: begin
|
|
if lBin2 and FStoreStringsAsReference then
|
|
flag := ROWideCompare(PWidestring(Buf)^, MasterArray[j].AsWideString,True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0
|
|
else
|
|
flag := ROWideCompare(PWideChar(Buf), MasterArray[j].AsWideString,True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0
|
|
end;
|
|
ftSmallint: flag := PSmallint(buf)^ = MasterArray[j].value;
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Flag := PInteger(buf)^ = MasterArray[j].value;
|
|
ftWord: flag := PWord(buf)^ = MasterArray[j].value;
|
|
ftBoolean: flag := PWordBool(buf)^ = wordbool(MasterArray[j].value);
|
|
ftFloat, ftCurrency: flag := PDouble(Buf)^ = MasterArray[j].value;
|
|
ftDateTime: flag := PDateTime(Buf)^ = MasterArray[j].value;
|
|
ftBcd: flag := PCurrency(Buf)^ = MasterArray[j].value;
|
|
ftFMTBCD: flag := BcdCompare(PBcd(buf)^, VariantToBCD(MasterArray[j].value)) = 0;
|
|
ftLargeint: flag := PInt64(Buf)^ = MasterArray[j].value;
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: flag := SQLTimeStampToDateTime(PSQLTimeStamp(Buf)^) = SQLTimeStampToDateTime(VarToSQLTimeStamp(MasterArray[j].value));
|
|
{$ENDIF FPC}
|
|
ftGuid: begin
|
|
SetString(str, PAnsiChar(Buf), guidsize);
|
|
flag := ROAnsiCompare(str, MasterArray[j].AsAnsiString, True) = 0;
|
|
end;
|
|
end
|
|
else
|
|
Flag := not VarIsNull(MasterArray[j].value);
|
|
if not flag then Break;
|
|
end;
|
|
if flag then FDataList.Add(lList.FList^[i]);
|
|
end;
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
Result := true;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CompareValues_Range(buf: PMemDatasetrecord_Native; keybuffer: PMemKeyBuffer): integer;
|
|
var
|
|
i, lFieldCount: integer;
|
|
p1,p2: PAnsiChar;
|
|
lField: TField;
|
|
lBuf, lbuf2: Dataset_PAnsiChar;
|
|
lbin2_1,lbin2_2 :Boolean;
|
|
begin
|
|
if f_DefaultIndexRecord.IndexFieldNameList.Count >= keybuffer^.FieldCount then begin
|
|
lFieldCount := keybuffer^.FieldCount
|
|
end
|
|
else begin
|
|
lFieldCount := f_DefaultIndexRecord.IndexFieldNameList.Count;
|
|
{$IFDEF CHECK_RANGE}
|
|
DatabaseError('Error during applying range');
|
|
{$ENDIF CHECK_RANGE}
|
|
end;
|
|
Result := 0;
|
|
lbuf := buf^.Data;
|
|
lbuf2 := @keybuffer.Data;
|
|
lbin2_1 := buf^.Ident = mrBin2Style;
|
|
lbin2_2 := True;
|
|
For i:=0 to lFieldCount-1 do begin
|
|
lField := TField(f_DefaultIndexRecord.IndexFieldNameList[i]);
|
|
|
|
if (lBuf <> nil) and not GetNullMask(lbuf, lField.Index) then
|
|
p1 := intFindFieldData(lbuf, lField, lbin2_1)
|
|
else
|
|
p1 := nil;
|
|
|
|
if not GetNullMask(lbuf2, lField.Index) then
|
|
p2 := intFindFieldData(lbuf2, lField, lbin2_2)
|
|
else
|
|
p2 := nil;
|
|
|
|
if (p1 <> nil) and (p2 <> nil) then
|
|
Result := CompareValues(p1, p2, lField.DataType, f_DefaultIndexRecord.IndexCaseInsList[i] <> nil, lbin2_1, lbin2_2)
|
|
else if p1 <> nil then Result := 1
|
|
else if p2 <> nil then Result := -1
|
|
else Continue;
|
|
|
|
if Result <> 0 then break;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ApplyRangeFilter;
|
|
begin
|
|
{ TODO : Can be optimized here }
|
|
end;
|
|
|
|
function TDAMemoryDataset.CompareValues2_full(buf1: pointer;
|
|
aValue: TDAValueStruct; aDataType: TFieldType;
|
|
aSortCaseInsensitive: Boolean; abin2: boolean): boolean;
|
|
begin
|
|
Result := CompareValues2(buf1,aValue,aDataType,aSortCaseInsensitive, abin2) = 0;
|
|
end;
|
|
|
|
|
|
function TDAMemoryDataset.FindKey(const KeyValues: array of const): Boolean;
|
|
begin
|
|
CheckBrowseMode;
|
|
SetKeyFields(kiLookup, KeyValues);
|
|
Result := GotoKey;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FindNearest(const KeyValues: array of const);
|
|
begin
|
|
CheckBrowseMode;
|
|
SetKeyFields(kiLookup, KeyValues);
|
|
GotoNearest;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GotoKey: Boolean;
|
|
begin
|
|
Result := internalGotoKey(FKeyBuffers[kiLookup], False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.GotoNearest;
|
|
begin
|
|
internalGotoKey(FKeyBuffers[kiLookup], True);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.EditKey;
|
|
begin
|
|
SetKeyBuffer(kiLookup, False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetKey;
|
|
begin
|
|
SetKeyBuffer(kiLookup, True);
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetIndexFields: string;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result := '';
|
|
if FIndexName <> '' then begin
|
|
if FFieldsIndex then begin
|
|
Result:=FIndexName
|
|
end
|
|
else begin
|
|
i:= IndexDefs.IndexOf(FIndexName);
|
|
if i = -1 then DatabaseErrorFmt(SIndexNotFound,[FIndexName]);
|
|
Result:=IndexDefs[i].Fields;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.internalGotoKey(const KeyBuffer: PMemKeyBuffer;
|
|
isNearest: Boolean): Boolean;
|
|
var
|
|
L, H, I, C : integer;
|
|
begin
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
RefreshIndexConditional;
|
|
if not isNearest then CursorPosChanged;
|
|
KeyBuffer.FieldCount:= f_DefaultIndexRecord.IndexFieldNameList.Count;
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
Result := False;
|
|
if isNearest then l:= FRecordPos else L := 0;
|
|
H := FDataList.Count - 1;
|
|
while L <= H do
|
|
begin
|
|
I := (L + H) shr 1;
|
|
c := CompareValues_Range(FDataList.List[i],KeyBuffer);
|
|
if C < 0 then
|
|
L := I + 1
|
|
else
|
|
begin
|
|
H := I - 1;
|
|
if C = 0 then Result := True;
|
|
end;
|
|
end;
|
|
if Result then
|
|
FRecordPos := l
|
|
else if isNearest then begin
|
|
if L + 1 <= H then
|
|
FRecordPos := L+1
|
|
else
|
|
FRecordPos := L;
|
|
end;
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
if not isNearest then begin
|
|
if Result then begin
|
|
Resync([rmExact, rmCenter]);
|
|
DoAfterScroll;
|
|
end;
|
|
end else begin
|
|
Resync([rmCenter]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetIsIndexField(Field: TField): Boolean;
|
|
begin
|
|
with Field do
|
|
Result:= (FieldNo > 0) and (f_DefaultIndexRecord.IndexFieldNameList.IndexOf(Field) >= 0);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.PostKeyBuffer(Commit: Boolean);
|
|
begin
|
|
DataEvent(deCheckBrowseMode, 0);
|
|
if Commit then
|
|
FKeyBuffer.Modified := Modified else
|
|
Move(FKeyBuffers[kiSave]^, FKeyBuffer^, SizeOf(TMemKeyBuffer) + FNativeRecordSize);
|
|
SetState(dsBrowse);
|
|
DataEvent(deDataSetChange, 0);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.Post;
|
|
begin
|
|
inherited;
|
|
if State = dsSetKey then PostKeyBuffer(True);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.Cancel;
|
|
begin
|
|
inherited;
|
|
if State = dsSetKey then PostKeyBuffer(False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.RefreshIndexConditional;
|
|
begin
|
|
if FLastUpdate > f_DefaultIndexRecord.LastSorted then SortOnFields;
|
|
end;
|
|
|
|
{$IFDEF BDS4UP}{$REGION 'MEM_PACKETRECORDS'}{$ENDIF BDS4UP}
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
procedure TDAMemoryDataset.CancelPackedMode;
|
|
begin
|
|
{ TODO : }
|
|
PackedRecordListClear;
|
|
PackedMode := False;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CommitPackedMode;
|
|
begin
|
|
{ TODO : ApplyChanges }
|
|
PackedMode := False;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.StartPackedMode;
|
|
begin
|
|
PackedMode := True;
|
|
{ TODO : }
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetPackedMode: Boolean;
|
|
begin
|
|
{ if FCloneSource <> nil then
|
|
Result:= FCloneSource.PackedMode
|
|
else
|
|
}
|
|
Result := fPackedMode;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetPackedMode(const Value: Boolean);
|
|
begin
|
|
if Value and (Value = GetPackedMode) then DatabaseError('Dataset already in packed mode');
|
|
{ if FCloneSource <> nil then
|
|
FCloneSource.PackedMode := Value
|
|
else }
|
|
fPackedMode := Value;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.PackedRecordListClear;
|
|
begin
|
|
// MemList_ClearRecords(FPackedRecordsList);
|
|
end;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
{$IFDEF BDS4UP}{$ENDREGION}{$ENDIF BDS4UP}
|
|
|
|
procedure TDAMemoryDataset.MemList_ClearRecords(aMemList: TMemList);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := aMemList.Count - 1 downto 0 do
|
|
FreeMemDatasetRecord(aMemList.List[i]);
|
|
aMemList.Clear;
|
|
end;
|
|
|
|
function TDAMemoryDataset.LocateByIndex(const aIndexName: string;
|
|
const KeyValues: Variant): Boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
Result := LocateRecordByIndex(aIndexName, KeyValues, True);
|
|
if Result then
|
|
begin
|
|
Resync([rmExact, rmCenter]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.LookupByIndex(const aIndexName: string;
|
|
const KeyValues: Variant; const ResultFields: string): Variant;
|
|
begin
|
|
Result := Null;
|
|
if LocateRecordByIndex(aIndexName, KeyValues, False) then
|
|
begin
|
|
SetTempState(dsCalcFields);
|
|
try
|
|
CalculateFields(TempBuffer);
|
|
Result := FieldValues[ResultFields];
|
|
finally
|
|
RestoreState(dsBrowse);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.LocateRecordByIndex(const aIndexName: string;
|
|
const KeyValues: Variant; SyncCursor: Boolean): Boolean;
|
|
var
|
|
i: integer;
|
|
lIndex: TDAMemIndex;
|
|
begin
|
|
i:= IndexDefs.IndexOf(aIndexName);
|
|
if i = -1 then DatabaseErrorFmt(SIndexNotFound,[aIndexName]);
|
|
UpdateMemIndexes(i);
|
|
lIndex := TDAMemIndex(FIndexList[i]);
|
|
DoSort(lIndex);
|
|
Result:= intLocateRecordByIndex(lIndex, KeyValues, SyncCursor);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SortOnFields(AIndex: TDAMemIndex);
|
|
begin
|
|
if FActive then DoSort(AIndex);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IndexList_Clear;
|
|
begin
|
|
While FIndexList.Count >0 do begin
|
|
TDAMemIndex(FIndexList.Last).Free;
|
|
FIndexList.Delete(FIndexList.Count-1);
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.LocateWithIndex(const LocateStruct: PMemLocateStruct; Buffer: PMemDatasetrecord): boolean;
|
|
var
|
|
L, H, I, C,j : integer;
|
|
lBin2: Boolean;
|
|
lBuf: Dataset_PAnsiChar;
|
|
begin
|
|
with LocateStruct^ do begin
|
|
Result := False;
|
|
L := 0;
|
|
H := lWorkList.Count - 1;
|
|
while L <= H do
|
|
begin
|
|
I := (L + H) shr 1;
|
|
c:=0;
|
|
lBuf:=PMemDatasetrecord_Native(lWorkList[i])^.Data;
|
|
lBin2:=PMemDatasetrecord_Native(lWorkList[i])^.Ident = mrBin2Style;
|
|
For j:=0 to lFields.Count-1 do begin
|
|
if GetNullMask(lBuf ,lFieldIndexes[j]) = lnull[j] then begin
|
|
if lnull[j] then
|
|
c := 0 // null | null
|
|
else
|
|
if lBin2 then
|
|
c := CompareValues2(lBuf + lOffsets[j], lValues[j], lDatatypes[j], lcaseIns[j],True) // not null | not null
|
|
else
|
|
c := CompareValues2(lBuf + GetBin3Offset(lBuf,lFieldIndexes[j]), lValues[j], lDatatypes[j], lcaseIns[j],True) // not null | not null
|
|
end
|
|
else begin
|
|
if lNull[j] then
|
|
c := 1 // not null | null
|
|
else
|
|
c := -1; // null | not null
|
|
end;
|
|
if c <> 0 then begin
|
|
if ldesc[j] then c:=-c;
|
|
Break;
|
|
end;
|
|
end;
|
|
if (C < 0) then
|
|
L := I + 1
|
|
else
|
|
begin
|
|
H := I - 1;
|
|
if C = 0 then Result := True;
|
|
end;
|
|
end;
|
|
if Result then LocalBufferToDatasetBuffer(lWorkList[l],Buffer);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.UpdateMemIndexes(AIndex: integer = -1);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if Active then begin
|
|
While FIndexDefs.Count > FIndexList.Count do
|
|
FIndexList.Add(TDAMemIndex.Create(self));
|
|
|
|
While FIndexDefs.Count < FIndexList.Count do begin
|
|
TDAMemIndex(FIndexList.Last).Free;
|
|
FIndexList.Delete(FIndexList.Count-1);
|
|
end;
|
|
|
|
if AIndex <> -1 then begin
|
|
TDAMemIndex(FIndexList[AIndex]).UpdateIndex(FIndexDefs[AIndex]);
|
|
end
|
|
else begin
|
|
For i:= 0 to FIndexDefs.Count -1 do
|
|
TDAMemIndex(FIndexList[i]).UpdateIndex(FIndexDefs[i]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.LocalBufferToDatasetBuffer(LocalBuf: PMemDatasetrecord_Native; DatasetBuffer: PMemDatasetrecord);
|
|
begin
|
|
IntGetRecordList.LockListForReading;
|
|
try
|
|
with DatasetBuffer^.BookmarkData do begin
|
|
Bookmark := TBookmarkData(LocalBuf);
|
|
BookmarkFlag := bfCurrent;
|
|
end;
|
|
DuplicateBuffer(LocalBuf, Pointer(DatasetBuffer),False);
|
|
finally
|
|
IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.PrepareIndexForSorting(const aIndexName: string = '');
|
|
var
|
|
i: integer;
|
|
begin
|
|
if aIndexName = '' then begin
|
|
UpdateMemIndexes(-1);
|
|
For i := 0 to IndexDefs.Count-1 do
|
|
DoSort(TDAMemIndex(FIndexList[i]));
|
|
end
|
|
else begin
|
|
i:= IndexDefs.IndexOf(aIndexName);
|
|
if i = -1 then DatabaseErrorFmt(SIndexNotFound,[aIndexName]);
|
|
UpdateMemIndexes(i);
|
|
DoSort(TDAMemIndex(FIndexList[i]));
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.intLocateRecordByIndex(aIndex: TDAMemIndex;
|
|
const KeyValues: Variant; SyncCursor: Boolean): Boolean;
|
|
var
|
|
i: integer;
|
|
Buffer: PMemDatasetrecord;
|
|
lBookmark: TMemBookmarkData;
|
|
lLocateStr: TMemLocateStruct;
|
|
begin
|
|
Result := False;
|
|
SetLength(lBookmark, BookmarkSize);
|
|
FillChar(lBookmark, BookmarkSize, 0);
|
|
if Self.State <> dsBrowse then CheckBrowseMode;
|
|
CursorPosChanged;
|
|
Buffer := pointer(TempBuffer);
|
|
if IsEmpty then Exit;
|
|
try
|
|
FillChar(lLocateStr, SizeOf(TMemLocateStruct),0);
|
|
lLocateStr.lFields := aIndex.IndexFieldNameList;
|
|
InitMemLocateStruct(@lLocateStr, KeyValues);
|
|
for i:=0 to lLocateStr.lFields.Count-1 do begin
|
|
lLocateStr.ldesc[i]:=aIndex.IndexDescFields[i]<>nil;
|
|
lLocateStr.lcaseIns[i] := aIndex.IndexCaseInsList[i]<>nil;
|
|
end;
|
|
lLocateStr.lWorkList:= aIndex.DataList;
|
|
Result := LocateWithIndex(@lLocateStr,Buffer);
|
|
if Result then begin
|
|
SetLength(lBookmark, BookmarkSize);
|
|
GetBookmarkData(pointer(Buffer), Pointer(lBookmark));
|
|
end;
|
|
finally
|
|
if Result then
|
|
if SyncCursor then begin
|
|
Bookmark := lBookmark;
|
|
UpdateCursorPos;
|
|
if EOF or BOF then Result := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InitMemLocateStruct(AStruct: PMemLocateStruct;
|
|
const KeyValues: Variant);
|
|
var
|
|
i: integer;
|
|
begin
|
|
with AStruct^ do begin
|
|
SetLength(lOffsets,lFields.Count);
|
|
SetLength(lDatatypes,lFields.Count);
|
|
SetLength(lValues,lFields.Count);
|
|
SetLength(lnull,lFields.Count);
|
|
SetLength(ldesc,lFields.Count);
|
|
SetLength(lcaseIns,lFields.Count);
|
|
SetLength(lFieldIndexes,lFields.Count);
|
|
for i:=0 to lFields.Count-1 do begin
|
|
lFieldIndexes[i]:=TField(lFields[i]).Index;
|
|
lOffsets[i] := GetBin2FieldOffset(lFieldIndexes[i]);
|
|
lDatatypes[i] := TField(lFields[i]).DataType;
|
|
if lFields.Count = 1 then
|
|
lValues[i].Value := KeyValues
|
|
else
|
|
lValues[i].Value := KeyValues[i];
|
|
lnull[i]:=VarIsEmpty(lValues[i].Value) or VarIsNull(lValues[i].Value);
|
|
if lDatatypes[i] in ft_AnsiStringValues then
|
|
lValues[i].AsAnsiString := {$IFDEF UNICODE}AnsiToUtf8{$ENDIF}(VarToStr(lValues[i].Value))
|
|
else if lDatatypes[i] in ft_WideStringValues then
|
|
lValues[i].AsWideString := VarToWideStr(lValues[i].Value)
|
|
else if lDatatypes[i] = ftDateTime then begin
|
|
case TVarData(lValues[i].Value).VType of
|
|
varString, varOleStr: lValues[i].Value := StrToDate(lValues[i].Value);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function TDAMemoryDataset.CreateBin3Struct(const ASize: Cardinal): Dataset_PAnsiChar;
|
|
begin
|
|
{$IFDEF FPC}
|
|
Result := nil;
|
|
{$ENDIF FPC}
|
|
GetMem(Result, ASize);
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetBin3Offset(Buffer: Dataset_PAnsiChar;
|
|
const aFieldNo: integer): cardinal;
|
|
begin
|
|
case pByte(buffer+FNullMaskSize)^ of
|
|
sizeOf(Byte): Result := PByteArray(Buffer+FNullMaskSize+1)^[aFieldNo];
|
|
sizeOf(word): Result := PWordArray(Buffer+FNullMaskSize+1)^[aFieldNo];
|
|
sizeOf(Cardinal): Result := PCardinalArray(Buffer+FNullMaskSize+1)^[aFieldNo];
|
|
else
|
|
raise Exception.Create('incompatible buffer format');
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CreateMemDatasetRecord(const AType: TmrMode;
|
|
ABin3Size: Cardinal;
|
|
ADatasetCompatible: Boolean): PMemDatasetrecord_Native;
|
|
var
|
|
lRecordSize: Cardinal;
|
|
begin
|
|
if ADatasetCompatible then
|
|
lRecordSize := SizeOf(TMemDatasetrecord)
|
|
else
|
|
lRecordSize := SizeOf(TMemDatasetrecord_Native);
|
|
{$IFDEF FPC}
|
|
Result := nil;
|
|
{$ENDIF}
|
|
GetMem(Result, lRecordSize);
|
|
FillChar(Result^,lRecordSize,0);
|
|
Result.Ident := AType;
|
|
case AType of
|
|
mrEmpty: ;
|
|
mrBin2Style: Result.Data := CreateBin2Struct;
|
|
mrBin3Style: Result.Data := CreateBin3Struct(ABin3Size);
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CreateBin2Struct: Dataset_PAnsiChar;
|
|
begin
|
|
{$IFDEF FPC}
|
|
Result := nil;
|
|
{$ENDIF FPC}
|
|
GetMem(Result, FNativeRecordSize);
|
|
FillChar(Result^, FNullMaskSize, $FF);
|
|
FillChar((Result+FNullMaskSize)^, FNativeRecordSize-FNullMaskSize, 0);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FreeMemDatasetRecord(Buffer: PMemDatasetrecord_Native);
|
|
begin
|
|
if Buffer <> nil then begin
|
|
with buffer^ do
|
|
case Ident of
|
|
mrBin2Style: FreeBin2Buffer(Data);
|
|
mrBin3Style: FreeBin3Buffer(Data);
|
|
mrEmpty:;
|
|
end;
|
|
FreeMem(Buffer);
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FreeBin2Buffer(Buffer: Dataset_PAnsiChar);
|
|
begin
|
|
if buffer <> nil then ClearBin2Buffer(Buffer);
|
|
FreeMem(buffer);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.FreeBin3Buffer(Buffer: Dataset_PAnsiChar);
|
|
begin
|
|
FreeMem(buffer);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ConvertBin3ToBin2Record(Buffer: PMemDatasetrecord_Native);
|
|
var
|
|
i: integer;
|
|
source, dest: Dataset_PAnsiChar;
|
|
k,k1: cardinal;
|
|
p2: PBlobRecord;
|
|
begin
|
|
case Buffer^.Ident of
|
|
mrEmpty: begin
|
|
Buffer^.Data := CreateBin2Struct;
|
|
Buffer^.Ident := mrBin2Style;
|
|
end;
|
|
mrBin2Style: ; //nothing
|
|
mrBin3Style: begin
|
|
source := Buffer^.Data;
|
|
Dest := CreateBin2Struct;
|
|
Buffer.Data:= Pointer(dest);
|
|
Buffer.Ident := mrBin2Style;
|
|
try
|
|
Move(pointer(Source)^, pointer(Dest)^, FNullMaskSize);
|
|
|
|
for I := 0 to FieldCount - 1 do begin
|
|
if (not GetNullMask(Source, i)) then begin
|
|
k := GetBin3Offset(Source, i);
|
|
k1:= GetBin3Offset(Source, i+1);
|
|
if not IsReferencedField(FDataTypeArray[i]) then begin
|
|
Move(pointer(Source + k)^, pointer(Dest + FOffsets[i])^, k1-k)
|
|
end
|
|
else begin
|
|
case FDataTypeArray[i] of
|
|
ftString,ftFixedChar: PAnsiString(Dest + FOffsets[i])^ := PAnsiString(Source + k)^;
|
|
ftWideString: PWideString(Dest + FOffsets[i])^ := PWideString(Source + k)^;
|
|
else
|
|
if FDataTypeArray[i] in ft_BlobTypes then begin
|
|
p2 := CreateBlobRecord(k1-k);
|
|
Move(pointer(Source + k)^, pointer(@p2.Data)^, k1-k);
|
|
PPointer(Dest + FOffsets[i])^ := p2;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeBin3Buffer(source);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CalculateRecordsSize: Cardinal;
|
|
var
|
|
i,j: integer;
|
|
List: TMemList;
|
|
buf: Dataset_PAnsiChar;
|
|
begin
|
|
if FCloneSource <> nil then
|
|
Result := FCloneSource.CalculateRecordsSize
|
|
else begin
|
|
Result:=0;
|
|
List:=FRecordsList.LockListForReading;
|
|
try
|
|
inc(Result, SizeOf(TMemDatasetrecord_Native)*List.Count);
|
|
For i:= 0 To List.Count-1 do begin
|
|
buf:=PMemDatasetrecord_Native(List[i])^.Data;
|
|
case PMemDatasetrecord_Native(List[i])^.Ident of
|
|
mrBin2Style : begin
|
|
inc(Result,FNativeRecordSize);
|
|
For j := 0 to FieldCount-1 do begin
|
|
if not GetNullMask(buf,j) then begin
|
|
if FDataTypeArray[j] in ft_BlobTypes then
|
|
inc(Result, PBlobRecord(PPointer(buf + FOffsets[j])^)^.size)
|
|
else if FStoreStringsAsReference then
|
|
case FDataTypeArray[j] of
|
|
ftString, ftFixedChar : inc(Result,Length(PAnsiString(buf + FOffsets[j])^)*SizeOf(AnsiChar));
|
|
ftWideString:inc(Result,Length(PWideString(buf + FOffsets[j])^)*SizeOf(WideChar));
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
mrBin3Style : inc(Result,GetBin3Offset(buf,FieldCount));
|
|
end;
|
|
end;
|
|
finally
|
|
FRecordsList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ClearBin2Buffer(Buffer: Dataset_PAnsiChar);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FHasReferencedFields then begin
|
|
for I := 0 to FieldCount - 1 do
|
|
if (not GetNullMask(Buffer, i)) and
|
|
IsReferencedField(FDataTypeArray[i]) and
|
|
(PPointer(Buffer + FOffsets[i])^ <> nil) then
|
|
ClearFieldByFieldType(Buffer + FOffsets[i], FDataTypeArray[i]);
|
|
end;
|
|
end;
|
|
|
|
function WStrLen(const Str: PWideChar): Cardinal;
|
|
var
|
|
P : PWideChar;
|
|
begin
|
|
P := Str;
|
|
while (P^ <> #0) do Inc(P);
|
|
Result := (P - Str);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ConvertBin2ToBin3Record(ASource : PMemDatasetrecord_Native);
|
|
var
|
|
lbin2, lbin3: Dataset_PAnsiChar;
|
|
begin
|
|
if ASource^.Ident = mrBin2Style then begin
|
|
lbin2 := ASource^.Data;
|
|
lBin3 := Bin2ToBin3(lBin2);
|
|
if lbin3 <> nil then begin
|
|
FreeBin2Buffer(lBin2);
|
|
ASource^.Data := lBin3;
|
|
ASource^.Ident := mrBin3Style;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CompactRecords;
|
|
var
|
|
List: TMemList;
|
|
i: integer;
|
|
begin
|
|
if FCloneSource <> nil then
|
|
FCloneSource.CompactRecords
|
|
else begin
|
|
List := FRecordsList.LockListForWriting;
|
|
try
|
|
for i:= 0 to List.Count -1 do
|
|
try
|
|
ConvertBin2ToBin3Record(List.FList^[i]);
|
|
except
|
|
FAutoCompactRecords := FAutoCompactRecords;
|
|
end;
|
|
finally
|
|
FRecordsList.UnlockListForWriting;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDAMemoryDataset.Bin2ToBin3(ASource: Dataset_PAnsiChar): Dataset_PAnsiChar;
|
|
var
|
|
i: integer;
|
|
p1: Dataset_PAnsiChar;
|
|
lBin2RecordSize, dx: cardinal;
|
|
lBlobPresent: boolean;
|
|
loffsets: array of cardinal;
|
|
lBin2DataSize: array of cardinal;
|
|
lDatatypeSize: Byte;
|
|
buf: Dataset_PAnsiChar;
|
|
begin
|
|
Result := nil;
|
|
lBin2RecordSize := 0;
|
|
lBlobPresent := False;
|
|
SetLength(loffsets, FieldCount+1);
|
|
SetLength(lBin2DataSize, FieldCount);
|
|
loffsets[0] := 0;
|
|
For i := 0 to FieldCount-1 do begin
|
|
if GetNullMask(ASource, i) then begin
|
|
lBin2DataSize[i] := 0;
|
|
end
|
|
else begin
|
|
if FDataTypeArray[i] in ft_BlobTypes then begin
|
|
lBlobPresent := True;
|
|
lBin2DataSize[i] := PBlobRecord(PPointer(ASource + FOffsets[i])^)^.size;
|
|
end
|
|
else if FDataTypeArray[i] in [ftString, ftFixedChar] then begin
|
|
if FStoreStringsAsReference then
|
|
lBin2DataSize[i] := Length(PAnsiString(ASource + FOffsets[i])^)
|
|
else
|
|
lBin2DataSize[i] := StrLen(PAnsiChar(ASource + FOffsets[i]));
|
|
inc(lBin2DataSize[i],SizeOf(AnsiChar)); // #0
|
|
end
|
|
else if FDataTypeArray[i] in [ftWideString] then begin
|
|
if FStoreStringsAsReference then
|
|
lBin2DataSize[i] := Length(PWideString(ASource + FOffsets[i])^)*SizeOf(WideChar)
|
|
else
|
|
lBin2DataSize[i] := WStrLen(PWideChar(ASource + FOffsets[i]))*SizeOf(WideChar);
|
|
inc(lBin2DataSize[i], SizeOf(WideChar)); // #0
|
|
end
|
|
else
|
|
lBin2DataSize[i]:= FDataSizeArray[i];
|
|
end;
|
|
loffsets[i+1] := loffsets[i]+ lBin2DataSize[i];
|
|
inc(lBin2RecordSize, lBin2DataSize[i]);
|
|
end;
|
|
inc(lBin2RecordSize, FNullMaskSize+SizeOf(Byte));
|
|
if lBin2RecordSize <= $FF - (Cardinal(FieldCount)+1)*SizeOf(Byte) then
|
|
lDatatypeSize := SizeOf(Byte)
|
|
else if lBin2RecordSize <= $FFFF - Cardinal(FieldCount+1)*SizeOf(Word) then
|
|
lDatatypeSize := SizeOf(Word)
|
|
else
|
|
lDatatypeSize := SizeOf(Cardinal);
|
|
inc(lBin2RecordSize,(FieldCount+1)*lDatatypeSize);
|
|
if (FNativeRecordSize > lBin2RecordSize) or FStoreStringsAsReference or lBlobPresent then begin
|
|
// convert it!
|
|
Result:=CreateBin3Struct(lBin2RecordSize);
|
|
p1 := Result;
|
|
move(ASource^, p1^, FNullMaskSize);
|
|
PByte(p1 + FNullMaskSize)^ := lDatatypeSize;
|
|
dx:=FNullMaskSize+SizeOf(Byte);
|
|
inc(p1, dx);
|
|
inc(dx,(FieldCount+1)*lDatatypeSize);
|
|
case lDatatypeSize of
|
|
SizeOf(Byte): for i:=0 to FieldCount do PBytearray(p1)^[i] := loffsets[i]+dx;
|
|
SizeOf(Word): for i:=0 to FieldCount do PWordArray(p1)^[i] := loffsets[i]+dx;
|
|
SizeOf(Cardinal): for i:=0 to FieldCount do PCardinalArray(p1)^[i] := loffsets[i]+dx;
|
|
end;
|
|
inc(p1, (FieldCount+1)*lDatatypeSize);
|
|
for i:=0 to FieldCount-1 do begin
|
|
if lBin2DataSize[i] > 0 then begin
|
|
buf := ASource + FOffsets[i];
|
|
if FDataTypeArray[i] in ft_BlobTypes then begin
|
|
move(PBlobRecord(PPointer(buf)^)^.Data, p1^,lBin2DataSize[i]);
|
|
end
|
|
else if FDataTypeArray[i] in [ftString, ftFixedChar] then begin
|
|
dx := lBin2DataSize[i]-SizeOf(AnsiChar);
|
|
if FStoreStringsAsReference then
|
|
Move(pointer(PAnsiString(buf)^)^, p1^, dx)
|
|
else
|
|
move(buf^, p1^, dx);
|
|
PAnsiChar(p1+dx)^ := #0;
|
|
end
|
|
else if FDataTypeArray[i] in [ftWideString] then begin
|
|
dx := lBin2DataSize[i] - SizeOf(WideChar);
|
|
if FStoreStringsAsReference then
|
|
Move(pointer(PWideString(buf)^)^, p1^, dx)
|
|
else
|
|
move(buf^, p1^, dx);
|
|
PWideChar(p1+dx)^ := #0;
|
|
end
|
|
else
|
|
move(buf^, p1^, lBin2DataSize[i]);
|
|
inc(p1, lBin2DataSize[i]);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TDAMemoryDataset.SetAutoPackRecords(const Value: boolean);
|
|
begin
|
|
FAutoCompactRecords := Value;
|
|
if FAutoCompactRecords then CompactRecords;
|
|
end;
|
|
|
|
{ TDABlobStream }
|
|
|
|
constructor TDABlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
var
|
|
lbuf: Dataset_PAnsiChar;
|
|
begin
|
|
inherited Create;
|
|
FMode := Mode;
|
|
FField := Field;
|
|
FDataSet := FField.DataSet as TDAMemoryDataset;
|
|
if not FDataSet.GetActiveRecBuf(lBuf) then Exit;
|
|
FBuffer := PMemDatasetrecord_Native(lBuf);
|
|
if not FField.Modified and (Mode <> bmRead) then begin
|
|
if FField.ReadOnly then DatabaseErrorFmt({$IFDEF FPC}SReadOnlyField{$ELSE}SFieldReadOnly{$ENDIF}, [FField.DisplayName]);
|
|
if not (FDataSet.State in [dsEdit, dsInsert]) then DatabaseError(SNotEditing);
|
|
FCached := True;
|
|
end
|
|
else
|
|
FCached := (lBuf = FDataSet.ActiveBuffer);
|
|
FOpened := True;
|
|
if Mode = bmWrite then Truncate;
|
|
end;
|
|
|
|
destructor TDABlobStream.Destroy;
|
|
begin
|
|
if FOpened and FModified then FField.Modified := True;
|
|
if FModified then try
|
|
FDataSet.DataEvent(deFieldChange, Longint(FField));
|
|
except
|
|
{$IFDEF FPC}
|
|
if assigned(classes.ApplicationHandleException) then
|
|
classes.ApplicationHandleException(self)
|
|
else
|
|
ShowException(ExceptObject,ExceptAddr);
|
|
{$ELSE}
|
|
Application.HandleException(Self);
|
|
{$ENDIF}
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TDABlobStream.GetBLOBRecordFromRecord(Field: TField; out aLocked:Boolean; out blob_size: integer; out blob_data: pointer);
|
|
var
|
|
Pos: Integer;
|
|
begin
|
|
Pos := FDataSet.FRecordPos;
|
|
if (Pos < 0) and (FDataSet.RecordCount > 0) then
|
|
Pos := 0
|
|
else if Pos >= FDataSet.RecordCount then
|
|
Pos := FDataSet.RecordCount - 1;
|
|
if (Pos >= 0) and (Pos < FDataSet.RecordCount) then begin
|
|
GetBLOBRecordFromBuffer(FDataSet.IntGetRecordList.LockListForReading[Pos], Field, blob_size, blob_data);
|
|
ALocked:=True;
|
|
end
|
|
else begin
|
|
blob_data:=nil;
|
|
blob_size:=0;
|
|
end;
|
|
end;
|
|
|
|
function TDABlobStream.GetBlobSize: Longint;
|
|
var
|
|
llocked: Boolean;
|
|
ldata: pointer;
|
|
begin
|
|
Result := 0;
|
|
if FOpened then begin
|
|
if FCached then begin
|
|
GetBLOBRecordFromBuffer(FBuffer, FField,Result,ldata);
|
|
end
|
|
else begin
|
|
GetBLOBRecordFromRecord(FField, llocked,Result, ldata);
|
|
if llocked then FDataSet.IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDABlobStream.GetBLOBRecordFromBuffer(Buffer: PMemDatasetrecord_Native; Field: TField;out blob_size: integer; out blob_data: pointer): PBLOBRecord;
|
|
begin
|
|
case Buffer^.Ident of
|
|
mrBin2Style: begin
|
|
Result := PPointer(FDataSet.IntFindFieldData(Buffer^.Data, Field, True))^;
|
|
if Result <> nil then begin
|
|
with Result^ do begin
|
|
blob_data := @Data;
|
|
blob_size := size;
|
|
end;
|
|
end
|
|
else begin
|
|
blob_data := nil;
|
|
blob_size := 0;
|
|
end;
|
|
end;
|
|
mrBin3Style: begin
|
|
blob_size := FDataSet.GetBin3Offset(Buffer^.Data,Field.Index+1)-FDataSet.GetBin3Offset(Buffer^.Data,Field.Index);
|
|
blob_data := FDataSet.IntFindFieldData(Buffer^.Data, Field, False);
|
|
Result := nil;
|
|
end;
|
|
else
|
|
blob_data := nil;
|
|
blob_size := 0;
|
|
Result := nil;
|
|
end;
|
|
end;
|
|
|
|
function TDABlobStream.Read(var Buffer; Count: Integer): Longint;
|
|
var
|
|
llocked: boolean;
|
|
lData: pointer;
|
|
lSize: integer;
|
|
begin
|
|
llocked:=False;
|
|
Result := 0;
|
|
if FOpened then begin
|
|
if Count > Size - FPosition then
|
|
Result := Size - FPosition
|
|
else
|
|
Result := Count;
|
|
if Result > 0 then begin
|
|
if FCached then
|
|
GetBLOBRecordFromBuffer(FBuffer, FField,lSize,lData)
|
|
else
|
|
GetBLOBRecordFromRecord(FField,llocked,lSize,lData);
|
|
try
|
|
if lSize <> 0 then begin
|
|
Move(Dataset_PAnsiChar(lData)[FPosition], Buffer, Result);
|
|
Inc(FPosition, Result);
|
|
end;
|
|
finally
|
|
if llocked then FDataSet.IntGetRecordList.UnlockListForReading;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDABlobStream.Seek(Offset: Integer; Origin: Word): Longint;
|
|
begin
|
|
case Origin of
|
|
soFromBeginning: FPosition := Offset;
|
|
soFromCurrent: Inc(FPosition, Offset);
|
|
soFromEnd: FPosition := GetBlobSize + Offset;
|
|
end;
|
|
Result := FPosition;
|
|
end;
|
|
|
|
procedure TDABlobStream.Truncate;
|
|
begin
|
|
if FOpened and FCached and (FMode <> bmRead) then begin
|
|
FDataset.ConvertBin3ToBin2Record(FBuffer);
|
|
FDataset.ClearBin2Field(FBuffer^.Data, FField);
|
|
FModified := True;
|
|
end;
|
|
end;
|
|
|
|
function TDABlobStream.Write(const Buffer; Count: Integer): Longint;
|
|
var
|
|
Temp: PBLOBRecord;
|
|
lblobSize: integer;
|
|
lBlobData: pointer;
|
|
begin
|
|
Result := 0;
|
|
if FOpened and FCached and (FMode <> bmRead) then begin
|
|
Temp := GetBLOBRecordFromBuffer(FBuffer, FField,lblobSize,lBlobData);
|
|
if temp = nil then begin
|
|
temp := CreateBlobRecord(FPosition + Count);
|
|
end
|
|
else if Temp.size + SizeOf(TBLOBRecord) < Cardinal(FPosition + Count) then begin
|
|
ReallocMem(temp, SizeOf(TBLOBRecord) + FPosition); // compact date before realloc
|
|
ReallocMem(temp, SizeOf(TBLOBRecord) + FPosition + Count);
|
|
inc(Temp.size, Count);
|
|
end;
|
|
Move(Buffer, PAnsiChar(@Temp.Data)[FPosition], Count);
|
|
FDataset.SetBlobData(FField, FBuffer, Temp);
|
|
Inc(FPosition, Count);
|
|
Result := Count;
|
|
FModified := True;
|
|
end;
|
|
end;
|
|
|
|
{ TThreadMemList }
|
|
|
|
procedure TThreadMemList.Add(Item: Pointer);
|
|
begin
|
|
LockListForWriting;
|
|
try
|
|
FList.Add(Item);
|
|
finally
|
|
UnlockListForWriting;
|
|
end;
|
|
end;
|
|
|
|
procedure TThreadMemList.Clear;
|
|
begin
|
|
LockListForWriting;
|
|
try
|
|
FList.Clear;
|
|
finally
|
|
UnlockListForWriting;
|
|
end;
|
|
end;
|
|
|
|
constructor TThreadMemList.Create;
|
|
begin
|
|
inherited Create;
|
|
{$IFDEF FPC}
|
|
InitCriticalSection(FLock);
|
|
{$ELSE}
|
|
InitializeCriticalSection(FLock);
|
|
{$ENDIF}
|
|
FList := TMemList.Create;
|
|
FReadLock:=0;
|
|
end;
|
|
|
|
destructor TThreadMemList.Destroy;
|
|
begin
|
|
LockListForWriting; // Make sure nobody else is inside the list.
|
|
try
|
|
FList.Free;
|
|
inherited Destroy;
|
|
finally
|
|
UnlockListForWriting;
|
|
{$IFDEF FPC}
|
|
DoneCriticalSection(FLock);
|
|
{$ELSE}
|
|
DeleteCriticalSection(FLock);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function TThreadMemList.LockListForReading: TMemList;
|
|
begin
|
|
if FReadLock = 0 then EnterCriticalSection(FLock);
|
|
inc(FReadLock);
|
|
Result := FList;
|
|
end;
|
|
|
|
function TThreadMemList.LockListForWriting: TMemList;
|
|
begin
|
|
EnterCriticalSection(FLock);
|
|
Result := FList;
|
|
end;
|
|
|
|
procedure TThreadMemList.Remove(Item: Pointer);
|
|
begin
|
|
LockListForWriting;
|
|
try
|
|
FList.Remove(Item);
|
|
finally
|
|
UnlockListForWriting;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TThreadMemList.UnlockListForReading;
|
|
begin
|
|
Dec(FReadLock);
|
|
if FReadLock = 0 then LeaveCriticalSection(FLock);
|
|
end;
|
|
|
|
procedure TThreadMemList.UnlockListForWriting;
|
|
begin
|
|
LeaveCriticalSection(FLock);
|
|
end;
|
|
|
|
{$IFDEF BDS4UP}{$REGION 'MEM_PACKETRECORDS'}{$ENDIF BDS4UP}
|
|
{$IFDEF MEM_PACKETRECORDS}
|
|
{ TMemPackedRecord }
|
|
|
|
constructor TMemPackedRecord.Create(AOwner: TMemPackedRecords);
|
|
begin
|
|
fOwner := AOwner;
|
|
if AOwner = nil then DatabaseError('AOwner should be assigned');
|
|
fBuffer:= AOwner.fOwner.IntAllocRecordBuffer(True);
|
|
end;
|
|
|
|
destructor TMemPackedRecord.Destroy;
|
|
begin
|
|
fOwner.fOwner.IntFreeRecordBuffer(fBuffer);
|
|
inherited;
|
|
end;
|
|
|
|
function TMemPackedRecord.GetIsNull(Index: Integer): Boolean;
|
|
begin
|
|
Result := fOwner.fOwner.GetNullMask(fBuffer,Index);
|
|
end;
|
|
|
|
function TMemPackedRecord.GetValues(Index: Integer): Variant;
|
|
begin
|
|
Result := FOwner.fOwner.GetVarValueFromBuffer(fBuffer,FOwner.fOwner.Fields[Index]);
|
|
end;
|
|
|
|
function TMemPackedRecord.GetValuesByFieldName(AName: string): Variant;
|
|
begin
|
|
Result := FOwner.fOwner.GetVarValueFromBuffer(fBuffer,FOwner.fOwner.FieldByName(AName));
|
|
end;
|
|
|
|
procedure TMemPackedRecord.SetIsNull(Index: Integer; const Value: Boolean);
|
|
begin
|
|
fOwner.fOwner.ClearBin2Field(fBuffer,fOwner.fOwner.Fields[Index]);
|
|
fOwner.fOwner.SetNullMask(fBuffer,Index,Value);
|
|
end;
|
|
|
|
procedure TMemPackedRecord.SetValues(Index: Integer; const Value: Variant);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TMemPackedRecord.SetValuesByFieldName(AName: string;
|
|
const Value: Variant);
|
|
begin
|
|
|
|
end;
|
|
|
|
{ TMemPackedRecords }
|
|
|
|
function TMemPackedRecords.Add: TMemPackedRecord;
|
|
begin
|
|
Result:= TMemPackedRecord.Create(Self);
|
|
fList.Add(Result);
|
|
end;
|
|
|
|
procedure TMemPackedRecords.Clear;
|
|
var
|
|
i: integer;
|
|
begin
|
|
For i:= 0 to fList.Count - 1 do
|
|
TMemPackedRecord(fList[i]).Free;
|
|
fList.Clear;
|
|
end;
|
|
|
|
constructor TMemPackedRecords.Create(AOwner: TDAMemoryDataset);
|
|
begin
|
|
fOwner := AOwner;
|
|
fList := TList.Create;
|
|
end;
|
|
|
|
procedure TMemPackedRecords.Delete(aIndex: integer);
|
|
var
|
|
lRec: TMemPackedRecord;
|
|
begin
|
|
lRec := TMemPackedRecord(fList.Items[aIndex]);
|
|
fList.Delete(aIndex);
|
|
lRec.Free;
|
|
end;
|
|
|
|
destructor TMemPackedRecords.Destroy;
|
|
begin
|
|
Clear;
|
|
fList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TMemPackedRecords.GetCount: Integer;
|
|
begin
|
|
Result:= fList.Count;
|
|
end;
|
|
|
|
function TMemPackedRecords.GetItems(Index: Integer): TMemPackedRecord;
|
|
begin
|
|
Result := TMemPackedRecord(fList[Index]);
|
|
end;
|
|
{$ENDIF MEM_PACKETRECORDS}
|
|
{$IFDEF BDS4UP}{$ENDREGION}{$ENDIF BDS4UP}
|
|
|
|
{ TDAMemIndex }
|
|
|
|
procedure TDAMemIndex.Clear;
|
|
begin
|
|
FInit_FieldNames:= '';
|
|
FInit_CaseInsFields:='';
|
|
FInit_DescFields:='';
|
|
FIndexDef_Options:= [];
|
|
FIndexDef_Fields:='';
|
|
FIndexDef_DescFields:='';
|
|
FIndexDef_CaseInsFields:='';
|
|
FIndexCaseInsList.Clear;
|
|
FIndexDescFields.Clear;
|
|
FIndexFieldNameList.Clear;
|
|
FSortDescMode := False;
|
|
FDataList.Clear;
|
|
FLastSorted := 0;
|
|
end;
|
|
|
|
constructor TDAMemIndex.Create(AOwner: TDAMemoryDataset);
|
|
begin
|
|
inherited Create;
|
|
FOwner := AOwner;
|
|
FIndexCaseInsList:= TList.Create;
|
|
FIndexDescFields := TList.Create;
|
|
FIndexFieldNameList := TList.Create;
|
|
FSortDescMode := False;
|
|
FInitFromIndexDef := False;
|
|
FLastSorted := 0;
|
|
FDataList:=TMemList.Create;
|
|
end;
|
|
|
|
destructor TDAMemIndex.Destroy;
|
|
begin
|
|
Clear;
|
|
FIndexCaseInsList.Free;
|
|
FIndexDescFields.Free;
|
|
FIndexFieldNameList.Free;
|
|
FDataList.Free;
|
|
inherited;
|
|
end;
|
|
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF DELPHI10UP}
|
|
procedure TDAMemIndex.Init(const AFieldNames: string; const CaseInsFields: string = ''; const DescFields: string='');
|
|
var
|
|
pos1: integer;
|
|
fld: TField;
|
|
j: integer;
|
|
begin
|
|
Clear;
|
|
FInit_FieldNames:= AFieldNames;
|
|
FInit_CaseInsFields:=CaseInsFields;
|
|
FInit_DescFields:=DescFields;
|
|
|
|
Pos1 := 1;
|
|
while Pos1 <= Length(AFieldNames) do begin
|
|
Fld := FOwner.FieldByName(ExtractFieldName(AFieldNames, Pos1));
|
|
FOwner.ValidateFieldForIndex(Fld);
|
|
FIndexFieldNameList.Add(Fld);
|
|
end;
|
|
|
|
//CaseInsFields
|
|
FIndexCaseInsList.Count := FIndexFieldNameList.Count;
|
|
Pos1 := 1;
|
|
while Pos1 <= Length(CaseInsFields) do begin
|
|
Fld := FOwner.FieldByName(ExtractFieldName(CaseInsFields, Pos1));
|
|
j := FIndexFieldNameList.IndexOf(Fld);
|
|
if j <> -1 then FIndexCaseInsList[j]:=pointer(1) ;
|
|
end;
|
|
|
|
// DescFields
|
|
FIndexDescFields.Count := FIndexFieldNameList.Count;
|
|
Pos1 := 1;
|
|
while Pos1 <= Length(DescFields) do begin
|
|
Fld := FOwner.FieldByName(ExtractFieldName(DescFields, Pos1));
|
|
j:= IndexFieldNameList.IndexOf(Fld);
|
|
if j <> -1 then FIndexDescFields[j]:=pointer(1);
|
|
end;
|
|
end;
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED ON}
|
|
{$ENDIF DELPHI10UP}
|
|
|
|
|
|
function TDAMemIndex.GetDataList: TMemList;
|
|
begin
|
|
if FInitFromIndexDef then
|
|
Result := FDataList
|
|
else
|
|
Result := FOwner.FDataList;
|
|
end;
|
|
|
|
procedure TDAMemIndex.Init(AIndexDef: TIndexDef);
|
|
var
|
|
lCaseInsField, lDescFields: string;
|
|
begin
|
|
lCaseInsField := AIndexDef.CaseInsFields;
|
|
if (lCaseInsField = '') and (ixCaseInsensitive in AIndexDef.Options) then
|
|
lCaseInsField := AIndexDef.Fields;
|
|
lDescFields := AIndexDef.DescFields;
|
|
if (lDescFields = '') and (ixDescending in AIndexDef.Options) then
|
|
lDescFields := AIndexDef.Fields;
|
|
Init(AIndexDef.Fields, lCaseInsField,lDescFields);
|
|
FInitFromIndexDef := True;
|
|
FIndexDef_Options:=AIndexDef.Options;
|
|
FIndexDef_Fields:=AIndexDef.Fields;
|
|
FIndexDef_DescFields:=AIndexDef.DescFields;
|
|
FIndexDef_CaseInsFields:=AIndexDef.CaseInsFields;
|
|
end;
|
|
|
|
procedure TDAMemIndex.Init(const Fields: string; CaseInsensitive,
|
|
Descending: Boolean);
|
|
var
|
|
i: integer;
|
|
begin
|
|
Init(Fields);
|
|
|
|
if CaseInsensitive then FInit_CaseInsFields := FInit_FieldNames;
|
|
for i:= 0 to IndexCaseInsList.Count-1 do
|
|
IndexCaseInsList[i]:= Pointer({$IFDEF FPC}PtrUInt{$ELSE}cardinal{$ENDIF}(ord(CaseInsensitive)));
|
|
|
|
if Descending then FInit_DescFields := FInit_FieldNames;
|
|
FSortDescMode:= Descending;
|
|
for i:= 0 to IndexDescFields.Count-1 do
|
|
IndexDescFields[i]:= Pointer({$IFDEF FPC}PtrUInt{$ELSE}cardinal{$ENDIF}(ord(Descending)));
|
|
end;
|
|
|
|
function TDAMemIndex.IsValid: boolean;
|
|
begin
|
|
Result := FIndexFieldNameList.Count > 0;
|
|
end;
|
|
|
|
procedure TDAMemIndex.UpdateIndex(AIndexDef: TIndexDef);
|
|
begin
|
|
if not ((AIndexDef.Fields = FIndexDef_Fields) and
|
|
(AIndexDef.CaseInsFields = FIndexDef_CaseInsFields) and
|
|
(AIndexDef.DescFields = FIndexDef_DescFields) and
|
|
(AIndexDef.Options = FIndexDef_Options)) then Init(AIndexDef);
|
|
end;
|
|
|
|
function TDAMemIndex.isCanUsed(const Fields: string; CaseInsensitive: Boolean): boolean;
|
|
var
|
|
lcase: string;
|
|
begin
|
|
if CaseInsensitive then lcase:= Fields else lcase := '';
|
|
Result :=
|
|
IsValid and
|
|
(FLastSorted > FOwner.FLastUpdate) and
|
|
// eugene: 20080407: AnsiSameText
|
|
AnsiSameText(FInit_FieldNames,Fields) and
|
|
AnsiSameText(FInit_CaseInsFields,lcase) and
|
|
(AnsiSameText(FInit_DescFields,Fields) or (FInit_DescFields=''));
|
|
end;
|
|
|
|
end.
|