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} {$IF defined(DELPHI6UP) or defined(FPC) } {$DEFINE ftFMTBCD_Support} {$IFEND} uses {$IFDEF MSWINDOWS}Windows,{$ENDIF} Classes, DB, uDAExpressionEvaluator; type PBookmarkData = ^TBookmarkData; TBookmarkData = Pointer; PRecInfo = ^TRecInfo; TRecInfo = packed record Bookmark: TBookmarkData; BookmarkFlag: TBookmarkFlag; end; TOffsetArray = array of Cardinal; PBLOBRecord = ^TBLOBRecord; TBLOBRecord = packed record size: Cardinal; Data: WideChar; end; TDAMemDatasetCompare = function(p1, p2: pointer): Integer of object; TSortRecord = record data: PChar; 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: Pchar): 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, mdnRemoveDeleted); TMemLocateCompare = function (buf1: pointer; aValue:variant; aDataType: TFieldType;aSortCaseInsensitive:Boolean): boolean of Object; TMemKeyIndex = (kiLookup, kiRangeStart, kiRangeEnd, kiCurRangeStart, kiCurRangeEnd, kiSave); PMemKeyBuffer = ^TMemKeyBuffer; TMemKeyBuffer = record Modified: Boolean; Exclusive: Boolean; FieldCount: Integer; Data: record end; end; { NULLMASK DELETED FIELDDATA BOOKMARKDATA CALCULATEDDATA FNullMaskSize ======== | = (FieldCount + 7) div 8 FNativeRecordSize ========================== | = FNullMaskSize + 1 FBookMarkOffset ========================== | = FNativeRecordSize FCalculatedOffset ======================================= | = FBookMarkOffset + SizeOf(TRecInfo) FDatasetBufferSize ====================================================== | = FCalculatedOffset + CalcFieldsSize } { TDAMemoryDataset } TDAMemoryDataset = class(TDataset) private FRecordsList: TThreadMemList; FDataList: TMemList; FRecordPos: integer; FActive: Boolean; FOffsets: TOffsetArray; // FOffset[0] = FDeletedOffset+siseOf(Byte) FDataSizeArray:TOffsetArray; FNativeRecordSize: Integer; FBookMarkOffset: Integer; // = FNativeRecordSize FCalculatedOffset: Integer; // FBookMarkOffset + BookMark data size FDatasetBufferSize: Integer; // FCalculatedOffset+ Calc fields size FNullMaskSize: Integer; FDeletedOffset : Integer; // = FNullMaskSize FMasterDataLink: TMasterDataLink; FFilterBuffer: PChar; FIndexName: string; FIndexFieldNameList: TList; FIndexCaseInsList: TList; FIndexDescFields: TList; FSortDescMode: Boolean; FDataTypeArray: array of TFieldType; FStoreStringsAsReference: boolean; FExpressionEvaluator: TDAExpressionEvaluator; FExpressionBuffer: Pchar; {$IFDEF MSWINDOWS} FSortLocale: LCID; {$ENDIF MSWINDOWS} FFieldsIndex: Boolean; FIndexDefs: TIndexDefs; FCloneSource: TDAMemoryDataset; FCloneClientList:TThreadList; FReadOnly: Boolean; FDetailFields: string; FDetailsFieldNameList: TList; FRangeActive: boolean; fUseIndexinLocate: Boolean; fShowDeletedRecords: Boolean; FRestricttoRestoreRecords: Boolean; FNeedRefreshIndexConditional: Boolean; function CalcFieldLen(aDataType: TFieldType; aSize: Integer): integer; procedure CalculateOffsets; procedure ClearRecords; procedure ClearRecord(Buffer: PChar; AReInitRecord: Boolean); procedure ClearFieldByFieldType(FieldBuffer: pointer; ADataType: TFieldType); procedure ClearField(Buffer: pointer; AField: TField); function IsReferencedField(ADataType: TFieldType):Boolean; function GetNullMask(Buffer: PChar; const AIndex: Integer): boolean; function IntFindRecordID(Buf: pointer): Integer; function GetActiveRecBuf(var RecBuf: PChar): Boolean; procedure InternalSetFieldData(Field: TField; Buffer: Pointer); procedure IntAssignRecord(Source, Dest: Pchar); function IntAllocRecordBuffer(const ANative: Boolean): PChar; procedure IntFreeRecordBuffer(Buffer: PChar{$IFDEF MEMDATASET_DEBUG};const ANative: Boolean=true{$ENDIF}); procedure SetBlobData(Field: TField; Buffer: PChar; Value: Pointer); function GetMasterFields: string; procedure SetDataSource(const Value: TDataSource); procedure SetMasterFields(const Value: string); function GetIndexFieldNames: string; procedure SetIndexFieldNames(const Value: string); function InternalGetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; procedure DoSort; procedure QuickSort(L, R: Integer; SCompare: TDAMemDatasetCompare); function Compare(i1, i2: pointer): Integer; function CompareValues(buf1, buf2: pointer; aDataType: TFieldType;aSortCaseInsensitive:Boolean): integer; function CompareValues2(buf1: pointer; aValue:variant; aDataType: TFieldType;aSortCaseInsensitive:Boolean): integer; function CompareValues2_full(buf1: pointer; aValue:variant; aDataType: TFieldType;aSortCaseInsensitive:Boolean): boolean; function CompareValues2_partial(buf1: pointer; aValue:variant; aDataType: TFieldType;aSortCaseInsensitive: Boolean): boolean; function CompareValues_Range(buf: pointer; keybuffer: PMemKeyBuffer): integer; procedure DoFilterRecords; function ApplyMasterFilter: boolean; procedure ApplyRangeFilter; function FilterRecord(buf: pointer; AUseEvent: Boolean):Boolean; procedure InitIndexFieldNamesList(AFieldNames: string); procedure SetStoreStringAsReference(const Value: Boolean); procedure EEGetValue(Sender: TDAExpressionEvaluator; const aIdentifier: string; out aValue: Variant); function GetVarValueFromBuffer(Buffer: pointer; Field: TField):variant; function IsActiveFilter: Boolean; function GetIndexDefs: TIndexDefs; procedure SetIndexDefs(const Value: TIndexDefs); function GetIndexName: string; procedure SetIndexName(const Value: string); procedure SetIndex(const Value: string; FieldsIndex: Boolean); procedure ValidateFieldForIndex(aField: TField); function IntGetRecordList: TThreadMemList; procedure RegisterClient(const AClient: TDAMemoryDataset); procedure UnregisterClient(const AClient: TDAMemoryDataset); procedure UnregisterAllClients; procedure DetachFromSource; procedure NotifyClients(Buf: Pointer; Operation: TMemDataSetNotification; ASender: TDAMemoryDataset); procedure RecordNotification(Buf: Pointer; Operation: TMemDataSetNotification); procedure IntInsertBuffer(Buffer: Pointer; ASender: TDAMemoryDataset=nil); procedure IntRemoveBuffer(Buffer: Pointer;ASender: TDAMemoryDataset = nil); procedure IntUpdateBuffer(Buffer: Pointer;ASender: TDAMemoryDataset = nil); procedure DuplicateBuffer(Source, Dest: PChar); procedure SetReadOnly(const Value: Boolean); procedure SetDetailsFields(const Value: string); procedure InitDetailFieldNamesList; function IsRecordDeleted(const Buffer: Pointer): boolean; procedure SetRecordDeleted(const Buffer: Pointer; const aValue: Boolean); procedure SetShowDeletedRecords(const Value: Boolean); function GetIndexFields: string; function internalGotoKey(const KeyBuffer: PMemKeyBuffer;isNearest: Boolean):Boolean; procedure RefreshIndexConditional; 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 // for IDAMemDatasetBatchAdding procedure SetNullMask(Buffer: PChar; const AIndex: Integer; const Value: boolean); function IntFindFieldData(Buffer: Pointer; Field: TField): Pointer; function IntCreateBuffer(const ANative: Boolean): Pchar; function MakeBlobFromString(Blob:String):pointer; function GetFieldOffset(const aFieldNo:integer):cardinal; procedure SetAnsiString(NativeBuf: Pointer; Field: TField; const Value: Ansistring); procedure SetWideString(NativeBuf: Pointer; Field: TField; const Value: Widestring); procedure ProcessFilter; procedure AddRecordsfromList(AList: TList); protected procedure RecordToBuffer(RecNo: integer; Buffer: PChar); 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: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; procedure InternalClose; override; procedure InternalHandleException; override; procedure InternalInitFieldDefs; override; procedure InternalOpen; override; function IsCursorOpen: Boolean; override; function AllocRecordBuffer: PChar; override; procedure FreeRecordBuffer(var Buffer: PChar); override; procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; function GetBookmarkFlag(Buffer: PChar): 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: PChar); override; procedure InternalLast; override; procedure InternalPost; override; procedure InternalSetToRecord(Buffer: PChar); override; procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; procedure SetFieldData(Field: TField; Buffer: Pointer); overload; override; function GetRecordCount: Integer; override; function GetRecNo: Integer; override; procedure SetRecNo(Value: Integer); override; procedure OpenCursor(InfoQuery: Boolean); override; procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override; function GetDataSource: TDataSource; override; procedure SetFiltered(Value: Boolean); override; procedure SetFilterOptions(Value: TFilterOptions); override; procedure SetFilterText(const Value: string); override; procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override; procedure DoAfterOpen; override; procedure UpdateIndexDefs; override; procedure DefChanged(Sender: TObject); {$IFNDEF FPC}override;{$ENDIF} procedure intInsertRecord(Buf: Pointer); 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 CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override; function BookmarkValid(Bookmark: TBookmark): Boolean; override; {$IFNDEF MEMDATASET_DEBUG} protected // postponed to .29 {$ENDIF MEMDATASET_DEBUG} property UseIndexinLocate: Boolean read fUseIndexinLocate write fUseIndexinLocate; property ShowDeletedRecords: Boolean read fShowDeletedRecords write SetShowDeletedRecords; procedure RemoveDeletedRecords; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SortOnFields(const Fields: string; CaseInsensitive: Boolean = False; Descending: Boolean = False);overload; procedure SortOnFields(const Fields, CaseInsFields, DescFields: string);overload; procedure SortOnFields;overload; procedure GetIndexNames(List: TStrings); procedure AddIndex(const Name, Fields: string; const DescFields: string = ''; const CaseInsFields: string = ''); procedure DeleteIndex(const Name: string); procedure CloneCursor(Source: TDAMemoryDataset; Reset: Boolean; KeepSettings: Boolean = False); virtual; property StoreStringAsReference: Boolean read FStoreStringsAsReference write SetStoreStringAsReference; property CloneSource: TDAMemoryDataset read FCloneSource; procedure Post; override; procedure Cancel; override; {$IFDEF MSWINDOWS} property SortLocale: LCID read FSortLocale write FSortLocale; {$ENDIF MSWINDOWS} public { Set range } procedure ApplyRange; procedure CancelRange; procedure SetRange(const StartValues, EndValues: array of const); procedure EditRangeEnd; procedure EditRangeStart; procedure SetRangeEnd; procedure SetRangeStart; // procedure SetKey; procedure EditKey; function FindKey(const KeyValues: array of const): Boolean; procedure FindNearest(const KeyValues: array of const); function GotoKey: Boolean; procedure GotoNearest; published property Active; property FieldDefs; property OnFilterRecord; property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames; property IndexName: string read GetIndexName write SetIndexName; property IndexDefs: TIndexDefs read GetIndexDefs write SetIndexDefs; property MasterFields: string read GetMasterFields write SetMasterFields; property MasterSource: TDataSource read GetDataSource write SetDataSource; property DetailFields: string read FDetailFields write SetDetailsFields; property ReadOnly: Boolean read FReadOnly write SetReadOnly default False; property Filter; property Filtered; property BeforeOpen; property AfterOpen; property BeforeClose; property AfterClose; property BeforeInsert; property AfterInsert; property BeforeEdit; property AfterEdit; property BeforePost; property AfterPost; property BeforeCancel; property AfterCancel; property BeforeDelete; property AfterDelete; property BeforeScroll; property AfterScroll; property BeforeRefresh; property AfterRefresh; property OnCalcFields; property OnDeleteError; property OnEditError; property OnNewRecord; property OnPostError; end; TDABlobStream = class(TMemoryStream) private FField: TBlobField; FDataSet: TDAMemoryDataset; FBuffer: PChar; FMode: TBlobStreamMode; FOpened: Boolean; FModified: Boolean; FPosition: Longint; FCached: Boolean; function GetBlobSize: Longint; function GetBLOBRecordFromRecord(Field: TField; out aLocked:Boolean): PBLOBRecord; function GetBLOBRecordFromBuffer(Buffer: Pchar; Field: TField): 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; {$IFDEF FPC} type PDateTime = ^TDateTime; {$ENDIF} {$IFDEF MEMDATASET_DEBUG} var memdataset_buff_cnt, memdataset_buff_cnt_native, memdataset_buff_cnt_notnative: cardinal; {$ENDIF} const guidsize = 38; { Length(GuidString) } resourcestring SNoDetailFilter = 'Filter property cannot be used for detail tables'; SNoFilterOptions = 'FilterOptions are not supported'; const ft_Inline = [ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftLargeint, {$IFNDEF FPC}ftTimeStamp,{$ENDIF} ftBCD, {$IFDEF ftFMTBCD_Support}ftFMTBCD, {$ENDIF}ftGuid]; ft_BlobTypes = [ftBlob, ftMemo,{$IFDEF DA_WideMemoSupport}ftWideMemo,{$ENDIF DA_WideMemoSupport} ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob]; ft_Strings = [ftString, ftWideString, ftFixedChar]; ft_Supported = ft_Inline + ft_BlobTypes + ft_Strings; // ft_UnSupported = [ftADT, ftArray, ftReference, ftDataSet, ftBytes, ftVarBytes] + [ftVariant]; 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: Pchar): 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: PChar; begin Result := IntAllocRecordBuffer(False); end; procedure TDAMemoryDataset.CalculateOffsets; var i: integer; lField: TField; llen: cardinal; begin if not FStoreStringsAsReference then begin for i := 0 to FieldCount - 1 do with Fields[i] do if (DataType in ft_Strings) and (Size >= MaxStringSizeInline) then begin FStoreStringsAsReference := True; Break; end; end; SetLength(FOffsets, FieldCount + 1); SetLength(FDataSizeArray,FieldCount); SetLength(FDataTypeArray,FieldCount); // FOffsets[FieldCount+1] = BookMarkOffset FNullMaskSize := (FieldCount + 7) div 8; FDeletedOffset := FNullMaskSize; FOffsets[0] := FNullMaskSize + Sizeof(byte); for i := 0 to FieldCount - 1 do begin lField := Fields[i]; FDataTypeArray[i]:=lField.DataType; llen:=CalcFieldLen(lField.DataType,lField.Size); FDataSizeArray[i] := llen; FOffsets[i + 1] := FOffsets[i] + llen; end; FNativeRecordSize := FOffsets[FieldCount]; FBookMarkOffset := FNativeRecordSize; FCalculatedOffset := FBookMarkOffset + SizeOf(TRecInfo); FDatasetBufferSize := FCalculatedOffset + CalcFieldsSize; end; procedure TDAMemoryDataset.ClearFieldByFieldType(FieldBuffer: pointer; ADataType: TFieldType); begin case ADataType of ftString: begin PAnsiString(FieldBuffer)^ := ''; PPointer(FieldBuffer)^ := nil; end; ftWideString: begin PWideString(FieldBuffer)^ := ''; PPointer(FieldBuffer)^ := nil; end; else if ADataType in ft_BlobTypes then begin FreeBlobRecord(PPointer(FieldBuffer)^); PPointer(FieldBuffer)^ := nil; end; end; end; procedure TDAMemoryDataset.ClearField(Buffer: pointer; AField: TField); begin if GetNullMask(Buffer, AField.Index) then Exit; if IsReferencedField(AField.DataType) then ClearFieldByFieldType(IntFindFieldData(Buffer, AField), AField.DataType); SetNullMask(Buffer, AField.Index, True); end; procedure TDAMemoryDataset.ClearRecord(Buffer: PChar; AReInitRecord: Boolean); var i: integer; begin for i := 0 to FieldCount - 1 do begin if IsReferencedField(FDataTypeArray[i]) then ClearFieldByFieldType((Buffer + FOffsets[i]), FDataTypeArray[i]); end; if AReInitRecord then // set NullMask for i := 0 to FNullMaskSize - 1 do Buffer[i] := #$FF; // all fields is null end; procedure TDAMemoryDataset.ClearRecords; var i,j: integer; buf: pchar; begin FDataList.Clear; UnregisterAllClients; with FRecordsList.LockListForWriting do try for i := Count - 1 downto 0 do begin buf := List[i]; for j := 0 to FieldCount - 1 do if IsReferencedField(FDataTypeArray[j]) then ClearFieldByFieldType((Buf + FOffsets[j]), FDataTypeArray[j]); FreeMem(Buf); end; Clear; finally FRecordsList.UnlockListForWriting; end; end; constructor TDAMemoryDataset.Create(AOwner: TComponent); begin inherited; FRecordsList := TThreadMemList.Create; FDataList := TMemList.Create; FMasterDataLink := TMasterDataLink.Create(Self); FMasterDataLink.OnMasterChange := MasterChanged; FMasterDataLink.OnMasterDisable := MasterDisabled; 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; fUseIndexinLocate:=True; FRestricttoRestoreRecords := True; // defer to .29 fShowDeletedRecords:=True; // don't have any sense if FRestricttoRestoreRecords=True, but can remove additional check. end; function TDAMemoryDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; begin Result := TDABlobStream.Create(TBlobField(Field), Mode); end; destructor TDAMemoryDataset.Destroy; begin inherited; FDetailsFieldNameList.Free; FExpressionEvaluator.Free; FIndexFieldNameList.Free; FIndexCaseInsList.Free; FIndexDescFields.Free; FMasterDataLink.Free; FDataList.Free; FRecordsList.Free; FIndexDefs.Free; if FCloneClientList <> nil then FCloneClientList.Free; end; procedure TDAMemoryDataset.DuplicateBuffer(Source, Dest: PChar); var i: integer; p, p2: PBlobRecord; begin for I := 0 to FieldCount - 1 do if (not GetNullMask(Dest, i)) and IsReferencedField(FDataTypeArray[i]) and (PPointer(Dest + FOffsets[i])^ <> nil) then ClearFieldByFieldType(Dest + FOffsets[i], FDataTypeArray[i]); Move(pointer(Source)^, pointer(Dest)^, FNullMaskSize); for I := 0 to FieldCount - 1 do begin if (not GetNullMask(Source, i)) then begin if not IsReferencedField(FDataTypeArray[i]) then begin Move(pointer(Source + FOffsets[i])^, pointer(Dest + FOffsets[i])^, FDataSizeArray[i]) end else begin case FDataTypeArray[i] of ftString: PAnsiString(Dest + FOffsets[i])^ := PAnsiString(Source + FOffsets[i])^; ftWideString: PWideString(Dest + FOffsets[i])^ := PWideString(Source + FOffsets[i])^; else if FDataTypeArray[i] in ft_BlobTypes then begin p := PPointer(Source + FOffsets[i])^; if p <> nil then begin p2 := CreateBlobRecord(PBlobRecord(p)^.size); Move(pointer(p)^, pointer(p2)^, p^.size + SizeOf(TBlobRecord)); PPointer(Dest + FOffsets[i])^ := p2; end else begin SetNullMask(Dest, i, True); end; end; end; end; end; end; end; procedure TDAMemoryDataset.EEGetValue(Sender: TDAExpressionEvaluator; const aIdentifier: string; out aValue: Variant); begin aValue:= GetVarValueFromBuffer(FExpressionBuffer, FieldByName(aIdentifier)); end; procedure TDAMemoryDataset.ProcessFilter; begin CheckBrowseMode; DoFilterRecords; end; function TDAMemoryDataset.FilterRecord(buf: pointer; AUseEvent: Boolean): Boolean; begin Result:=True; if FRangeActive then begin IntGetRecordList.LockListForReading; try Result := (CompareValues_Range(buf,FKeyBuffers[kiCurRangeStart]) >=0) and (CompareValues_Range(buf,FKeyBuffers[kiCurRangeEnd]) <=0); finally IntGetRecordList.UnlockListForReading; end; end; if Result and (Filter <> '') then begin IntGetRecordList.LockListForReading; try FExpressionBuffer:=buf; Result := FExpressionEvaluator.Evaluate(Filter); finally IntGetRecordList.UnlockListForReading; end; end; if Result and AUseEvent and Assigned(OnFilterRecord) then OnFilterRecord(Self, Result); end; procedure TDAMemoryDataset.FreeRecordBuffer(var Buffer: PChar); begin IntFreeRecordBuffer(Buffer{$IFDEF MEMDATASET_DEBUG}, False{$ENDIF}); Buffer := nil; end; function TDAMemoryDataset.GetActiveRecBuf(var RecBuf: PChar): 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 := PChar(FKeyBuffer) + SizeOf(TMemKeyBuffer); else RecBuf := nil; end; Result := RecBuf <> nil; end; procedure TDAMemoryDataset.GetBookmarkData(Buffer: PChar; Data: Pointer); begin Move(PRecInfo(Buffer + FBookMarkOffset).Bookmark, Data^, SizeOf(TBookmarkData)); end; function TDAMemoryDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; begin Result := PRecInfo(Buffer + FBookMarkOffset).BookmarkFlag; end; function TDAMemoryDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean; var RecBuf, Data: PChar; // VarData : Variant; Len: integer; begin Result := False; {$IFDEF FPC} RecBuf := nil; {$ENDIF FPC} if not GetActiveRecBuf(RecBuf) then Exit; Data := intFindFieldData(RecBuf, Field); if Data <> nil then begin Result := GetNullMask(RecBuf, Field.Index) = False; if Result and (Buffer <> nil) then begin {if Field.DataType = ftVariant then begin VarData := PVariant(Data)^; PVariant(Buffer)^ := VarData; end else} if not IsReferencedField(Field.DataType) then begin Move(Data^, Buffer^, FDataSizeArray[Field.Index]) end else begin case Field.DataType of ftString: begin len := Length(PAnsiString(Data)^); if Len > Field.Size then Len := Field.Size; Move(pointer(PAnsiString(Data)^)^, buffer^, len); PAnsiChar(buffer)[Len] := #0; end; ftWideString: begin len := Length(PWideString(Data)^); if Len > Field.Size then Len := Field.Size; Move(pointer(PWideString(Data)^)^, buffer^, len * sizeOf(WideChar)); PWideChar(buffer)[Len] := #0; end; else if Field.DataType in ft_BlobTypes then DatabaseError('GetFieldData: BlobType'); end; end; end; end; end; function TDAMemoryDataset.GetRecNo: Integer; begin UpdateCursorPos; if (FRecordPos = -1) and (RecordCount > 0) then Result := 1 else Result := FRecordPos + 1; end; function TDAMemoryDataset.InternalGetRecord(Buffer: PChar; 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(Buffer); end else if (Result = grError) and DoCheck then DatabaseError('No data found'); end; function TDAMemoryDataset.GetRecordCount: Integer; begin Result := FDataList.Count; end; function TDAMemoryDataset.GetRecordSize: Word; begin Result := FDatasetBufferSize; end; function TDAMemoryDataset.GetVarValueFromBuffer(Buffer: pointer; Field: TField): variant; var buf: pchar; p: pointer; begin if GetNullMask(Buffer,Field.Index) then begin Result := Null; end else begin buf := IntFindFieldData(Buffer,Field); case Field.DataType of ftString,ftFixedChar: begin if FStoreStringsAsReference then Result:=PAnsistring(Buf)^ else Result:= Ansistring(PAnsiChar(Buf)); end; ftWideString: begin if FStoreStringsAsReference then Result:=PWidestring(Buf)^ else Result := WideString(PWideChar(Buf)) end; ftSmallint: Result:= PSmallint(buf)^; ftInteger, ftDate, ftTime, ftAutoInc: Result := PInteger(buf)^; ftWord: Result := PWord(buf)^; ftBoolean: Result := PWordBool(buf)^; ftFloat, ftCurrency: Result := PDouble(Buf)^; ftDateTime: Result := TimeStampToDateTime(MSecsToTimeStamp({$IFDEF FPC}Trunc{$ENDIF}( PDateTime(Buf)^))); ftBcd{$IFDEF ftFMTBCD_Support}, ftFMTBCD{$ENDIF}: Result := BCDToVariant(PBcd(buf)^); ftLargeint: Result := PInt64(Buf)^; {$IFNDEF FPC} ftTimeStamp: Result := VarSQLTimeStampCreate(PSQLTimeStamp(Buf)^); {$ENDIF FPC} ftGuid: Result:= AnsiString(PChar(Buf)); else Result := VarArrayCreate([0,PBLOBRecord(buf)^.size-1],varByte); p := VarArrayLock(Result); try move(PBLOBRecord(buf)^.Data, p^,PBLOBRecord(buf)^.size); finally VarArrayUnlock(Result); end; end; end; end; function TDAMemoryDataset.IntAllocRecordBuffer(const ANative: Boolean): PChar; begin {$IFDEF MEMDATASET_DEBUG} inc(memdataset_buff_cnt); {$ENDIF} {$IFDEF FPC} Result := nil; {$ENDIF FPC} if ANative then begin GetMem(Result, FNativeRecordSize); FillChar(Result^, FNullMaskSize, $FF); FillChar((Result+FNullMaskSize)^, FNativeRecordSize-FNullMaskSize, 0); {$IFDEF MEMDATASET_DEBUG} inc(memdataset_buff_cnt_native); {$ENDIF} end else begin GetMem(Result, FDatasetBufferSize); FillChar(Result^, FNullMaskSize, $FF); FillChar((Result+FNullMaskSize)^, FDatasetBufferSize-FNullMaskSize, 0); {$IFDEF MEMDATASET_DEBUG} inc(memdataset_buff_cnt_notnative); {$ENDIF} end; {$IFDEF MEMDATASET_DEBUG} OutputDebugString(Pchar('memdataset:IntAllocRecordBuffer =$'+ IntToHex(cardinal(Result),8)+ ' | native='+BoolToStr(ANative,True))); {$ENDIF} end; procedure TDAMemoryDataset.IntAssignRecord(Source, Dest: Pchar); begin if State = dsFilter then DatabaseError(SNotEditing); DuplicateBuffer(Source, Dest); end; function TDAMemoryDataset.IntCreateBuffer(const ANative: Boolean): Pchar; begin Result := IntAllocRecordBuffer(ANative); end; procedure TDAMemoryDataset.InternalAddRecord(Buffer: Pointer; Append: Boolean); var RecPos: Integer; Rec: PChar; begin Rec := IntCreateBuffer(True); 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; begin FIndexFieldNameList.Clear; FIndexCaseInsList.Clear; FIndexDescFields.Clear; UnregisterClient(Self); ClearRecords; FreeKeyBuffers; FCloneSource := nil; BindFields(False); if DefaultFields then DestroyFields; SetLength(FDataTypeArray,0); SetLength(FOffsets, 0); SetLength(FDataSizeArray,0); FActive := False; end; procedure TDAMemoryDataset.InternalDelete; begin IntRemoveBuffer(FDataList.Items[FRecordPos]); end; procedure TDAMemoryDataset.InternalFirst; begin FRecordPos := -1; end; procedure TDAMemoryDataset.InternalGotoBookmark(Bookmark: Pointer); var RecNo: Integer; begin RecNo := IntFindRecordID(TBookMarkData(PPointer(Bookmark)^)); if RecNo <> -1 then FRecordPos := RecNo 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: PChar); begin ClearRecord(Buffer, True); end; procedure TDAMemoryDataset.InternalLast; begin FRecordPos := RecordCount; end; procedure TDAMemoryDataset.InternalOpen; begin BookmarkSize := SizeOf(TBookmarkData); FieldDefs.Update; IndexDefs.Updated := False; if DefaultFields then CreateFields; BindFields(True); CalculateOffsets; RegisterClient(Self); AllocKeyBuffers; if FDetailFields <> '' then InitDetailFieldNamesList; if FIndexName <> '' then InitIndexFieldNamesList(GetIndexFields); DoFilterRecords; InternalFirst; end; procedure TDAMemoryDataset.InternalPost; var Rec: PChar; begin {$IFDEF DELPHI6UP} inherited InternalPost; {$ENDIF} if State = dsEdit then begin Rec:=FDataList[FRecordPos]; IntGetRecordList.LockListForWriting; try IntAssignRecord(ActiveBuffer, Rec); finally IntGetRecordList.UnlockListForWriting; end; IntUpdateBuffer(Rec); end else begin // if State in [dsInsert] then SetAutoIncFields(ActiveBuffer); Rec := IntCreateBuffer(True); IntAssignRecord(ActiveBuffer, Rec); intInsertRecord(Rec); IntInsertBuffer(Rec); end; end; procedure TDAMemoryDataset.InternalSetFieldData(Field: TField; Buffer: Pointer); var RecBuf, Data: Pchar; begin {$IFDEF FPC} RecBuf := nil; {$ENDIF FPC} GetActiveRecBuf(RecBuf); with Field do begin Data := IntFindFieldData(RecBuf, Field); if Data <> nil then begin { if DataType = ftVariant then begin if Buffer <> nil then VarData := PVariant(Buffer)^ else VarData := EmptyParam; PVariant(Data)^ := VarData; end else } if not IsReferencedField(DataType) then begin if Buffer <> nil then begin Move(Buffer^, Data^, FDataSizeArray[Field.Index]); SetNullMask(RecBuf, Index, False); end else SetNullMask(RecBuf, Index, True); end else begin if Buffer <> nil then begin if DataType = ftString then begin PAnsiString(Data)^ := PAnsiChar(buffer); SetNullMask(RecBuf, Index, False); end else if DataType = ftWideString then begin PWideString(Data)^ := PWideChar(buffer); SetNullMask(RecBuf, Index, False); end; end else SetNullMask(RecBuf, Index, True); end; end; end; end; procedure TDAMemoryDataset.InternalSetToRecord(Buffer: PChar); begin InternalGotoBookmark(@PRecInfo(Buffer + FBookMarkOffset).Bookmark); end; function TDAMemoryDataset.IntFindFieldData(Buffer: Pointer; Field: TField): Pointer; begin Result := nil; if (Buffer <> nil) and (Field.DataType in ft_Supported) then Result := (PChar(Buffer) + FOffsets[Field.Index]); end; function TDAMemoryDataset.IntFindRecordID(Buf: pointer): Integer; begin Result := FDataList.IndexOf(Buf); end; function TDAMemoryDataset.IsActiveFilter: Boolean; begin Result := (Filtered and (Filter <> '')) or FRangeActive; end; function TDAMemoryDataset.IsCursorOpen: Boolean; begin Result := FActive; end; function TDAMemoryDataset.IsReferencedField(ADataType: TFieldType): Boolean; begin Result:= (FStoreStringsAsReference and (ADataType in ft_Strings)) or (ADataType in ft_BlobTypes); end; procedure TDAMemoryDataset.OpenCursor(InfoQuery: Boolean); var i: integer; lfld, lfld2: TField; begin if not InfoQuery then begin if FCloneSource <> nil then begin Fields.Clear; // creating FieldDefs.Assign(FCloneSource.FieldDefs); for i:=0 to FieldDefs.Count-1 do FieldDefs[i].CreateField(Self).DataSet := Self; // creating lookups For i:=0 to FCloneSource.Fields.Count-1 do begin lfld2 := FCloneSource.Fields[i]; if lfld2.FieldKind in [fkCalculated,fkLookup] then begin lfld := TField(lfld2.NewInstance).Create(Self); lfld.Name := Self.Name + lfld2.FieldName; lfld.FieldName := lfld2.FieldName; lfld.DataSet := Self; if (lfld2 is TStringField) or (lfld2 is TWideStringField) then lfld.Size := lfld2.Size; lfld.FieldKind := lfld2.FieldKind; lfld.Required := lfld2.Required; {$IFNDEF FPC} lfld.Lookup := lfld2.Lookup; {$ENDIF} lfld.LookupDataSet := lfld2.LookupDataSet; lfld.LookupKeyFields := lfld2.LookupKeyFields; lfld.LookupCache := lfld2.LookupCache; lfld.LookupResultField := lfld2.LookupResultField; lfld.KeyFields := lfld2.KeyFields; end; end; for i := 0 to FCloneSource.Fields.Count-1 do FieldByName(FCloneSource.Fields[i].FieldName).Index := i + 1; end else begin if FieldCount > 0 then FieldDefs.Clear; InitFieldDefsFromFields; end; FExpressionEvaluator.UseTrueFalseinVariableName:=False; For i:=0 to Fields.Count-1 do begin 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: PChar; 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: PChar); begin IntGetRecordList.LockListForReading; try with PRecInfo(Buffer + FBookMarkOffset)^ do begin Bookmark := TBookmarkData(FDataList[RecNo]); BookmarkFlag := bfCurrent; end; DuplicateBuffer(FDataList[RecNo], Buffer); finally IntGetRecordList.UnlockListForReading; end; end; procedure TDAMemoryDataset.SetAnsiString(NativeBuf: Pointer; Field: TField; const Value: Ansistring); var len: integer; begin if FStoreStringsAsReference then PAnsiString(NativeBuf)^:=Value else begin len := Length(Value); if Len > Field.Size then len:= Field.Size; move(Pointer(Value)^,NativeBuf^,len); Pchar(NativeBuf)[len]:=#0; end; end; procedure TDAMemoryDataset.SetBlobData(Field: TField; Buffer: PChar; Value: Pointer); begin PPointer(Buffer + FOffsets[Field.Index])^ := Value; SetNullMask(Buffer, Field.Index, False); end; procedure TDAMemoryDataset.SetBookmarkData(Buffer: PChar; Data: Pointer); begin Move(Data^, PRecInfo(Buffer + FBookMarkOffset)^.Bookmark, SizeOf(TBookmarkData)); end; procedure TDAMemoryDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); begin PRecInfo(Buffer + FBookMarkOffset).BookmarkFlag := Value; end; procedure TDAMemoryDataset.SetFieldData(Field: TField; Buffer: Pointer); begin if (State = dsSetKey) and ((Field.FieldNo < 0) or (FIndexFieldNameList.Count > 0) 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 InternalSetFieldData(Field, Buffer); if not (State in [dsCalcFields, dsInternalCalc, dsFilter, dsNewValue]) then DataEvent(deFieldChange, Longint(Field)); end; end; procedure TDAMemoryDataset.SetNullMask(Buffer: PChar; const AIndex: Integer; const Value: boolean); var i: byte; begin i := AIndex shr 3; if Value then Buffer[I] := Chr(ord(Buffer[I]) or (1 shl (AIndex and 7))) else Buffer[I] := Chr(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 {$IFNDEF DELPHI10UP} if Field.DataType = ftWideString then begin if ToNative then begin len := Length(PWideString(Source)^); Move(PWideChar(Source^)^, PWideChar(Dest)^, len * SizeOf(WideChar)); PWideChar(Dest)[Len] := #0; end else begin len := Length(PWideChar(Source)); SetString(WideString(Dest^), PWideChar(Source), Len); end; end else {$ENDIF DELPHI10UP} inherited DataConvert(Field, Source, Dest, ToNative); end; function TDAMemoryDataset.GetDataSource: TDataSource; begin Result := MasterDataLink.DataSource; end; function TDAMemoryDataset.GetMasterFields: string; begin Result := MasterDataLink.FieldNames; end; {$IFDEF FPC} const SCircularDataLink = 'Circular datalinks are not allowed'; {$ENDIF} procedure TDAMemoryDataset.SetDataSource(const Value: TDataSource); begin if IsLinkedTo(Value) then DatabaseError(SCircularDataLink, Self); if MasterDataLink.DataSource <> Value then DataEvent(dePropertyChange, 0); MasterDataLink.DataSource := Value; end; procedure TDAMemoryDataset.SetMasterFields(const Value: string); begin if (Value <> '') and (Filter <> '') then DatabaseError(SNoDetailFilter, Self); if MasterDataLink.FieldNames <> Value then DataEvent(dePropertyChange, 0); MasterDataLink.FieldNames := Value; end; function TDAMemoryDataset.GetIndexFieldNames: string; begin if FFieldsIndex then Result := FIndexName else Result := ''; end; procedure TDAMemoryDataset.SetIndexFieldNames(const Value: string); begin SetIndex(Value, True); end; function TDAMemoryDataset.GetRecord(Buffer: PChar; 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(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(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 DatabaseError(SNoFilterOptions,Self); inherited; 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; var pos: TBookmarkData; lRecList:TThreadMemList; LList:TMemList; lflag: boolean; loldRangeActive: Boolean; begin if Active and (FieldCount > 0) and (RecordCount <> 0) then begin loldRangeActive := FRangeActive; FRangeActive := False; try if (FRecordPos<>-1) then pos := FDataList[FRecordPos] else pos := nil; try lRecList:=IntGetRecordList; LList:=lRecList.LockListForReading; try lflag:=(FIndexFieldNameList.Count = 0) and (FDataList.Count = LList.Count); if lFlag then FDataList.Assign(LList) else QuickSort(0, RecordCount - 1, Compare); finally lRecList.UnlockListForReading; end; 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; end; procedure TDAMemoryDataset.QuickSort(L, R: Integer; SCompare: TDAMemDatasetCompare); var I, J: Integer; P: pointer; begin repeat I := L; J := R; P := FDatalist[(L + R) shr 1]; repeat while SCompare(FDatalist[I], P) < 0 do Inc(I); while SCompare(FDatalist[j], P) > 0 do Dec(J); if I <= J then begin FDataList.Exchange(I, J); Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J, SCompare); L := I; until I >= R; end; function TDAMemoryDataset.Compare(i1, i2: pointer): Integer; var buf1, buf2: PChar; i: integer; Field: TField; p1, p2: PChar; lList: TMemList; begin buf1 := i1; buf2 := i2; Result := 0; if FIndexFieldNameList <> nil then for i := 0 to FIndexFieldNameList.Count - 1 do begin Field := FIndexFieldNameList[i]; if not GetNullMask(buf1, Field.Index) then p1 := intFindFieldData(buf1, Field) else p1 := nil; if not GetNullMask(buf2, Field.Index) then p2 := intFindFieldData(buf2, Field) else p2 := nil; if (p1 <> nil) and (p2 <> nil) then begin Result := CompareValues(p1, p2, Field.DataType, FIndexCaseInsList[i] <> nil) end else if p1 <> nil then Result := 1 else if p2 <> nil then Result := -1 else continue; if FIndexDescFields[i] <> nil then Result := -Result; if Result <> 0 then Exit; end; if Result = 0 then begin lList:=IntGetRecordList.LockListForReading; try Result := lList.IndexOf(buf1) - lList.IndexOf(buf2); finally IntGetRecordList.UnlockListForReading; end; if FSortDescMode 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 TDAMemoryDataset.CompareValues(buf1, buf2: pointer; aDataType: TFieldType;aSortCaseInsensitive:Boolean): integer; var s1, s2: AnsiString; begin Result := 0; case aDataType of ftString, ftFixedChar: begin if FStoreStringsAsReference then begin s1:=PAnsiString(Buf1)^; s2:=PAnsiString(Buf2)^; end else begin s1:=PAnsiChar(Buf1); s2:=PAnsiChar(Buf2); end; if aSortCaseInsensitive then Result := AnsiCompareText(s1,s2) else Result := AnsiCompareStr(s1,s2); end; ftWideString: begin if FStoreStringsAsReference then Result:= ROWideCompare(PWideString(Buf1)^,PWideString(Buf2)^,aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWIN}) else Result:= ROWideCompare(PWideChar(Buf1),PWideChar(Buf2),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWIN}); end; ftGuid: Result := StrLIComp(PChar(Buf1), Pchar(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{$IFDEF ftFMTBCD_Support}, ftFMTBCD{$ENDIF}: Result := BcdCompare(PBcd(buf1)^, PBcd(buf2)^); ftLargeint: Result := Int64Compare(PInt64(Buf1)^, PInt64(Buf2)^); {$IFNDEF FPC} ftTimeStamp: Result := DoubleCompare(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^), SQLTimeStampToDateTime(PSQLTimeStamp(Buf2)^)); {$ENDIF FPC} else end; end; {$HINTS OFF} procedure TDAMemoryDataset.SortOnFields(const Fields: string; CaseInsensitive, Descending: Boolean); var i: integer; begin if FActive then begin if (Fields = '') and (FIndexName <> '') then begin // default sorting if FFieldsIndex then SortOnFields(IndexFieldNames) else SwitchToIndex(IndexName); FNeedRefreshIndexConditional:=False; end else begin if Fields = '' then InitIndexFieldNamesList(IndexFieldNames) else InitIndexFieldNamesList(Fields); for i:= 0 to FIndexCaseInsList.Count-1 do FIndexCaseInsList[i]:= Pointer({$IFDEF FPC}PtrUInt{$ELSE}cardinal{$ENDIF}(ord(CaseInsensitive))); FSortDescMode:= Descending; for i:= 0 to FIndexDescFields.Count-1 do FIndexDescFields[i]:= Pointer({$IFDEF FPC}PtrUInt{$ELSE}cardinal{$ENDIF}(ord(Descending))); FNeedRefreshIndexConditional := True; DoSort; end; end; end; {$HINTS ON} procedure TDAMemoryDataset.SetStoreStringAsReference(const Value: Boolean); begin CheckInactive; FStoreStringsAsReference := Value; end; procedure TDAMemoryDataset.SetWideString(NativeBuf: Pointer; Field: TField; const Value: Widestring); var len: integer; begin if FStoreStringsAsReference then PWideString(NativeBuf)^:=Value else begin len := Length(Value); if Len > Field.Size then len:= Field.Size; move(Pointer(Value)^,NativeBuf^,len*Sizeof(WideChar)); PWideChar(NativeBuf)[len]:=#0; end; end; procedure TDAMemoryDataset.DoAfterOpen; begin if not IsEmpty then SortOnFields(); inherited; end; procedure TDAMemoryDataset.MasterChanged(Sender: TObject); begin ProcessFilter; end; procedure TDAMemoryDataset.MasterDisabled(Sender: TObject); begin DataEvent(dePropertyChange, 0); DoFilterRecords; end; (* procedure TDAMemoryDataset.GetDetailLinkFields(MasterFields, DetailFields: TList); begin { TODO : GetDetailLinkFields } inherited GetDetailLinkFields(MasterFields, DetailFields); end; *) type TDAMasterStruct = packed record value: variant; end; procedure TDAMemoryDataset.DoFilterRecords; var i: integer; pos: TBookmarkData; begin if (RecordCount > 0) and (FRecordPos<>-1) then pos := FDataList[FRecordPos] else pos := nil; //============================== if ApplyMasterFilter then pos := nil; if FRangeActive then begin ApplyRangeFilter; pos := nil; end; // apply filters if IsActiveFilter then begin for i := FDataList.Count-1 downto 0 do if not FilterRecord(FDataList.List[i], False) then FDataList.Delete(i); end; //============================== if FIndexName <> '' then SortOnFields; if Active then begin if pos = nil then FRecordPos := -1 else FRecordPos := IntFindRecordID(pos); if (FRecordPos = -1) then First; if (RecordCount > 0) then FRecordPos := 0 else Resync([]); end; end; {$IFDEF FPC} const SInvalidCalcType = 'Field ''%s'' cannot be a calculated or lookup field'; {$ENDIF} {$IFDEF DELPHI10UP} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF DELPHI10UP} procedure TDAMemoryDataset.InitIndexFieldNamesList(AFieldNames: string); var pos1: integer; fld: TField; begin FIndexFieldNameList.Clear; FIndexCaseInsList.Clear; FIndexDescFields.Clear; Pos1 := 1; while Pos1 <= Length(AFieldNames) do begin Fld := FieldByName(ExtractFieldName(AFieldNames, Pos1)); ValidateFieldForIndex(Fld); FIndexFieldNameList.Add(Fld); end; FIndexCaseInsList.Count := FIndexFieldNameList.Count; FIndexDescFields.Count := FIndexFieldNameList.Count; end; {$IFDEF DELPHI10UP} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF DELPHI10UP} function TDAMemoryDataset.MakeBlobFromString(Blob: String): pointer; var s: integer; begin s:= Length(blob); Result:=CreateBlobRecord(s); Move(Pointer(blob)^, PBlobRecord(Result)^.Data,s); end; procedure TDAMemoryDataset.IntInsertBuffer(Buffer: Pointer;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.GetFieldOffset( const aFieldNo: integer): cardinal; begin if aFieldNo < FieldCount then Result:=FOffsets[aFieldNo] else Result:=0; end; procedure TDAMemoryDataset.DoOnNewRecord; var I: Integer; begin if FMasterDataLink.Active and (FMasterDataLink.Fields.Count > 0) then for I := 0 to FMasterDataLink.Fields.Count - 1 do if FDetailsFieldNameList.Count > i then TField(FDetailsFieldNameList[I]).Assign(TField(FMasterDataLink.Fields[I])); inherited; end; function TDAMemoryDataset.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; begin DoBeforeScroll; Result := LocateRecord(KeyFields, KeyValues, Options, True); if Result then begin Resync([rmExact, rmCenter]); DoAfterScroll; end; end; function TDAMemoryDataset.LocateRecord(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions; SyncCursor: Boolean): Boolean; // TLocateOption = (loCaseInsensitive, loPartialKey); var lWorkList: TMemList; lFields : TList; lFieldIndexes: array of integer; lOffsets: array of cardinal; lDatatypes: array of TFieldType; lValues: array of variant; lCaseInsensitive: Boolean; lnull: array of boolean; Buffer: Pchar; f: TMemLocateCompare; luseDescList: Boolean; function LocateWithIndex: boolean; var L, H, I, C,j : integer; begin Result := False; L := 0; H := lWorkList.Count - 1; while L <= H do begin I := (L + H) shr 1; c:=0; For j:=0 to lFields.Count-1 do begin if GetNullMask(lWorkList[i],lFieldIndexes[j]) = lnull[j] then begin if lnull[j] then c := 0 // null | null else c := CompareValues2(Pchar(lWorkList[i])+lOffsets[j], lValues[j], lDatatypes[j], lCaseInsensitive); // 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 Break; end; if C < 0 then L := I + 1 else begin H := I - 1; if C = 0 then Result := True; end; end; if Result then begin if luseDescList then RecordToBuffer(lWorkList.Count - 1 - L, Buffer) else RecordToBuffer(L, Buffer); end; end; function LocateWithOutIndex: boolean; var i,j: integer; k: boolean; begin Result:=False; For i:= 0 to lWorkList.Count - 1 do begin k := False; For j:=0 to lFields.Count-1 do begin if GetNullMask(lWorkList[i],lFieldIndexes[j]) = lnull[j] then begin if lnull[j] then k := True // null | null else k := f(Pchar(lWorkList[i])+lOffsets[j], lValues[j], lDatatypes[j], lCaseInsensitive); end else k:=False; if not k then Break; end; if k then begin RecordToBuffer(i, Buffer); Result:=True; Break; end; end; end; var lBookmark: TBookmarkStr; i,j: integer; lPartialKey:Boolean; lCanUseIndex : Boolean; begin Result := False; lBookmark:=''; if Self.State <> dsBrowse then CheckBrowseMode; CursorPosChanged; Buffer:=TempBuffer; if IsEmpty then Exit; try lFields := TList.Create; try GetFieldList(lFields,KeyFields); if lFields.Count = 0 then Exit; lCaseInsensitive:= loCaseInsensitive in Options; lPartialKey:= loPartialKey in Options; SetLength(lOffsets,lFields.Count); SetLength(lDatatypes,lFields.Count); SetLength(lValues,lFields.Count); SetLength(lnull,lFields.Count); SetLength(lFieldIndexes,lFields.Count); for i:=0 to lFields.Count-1 do begin lFieldIndexes[i]:=TField(lFields[i]).Index; lOffsets[i] := GetFieldOffset(lFieldIndexes[i]); lDatatypes[i] := TField(lFields[i]).DataType; if lFields.Count = 1 then lValues[i]:= KeyValues else lValues[i]:= KeyValues[i]; lnull[i]:=VarIsEmpty(lValues[i]) or VarIsNull(lValues[i]); end; if lPartialKey then f := CompareValues2_partial else f := CompareValues2_full; lCanUseIndex := fUseIndexinLocate and (not lPartialKey); // same fields lCanUseIndex := lCanUseIndex and (FIndexFieldNameList.Count = lFields.Count); if lCanUseIndex then begin for i:= 0 to FIndexFieldNameList.Count-1 do if lFields[i] <> FIndexFieldNameList[i] then begin lCanUseIndex:= False; Break; end; end; // same CaseInsensitive if lCanUseIndex then begin j:=0; for i:=0 to FIndexCaseInsList.Count -1 do if FIndexCaseInsList[i] <> nil then inc(j); lCanUseIndex:=(lCaseInsensitive and (j = FIndexFieldNameList.Count)) or (not lCaseInsensitive and (j = 0)); end; luseDescList := False; if lCanUseIndex then begin j:=0; for i:=0 to FIndexDescFields.Count -1 do if FIndexDescFields[i] <> nil then inc(j); luseDescList := (j = FIndexFieldNameList.Count); lCanUseIndex := (j = 0) or luseDescList; end; IntGetRecordList.LockListForReading; try if lCanUseIndex and luseDescList then begin lWorkList:= TMemList.Create; lWorkList.Count := FDataList.Count; j:= FDataList.Count -1; For i := 0 to j do lWorkList.List[i] := FDataList.List[j-i]; end else begin lWorkList:=FDataList; end; try if lCanUseIndex then result:= LocateWithIndex else result:= LocateWithOutIndex; if Result then begin SetLength(lBookmark, BookmarkSize); GetBookmarkData(Buffer, Pointer(lBookmark)); end; finally if lCanUseIndex and luseDescList then lWorkList.Free; end; finally IntGetRecordList.UnlockListForReading; end; finally lFields.Free; end; finally if Result then if SyncCursor then begin Bookmark := lBookmark; if EOF or BOF then Result := False; end; end; end; function TDAMemoryDataset.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; begin Result := Null; if LocateRecord(KeyFields, KeyValues, [], False) then begin SetTempState(dsCalcFields); try CalculateFields(TempBuffer); Result := FieldValues[ResultFields]; finally RestoreState(dsBrowse); end; end; end; function TDAMemoryDataset.CompareValues2(buf1: pointer; aValue: variant; aDataType: TFieldType; aSortCaseInsensitive: Boolean): integer; var str, str1: string; wstr1: widestring; begin Result := 0; case aDataType of ftString, ftFixedChar: begin if FStoreStringsAsReference then str1:=PAnsiString(Buf1)^ else str1 := PAnsiChar(Buf1); if aSortCaseInsensitive then Result := AnsiCompareText(str1, VarToStr(aValue)) else Result := AnsiCompareStr(str1, VarToStr(aValue)); end; ftWideString: begin if FStoreStringsAsReference then wstr1:=PWideString(Buf1)^ else wstr1:=PWideChar(Buf1); Result:= ROWideCompare(wstr1,VarToWideStr(aValue),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWIN}); end; ftGuid: begin SetString(str, PAnsiChar(buf1), guidsize); Result := AnsiCompareText(str, VarToStr(aValue)) end; ftSmallint: Result := IntegerCompare(PSmallInt(buf1)^, aValue); ftInteger, ftDate, ftTime, ftAutoInc: Result := IntegerCompare(PInteger(buf1)^, aValue); ftWord: Result := IntegerCompare(PWord(buf1)^, aValue); ftBoolean: Result := WordBoolCompare(PWordBool(buf1)^, aValue); ftFloat, ftCurrency: Result := DoubleCompare(PDouble(Buf1)^, aValue); ftDateTime: Result := TDateTimeCompare(PDateTime(Buf1)^, TimeStampToMSecs(DateTimeToTimeStamp(aValue))); ftBcd{$IFDEF ftFMTBCD_Support}, ftFMTBCD{$ENDIF}: Result := BcdCompare(PBcd(buf1)^, VariantToBCD(aValue)); ftLargeint: Result := Int64Compare(PInt64(Buf1)^, aValue); {$IFNDEF FPC} ftTimeStamp: Result := DoubleCompare(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^), SQLTimeStampToDateTime(VarToSQLTimeStamp(aValue))); {$ENDIF FPC} else end; end; procedure TDAMemoryDataset.IntFreeRecordBuffer(Buffer: PChar{$IFDEF MEMDATASET_DEBUG};const ANative: Boolean=true{$ENDIF}); begin {$IFDEF MEMDATASET_DEBUG} OutputDebugString(Pchar('memdataset:IntFreeRecordBuffer =$'+ IntToHex(cardinal(Buffer),8))); // OutputDebugString(Pchar(' =$'+ IntTostr(FRecordsList.IndexOf(PRecInfo(Buffer + FBookMarkOffset).Bookmark)))); dec(memdataset_buff_cnt); if ANative then dec(memdataset_buff_cnt_native) else dec(memdataset_buff_cnt_notnative); {$ENDIF} ClearRecord(Buffer, False); FreeMem(Buffer); 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; FNeedRefreshIndexConditional := False; end; procedure TDAMemoryDataset.SwitchToIndex(const IndexName: string); var i: integer; lCaseInsField, lDescFields: string; begin if FActive then begin i:= IndexDefs.IndexOf(IndexName); if i = -1 then DatabaseErrorFmt(SIndexNotFound,[IndexName]); lCaseInsField := IndexDefs[i].CaseInsFields; if (lCaseInsField = '') and (ixCaseInsensitive in IndexDefs[i].Options) then lCaseInsField := IndexDefs[i].Fields; lDescFields := IndexDefs[i].DescFields; if (lDescFields = '') and (ixDescending in IndexDefs[i].Options) then lDescFields := IndexDefs[i].Fields; SortOnFields(IndexDefs[i].Fields, lCaseInsField, lDescFields); 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; 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); var j: integer; pos1: integer; fld: TField; begin if FActive then begin InitIndexFieldNamesList(Fields); Pos1 := 1; // DescFields while Pos1 <= Length(DescFields) do begin Fld := FieldByName(ExtractFieldName(DescFields, Pos1)); j:= FIndexFieldNameList.IndexOf(Fld); if j <> -1 then FIndexDescFields[j]:=pointer(1); end; //CaseInsFields Pos1 := 1; while Pos1 <= Length(CaseInsFields) do begin Fld := FieldByName(ExtractFieldName(CaseInsFields, Pos1)); j:= FIndexFieldNameList.IndexOf(Fld); if j <> -1 then FIndexCaseInsList[j]:=pointer(1) ; end; FNeedRefreshIndexConditional := True; DoSort; 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 if (not FFieldsIndex) and (FIndexName <> '') then begin if FIndexDefs.Count = 0 then FIndexName:=''; SortOnFields; end; end; function CompareAnsiStrPartial(const aStr1, aStr2: AnsiString): integer; begin Result := pos(aStr1, aStr2)-1; if Result <> 0 then Result := AnsiCompareStr(aStr1, aStr2); end; function CompareWideStrPartial(const aStr1, aStr2: WideString): integer; begin Result := pos(aStr1, aStr2)-1; if Result <> 0 then Result := WideCompareStr(aStr1, aStr2); end; function TDAMemoryDataset.CompareValues2_partial(buf1: pointer; aValue: variant; aDataType: TFieldType; aSortCaseInsensitive:Boolean): boolean; var str, str1: string; wstr1: widestring; begin Result := False; case aDataType of ftString, ftFixedChar: begin if FStoreStringsAsReference then str1:=PAnsiString(Buf1)^ else str1 := PAnsiChar(Buf1); if aSortCaseInsensitive then Result := pos(AnsiUpperCase(VarToStr(aValue)), AnsiUpperCase(str1)) = 1 else Result := pos(VarToStr(aValue), str1) = 1; end; ftWideString: begin if FStoreStringsAsReference then wstr1:=PWideString(Buf1)^ else wstr1:=PWideChar(Buf1); if aSortCaseInsensitive then Result := pos(WideUpperCase(VarToWideStr(aValue)), WideUpperCase(wstr1)) = 1 else Result := pos(VarToWideStr(aValue), wstr1) = 1; end; ftGuid: begin SetString(str, PAnsiChar(buf1), guidsize); Result := pos(AnsiUpperCase(VarToStr(aValue)), AnsiUpperCase(str)) = 1; end; ftSmallint: Result := pos(VarToStr(aValue), IntToStr(PSmallInt(buf1)^)) = 1; ftInteger, ftDate, ftTime, ftAutoInc: Result := pos(VarToStr(aValue), IntToStr(PInteger(buf1)^)) = 1; ftWord: Result := pos(VarToStr(aValue), IntToStr(PWord(buf1)^)) = 1; ftBoolean: Result:= PWordBool(buf1)^ = aValue; ftFloat, ftCurrency: Result := pos(VarToStr(aValue), FloatToStr(PDouble(buf1)^)) = 1; ftDateTime: Result := pos(VarToStr(aValue), DateToStr(TimeStampToDateTime(MSecsToTimeStamp({$IFDEF FPC}Trunc{$ENDIF}(PDateTime(buf1)^))))) = 1; ftBcd{$IFDEF ftFMTBCD_Support}, ftFMTBCD{$ENDIF}: Result :=pos(VarToStr(aValue), BcdToStr(PBcd(buf1)^)) = 1; ftLargeint: Result := pos(VarToStr(aValue), IntToStr(PInt64(buf1)^)) = 1; {$IFNDEF FPC} ftTimeStamp: Result := pos(VarToStr(aValue), DateTimeToStr(SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^))) = 1; {$ENDIF FPC} else end; end; procedure TDAMemoryDataset.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (AComponent = FCloneSource) then DetachFromSource; end; procedure TDAMemoryDataset.CloneCursor(Source: TDAMemoryDataset; Reset: Boolean; KeepSettings: Boolean = False); begin Source.CheckActive; Close; Source.UpdateCursorPos; FCloneSource := Source; if Reset then begin Filtered := False; Filter := ''; OnFilterRecord := nil; IndexDefs.Clear; IndexName := ''; MasterSource := nil; MasterFields := ''; DetailFields := ''; ReadOnly := False; end else if not KeepSettings then begin Filter := Source.Filter; OnFilterRecord := Source.OnFilterRecord; Filtered := Source.Filtered; IndexDefs.Assign(Source.IndexDefs); if Source.IndexName <> '' then IndexName := Source.IndexName else IndexFieldNames := Source.IndexFieldNames; MasterSource := Source.MasterSource; MasterFields := Source.MasterFields; DetailFields := Source.DetailFields; ReadOnly := Source.ReadOnly; end; Open; if Reset then Resync([]); end; procedure TDAMemoryDataset.IntRemoveBuffer(Buffer: Pointer;ASender: TDAMemoryDataset); begin if FCloneSource <> nil then FCloneSource.IntRemoveBuffer(Buffer,ASender) else begin NotifyClients(Buffer,mdnDelete,ASender); with FRecordsList.LockListForWriting do try if FRestricttoRestoreRecords then begin Remove(Buffer); IntFreeRecordBuffer(Buffer{$IFDEF MEMDATASET_DEBUG}, True{$ENDIF}); end else begin SetRecordDeleted(Buffer,True); end; finally FRecordsList.UnlockListForWriting; end; end; end; function TDAMemoryDataset.IntGetRecordList: TThreadMemList; begin if FCloneSource <> nil then Result:= FCloneSource.IntGetRecordList else Result:=FRecordsList; end; procedure TDAMemoryDataset.RegisterClient(const AClient: TDAMemoryDataset); begin if FCloneSource <> nil then begin FCloneSource.RegisterClient(AClient); end else begin if FCloneClientList = nil then FCloneClientList:=TThreadList.Create; FCloneClientList.Add(AClient); end; end; procedure TDAMemoryDataset.UnregisterClient(const AClient: TDAMemoryDataset); begin if FCloneSource <> nil then begin FCloneSource.UnregisterClient(AClient); end else begin if FCloneClientList <> nil then FCloneClientList.Remove(AClient); end; end; procedure TDAMemoryDataset.UnregisterAllClients; var i: integer; lList: TList; lClient: TDAMemoryDataset; begin if FCloneClientList <> nil then begin lList:= FCloneClientList.LockList; try for i:= lList.Count-1 downto 0 do begin lClient:= TDAMemoryDataset(lList[i]); if Assigned(lClient) then lClient.DetachFromSource; end; lList.Clear; finally FCloneClientList.UnlockList; end; end; end; procedure TDAMemoryDataset.DetachFromSource; begin FDataList.Clear; FCloneSource := nil; InternalFirst; Resync([]); end; procedure TDAMemoryDataset.NotifyClients(Buf: Pointer; Operation: TMemDataSetNotification;ASender: TDAMemoryDataset); var i: integer; begin if FCloneClientList <> nil then with FCloneClientList.LockList do try For i:=0 to Count -1 do if ASender <> TDAMemoryDataset(Items[i]) then TDAMemoryDataset(Items[i]).RecordNotification(Buf,Operation); finally FCloneClientList.UnlockList; end; end; procedure TDAMemoryDataset.RecordNotification(Buf: Pointer; Operation: TMemDataSetNotification); var i: integer; begin case Operation of mdnInsert: begin intInsertRecord(Buf); end; mdnModify: if IsActiveFilter and not FilterRecord(Buf, True) then begin i := FDataList.Remove(buf); if (i <> -1) and (i = FRecordPos) and (FRecordPos >= RecordCount) then Dec(FRecordPos); end; mdnDelete: begin i := FDataList.Remove(buf); if (i <> -1) and (i = FRecordPos) and (FRecordPos >= RecordCount) then Dec(FRecordPos); end; mdnBatchAdding: begin ProcessFilter; end; mdnRemoveDeleted: begin ProcessFilter; end; end; DataEvent(deUpdateState, 0); // Refresh; Resync([]); end; procedure TDAMemoryDataset.IntUpdateBuffer(Buffer: Pointer; 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: Pointer); var lCount: integer; RecPos: integer; begin if not IsActiveFilter or FilterRecord(Buf, True) then begin if State = dsInsert then begin lCount:= IntGetRecordList.lockListForReading.Count; IntGetRecordList.UnlockListForReading; if FRecordPos >= lCount then begin FDataList.Add(Buf); FRecordPos := RecordCount - 1; end else begin if FRecordPos = -1 then RecPos := 0 else RecPos := FRecordPos; FDataList.Insert(RecPos, Buf); FRecordPos := RecPos; end; end else begin FDataList.Add(Buf); end; end; end; procedure TDAMemoryDataset.AddRecordsfromList(AList: TList); var old_count: integer; begin with IntGetRecordList.LockListForWriting do try old_count:=Count; Count:=old_count+AList.Count; System.Move(AList.List^, Pchar(List^[old_Count]), AList.Count*SizeOf(Pointer)); finally IntGetRecordList.UnlockListForWriting; end; AList.Clear; NotifyClients(nil, mdnBatchAdding, nil); end; function TDAMemoryDataset.CalcFieldLen(aDataType: TFieldType; aSize: Integer): integer; begin if not (aDataType in ft_Supported) then Result := 0 else if IsReferencedField(aDataType) then Result := sizeof(Pointer) else case aDataType of ftSmallint: Result := SizeOf(Smallint); ftInteger, ftAutoInc: Result := SizeOf(Integer); ftWord: Result := SizeOf(Word); ftBoolean: Result := SizeOf(WordBool); ftFloat, ftCurrency: Result := SizeOf(Double); ftDate, ftTime: Result := SizeOf(Integer); ftDateTime: Result := SizeOf(TDateTime); ftLargeint: Result := SizeOf(Largeint); {$IFNDEF FPC} ftTimeStamp: Result := SizeOf(TSQLTimeStamp); {$ENDIF} {$IFDEF ftFMTBCD_Support} ftFMTBCD, {$ENDIF ftFMTBCD_Support} ftBCD: Result := SizeOf(TBcd); ftGuid: Result := GuidSize+1; ftString,ftFixedChar: Result := (aSize + 1); ftWideString: Result := (aSize + 1) * Sizeof(WideChar); else Result:=0; end; end; procedure TDAMemoryDataset.SetReadOnly(const Value: Boolean); begin FReadOnly := Value; end; function TDAMemoryDataset.GetCanModify: Boolean; begin Result := not FReadOnly; end; procedure TDAMemoryDataset.ApplyRange; begin CheckBrowseMode; if not (BuffersEqual(FKeyBuffers[kiRangeStart], FKeyBuffers[kiCurRangeStart], SizeOf(TMemKeyBuffer) + FNativeRecordSize) and BuffersEqual(FKeyBuffers[kiRangeEnd], FKeyBuffers[kiCurRangeEnd], SizeOf(TMemKeyBuffer) + FNativeRecordSize)) then begin Move(FKeyBuffers[kiRangeStart]^, FKeyBuffers[kiCurRangeStart]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize); Move(FKeyBuffers[kiRangeEnd]^, FKeyBuffers[kiCurRangeEnd]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize); FRangeActive:=(FKeyBuffers[kiCurRangeStart]<>nil) and (FKeyBuffers[kiCurRangeEnd]<>nil); RefreshIndexConditional; InternalFirst; DoFilterRecords; First; end; end; procedure TDAMemoryDataset.CancelRange; begin CheckBrowseMode; UpdateCursorPos; FRangeActive := False; if FKeyBuffers[kiCurRangeStart].Modified or FKeyBuffers[kiCurRangeEnd].Modified then begin InitKeyBuffer(FKeyBuffers[kiCurRangeStart]); InitKeyBuffer(FKeyBuffers[kiCurRangeEnd]); end; DoFilterRecords; end; procedure TDAMemoryDataset.EditRangeEnd; begin SetKeyBuffer(kiRangeEnd, False); end; procedure TDAMemoryDataset.EditRangeStart; begin SetKeyBuffer(kiRangeStart, False); end; procedure TDAMemoryDataset.SetRange(const StartValues, EndValues: array of const); begin CheckBrowseMode; SetKeyFields(kiRangeStart, StartValues); SetKeyFields(kiRangeEnd, EndValues); ApplyRange; end; procedure TDAMemoryDataset.SetRangeEnd; begin SetKeyBuffer(kiRangeEnd, True); end; procedure TDAMemoryDataset.SetRangeStart; begin SetKeyBuffer(kiRangeStart, True); end; procedure TDAMemoryDataset.SetKeyBuffer(KeyIndex: TMemKeyIndex; Clear: Boolean); begin CheckBrowseMode; RefreshIndexConditional; FKeyBuffer := FKeyBuffers[KeyIndex]; Move(FKeyBuffer^, FKeyBuffers[kiSave]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize); if Clear then InitKeyBuffer(FKeyBuffer); FKeyBuffer.FieldCount:= FIndexFieldNameList.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 FIndexFieldNameList.Count = 0 then DatabaseError(SNoFieldIndexes, Self); SaveState := SetTempState(dsSetKey); try if FIndexFieldNameList.Count >= High(Values)-Low(Values)+1 then k:= High(Values)-Low(Values)+1 else begin k:= FIndexFieldNameList.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(FIndexFieldNameList[i]).AssignValue(Values[I]); FKeyBuffer^.FieldCount := High(Values) + 1; FKeyBuffer^.Modified := Modified; finally RestoreState(SaveState); end; end; procedure TDAMemoryDataset.AllocKeyBuffers; var KeyIndex: TMemKeyIndex; begin try for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do FKeyBuffers[KeyIndex] := AllocMem(SizeOf(TMemKeyBuffer) + FNativeRecordSize); if Assigned(FCloneSource) then for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do Move(FCloneSource.FKeyBuffers[KeyIndex]^, FKeyBuffers[KeyIndex]^, SizeOf(TMemKeyBuffer) + FNativeRecordSize); except FreeKeyBuffers; raise; end; end; procedure TDAMemoryDataset.FreeKeyBuffers; var KeyIndex: TMemKeyIndex; begin for KeyIndex := Low(TMemKeyIndex) to High(TMemKeyIndex) do DisposeMem(FKeyBuffers[KeyIndex], SizeOf(TMemKeyBuffer) + FNativeRecordSize); end; function TDAMemoryDataset.InitKeyBuffer(Buffer: PMemKeyBuffer): PMemKeyBuffer; begin FillChar(Buffer^, SizeOf(TMemKeyBuffer) + FNativeRecordSize, 0); Result := Buffer; end; procedure TDAMemoryDataset.SetDetailsFields(const Value: string); begin if FDetailFields <> Value then begin FDetailFields := Value; if Active then begin InitDetailFieldNamesList; DoFilterRecords; end; DataEvent(dePropertyChange, 0); end; end; {$IFDEF DELPHI10UP} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF DELPHI10UP} procedure TDAMemoryDataset.InitDetailFieldNamesList; var pos1: integer; fld: TField; begin FDetailsFieldNameList.Clear; if FDetailFields = '' then Exit;; Pos1 := 1; while Pos1 <= Length(FDetailFields) do begin Fld := FieldByName(ExtractFieldName(FDetailFields, Pos1)); ValidateFieldForIndex(Fld); FDetailsFieldNameList.Add(Fld); end; end; {$IFDEF DELPHI10UP} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF DELPHI10UP} function TDAMemoryDataset.ApplyMasterFilter:boolean; procedure AddNonDeletedRecord(const buffer: Pointer); begin if fShowDeletedRecords or not IsRecordDeleted(buffer) then FDataList.Add(buffer); end; var i, j: integer; MasterArray: array of TDAMasterStruct; buf: pchar; flag: boolean; fld_cnt: integer; str: string; lList: TMemList; 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.Capacity:=LList.Count; For i := 0 to LList.Count -1 do AddNonDeletedRecord(lList.List[i]); finally IntGetRecordList.UnlockListForReading; end; SortOnFields; Result := False; end else begin fld_cnt := MasterDataLink.Fields.Count; if FDetailsFieldNameList.Count < fld_cnt then fld_cnt := FDetailsFieldNameList.Count; SetLength(MasterArray, fld_cnt); for i := 0 to fld_cnt - 1 do MasterArray[i].value := TField(MasterDataLink.Fields[i]).Value; lList:= IntGetRecordList.LockListForReading; try FDataList.Capacity := lList.Count; for i := 0 to LList.Count - 1 do begin flag := true; for j := 0 to fld_cnt - 1 do begin buf := IntFindFieldData(LList.FList^[i], TField(FDetailsFieldNameList[j])); if (buf <> nil) then case TField(FDetailsFieldNameList[j]).DataType of ftString: begin if FStoreStringsAsReference then flag := AnsiCompareText(PAnsistring(Buf)^, VarToStr(MasterArray[j].value)) = 0 else flag := AnsiCompareText(PAnsiChar(Buf), VarToStr(MasterArray[j].value)) = 0 end; ftWideString: begin if FStoreStringsAsReference then flag := ROWideCompare(PWidestring(Buf)^, VarToWideStr(MasterArray[j].value),True {$IFDEF MSWINDOWS}, FSortLocale {$ENDIF}) = 0 else flag := ROWideCompare(PWideChar(Buf), VarToWideStr(MasterArray[j].value),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{$IFDEF ftFMTBCD_Support}, ftFMTBCD{$ENDIF}: 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,PChar(Buf),guidsize); flag := AnsiSameText(str, VarToStr(MasterArray[j].value)); end; end else Flag := not VarIsNull(MasterArray[j].value); if not flag then Break; end; if flag then AddNonDeletedRecord(lList.FList^[i]); end; finally IntGetRecordList.UnlockListForReading; end; Result := true; end; end; function TDAMemoryDataset.CompareValues_Range(buf: pointer; keybuffer: PMemKeyBuffer): integer; var i, lFieldCount: integer; p1,p2: pchar; lField: TField; begin if FIndexFieldNameList.Count >= keybuffer^.FieldCount then begin lFieldCount := keybuffer^.FieldCount end else begin lFieldCount := FIndexFieldNameList.Count; {$IFDEF CHECK_RANGE} DatabaseError('Error during applying range'); {$ENDIF CHECK_RANGE} end; Result := 0; For i:=0 to lFieldCount-1 do begin lField := TField(FIndexFieldNameList[i]); if not GetNullMask(buf, lField.Index) then p1 := intFindFieldData(buf, lField) else p1 := nil; if not GetNullMask(Pchar(@keybuffer.Data), lField.Index) then p2 := intFindFieldData(Pchar(@keybuffer.Data), lField) else p2 := nil; if (p1 <> nil) and (p2 <> nil) then Result := CompareValues(p1, p2, lField.DataType, FIndexCaseInsList[i] <> nil) 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: variant; aDataType: TFieldType; aSortCaseInsensitive: Boolean): boolean; begin Result := CompareValues2(buf1,aValue,aDataType,aSortCaseInsensitive) = 0; end; function TDAMemoryDataset.IsRecordDeleted(const Buffer: Pointer): boolean; begin Result := Pchar(Buffer)[FDeletedOffset] <> #0; end; procedure TDAMemoryDataset.SetRecordDeleted(const Buffer: Pointer; const aValue: Boolean); begin if aValue then Pchar(Buffer)[FDeletedOffset] := #1 else Pchar(Buffer)[FDeletedOffset] := #0; end; procedure TDAMemoryDataset.RemoveDeletedRecords; var i: integer; lMemList: TMemList; Buffer: Pointer; begin if FCloneSource <> nil then FCloneSource.RemoveDeletedRecords else begin lMemList:=FRecordsList.LockListForWriting; try For i:= lMemList.Count -1 downto 0 do begin buffer := lMemList.List[i]; if IsRecordDeleted(buffer) then begin lMemList.Delete(i); IntFreeRecordBuffer(Buffer{$IFDEF MEMDATASET_DEBUG}, True{$ENDIF}); end; end; NotifyClients(nil,mdnRemoveDeleted,nil); finally FRecordsList.UnlockListForWriting; end; end; end; procedure TDAMemoryDataset.SetShowDeletedRecords(const Value: Boolean); begin fShowDeletedRecords := Value; if Active then ProcessFilter; 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:= FIndexFieldNameList.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 (FIndexFieldNameList.IndexOf(Field) >= 0); end; procedure TDAMemoryDataset.PostKeyBuffer(Commit: Boolean); begin DataEvent(deCheckBrowseMode, 0); if Commit then FKeyBuffer.Modified := Modified else Move(FKeyBuffers[kiSave]^, FKeyBuffer^, SizeOf(TMemKeyBuffer) + FNativeRecordSize); SetState(dsBrowse); DataEvent(deDataSetChange, 0); end; procedure TDAMemoryDataset.Post; begin inherited; if State = dsSetKey then PostKeyBuffer(True); end; procedure TDAMemoryDataset.Cancel; begin inherited; if State = dsSetKey then PostKeyBuffer(False); end; procedure TDAMemoryDataset.RefreshIndexConditional; begin if FNeedRefreshIndexConditional then SortOnFields; end; { TDABlobStream } constructor TDABlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode); begin inherited Create; FMode := Mode; FField := Field; FDataSet := FField.DataSet as TDAMemoryDataset; if not FDataSet.GetActiveRecBuf(FBuffer) then Exit; 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 := (FBuffer = 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; function TDABlobStream.GetBLOBRecordFromRecord(Field: TField; out aLocked:Boolean): PBLOBRecord; var Pos: Integer; begin Result := nil; 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 Result := GetBLOBRecordFromBuffer(FDataSet.IntGetRecordList.LockListForReading[Pos], Field); ALocked:=True; end; end; function TDABlobStream.GetBlobSize: Longint; var rec: PBlobRecord; llocked: Boolean; begin Result := 0; if FOpened then begin if FCached then begin Rec := GetBLOBRecordFromBuffer(FBuffer, FField); if rec <> nil then Result := rec.size; end else begin Rec := GetBLOBRecordFromRecord(FField, llocked); try if rec <> nil then Result := rec.size; finally if llocked then FDataSet.IntGetRecordList.UnlockListForReading; end; end; end; end; function TDABlobStream.GetBLOBRecordFromBuffer(Buffer: Pchar; Field: TField): PBLOBRecord; begin Result := PPointer(FDataSet.IntFindFieldData(Buffer, Field))^; end; function TDABlobStream.Read(var Buffer; Count: Integer): Longint; var rec: PBlobRecord; llocked: boolean; 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 rec := GetBLOBRecordFromBuffer(FBuffer, FField) else rec := GetBLOBRecordFromRecord(FField,llocked); try if rec <> nil then begin Move(PChar(@Rec.Data)[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.ClearField(FBuffer, FField); FModified := True; end; end; function TDABlobStream.Write(const Buffer; Count: Integer): Longint; var Temp: PBLOBRecord; begin Result := 0; if FOpened and FCached and (FMode <> bmRead) then begin Temp := GetBLOBRecordFromBuffer(FBuffer, FField); 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 copying ReallocMem(temp, SizeOf(TBLOBRecord) + FPosition + Count); inc(Temp.size, Count); end; Move(Buffer, PChar(@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; InitializeCriticalSection(FLock); 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; DeleteCriticalSection(FLock); 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; initialization {$IFDEF MEMDATASET_DEBUG} memdataset_buff_cnt := 0; memdataset_buff_cnt_native := 0; memdataset_buff_cnt_notnative:= 0; {$ENDIF} end.