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 DELPHI2009UP} Dataset_PAnsiChar = PByte; {$ELSE} Dataset_PAnsiChar = PAnsiChar; {$ENDIF} {$IFDEF DELPHI2009UP} TMemBookmarkData = TBookmark; {$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 = 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; FClonePermanentClientList: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; FMemCloneSource: TDAMemoryDataset; FAutoSort: 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 RegisterPermanentClient(const AClient: TDAMemoryDataset); procedure UnregisterPermanentClient(const AClient: TDAMemoryDataset); procedure RegisterPermanentClients; procedure UnregisterClient(const AClient: TDAMemoryDataset); procedure UnregisterAllClients; procedure UnregisterPermanentClients; 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); procedure SetCloneSource(const Value: TDAMemoryDataset); Procedure AssignCloneSource(Source: TDAMemoryDataset); procedure CheckforCircularLinks(ASource:TDataset; CheckForClone: Boolean); procedure SetAutoSort(const Value: Boolean); procedure IntAutoSort(ABuf : PMemDatasetrecord_Native); 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); procedure AttachToSource(const Source: TDAMemoryDataset);virtual; procedure DetachFromSource; virtual; function IsLoadingState: Boolean; virtual; 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; 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; property CloneSource: TDAMemoryDataset read FMemCloneSource write SetCloneSource; property AutoSortRecords: Boolean read FAutoSort write SetAutoSort default False; 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,{$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} ftFixedChar]; ft_AnsiStringValues = [ftString, ftFixedChar, {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport}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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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; FAutoSort := False; end; function TDAMemoryDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; begin Result := TDABlobStream.Create(TBlobField(Field), Mode); end; destructor TDAMemoryDataset.Destroy; begin CloneSource := nil; inherited; UnregisterPermanentClients; 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; if FClonePermanentClientList <> nil then FClonePermanentClientList.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])^; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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, PBookmarkData(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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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); UnregisterPermanentClients; 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(PBookMarkData(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); RegisterPermanentClients; 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 in [{$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport}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 (FMemCloneSource <> nil) and (FCloneSource = nil) then begin if FMemCloneSource <> nil then FMemCloneSource.Open; FMemCloneSource.RegisterClient(Self); end; 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 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 DELPHI2009UP}AnsiChar{$ENDIF}(ord(Buffer[I]) or (1 shl (AIndex and 7))) else Buffer[I] := {$IFNDEF DELPHI2009UP}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 Value <> MasterDataLink.DataSource then begin if (Value <> nil) and (Value.DataSet <> nil) then CheckforCircularLinks(Value.DataSet, False); if IsLinkedTo(Value) then DatabaseError(SCircularDataLink, Self); DataEvent(dePropertyChange, 0); MasterDataLink.DataSource := Value; end; 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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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; 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 begin if SyncCursor then begin Bookmark := lBookmark; UpdateCursorPos; if EOF or BOF then Result := False; end; SetLength(lBookmark, 0); 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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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; if (Operation = opRemove) and (AComponent = fMemCloneSource) then FMemCloneSource := nil; end; procedure TDAMemoryDataset.CloneCursor(Source: TDAMemoryDataset; Reset: Boolean; KeepSettings: Boolean = False); begin if Source <> nil then CheckforCircularLinks(Source,True); Source.CheckActive; Close; FMemCloneSource := Source; FCloneSource := Source; if Reset then AssignCloneSource(nil) else if not KeepSettings then AssignCloneSource(Source); 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); if AClient <> self then AClient.AttachToSource(Self); 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); if AClient.FCloneSource <> nil then AClient.DetachFromSource; 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 FCloneSource := nil; if Active then begin FDataList.Clear; InternalFirst; Resync([]); end; 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 begin TDAMemoryDataset(Items[i]).RecordNotification(Buf,Operation) end else begin if Operation in [mdnInsert, mdnModify] then IntAutoSort(Buf); end; finally FCloneClientList.UnlockList; end; end; procedure TDAMemoryDataset.RecordNotification(Buf: PMemDatasetrecord_Native; Operation: TMemDataSetNotification); var i: integer; FNeedResort: boolean; f: boolean; begin if Active then begin f := f_DefaultIndexRecord.LastSorted > FLastUpdate; FNeedResort := False; FLastUpdate := now; case Operation of mdnInsert: begin intInsertRecord(Buf); FNeedResort:= True; 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 else begin FNeedResort:= True; end; mdnDelete: begin if f then f_DefaultIndexRecord.LastSorted :=Now; 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; if FNeedResort then IntAutoSort(Buf) else Resync([]); end; 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); {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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) and FCloneSource.Active 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 DELPHI2009UP}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; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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; 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 begin if SyncCursor then begin Bookmark := lBookmark; UpdateCursorPos; if EOF or BOF then Result := False; end; SetLength(lBookmark, 0); 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 not lnull[i] then begin if lDatatypes[i] in ft_AnsiStringValues then lValues[i].AsAnsiString := VarToAnsiStr(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, varUString: lValues[i].Value := StrToDate(lValues[i].Value); end; 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)^; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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)); {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} 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 [{$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport}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 [{$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport}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; procedure TDAMemoryDataset.AssignCloneSource(Source: TDAMemoryDataset); begin if Source = nil then begin Filtered := False; Filter := ''; OnFilterRecord := nil; IndexDefs.Clear; IndexName := ''; MasterSource := nil; MasterFields := ''; DetailFields := ''; ReadOnly := False; end else 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; end; procedure TDAMemoryDataset.SetCloneSource(const Value: TDAMemoryDataset); var FOldActive : Boolean; begin if (Value <> nil) and (Value <> FMemCloneSource) then CheckforCircularLinks(Value,True); if Value = Self then DatabaseError(Self.Name+ ': Can''t use itself as clonesource dataset'); FOldActive := Active; Close; if FMemCloneSource <> Value then begin if not IsLoadingState then begin if FMemCloneSource <> nil then begin FMemCloneSource.UnregisterPermanentClient(Self); AssignCloneSource(nil); end; end; FMemCloneSource := Value; if (FMemCloneSource <> nil) then begin FMemCloneSource.RegisterPermanentClient(Self); if not IsLoadingState then AssignCloneSource(FMemCloneSource); end; end; if FOldActive then Open; end; procedure TDAMemoryDataset.RegisterPermanentClient( const AClient: TDAMemoryDataset); begin if FClonePermanentClientList = nil then FClonePermanentClientList:=TThreadList.Create; FClonePermanentClientList.Add(AClient); end; procedure TDAMemoryDataset.RegisterPermanentClients; var lClient: TDAMemoryDataset; i: integer; begin if FClonePermanentClientList <> nil then begin with FClonePermanentClientList.LockList do try For I := 0 to Count - 1 do begin lClient:= TDAMemoryDataset(Items[i]); if Assigned(lClient) then begin RegisterClient(lClient); lClient.RegisterPermanentClients; end; end; finally FClonePermanentClientList.UnlockList; end; end; end; procedure TDAMemoryDataset.UnregisterPermanentClients; var i: integer; lList: TList; lClient: TDAMemoryDataset; begin if FClonePermanentClientList <> nil then begin lList:= FClonePermanentClientList.LockList; try for i:= lList.Count-1 downto 0 do begin lClient:= TDAMemoryDataset(lList[i]); if Assigned(lClient) then UnregisterClient(lClient); end; lList.Clear; finally FClonePermanentClientList.UnlockList; end; end; end; procedure TDAMemoryDataset.UnregisterPermanentClient( const AClient: TDAMemoryDataset); begin if FClonePermanentClientList <> nil then FClonePermanentClientList.Remove(AClient); end; procedure TDAMemoryDataset.AttachToSource(const Source: TDAMemoryDataset); var fOldActive: Boolean; begin if Source <> FCloneSource then begin DetachFromSource; fOldActive:= Active; Close; FCloneSource := Source; if fOldActive then Open; end; end; procedure TDAMemoryDataset.CheckforCircularLinks(ASource: TDataset; CheckForClone: Boolean); procedure _CheckInPermanentClients(APermSource: TDAMemoryDataset); var i: integer; lList: TList; lDataset: TDAMemoryDataset; begin if (APermSource.FClonePermanentClientList <> nil) then begin lList := APermSource.FClonePermanentClientList.LockList; try for i:=0 to lList.Count-1 do begin lDataset := TDAMemoryDataset(lList[i]); if lDataset = ASource then DatabaseError(SCircularDataLink, Self); _CheckInPermanentClients(lDataset); end; finally APermSource.FClonePermanentClientList.UnlockList; end; end; if (APermSource.MasterSource <> nil) and (APermSource.MasterSource.DataSet <> nil) and (APermSource.MasterSource.DataSet is TDAMemoryDataset) then _CheckInPermanentClients(TDAMemoryDataset(APermSource.MasterSource.DataSet)); end; begin if ASource = nil then Exit; if ASource = Self then DatabaseError(SCircularDataLink, Self); if CheckForClone then begin if ((MasterSource <> nil) and (ASource = MasterSource.DataSet)) then DatabaseError(SCircularDataLink, Self); if ASource.IsLinkedTo(MasterSource) then DatabaseError(SCircularDataLink, Self); end else begin if (ASource = FMemCloneSource) then DatabaseError(SCircularDataLink, Self); end; if (ASource is TDAMemoryDataset) then begin // check in parent MasterSources if (TDAMemoryDataset(ASource).MasterSource <> nil) then CheckforCircularLinks(TDAMemoryDataset(ASource).MasterSource.DataSet, CheckForClone); // check in parent clonesources CheckforCircularLinks(TDAMemoryDataset(ASource).FMemCloneSource,CheckForClone); end; _CheckInPermanentClients(Self); end; function TDAMemoryDataset.IsLoadingState: Boolean; begin Result := (csLoading in ComponentState); end; procedure TDAMemoryDataset.SetAutoSort(const Value: Boolean); begin FAutoSort := Value; if FAutoSort then IntAutoSort(nil); end; procedure TDAMemoryDataset.IntAutoSort(ABuf : PMemDatasetrecord_Native); var lbookmark: pointer; k: integer; st: TDataSetState; begin if FAutoSort and (FIndexName <> '') then begin if ABuf = nil then begin lbookmark:=GetBookmark; if lbookmark <> nil then ABuf := TBookMarkData(PPointer(lBookmark)^); end; SortOnFields; if ABuf <> nil then k := IntFindRecordID(ABuf) else k := -1; if k <> -1 then begin st := State; if St = dsInsert then SetState(dsBrowse); try FRecordPos := k; Resync([rmExact, rmCenter]); finally if st <> State then SetState(st); end; end; end else Resync([]); 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.