3641 lines
109 KiB
ObjectPascal
3641 lines
109 KiB
ObjectPascal
unit uDAMemDataset;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ Data Abstract Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 6 and up }
|
|
{ platform: Win32 }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the Data Abstract }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I DataAbstract.inc}
|
|
|
|
interface
|
|
{.$DEFINE MEMDATASET_DEBUG}
|
|
{$DEFINE CHECK_RANGE}
|
|
|
|
{$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.
|
|
|