david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
1775 lines
55 KiB
ObjectPascal
1775 lines
55 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}
|
|
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;
|
|
|
|
TDAMemoryDataset = class(TDataset)
|
|
private
|
|
FRecordsList: TList;
|
|
FDataList: TList;
|
|
FRecordPos: integer;
|
|
FActive: Boolean;
|
|
FOffsets: TOffsetArray;
|
|
FDataSizeArray:TOffsetArray;
|
|
FCalculatedOffset: Cardinal; // not used = FDatasetBufferSize
|
|
FDatasetBufferSize: Cardinal;
|
|
FNativeRecordSize: Cardinal;
|
|
FBookMarkOffset: Cardinal; // = FNativeRecordSize
|
|
FNullMaskSize: Cardinal;
|
|
FMasterDataLink: TMasterDataLink;
|
|
FFilterBuffer: PChar;
|
|
FIndexFieldNames: string;
|
|
FIndexFieldNameList: TList;
|
|
FSortDescMode: Boolean;
|
|
FSortCaseInsensitive: Boolean;
|
|
FDataTypeArray: array of TFieldType;
|
|
FStoreStringsAsReference: boolean;
|
|
FExpressionEvaluator: TDAExpressionEvaluator;
|
|
FExpressionBuffer: Pchar;
|
|
{$IFDEF MSWINDOWS}
|
|
FSortLocale: LCID;
|
|
{$ENDIF MSWINDOWS}
|
|
procedure CalculateOffsets;
|
|
procedure ClearRecords;
|
|
procedure ClearRecord(Buffer: PChar; AReInitRecord: Boolean);
|
|
procedure ClearField(FieldBuffer: pointer; ADataType: TFieldType); overload;
|
|
procedure ClearField(Buffer: pointer; AField: TField); overload;
|
|
function IsReferencedField(ADataType: TFieldType):Boolean;
|
|
function GetNullMask(Buffer: PChar; const Index: Integer): boolean;
|
|
function IntGetBookmark(ARecNo: Integer): TBookmarkData;
|
|
function IntFindRecordID(Bookmark: TBookmarkData): Integer;
|
|
function GetActiveRecBuf(var RecBuf: PChar): Boolean;
|
|
// function IntFindFieldData(Buffer: Pointer; Field: TField): Pointer;
|
|
procedure InternalSetFieldData(Field: TField; Buffer: Pointer);
|
|
procedure IntAssignRecord(Source, Dest: Pchar);
|
|
function IntAllocRecordBuffer(const ANative: Boolean): PChar;
|
|
procedure IntFreeRecordBuffer(var 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): integer;
|
|
function CompareValues2(buf1: pointer; aValue:variant; aDataType: TFieldType;aSortCaseInsensitive, aPartialKey :Boolean): boolean;
|
|
procedure DoFilterRecords;
|
|
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;
|
|
protected
|
|
// for IDAMemDatasetBatchAdding
|
|
procedure SetNullMask(Buffer: PChar; const Index: Integer; const Value: boolean);
|
|
function IntFindFieldData(Buffer: Pointer; Field: TField): Pointer;
|
|
function IntCreateBuffer(const ANative: Boolean): Pchar;
|
|
function MakeBlobFromString(Blob:String):pointer;
|
|
procedure IntInsertBuffer(Buffer: 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;
|
|
protected
|
|
procedure DuplicateBuffer(Source, Dest: PChar);
|
|
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
|
|
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;
|
|
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;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure SortOnFields(const FieldNames: string = ''; CaseInsensitive: Boolean = True; Descending: Boolean = False);
|
|
{$IFDEF MSWINDOWS}
|
|
property SortLocale: LCID read FSortLocale write FSortLocale;
|
|
{$ENDIF MSWINDOWS}
|
|
property StoreStringAsReference: Boolean read FStoreStringsAsReference write SetStoreStringAsReference;
|
|
published
|
|
property Active;
|
|
property FieldDefs;
|
|
property OnFilterRecord;
|
|
property IndexFieldNames: string read GetIndexFieldNames write SetIndexFieldNames;
|
|
property MasterFields: string read GetMasterFields write SetMasterFields;
|
|
property MasterSource: TDataSource read GetDataSource write SetDataSource;
|
|
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): PBLOBRecord;
|
|
function GetBLOBRecordFromBuffer(Buffer: Pchar; Field: TField): PBLOBRecord;
|
|
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;
|
|
procedure Truncate;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
uROClasses, uROBinaryHelpers,
|
|
Variants, SysUtils,{$IFDEF FPC}dbconst,{$ELSE}DBConsts,{$ENDIF}
|
|
{$IFNDEF FPC}Forms, SqlTimSt,{$ENDIF} FMTBcd;
|
|
|
|
{$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, ftTimeStamp, ftBCD, {$IFDEF DELPHI6UP}ftFMTBCD, {$ENDIF}ftGuid];
|
|
ft_BlobTypes = [ftBlob, ftMemo,{$IFDEF DELPHI10UP}ftWideMemo,{$ENDIF DELPHI10UP} 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
|
|
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;
|
|
|
|
{ TDAMemoryDataset }
|
|
|
|
function TDAMemoryDataset.AllocRecordBuffer: PChar;
|
|
begin
|
|
Result := IntAllocRecordBuffer(False);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.CalculateOffsets;
|
|
var
|
|
i: integer;
|
|
lField: TField;
|
|
llen: cardinal;
|
|
begin
|
|
SetLength(FOffsets, FieldCount + 1);
|
|
SetLength(FDataSizeArray,FieldCount);
|
|
SetLength(FDataTypeArray,FieldCount);
|
|
// FOffsets[FieldCount+1] = BookMarkOffset
|
|
FNullMaskSize := (FieldCount + 7) div 8;
|
|
FOffsets[0] := FNullMaskSize;
|
|
for i := 0 to FieldCount - 1 do begin
|
|
lField := Fields[i];
|
|
FDataTypeArray[i]:=lField.DataType;
|
|
if IsReferencedField(lField.DataType) then
|
|
llen := sizeof(Pointer)
|
|
else if lField.DataType = ftWideString then
|
|
lLen := (lField.Size + 1) * Sizeof(WideChar)
|
|
else
|
|
llen := lField.DataSize;
|
|
FDataSizeArray[i] := llen;
|
|
FOffsets[i + 1] := FOffsets[i] + llen;
|
|
end;
|
|
FNativeRecordSize := FOffsets[FieldCount];
|
|
FBookMarkOffset := FNativeRecordSize;
|
|
FCalculatedOffset := FBookMarkOffset + SizeOf(TRecInfo);
|
|
FDatasetBufferSize := FCalculatedOffset;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.ClearField(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
|
|
ClearField(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
|
|
ClearField((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
|
|
for i := FRecordsList.Count - 1 downto 0 do begin
|
|
buf := FRecordsList.List[i];
|
|
for j := 0 to FieldCount - 1 do
|
|
if IsReferencedField(FDataTypeArray[j]) then
|
|
ClearField((Buf + FOffsets[j]), FDataTypeArray[j]);
|
|
FreeMem(Buf);
|
|
end;
|
|
FRecordsList.Clear;
|
|
FDataList.Clear;
|
|
end;
|
|
|
|
constructor TDAMemoryDataset.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
FRecordsList := TList.Create;
|
|
FDataList := TList.Create;
|
|
FMasterDataLink := TMasterDataLink.Create(Self);
|
|
FMasterDataLink.OnMasterChange := MasterChanged;
|
|
FMasterDataLink.OnMasterDisable := MasterDisabled;
|
|
FIndexFieldNameList := TList.Create;
|
|
{$IFDEF MSWINDOWS}
|
|
FSortLocale := LOCALE_USER_DEFAULT;
|
|
{$ENDIF MSWINDOWS}
|
|
FStoreStringsAsReference:=False;
|
|
FExpressionEvaluator:= TDAStdExpressionEvaluator.Create;
|
|
FExpressionEvaluator.OnGetValue := EEGetValue;
|
|
end;
|
|
|
|
function TDAMemoryDataset.CreateBlobStream(Field: TField;
|
|
Mode: TBlobStreamMode): TStream;
|
|
begin
|
|
Result := TDABlobStream.Create(TBlobField(Field), Mode);
|
|
end;
|
|
|
|
destructor TDAMemoryDataset.Destroy;
|
|
begin
|
|
inherited;
|
|
FExpressionEvaluator.Free;
|
|
FIndexFieldNameList.Free;
|
|
FMasterDataLink.Free;
|
|
FDataList.Free;
|
|
FRecordsList.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
|
|
ClearField(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])^;
|
|
p2 := CreateBlobRecord(PBlobRecord(p)^.size);
|
|
Move(pointer(p)^, pointer(p2)^, p^.size + SizeOf(TBlobRecord));
|
|
PPointer(Dest + FOffsets[i])^ := p2;
|
|
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
|
|
FExpressionBuffer:=buf;
|
|
Result:= FExpressionEvaluator.Evaluate(Filter);
|
|
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});
|
|
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;
|
|
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;
|
|
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:
|
|
if (FRecordPos < 0) or (FRecordPos >= RecordCount) then Result := grError;
|
|
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
|
|
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, ftDateTime: Result := PDouble(Buf)^;
|
|
ftBcd{$IFDEF DELPHI6UP}, 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;
|
|
|
|
// ft_BlobTypes = [ftBlob, ftMemo,{$IFDEF DELPHI10UP}ftWideMemo,{$ENDIF DELPHI10UP} ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob];
|
|
|
|
|
|
function TDAMemoryDataset.IntAllocRecordBuffer(const ANative: Boolean): PChar;
|
|
begin
|
|
{$IFDEF MEMDATASET_DEBUG}
|
|
inc(memdataset_buff_cnt);
|
|
{$ENDIF}
|
|
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);
|
|
FRecordsList.Add(Rec);
|
|
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);
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalClose;
|
|
begin
|
|
FIndexFieldNameList.Clear;
|
|
ClearRecords;
|
|
BindFields(False);
|
|
if DefaultFields then DestroyFields;
|
|
SetLength(FDataTypeArray,0);
|
|
SetLength(FOffsets, 0);
|
|
SetLength(FDataSizeArray,0);
|
|
FActive := False;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalDelete;
|
|
var
|
|
Buf: Pchar;
|
|
begin
|
|
Buf := FDataList[FRecordPos];
|
|
FRecordsList.Remove(Buf);
|
|
FDataList.Delete(FRecordPos);
|
|
IntFreeRecordBuffer(Buf{$IFDEF MEMDATASET_DEBUG}, True{$ENDIF});
|
|
if FRecordPos >= RecordCount then Dec(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;
|
|
if DefaultFields then CreateFields;
|
|
BindFields(True);
|
|
InitIndexFieldNamesList(FIndexFieldNames);
|
|
CalculateOffsets;
|
|
DoFilterRecords;
|
|
InternalFirst;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalPost;
|
|
var
|
|
RecPos: Integer;
|
|
Rec: PChar;
|
|
begin
|
|
{$IFDEF DELPHI6UP}
|
|
inherited InternalPost;
|
|
{$ENDIF}
|
|
if State = dsEdit then
|
|
IntAssignRecord(ActiveBuffer, FDataList[FRecordPos])
|
|
else begin
|
|
// if State in [dsInsert] then SetAutoIncFields(ActiveBuffer);
|
|
Rec := IntCreateBuffer(True);
|
|
FRecordsList.Add(Rec);
|
|
IntAssignRecord(ActiveBuffer, Rec);
|
|
if not IsActiveFilter or FilterRecord(Rec, True) then
|
|
if FRecordPos >= FRecordsList.Count then begin
|
|
FDataList.Add(Rec);
|
|
FRecordPos := RecordCount - 1;
|
|
end
|
|
else begin
|
|
if FRecordPos = -1 then
|
|
RecPos := 0
|
|
else
|
|
RecPos := FRecordPos;
|
|
FDataList.Insert(RecPos, Rec);
|
|
FRecordPos := RecPos;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.InternalSetFieldData(Field: TField; Buffer: Pointer);
|
|
var
|
|
RecBuf, Data: Pchar;
|
|
begin
|
|
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(Bookmark: TBookmarkData): Integer;
|
|
begin
|
|
Result := FDataList.IndexOf(Bookmark);
|
|
end;
|
|
|
|
function TDAMemoryDataset.IntGetBookmark(ARecNo: Integer): TBookmarkData;
|
|
begin
|
|
Result := TBookmarkData(FDataList[ARecNo]);
|
|
end;
|
|
|
|
function TDAMemoryDataset.IsActiveFilter: Boolean;
|
|
begin
|
|
Result := Filtered and (Filter <> '');
|
|
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);
|
|
begin
|
|
if not InfoQuery then begin
|
|
if FieldCount > 0 then FieldDefs.Clear;
|
|
InitFieldDefsFromFields;
|
|
end;
|
|
FActive := True;
|
|
inherited OpenCursor(InfoQuery);
|
|
end;
|
|
|
|
function TDAMemoryDataset.GetNullMask(Buffer: PChar; const Index: Integer): boolean;
|
|
begin
|
|
Result := (ord(Buffer[Index shr 3]) shr (Index and 7)) and 1 = 1;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.RecordToBuffer(RecNo: integer; Buffer: PChar);
|
|
begin
|
|
with PRecInfo(Buffer + FBookMarkOffset)^ do begin
|
|
Bookmark := IntGetBookmark(RecNo);
|
|
BookmarkFlag := bfCurrent;
|
|
end;
|
|
DuplicateBuffer(FDataList[RecNo], Buffer);
|
|
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 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 Index: Integer; const Value: boolean);
|
|
var
|
|
i: byte;
|
|
begin
|
|
i := Index shr 3;
|
|
if Value then
|
|
Buffer[I] := Chr(ord(Buffer[I]) or (1 shl (Index and 7)))
|
|
else
|
|
Buffer[I] := Chr(ord(Buffer[I]) and not (1 shl (Index 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
|
|
FRecordPos := Value - 1;
|
|
Resync([]);
|
|
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
|
|
Result := FIndexFieldNames;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetIndexFieldNames(const Value: string);
|
|
begin
|
|
if FIndexFieldNames <> Value then begin
|
|
FIndexFieldNames := Value;
|
|
if Active then begin
|
|
InitIndexFieldNamesList(FIndexFieldNames);
|
|
DoSort;
|
|
end;
|
|
end;
|
|
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: TBookmarkStr;
|
|
begin
|
|
if Active and (FieldCount > 0) and (RecordCount <> 0) then begin
|
|
Pos := Bookmark;
|
|
try
|
|
if (FIndexFieldNameList.Count = 0) and (FDataList.Count = FRecordsList.Count) then
|
|
begin
|
|
// nosort
|
|
FDataList.Assign(FRecordsList);
|
|
end
|
|
else
|
|
QuickSort(0, RecordCount - 1, Compare);
|
|
SetBufListSize(0);
|
|
try
|
|
SetBufListSize(BufferCount + 1);
|
|
except
|
|
SetState(dsInactive);
|
|
CloseCursor;
|
|
raise;
|
|
end;
|
|
finally
|
|
Bookmark := Pos;
|
|
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;
|
|
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)
|
|
end
|
|
else
|
|
if p1 <> nil then Result := 1
|
|
else if p2 <> nil then Result := -1
|
|
else continue;
|
|
if FSortDescMode then Result := -Result;
|
|
if Result <> 0 then Exit;
|
|
end;
|
|
if Result = 0 then begin
|
|
Result :=FRecordsList.IndexOf(buf1) - FRecordsList.IndexOf(buf2);
|
|
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 TDAMemoryDataset.CompareValues(buf1, buf2: pointer;
|
|
aDataType: TFieldType): 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 FSortCaseInsensitive then
|
|
Result := AnsiCompareText(s1,s2)
|
|
else
|
|
Result := AnsiCompareStr(s1,s2);
|
|
end;
|
|
ftWideString: begin
|
|
if FStoreStringsAsReference then
|
|
Result:= ROWideCompare(PWideString(Buf1)^,PWideString(Buf2)^,FSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWIN})
|
|
else
|
|
Result:= ROWideCompare(PWideChar(Buf1),PWideChar(Buf2),FSortCaseInsensitive {$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, ftDateTime: Result := DoubleCompare(PDouble(Buf1)^, PDouble(Buf2)^);
|
|
ftBcd{$IFDEF DELPHI6UP}, 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;
|
|
|
|
procedure TDAMemoryDataset.SortOnFields(const FieldNames: string;
|
|
CaseInsensitive, Descending: Boolean);
|
|
var
|
|
s: string;
|
|
begin
|
|
if Active then begin
|
|
FSortCaseInsensitive := CaseInsensitive;
|
|
FSortDescMode := Descending;
|
|
s := FieldNames;
|
|
if s = '' then s := FIndexFieldNames;
|
|
InitIndexFieldNamesList(s);
|
|
DoSort;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetStoreStringAsReference(const Value: Boolean);
|
|
begin
|
|
CheckInactive;
|
|
FStoreStringsAsReference := Value;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.SetWideString(NativeBuf: Pointer; Field: TField;
|
|
const Value: Widestring);
|
|
var
|
|
len: integer;
|
|
begin
|
|
if FStoreStringsAsReference then
|
|
PWideString(NativeBuf)^:=Value
|
|
else begin
|
|
len := Length(Value);
|
|
if Len > Field.Size then len:= Field.Size;
|
|
move(Pointer(Value)^,NativeBuf^,len*Sizeof(WideChar));
|
|
PWideChar(NativeBuf)[len]:=#0;
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DoAfterOpen;
|
|
begin
|
|
if not IsEmpty then SortOnFields();
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.MasterChanged(Sender: TObject);
|
|
begin
|
|
ProcessFilter;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.MasterDisabled(Sender: TObject);
|
|
begin
|
|
DataEvent(dePropertyChange, 0);
|
|
DoFilterRecords;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.GetDetailLinkFields(MasterFields,
|
|
DetailFields: TList);
|
|
begin
|
|
{ TODO : GetDetailLinkFields }
|
|
inherited;
|
|
|
|
end;
|
|
|
|
type
|
|
TDAMasterStruct = packed record
|
|
value: variant;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.DoFilterRecords;
|
|
var
|
|
i, j: integer;
|
|
MasterArray: array of TDAMasterStruct;
|
|
buf: pchar;
|
|
flag: boolean;
|
|
fld_cnt: integer;
|
|
pos: TBookmarkData;
|
|
str: string;
|
|
begin
|
|
if (RecordCount > 0) and (FRecordPos<>-1) then
|
|
pos := FDataList[FRecordPos]
|
|
else
|
|
pos := nil;
|
|
FDataList.Clear;
|
|
if (MasterSource = nil) or (MasterSource.DataSet = nil) or
|
|
(not MasterSource.DataSet.Active) or (MasterDataLink.Fields.Count = 0) or
|
|
(FIndexFieldNameList.Count = 0) then begin
|
|
// not filtered!
|
|
FDataList.Assign(FRecordsList);
|
|
end
|
|
else begin
|
|
fld_cnt := MasterDataLink.Fields.Count;
|
|
if FIndexFieldNameList.Count < fld_cnt then fld_cnt := FIndexFieldNameList.Count;
|
|
SetLength(MasterArray, fld_cnt);
|
|
for i := 0 to fld_cnt - 1 do
|
|
MasterArray[i].value := TField(MasterDataLink.Fields[i]).Value;
|
|
for i := 0 to FRecordsList.Count - 1 do begin
|
|
flag := true;
|
|
for j := 0 to fld_cnt - 1 do begin
|
|
buf := IntFindFieldData(FRecordsList[i], TField(FIndexFieldNameList[j]));
|
|
if (buf <> nil) then
|
|
case TField(FIndexFieldNameList[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, ftDateTime: flag := PDouble(Buf)^ = MasterArray[j].value;
|
|
ftBcd{$IFDEF DELPHI6UP}, 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 FDataList.Add(FRecordsList[i]);
|
|
end;
|
|
end;
|
|
//==============================
|
|
// apply filters
|
|
if IsActiveFilter then
|
|
for i := FDataList.Count-1 downto 0 do
|
|
if not FilterRecord(FDataList[i], False) then FDataList.Delete(i);
|
|
//==============================
|
|
if Active then begin
|
|
FRecordPos := FDataList.IndexOf(pos);
|
|
if (FRecordPos = -1) and (RecordCount > 0) then FRecordPos := 0;
|
|
Resync([]);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF FPC}
|
|
const
|
|
SFieldTypeMismatch = 'Type mismatch for field ''%s'', expecting: %s actual: %s';
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DELPHI10UP}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF DELPHI10UP}
|
|
procedure TDAMemoryDataset.InitIndexFieldNamesList(AFieldNames: string);
|
|
var
|
|
pos1: integer;
|
|
fld: TField;
|
|
begin
|
|
FIndexFieldNameList.Clear;
|
|
Pos1 := 1;
|
|
while Pos1 <= Length(AFieldNames) do begin
|
|
Fld := FieldByName(ExtractFieldName(AFieldNames, Pos1));
|
|
if (Fld.FieldKind = fkData) and
|
|
(Fld.DataType in ft_Supported - ft_BlobTypes) then
|
|
FIndexFieldNameList.Add(Fld)
|
|
else
|
|
DatabaseErrorFmt(SFieldTypeMismatch, [Fld.DisplayName]);
|
|
end;
|
|
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);
|
|
begin
|
|
FRecordsList.Add(Buffer);
|
|
// FDataList.Add(Buffer);
|
|
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 FIndexFieldNameList.Count > i then
|
|
TField(FIndexFieldNameList[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
|
|
lBookmark: TBookmarkStr;
|
|
lOffsets: array of cardinal;
|
|
lDatatypes: array of TFieldType;
|
|
lValues: array of variant;
|
|
lFields : TList;
|
|
i,j: integer;
|
|
k: boolean;
|
|
lCaseInsensitive, lPartialKey:Boolean;
|
|
Buffer: Pchar;
|
|
begin
|
|
Result := False;
|
|
lBookmark:='';
|
|
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);
|
|
for i:=0 to lFields.Count-1 do begin
|
|
lOffsets[i] := GetFieldOffset(TField(lFields[i]).Index);
|
|
lDatatypes[i] := TField(lFields[i]).DataType;
|
|
if lFields.Count = 1 then
|
|
lValues[i]:= KeyValues
|
|
else
|
|
lValues[i]:= KeyValues[i];
|
|
end;
|
|
For i:= 0 to FDataList.Count - 1 do begin
|
|
k:=False;
|
|
For j:=0 to lFields.Count-1 do begin
|
|
k:= CompareValues2(Pchar(FDataList[i])+lOffsets[j], lValues[j],lDatatypes[j], lCaseInsensitive, lPartialKey);
|
|
if not k then Break;
|
|
end;
|
|
if k then begin
|
|
RecordToBuffer(i, Buffer);
|
|
SetLength(lBookmark, BookmarkSize);
|
|
GetBookmarkData(Buffer, Pointer(lBookmark));
|
|
Result:=True;
|
|
Break;
|
|
end;
|
|
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, aPartialKey: 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 aPartialKey then begin
|
|
if aSortCaseInsensitive then
|
|
Result := pos(AnsiUpperCase(VarToStr(aValue)), AnsiUpperCase(str1)) = 1
|
|
else
|
|
Result := pos(VarToStr(aValue), str1) = 1
|
|
end else begin
|
|
if aSortCaseInsensitive then
|
|
Result := AnsiCompareText(str1, VarToStr(aValue))=0
|
|
else
|
|
Result := AnsiCompareStr(str1, VarToStr(aValue))=0;
|
|
end;
|
|
end;
|
|
ftWideString: begin
|
|
if FStoreStringsAsReference then
|
|
wstr1:=PWideString(Buf1)^
|
|
else
|
|
wstr1:=PWideChar(Buf1);
|
|
if aPartialKey then begin
|
|
if aSortCaseInsensitive then
|
|
Result := pos(WideUpperCase(VarToWideStr(aValue)), WideUpperCase(wstr1)) = 1
|
|
else
|
|
Result := pos(VarToWideStr(aValue), wstr1) = 1
|
|
end else begin
|
|
Result:= ROWideCompare(wstr1,VarToWideStr(aValue),aSortCaseInsensitive {$IFDEF MSWINDOWS},FSortLocale {$ENDIF MSWIN})=0;
|
|
end;
|
|
end;
|
|
ftGuid: begin
|
|
SetString(str, PAnsiChar(buf1), guidsize);
|
|
if aPartialKey then begin
|
|
Result := pos(AnsiUpperCase(VarToStr(aValue)), AnsiUpperCase(str)) = 1
|
|
end else begin
|
|
Result := AnsiCompareText(str, VarToStr(aValue))=0
|
|
end;
|
|
end;
|
|
ftSmallint: Result := PSmallInt(buf1)^ = aValue;
|
|
ftInteger, ftDate, ftTime, ftAutoInc: Result := PInteger(buf1)^ = aValue;
|
|
ftWord: Result := PWord(buf1)^ = aValue;
|
|
ftBoolean: Result:= PWordBool(buf1)^ = aValue;
|
|
ftFloat, ftCurrency: Result := PDouble(Buf1)^ = aValue;
|
|
ftDateTime: Result := PDouble(Buf1)^ = TimeStampToMSecs(DateTimeToTimeStamp(aValue));
|
|
ftBcd{$IFDEF DELPHI6UP}, ftFMTBCD{$ENDIF}: Result := BcdCompare(PBcd(buf1)^, VariantToBCD(aValue))=0;
|
|
ftLargeint: Result := PInt64(Buf1)^ = aValue;
|
|
{$IFNDEF FPC}
|
|
ftTimeStamp: Result := SQLTimeStampToDateTime(PSQLTimeStamp(Buf1)^) = SQLTimeStampToDateTime(VarToSQLTimeStamp(aValue));
|
|
{$ENDIF FPC}
|
|
else
|
|
end;
|
|
end;
|
|
|
|
procedure TDAMemoryDataset.IntFreeRecordBuffer(var 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);
|
|
Buffer := nil;
|
|
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;
|
|
|
|
{ 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): 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
|
|
Result := GetBLOBRecordFromBuffer(FDataSet.FRecordsList[Pos], Field);
|
|
end;
|
|
|
|
function TDABlobStream.GetBlobSize: Longint;
|
|
var
|
|
rec: PBlobRecord;
|
|
begin
|
|
Result := 0;
|
|
if FOpened then begin
|
|
if FCached then
|
|
Rec := GetBLOBRecordFromBuffer(FBuffer, FField)
|
|
else
|
|
Rec := GetBLOBRecordFromRecord(FField);
|
|
if rec <> nil then Result := rec.size;
|
|
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;
|
|
begin
|
|
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);
|
|
if rec <> nil then begin
|
|
Move(PChar(@Rec.Data)[FPosition], Buffer, Result);
|
|
Inc(FPosition, Result);
|
|
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;
|
|
|
|
{$IFDEF MEMDATASET_DEBUG}
|
|
initialization
|
|
memdataset_buff_cnt := 0;
|
|
memdataset_buff_cnt_native := 0;
|
|
memdataset_buff_cnt_notnative:= 0;
|
|
{$ENDIF}
|
|
end.
|
|
|