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 UNICODE} UnicodeChar = Char; PUnicodeChar = PChar; {$ELSE} UnicodeString = WideString; PUnicodeString = PWideString; UnicodeChar = WideChar; PUnicodeChar = PWideChar; {$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: UnicodeChar; 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: UnicodeString; 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; FUseFullList: Boolean; 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; property UseFullList: Boolean read FUseFullList write FUseFullList; 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; TDAMemDatasetGetIDCallback = function: integer of object; PDACallbackRecord = ^TDACallbackRecord; TDACallbackRecord = record AppendMode: Boolean; RecIDCallback: TDAMemDatasetGetIDCallback; PK: string; end; TPostEditAction = (peaResort); TPostEditActions = set of TPostEditAction; { 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 FKeyBufferSize: cardinal; // SizeOf(TMemKeyBuffer) + FNativeRecordSize 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; FPostEditActions: TPostEditActions; FFieldNoList: TStringList; 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; AUseFullListForIndexes: boolean = False); 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;overload; function LocateRecordByIndex(const aIndex: Integer; const KeyValues: Variant; SyncCursor: Boolean): Boolean;overload; 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; ANeedResync: Boolean); function GetBin2FieldOffset(const aFieldNo:integer):cardinal; function GetStoreStringsAsReference : Boolean; function GetHasReferencedFields: Boolean; private { Set range } FKeyBuffers: array[TMemKeyIndex] of PMemKeyBuffer; FKeyBuffer: PMemKeyBuffer; procedure AllocKeyBuffers; procedure FreeKeyBuffers; procedure SetKeyBuffer(KeyIndex: TMemKeyIndex; Clear: Boolean); procedure SetKeyFields(KeyIndex: TMemKeyIndex; const Values: array of const); function InitKeyBuffer(Buffer: PMemKeyBuffer): PMemKeyBuffer; protected function CreateMemDatasetRecord(const AType:TmrMode; ABin3Size: Cardinal = 0; ADatasetCompatible: Boolean =False):PMemDatasetrecord_Native; procedure FreeMemDatasetRecord(Buffer: PMemDatasetrecord_Native); 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; procedure SetAnsiString(NativeBuf: Pointer; Field: TField; const Value: Ansistring); procedure SetWideString(NativeBuf: Pointer; Field: TField; const Value: Unicodestring); procedure ProcessFilter; procedure AddRecordsfromList(AList: TList; ACallbackRecord: PDACallbackRecord); procedure ClearBin2Buffer(Buffer: Dataset_PAnsiChar); Procedure FreeBin2Buffer(Buffer: Dataset_PAnsiChar); function CreateBin2Struct: Dataset_PAnsiChar; function GetFieldNo(aField: TField): integer; 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 DoAfterCancel; 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;overload; function LocateByIndex(const aIndex: integer; const KeyValues: Variant): Boolean;overload; function LookupByIndex(const aIndexName: string; const KeyValues: Variant; const ResultFields: string): Variant;overload; function LookupByIndex(const aIndex: integer; const KeyValues: Variant; const ResultFields: string): Variant;overload; 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 Assign(Source: TPersistent); 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 {$IFDEF DELPHI2009UP},ftLongWord, ftShortint, ftByte, ftExtended{$ENDIF} {$IFDEF DELPHI2010UP},ftSingle{$ENDIF}]; 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, ftCursor, ftInterface,ftIDispatch,ftOraTimeStamp, ftOraInterval,ftConnection,ftParams,ftStream] + [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; k: integer; 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; // = offset of 1st record FHasReferencedFields := FStoreStringsAsReference; FFieldNoList.Clear; FFieldNoList.Sorted := False; k := -1; for i := 0 to FieldCount - 1 do begin lField := Fields[i]; if lField.FieldNo = -1 then Continue; inc(k); FDataTypeArray[k]:=lField.DataType; llen:=CalcFieldLen(lField.DataType,lField.Size); FDataSizeArray[k] := llen; FOffsets[k + 1] := FOffsets[k] + llen; // = offset of k+1 record FHasReferencedFields := FHasReferencedFields or IsReferencedField(lField.DataType); end; for i := 0 to FieldCount - 1 do begin lField := Fields[i]; if lField.FieldNo <> -1 then Continue; inc(k); FDataTypeArray[k]:=lField.DataType; llen:=CalcFieldLen(lField.DataType,lField.Size); FDataSizeArray[k] := llen; FOffsets[k + 1] := FOffsets[k] + llen; // = offset of k+1 record FHasReferencedFields := FHasReferencedFields or IsReferencedField(lField.DataType); FFieldNoList.AddObject(lField.FieldName,pointer(k)); end; FFieldNoList.Sorted := True; FNativeRecordSize := FOffsets[FieldCount]; // // FBookMarkOffset := FNativeRecordSize; // FCalculatedOffset := FBookMarkOffset + SizeOf(TRecInfo); // FDatasetBufferSize := FCalculatedOffset + CalcFieldsSize; FDatasetBufferSize := SizeOf(TMemDatasetrecord)+CalcFieldsSize; FKeyBufferSize := SizeOf(TMemKeyBuffer) + FNativeRecordSize; 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 PUnicodeString(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, GetFieldNo(AField)) then Exit; if IsReferencedField(AField.DataType) then ClearFieldByFieldType(IntFindFieldData(Buffer, AField, True), AField.DataType); SetNullMask(Buffer, GetFieldNo(AField), 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; FPostEditActions := []; FFieldNoList:= TStringList.Create; 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; FFieldNoList.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 GetHasReferencedFields 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: PUnicodeString(Dest.Data + FOffsets[i])^ := PUnicodeString(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); var lIdentifier: string; lLen: integer; begin lLen := Length(aIdentifier); if (lLen >0) and (aIdentifier[1] = '[') and (aIdentifier[lLen] = ']') then lIdentifier := Copy(aIdentifier, 2, lLen-2) else lIdentifier := aIdentifier; aValue:= GetVarValueFromBuffer(FExpressionBuffer^.Data, FieldByName(lIdentifier), 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 Filtered 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, GetFieldNo(Field)); if Result and (Buffer <> nil) then begin case PMemDatasetrecord_Native(RecBuf)^.Ident of mrBin2Style: begin Data := PMemDatasetrecord_Native(RecBuf)^.Data + FOffsets[GetFieldNo(Field)]; 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[GetFieldNo(Field)]) 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(PUnicodeString(Data)^); if Len > Field.Size then Len := Field.Size; Move(pointer(PUnicodeString(Data)^)^, buffer^, len * sizeOf(UnicodeChar)); PUnicodeChar(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,GetFieldNo(Field)); k1 := GetBin3Offset(Data,GetFieldNo(Field)+1); Move((Data+k)^, buffer^, k1-k); end; end; end; end; function TDAMemoryDataset.GetFieldNo(aField: TField): integer; begin Result := aField.FieldNo-1; if Result < 0 then begin Result := FFieldNoList.IndexOf(aField.FieldName); if Result <> -1 then Result := integer(FFieldNoList.Objects[Result]); end; end; function TDAMemoryDataset.GetHasReferencedFields: Boolean; begin if FCloneSource <> nil then Result:= FCloneSource.FHasReferencedFields else Result:= FHasReferencedFields; 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.GetStoreStringsAsReference: Boolean; begin if FCloneSource <> nil then Result:= FCloneSource.GetStoreStringsAsReference else Result := FStoreStringsAsReference; end; function TDAMemoryDataset.GetVarValueFromBuffer(Buffer: pointer; Field: TField; abin2: boolean): variant; var buf: PAnsiChar; p: pointer; lLen: cardinal; begin if GetNullMask(Buffer,GetFieldNo(Field)) then begin Result := Null; end else begin buf := IntFindFieldData(Buffer,Field,aBin2); case Field.DataType of ftString, ftFixedChar: begin if abin2 and GetStoreStringsAsReference then Result := PAnsistring(Buf)^ else Result := Ansistring(PAnsiChar(Buf)); end; {$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport} ftWideString: begin if abin2 and GetStoreStringsAsReference then Result := PUnicodestring(Buf)^ else Result := UnicodeString(PUnicodeChar(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)); {$IFDEF DELPHI2009UP} ftLongWord: Result := PLongWord(Buf)^; ftShortint: Result := PShortInt(Buf)^; ftByte: Result := PByte(Buf)^; ftExtended: Result := PExtended(Buf)^; {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: Result := PSingle(Buf)^; {$ENDIF} else if abin2 then lLen:=PBLOBRecord(buf)^.size else lLen := GetBin3Offset(Buffer, GetFieldNo(Field)+1)-GetBin3Offset(Buffer, GetFieldNo(Field)); 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); with Field do begin if State = dsSetKey then nativeData := RecBuf else begin ConvertBin3ToBin2Record(PMemDatasetrecord_Native(RecBuf)); nativeData := PMemDatasetrecord_Native(RecBuf)^.Data; end; 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(Field.DataType) then begin if Buffer <> nil then begin Move(Buffer^, Data^, FDataSizeArray[GetFieldNo(Field)]); SetNullMask(nativeData, GetFieldNo(Field), False); end else SetNullMask(nativeData, GetFieldNo(Field), True); end else begin if Buffer <> nil then begin if Field.DataType in [ftString,ftFixedChar] then begin PAnsiString(Data)^ := PAnsiChar(buffer); SetNullMask(nativeData, GetFieldNo(Field), False); end else if Field.DataType in [{$IFDEF DA_FixedWideCharSupport}ftFixedWideChar,{$ENDIF DA_FixedWideCharSupport}ftWideString] then begin PUnicodeString(Data)^ := PUnicodeChar(buffer); SetNullMask(nativeData, GetFieldNo(Field), False); end; end else SetNullMask(nativeData, GetFieldNo(Field), 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[GetFieldNo(Field)]) else Result := Buffer + GetBin3Offset(Buffer,GetFieldNo(Field)); 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 Assigned(OnFilterRecord))) or FRangeActive; end; function TDAMemoryDataset.IsCursorOpen: Boolean; begin Result := FActive; end; function TDAMemoryDataset.IsReferencedField(ADataType: TFieldType): Boolean; begin Result:= (ADataType in ft_BlobTypes) or ((ADataType in ft_Strings) and GetStoreStringsAsReference); 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 GetStoreStringsAsReference 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[GetFieldNo(Field)])^ <> Value then begin PPointer(Buffer.Data + FOffsets[GetFieldNo(Field)])^ := Value; SetNullMask(Buffer.Data, GetFieldNo(Field), 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 FPC} {$IFNDEF DELPHI10UP} ftWideString: begin if ToNative then begin len := Length(PUnicodeString(Source)^); Move(PUnicodeChar(Source^)^, PUnicodeChar(Dest)^, len * SizeOf(UnicodeChar)); PUnicodeChar(Dest)[Len] := #0; end else begin len := Length(PUnicodeChar(Source)); SetString(UnicodeString(Dest^), PUnicodeChar(Source), Len); end; end {$ENDIF} {$ENDIF} 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; AUseFullListForIndexes: boolean = False); 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 {$IFDEF MEMDATASET_DEBUG} OutputDebugString(Pchar('TDAMemoryDataset.DoSort')); {$ENDIF} 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) or (AUseFullListForIndexes <> AIndex.UseFullList) then begin if AUseFullListForIndexes then begin lRecList:=IntGetRecordList; LList:=lRecList.LockListForReading; try AIndex.DataList.Assign(LList); QuickSort(0, FDataList.Count - 1, Compare, AIndex); finally lRecList.UnlockListForReading; end; end else begin AIndex.DataList.Assign(FDataList); QuickSort(0, AIndex.DataList.Count - 1, Compare, AIndex); end; AIndex.LastSorted := Now; AIndex.UseFullList := AUseFullListForIndexes; end; end; end; end; end; procedure TDAMemoryDataset.QuickSort(L, R: Integer; SCompare: TDAMemDatasetCompare;AIndex: TDAMemIndex); var I, J: Integer; P: pointer; llist: TMemList; begin if AIndex.DataList.Count < 2 then Exit; 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, GetFieldNo(Field)) then p1 := intFindFieldData(buf1, Field, lbin2_1) else p1 := nil; if not GetNullMask(buf2, GetFieldNo(Field)) 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 ExtendedCompare(val1, val2: Extended): integer; begin if val1 > val2 then Result := 1 else if val2 > val1 then Result := -1 else Result := 0; end; function SingleCompare(val1, val2: Single): integer; begin if val1 > val2 then Result := 1 else if val2 > val1 then Result := -1 else Result := 0; end; function ByteCompare(val1, val2: Byte): integer; begin if val1 > val2 then Result := 1 else if val2 > val1 then Result := -1 else Result := 0; end; function LongWordCompare(val1, val2: LongWord): integer; begin if val1 > val2 then Result := 1 else if val2 > val1 then Result := -1 else Result := 0; end; function ShortIntCompare(val1, val2: ShortInt): 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 GetStoreStringsAsReference 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 GetStoreStringsAsReference then begin case (ord(aBin2_1) shl 1) OR ord(aBin2_2) of 0 { 00b }: Result:= ROWideCompare(PUnicodeChar(Buf1),PUnicodeChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS}); 1 { 01b }: Result:= ROWideCompare(PUnicodeChar(Buf1),PUnicodeString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS}); 2 { 10b }: Result:= ROWideCompare(PUnicodeString(Buf1)^,PUnicodeChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS}); 3 { 11b }: Result:= ROWideCompare(PUnicodeString(Buf1)^,PUnicodeString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWINDOWS}); end; end else begin Result:= ROWideCompare(PUnicodeChar(Buf1),PUnicodeChar(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} {$IFDEF DELPHI2009UP} ftLongWord: Result := LongWordCompare(PLongWord(Buf1)^, PLongWord(Buf2)^); ftShortint: Result := ShortintCompare(PShortint(Buf1)^, PShortint(Buf2)^); ftByte: Result := ByteCompare(PByte(Buf1)^, PByte(Buf2)^); ftExtended: Result := ExtendedCompare(PExtended(Buf1)^, PExtended(Buf2)^); {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: Result := SingleCompare(PSingle(Buf1)^, PSingle(Buf2)^); {$ENDIF} 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: Unicodestring); var len: integer; begin if GetStoreStringsAsReference then PUnicodeString(NativeBuf)^:=Value else begin len := Length(Value); if Len > Field.Size then len:= Field.Size; move(Pointer(Value)^,NativeBuf^,len*Sizeof(UnicodeChar)); PUnicodeChar(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 FIndexName <> '' then SortOnFields; if FRangeActive then begin ApplyRangeFilter; // currently it is empty 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 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.LocateByIndex(const aIndex: integer; const KeyValues: Variant): Boolean; begin DoBeforeScroll; Result := LocateRecordByIndex(aIndex, KeyValues, 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 InternalGotoBookmark(pointer(lBookmark)); SetLength(lBookmark, 0); end; end; end; function TDAMemoryDataset.LocateRecordByIndex(const aIndex: Integer; const KeyValues: Variant; SyncCursor: Boolean): Boolean; var lIndex: TDAMemIndex; begin if (aIndex < 0) or (aIndex > FIndexDefs.Count) then DatabaseError(SFieldIndexError); UpdateMemIndexes(aIndex); lIndex := TDAMemIndex(FIndexList[aIndex]); DoSort(lIndex); Result:= intLocateRecordByIndex(lIndex, KeyValues, SyncCursor); 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.LookupByIndex(const aIndex: integer; const KeyValues: Variant; const ResultFields: string): Variant; begin Result := Null; if LocateRecordByIndex(aIndex, 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: UnicodeString; begin Result := 0; case aDataType of ftString, ftFixedChar: begin if abin2 and GetStoreStringsAsReference 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 GetStoreStringsAsReference then wstr1:=PUnicodeString(Buf1)^ else wstr1:=PUnicodeChar(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} {$IFDEF DELPHI2009UP} ftLongWord: Result := LongWordCompare(PLongWord(Buf1)^, aValue.Value); ftShortint: Result := ShortintCompare(PShortint(Buf1)^, aValue.Value); ftByte: Result := ByteCompare(PByte(Buf1)^, aValue.Value); ftExtended: Result := ExtendedCompare(PExtended(Buf1)^, aValue.Value); {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: Result := SingleCompare(PSingle(Buf1)^, aValue.Value); {$ENDIF} 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: UnicodeString; aSortCaseInsensitive:Boolean): boolean; var l1: integer; l2: Integer; k: UnicodeString; 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, PUnicodeChar(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: Unicodestring; begin Result := False; case aDataType of ftString, ftFixedChar: begin if abin2 and GetStoreStringsAsReference 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 GetStoreStringsAsReference then wstr1 := PUnicodeString(Buf1)^ else wstr1 := PUnicodeChar(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} {$IFDEF DELPHI2009UP} ftLongWord: Result := pos(VarToStr(aValue.Value), IntToStr(PLongWord(buf1)^)) = 1; ftShortint: Result := pos(VarToStr(aValue.Value), IntToStr(PShortInt(buf1)^)) = 1; ftByte: Result := pos(VarToStr(aValue.Value), IntToStr(PByte(buf1)^)) = 1; ftExtended: Result := pos(VarToStr(aValue.Value), FloatToStr(PExtended(buf1)^)) = 1; {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: Result := pos(VarToStr(aValue.Value), FloatToStr(PSingle(buf1)^)) = 1; {$ENDIF} 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 begin TDAMemoryDataset(Items[i]).IntAutoSort(Buf, peaResort in FPostEditActions); FPostEditActions := []; end; 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 State in dsEditModes then begin if FNeedResort then FPostEditActions := FPostEditActions + [peaResort]; end else begin if FNeedResort then IntAutoSort(Buf,True) else Resync([]); FPostEditActions := []; end; 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; ACallbackRecord: PDACallbackRecord); function SearchIndex_Direct: TDAMemIndex; var i: integer; begin Result := f_DefaultIndexRecord; if Result.isCanUsed(ACallbackRecord^.PK,False) then Exit; for i:= 0 to FIndexList.Count - 1 do begin Result := TDAMemIndex(FIndexList[i]); if Result.isCanUsed(ACallbackRecord^.PK,False) then Exit; end; Result := nil; end; var old_count: integer; i,j: integer; lRecIDOffset: Cardinal; lIndex: TDAMemIndex; ltempIndex: Boolean; or_buf,buf: PMemDatasetrecord_Native; lKeyValues: array of Variant; lUpdateList, lAppendList: TList; lcnt: Integer; begin lUpdateList := TList.Create; lAppendList := TList.Create; try if ACallbackRecord <> nil then begin // DataAbstract Mode. RecID = field[0] lRecIDOffset := GetBin2FieldOffset(0); if (ACallbackRecord^.AppendMode) and (ACallbackRecord^.PK <> '') then begin lIndex := SearchIndex_Direct; ltempIndex := lIndex = nil; if ltempIndex then begin lIndex := TDAMemIndex.Create(Self); lIndex.Init(ACallbackRecord^.PK,False,False); lIndex.FInitFromIndexDef:= False; end; try DoSort(lIndex,True); SetLength(lKeyValues, lIndex.IndexFieldNameList.Count); lcnt:= lIndex.IndexFieldNameList.Count; for I := 0 to AList.Count - 1 do begin buf:=PMemDatasetrecord_Native(AList[i]); for j := 0 to lcnt - 1 do lKeyValues[j]:=GetVarValueFromBuffer(buf.data,lIndex.IndexFieldNameList[j],True); if ((lcnt = 1) and (intLocateRecordByIndex(lIndex,lKeyValues[0],False))) or ((lcnt > 1) and (intLocateRecordByIndex(lIndex,lKeyValues,False))) then begin PCardinal(buf^.Data+lRecIDOffset)^:= PCardinal(IntFindFieldData(PMemDatasetrecord_Native(TempBuffer),Fields[0]))^; SetNullMask(buf^.Data,0,False); //RECID lUpdateList.Add(PMemDatasetrecord(TempBuffer)^.BookmarkData.Bookmark); lUpdateList.Add(AList[i]); end else begin PCardinal(buf^.Data+lRecIDOffset)^:=ACallbackRecord^.RecIDCallback; SetNullMask(buf^.Data,0,False); //RECID lAppendList.Add(AList[i]); end; end; finally if ltempIndex then lIndex.Free; end; end else begin for I := 0 to AList.Count - 1 do begin buf:=PMemDatasetrecord_Native(AList[i]); PCardinal(buf^.Data+lRecIDOffset)^:=ACallbackRecord^.RecIDCallback; SetNullMask(buf^.Data,0,False); //RECID end; lAppendList.Count := AList.Count; System.Move(AList.List^, lAppendList.List^, AList.Count*SizeOf(Pointer)); end; end; with IntGetRecordList.LockListForWriting do try for I := 0 to (lUpdateList.Count div 2)-1 do begin or_buf := lUpdateList.List^[i*2]; buf := lUpdateList.List^[i*2+1]; InternalInitRecord(Dataset_PAnsiChar(or_buf)); or_buf^.Ident := buf^.Ident; or_buf^.Data := buf^.Data; buf^.Ident:= mrEmpty; buf^.Data := nil; FreeMemDatasetRecord(buf); end; old_count:=Count; Count:=old_count+lAppendList.Count; System.Move(lAppendList.List^, PAnsiChar(List^[old_Count]), lAppendList.Count*SizeOf(Pointer)); if FAutoCompactRecords then begin For i := old_count to Count -1 do ConvertBin2ToBin3Record(List^[i]); for I := 0 to (lUpdateList.Count div 2)-1 do begin ConvertBin2ToBin3Record(lUpdateList.List^[i*2]); end; end; finally IntGetRecordList.UnlockListForWriting; end; if (AList.Count > 0) then FLastUpdate := Now; AList.Clear; NotifyClients(nil, mdnBatchAdding, nil); finally lUpdateList.Free; lAppendList.Free; end; 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(UnicodeChar); {$IFDEF DELPHI2009UP} ftLongWord: Result := SizeOf(LongWord); ftShortint: Result := SizeOf(ShortInt); ftByte: Result := SizeOf(Byte); ftExtended: Result := SizeOf(Extended); {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: Result := SizeOf(Single); {$ENDIF} 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], FKeyBufferSize) and BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd], FKeyBufferSize)) then begin Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^, FKeyBufferSize); Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^, FKeyBufferSize); 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]^, FKeyBufferSize); 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(FKeyBufferSize); if Assigned(FCloneSource) and FCloneSource.Active then for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do Move(FCloneSource.FKeyBuffers[KeyIndex]^, FKeyBuffers[KeyIndex]^, FKeyBufferSize); except FreeKeyBuffers; raise; end; end; procedure TDAMemoryDataset.FreeKeyBuffers; var KeyIndex: TMemKeyIndex; begin for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do DisposeMem(FKeyBuffers[KeyIndex], FKeyBufferSize); end; function TDAMemoryDataset.InitKeyBuffer(Buffer: PMemKeyBuffer): PMemKeyBuffer; begin FillChar(Buffer^, FKeyBufferSize, 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; lStoreStringsAsReference: 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; 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 if TField(MasterDataLink.Fields[i]).DataType = ftDate then MasterArray[i].Value := DateTimeToTimeStamp(TDateField(MasterDataLink.Fields[i]).AsDateTime).Date else if TField(MasterDataLink.Fields[i]).DataType = ftTime then MasterArray[i].Value := DateTimeToTimeStamp(TTimeField(MasterDataLink.Fields[i]).AsDateTime).Time else MasterArray[i].Value := TField(MasterDataLink.Fields[i]).Value; end; lList:= IntGetRecordList.LockListForReading; try FDataList.Capacity := lList.Count; lStoreStringsAsReference := GetStoreStringsAsReference; 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 lStoreStringsAsReference 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 lStoreStringsAsReference then flag := ROWideCompare(PUnicodeString(Buf)^, MasterArray[j].AsWideString,True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0 else flag := ROWideCompare(PUnicodeChar(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; {$IFDEF DELPHI2009UP} ftLongWord: flag := PLongWord(Buf)^ = MasterArray[j].value; ftShortint: flag := PShortInt(Buf)^ = MasterArray[j].value; ftByte: flag := PByte(Buf)^ = MasterArray[j].value; ftExtended: flag := PExtended(Buf)^ = MasterArray[j].value; {$ENDIF} {$IFDEF DELPHI2010UP} ftSingle: flag := PSingle(Buf)^ = MasterArray[j].value; {$ENDIF} 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, GetFieldNo(lField)) then p1 := intFindFieldData(lbuf, lField, lbin2_1) else p1 := nil; if not GetNullMask(lbuf2, GetFieldNo(lField)) 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^, FKeyBufferSize); 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; begin i:= IndexDefs.IndexOf(aIndexName); if i = -1 then DatabaseErrorFmt(SIndexNotFound,[aIndexName]); Result := LocateRecordByIndex(i,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 and SyncCursor then begin SetLength(lBookmark, BookmarkSize); GetBookmarkData(pointer(Buffer), Pointer(lBookmark)); end; finally if Result and SyncCursor then begin InternalGotoBookmark(pointer(lBookmark)); 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]:=GetFieldNo(TField(lFields[i])); 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] in [ftDate, ftTime, ftDateTime] then begin case TVarData(lValues[i].Value).VType of varString, varOleStr, varUString: lValues[i].Value := StrToDate(lValues[i].Value); end; case lDatatypes[i] of ftDate: lValues[i].Value := DateTimeToTimeStamp(lValues[i].Value).Date; ftTime: lValues[i].Value := DateTimeToTimeStamp(lValues[i].Value).Time; 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: PUnicodeString(Dest + FOffsets[i])^ := PUnicodeString(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; lStoreStringsAsReference: Boolean; begin if FCloneSource <> nil then Result := FCloneSource.CalculateRecordsSize else begin Result:=0; List:=FRecordsList.LockListForReading; try inc(Result, SizeOf(TMemDatasetrecord_Native)*List.Count); lStoreStringsAsReference := GetStoreStringsAsReference; 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 lStoreStringsAsReference 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(PUnicodeString(buf + FOffsets[j])^)*SizeOf(UnicodeChar)); 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 GetHasReferencedFields 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: PUnicodeChar): Cardinal; var P : PUnicodeChar; 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; lStoreStringsAsReference: Boolean; begin Result := nil; lBin2RecordSize := 0; lBlobPresent := False; SetLength(loffsets, FieldCount+1); SetLength(lBin2DataSize, FieldCount); loffsets[0] := 0; lStoreStringsAsReference := GetStoreStringsAsReference; 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 lStoreStringsAsReference 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 lStoreStringsAsReference then lBin2DataSize[i] := Length(PUnicodeString(ASource + FOffsets[i])^)*SizeOf(UnicodeChar) else lBin2DataSize[i] := WStrLen(PUnicodeChar(ASource + FOffsets[i]))*SizeOf(UnicodeChar); inc(lBin2DataSize[i], SizeOf(UnicodeChar)); // #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 lStoreStringsAsReference 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 lStoreStringsAsReference 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(UnicodeChar); if lStoreStringsAsReference then Move(pointer(PUnicodeString(buf)^)^, p1^, dx) else move(buf^, p1^, dx); PUnicodeChar(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.Assign(Source: TPersistent); var lSource: TDAMemoryDataset; begin inherited; if Source is TDAMemoryDataset then begin lSource := TDAMemoryDataset(Source); Active := False; AfterCancel := lSource.AfterCancel; AfterClose := lSource.AfterClose; AfterDelete := lSource.AfterDelete; AfterEdit := lSource.AfterEdit; AfterInsert := lSource.AfterInsert; AfterOpen := lSource.AfterOpen; AfterPost := lSource.AfterPost; AfterRefresh := lSource.AfterRefresh; AfterScroll := lSource.AfterScroll; AutoSortRecords := lSource.AutoSortRecords; BeforeCancel := lSource.BeforeCancel; BeforeClose := lSource.BeforeClose; BeforeDelete := lSource.BeforeDelete; BeforeEdit := lSource.BeforeEdit; BeforeInsert := lSource.BeforeInsert; BeforeOpen := lSource.BeforeOpen; BeforePost := lSource.BeforePost; BeforeRefresh := lSource.BeforeRefresh; BeforeScroll := lSource.BeforeScroll; CloneSource := lSource.CloneSource; DetailFields := lSource.DetailFields; FieldDefs := lSource.FieldDefs; Filter := lSource.Filter; Filtered := lSource.Filtered; IndexDefs := lSource.IndexDefs; IndexFieldNames := lSource.IndexFieldNames; IndexName := lSource.IndexName; MasterFields := lSource.MasterFields; MasterSource := lSource.MasterSource; OnCalcFields := lSource.OnCalcFields; OnDeleteError := lSource.OnDeleteError; OnEditError := lSource.OnEditError; OnFilterRecord := lSource.OnFilterRecord; OnNewRecord := lSource.OnNewRecord; OnPostError := lSource.OnPostError; ReadOnly := lSource.ReadOnly; Active := lSource.Active; end; 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,True); end; procedure TDAMemoryDataset.IntAutoSort(ABuf : PMemDatasetrecord_Native; ANeedResync: Boolean); var lbookmark: pointer; k: integer; st: TDataSetState; begin if Active then 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 if ANeedResync then Resync([]); end; end; procedure TDAMemoryDataset.DoAfterCancel; begin if peaResort in FPostEditActions then begin IntAutoSort(nil, True); FPostEditActions := []; end; inherited; 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,FDataSet.GetFieldNo(Field)+1)-FDataSet.GetBin3Offset(Buffer^.Data,FDataSet.GetFieldNo(Field)); 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.