david
fff1b2a4dc
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
3922 lines
114 KiB
ObjectPascal
3922 lines
114 KiB
ObjectPascal
|
|
//////////////////////////////////////////////////
|
|
// DB Access Components
|
|
// Copyright © 1998-2007 Core Lab. All right reserved.
|
|
// Memory Data Set
|
|
// Created: 01.02.98
|
|
//////////////////////////////////////////////////
|
|
|
|
{$IFNDEF CLR}
|
|
|
|
{$I Dac.inc}
|
|
|
|
unit MemDS;
|
|
{$ENDIF}
|
|
interface
|
|
uses
|
|
{$IFDEF CLR}
|
|
DB, SysUtils, Classes, MemData, MemUtils{$IFDEF BDE_SHARED}, DBTables{$ENDIF}, Variants,
|
|
System.Runtime.InteropServices, System.Text, System.IO, System.XML;
|
|
{$ELSE}
|
|
DB, SysUtils, Classes, MemData, MemUtils{$IFDEF BDE_SHARED}, DBTables{$ENDIF}
|
|
{$IFDEF VER6P}, Variants{$ENDIF}, CRXml, CLRClasses;
|
|
{$ENDIF}
|
|
|
|
const
|
|
uaDefault = 10; // TUpdateAction
|
|
|
|
type
|
|
|
|
{ TMemDataSet }
|
|
|
|
{$IFDEF VER4}
|
|
|
|
{$IFNDEF BDE_SHARED}
|
|
TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied); // uaDefault
|
|
{$ENDIF}
|
|
|
|
{$ENDIF}
|
|
|
|
TUpdateRecordTypes = set of (rtModified, rtInserted, rtDeleted, rtUnmodified);
|
|
TUpdateErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
|
|
UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction) of object;
|
|
TUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
|
|
var UpdateAction: TUpdateAction) of object;
|
|
|
|
{$IFDEF CLR}
|
|
PRecInfo = packed record
|
|
private
|
|
Ptr: IntPtr;
|
|
|
|
function GetRecordNumber: longint;
|
|
procedure SetRecordNumber(const Value: longint);
|
|
function GetUpdateStatus: TUpdateStatus;
|
|
procedure SetUpdateStatus(const Value: TUpdateStatus);
|
|
function GetBookmarkFlag: TBookmarkFlag;
|
|
procedure SetBookmarkFlag(const Value: TBookmarkFlag);
|
|
function GetRefComplexFields: boolean;
|
|
procedure SetRefComplexFields(const Value: boolean);
|
|
|
|
public
|
|
property RecordNumber: longint read GetRecordNumber write SetRecordNumber;
|
|
property UpdateStatus: TUpdateStatus read GetUpdateStatus write SetUpdateStatus;
|
|
property BookmarkFlag: TBookmarkFlag read GetBookmarkFlag write SetBookmarkFlag;
|
|
property RefComplexFields: boolean read GetRefComplexFields write SetRefComplexFields;
|
|
|
|
class operator Implicit(AValue: IntPtr): PRecInfo;
|
|
class operator Implicit(AValue: integer): PRecInfo;
|
|
end;
|
|
{$ELSE}
|
|
TRecordBuffer = PChar;
|
|
TValueBuffer = pointer;
|
|
PRecInfo = ^TRecInfo;
|
|
{$ENDIF}
|
|
TRecInfo = packed record
|
|
RecordNumber: longint;
|
|
UpdateStatus: TUpdateStatus;
|
|
BookmarkFlag: TBookmarkFlag;
|
|
RefComplexFields: boolean;
|
|
end;
|
|
|
|
// TBlobData = string;
|
|
|
|
TCalcFieldDescMapping = record
|
|
FieldDesc: TFieldDesc;
|
|
Field: TField;
|
|
end;
|
|
|
|
TMemDataSet = class(TDataSet)
|
|
private
|
|
FOldRecBuf: TRecordBuffer;
|
|
FFilterBuffer: TRecordBuffer;
|
|
FCachedUpdates: boolean;
|
|
FLocalUpdate: boolean;
|
|
//FInDeferredPost: boolean; to protected
|
|
FInInserting: boolean;
|
|
FInEditing: boolean;
|
|
FIndexFieldNames: string;
|
|
FCalcFieldsMapping: array of TCalcFieldDescMapping;
|
|
|
|
FOnUpdateError: TUpdateErrorEvent;
|
|
FOnUpdateRecord: TUpdateRecordEvent;
|
|
|
|
//Renamed LocateRecord (CBuilder5 bug - overloaded methods in different sections):
|
|
function InternalLocateRecord(KeyFields: TDAList; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean; overload;
|
|
|
|
{function GetBlobData(Field:TField; Buffer: PChar):TBlobData;
|
|
procedure SetBlobData(Field:TField; Buffer: PChar; Value:TBlobData);
|
|
procedure ClearBlobCache(Buffer: PChar);}
|
|
|
|
procedure SetCachedUpdates(Value: boolean);
|
|
function GetUpdatesPending: boolean;
|
|
function GetPrepared: boolean;
|
|
procedure SetPrepared(Value: boolean);
|
|
function GetUpdateRecordSet: TUpdateRecordTypes;
|
|
procedure SetUpdateRecordSet(Value: TUpdateRecordTypes);
|
|
procedure SetIndexFieldNames(Value: string);
|
|
|
|
protected
|
|
Data: TData; // FIRecordSet
|
|
|
|
FBookmarkOfs: longint;
|
|
FRecInfoOfs: longint;
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
FWideStringOfs: longint;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
FRecBufSize: longint;
|
|
FInCacheProcessing: boolean;
|
|
FInDeferredPost: boolean; // private
|
|
NewCacheRecBuf: TRecordBuffer;
|
|
OldCacheRecBuf: TRecordBuffer;
|
|
OldDeferredPostBuf: TRecordBuffer;
|
|
FParentDataSet: TMemDataSet;
|
|
FLastParentPos: integer;
|
|
FLocalConstraints: boolean;
|
|
FNumberRange: boolean;
|
|
FNeedAddRef: boolean;
|
|
FCacheCalcFields: boolean;
|
|
FCreateCalcFieldDescs: boolean;
|
|
|
|
procedure CreateIRecordSet; virtual;
|
|
procedure FreeIRecordSet;
|
|
procedure SetIRecordSet(Value: TData{TRecordSet}); virtual;
|
|
|
|
{ Open/Close DataSet }
|
|
procedure OpenCursor(InfoQuery: boolean); override;
|
|
procedure CloseCursor; override;
|
|
|
|
procedure InternalOpen; override;
|
|
procedure InternalClose; override;
|
|
function IsCursorOpen: boolean; override;
|
|
procedure DataReopen; virtual;
|
|
procedure InternalRefresh; override;
|
|
procedure CheckFieldCompatibility(Field: TField; FieldDef: TFieldDef); override;
|
|
procedure DoAfterOpen; override;
|
|
|
|
{ Field Management }
|
|
procedure InternalInitFieldDefs; override;
|
|
procedure CreateFieldDefs; virtual;
|
|
procedure ClearCalcFields(Buffer: TRecordBuffer); override;
|
|
|
|
function GetObjectFieldDefName(Parent: TFieldDef; Index: integer; ObjType: TObjectType):string; virtual;
|
|
function GetFielDefSize(FieldType: TFieldType; FieldDesc: TFieldDesc): integer; virtual;
|
|
procedure GetObjectTypeNames(Fields: TFields);
|
|
function GetFieldType(DataType: word): TFieldType; overload; virtual;
|
|
function GetFieldType(FieldDesc: TFieldDesc): TFieldType; overload; virtual;
|
|
procedure SetFieldData(Field: TField; Buffer: TValueBuffer); override;
|
|
procedure SetFieldData(Field: TField; Buffer: TValueBuffer; NativeFormat: Boolean); override;
|
|
procedure DataConvert(Field: TField; Source, Dest: TValueBuffer; ToNative: Boolean); override; //TODO
|
|
function GetSparseArrays: boolean;
|
|
procedure SetSparseArrays(Value: boolean);
|
|
|
|
procedure SetNumberRange(FieldDef: TFieldDef); virtual;
|
|
|
|
{ Buffer/Record Management }
|
|
function AllocRecordBuffer: TRecordBuffer; override;
|
|
procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override;
|
|
procedure CopyRecordBuffer(SrcBuffer: IntPtr; DstBuffer: IntPtr);
|
|
|
|
procedure InitRecord(Buffer: TRecordBuffer); override;
|
|
procedure InternalInitRecord(Buffer: TRecordBuffer); override;
|
|
|
|
function GetOldRecord: TRecordBuffer;
|
|
function GetActiveRecBuf(var RecBuf: TRecordBuffer): boolean;
|
|
function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: boolean): TGetResult; override;
|
|
|
|
procedure BlockReadNext; override;
|
|
procedure SetBlockReadSize(Value: integer); override;
|
|
procedure FreeRefBuffers;
|
|
procedure FreeRefComplexFields(Buffer: TRecordBuffer; WithBlob: boolean = True);
|
|
|
|
{ Bookmarks }
|
|
procedure GetBookmarkData(Buffer: TRecordBuffer; {$IFDEF CLR}var{$ENDIF} Bookmark: TBookmark); override;
|
|
procedure SetBookmarkData(Buffer: TRecordBuffer; {$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark); override;
|
|
function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override;
|
|
procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
|
|
//function GetBookmarkStr: TBookmarkStr; override;
|
|
|
|
{ Navigation }
|
|
procedure InternalFirst; override;
|
|
procedure InternalLast; override;
|
|
procedure InternalGotoBookmark({$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark); override;
|
|
procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
|
|
|
|
{ Editing }
|
|
procedure InternalAddRecord(Buffer: IntPtr; Append: boolean); override;
|
|
procedure InternalInsert; override;
|
|
procedure InternalDelete; override;
|
|
procedure InternalEdit; override;
|
|
|
|
procedure InternalPost; override;
|
|
procedure InternalCancel; override;
|
|
|
|
procedure InternalDeferredPost; virtual;
|
|
|
|
function PerformAppend: boolean; virtual;
|
|
function PerformDelete: boolean; virtual;
|
|
function PerformUpdate: boolean; virtual;
|
|
|
|
procedure DoPerformAppend;
|
|
procedure DoPerformDelete;
|
|
procedure DoPerformUpdate;
|
|
procedure DoGetCachedFields;
|
|
procedure DoGetCachedBuffer(Buffer: IntPtr; Source: IntPtr = nil);
|
|
|
|
procedure SetDefaultExpressionValue(Field: TField); virtual;
|
|
procedure DoOnNewRecord; override;
|
|
|
|
{ Filter/Find/Locate }
|
|
procedure ActivateFilters;
|
|
procedure DeactivateFilters;
|
|
function RecordFilter(RecBuf: IntPtr): boolean;
|
|
procedure SetFilterData(const Text: string; Options:TFilterOptions);
|
|
|
|
procedure SetFiltered(Value: boolean); override;
|
|
procedure SetFilterOptions(Value: TFilterOptions); override;
|
|
procedure SetFilterText(const Value: string); override;
|
|
procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
|
|
|
|
procedure CopyFieldValue(const Value: variant; out ValuePtr: IntPtr; out ValueType: integer; FieldDesc: TFieldDesc); virtual;
|
|
function LocateRecord(const KeyFields: string; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean; overload;
|
|
function LocateRecord(const KeyFields: array of TField; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean; overload;
|
|
function FindRecord(Restart, GoForward: boolean): boolean; override;
|
|
|
|
{ CachedUpdates }
|
|
function BatchUpdate: boolean; virtual;
|
|
function CanFlushBatch: boolean; virtual;
|
|
procedure FlushBatch; virtual;
|
|
|
|
procedure CheckCachedUpdateMode;
|
|
|
|
procedure DoApplyRecord(UpdateKind: TUpdateRecKind; var Action: TUpdateRecAction; LastItem: boolean);
|
|
|
|
{ Blobs }
|
|
//Renamed GetBlob (CBuilder5 bug - overloaded methods in different sections):
|
|
function InternalGetBlob(FieldDesc: TFieldDesc): TBlob;
|
|
function InternalSetBlob(FieldDesc: TFieldDesc; Blob: TBlob): boolean;
|
|
function SetBlob(Field: TField; Blob: TBlob): boolean;
|
|
procedure CloseBlob(Field: TField); override;
|
|
|
|
{ Misc }
|
|
function GetRecordCount: integer; override;
|
|
function GetRecordSize: word; override;
|
|
|
|
function GetRecNo: integer; override;
|
|
procedure SetRecNo(Value: integer); override;
|
|
|
|
procedure InternalHandleException; override;
|
|
|
|
procedure AssignTo(Dest: TPersistent); override;
|
|
|
|
{$IFDEF CLR}
|
|
procedure DataEvent(Event: TDataEvent; Info: TObject); override;
|
|
{$ELSE}
|
|
procedure DataEvent(Event: TDataEvent; Info: longint); override;
|
|
{$ENDIF}
|
|
|
|
function GetStateFieldValue(State: TDataSetState; Field: TField): Variant; override;
|
|
|
|
{ XML }
|
|
procedure WriteFieldXMLDataType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string;
|
|
XMLWriter: XMLTextWriter); virtual;
|
|
procedure WriteFieldXMLAttributeType(Field: TField; FieldDesc: TFieldDesc; const FieldAlias: string;
|
|
XMLWriter: XMLTextWriter); virtual;
|
|
function GetFieldXMLValue(Field: TField; FieldDesc: TFieldDesc): string; virtual;
|
|
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
procedure Prepare; virtual;
|
|
procedure UnPrepare; virtual;
|
|
procedure CheckPrepared;
|
|
|
|
{ Fields }
|
|
function GetFieldDescNo(Field: TField): integer;
|
|
function GetFieldDesc(const Field: TField): TFieldDesc; overload; virtual;
|
|
function GetFieldData(Field: TField; Buffer: TValueBuffer): boolean; overload; override;
|
|
//function Translate(const Src: string; var Dest: string; ToOem: boolean): integer; override;
|
|
|
|
function GetFieldData(FieldNo: integer; Buffer: TValueBuffer): boolean; overload; override;
|
|
function GetFieldData(Field: TField; Buffer: TValueBuffer; NativeFormat: Boolean): Boolean; override;
|
|
|
|
function GetBlob(const FieldName: string): TBlob; overload;
|
|
function GetBlob(Field: TField): TBlob; overload;
|
|
|
|
{ Edit }
|
|
procedure Cancel; override;
|
|
procedure DeferredPost;
|
|
|
|
{ Bookmarks }
|
|
{$IFDEF CLR} // TDataSet bug
|
|
function GetBookmark: TBookmark; override;
|
|
procedure FreeBookmark(var Bookmark: TBookmark); override;
|
|
{$ENDIF}
|
|
function BookmarkValid({$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark): boolean; override;
|
|
function CompareBookmarks({$IFDEF CLR}const{$ENDIF} Bookmark1, Bookmark2: TBookmark): integer; override;
|
|
|
|
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
|
|
|
|
function Locate(const KeyFields: string; const KeyValues: variant;
|
|
Options: TLocateOptions): boolean; overload; override;
|
|
function Locate(const KeyFields: array of TField; const KeyValues: variant;
|
|
Options: TLocateOptions): boolean; reintroduce; overload;
|
|
function LocateEx(const KeyFields: string; const KeyValues: variant;
|
|
Options: TLocateExOptions): boolean; overload;
|
|
function LocateEx(const KeyFields: array of TField; const KeyValues: variant;
|
|
Options: TLocateExOptions): boolean; overload;
|
|
function Lookup(const KeyFields: string; const KeyValues: variant;
|
|
const ResultFields: string): variant; override;
|
|
|
|
{ CachedUpdates }
|
|
function UpdateStatus: TUpdateStatus; override;
|
|
function UpdateResult: TUpdateAction;
|
|
procedure ApplyUpdates; virtual;
|
|
procedure CommitUpdates;
|
|
procedure CancelUpdates;
|
|
procedure RestoreUpdates;
|
|
procedure RevertRecord;
|
|
|
|
{ XML }
|
|
procedure SaveToXML(Destination: TStream); overload;
|
|
procedure SaveToXML(const FileName: string); overload;
|
|
|
|
function IsSequenced: boolean; override;
|
|
|
|
property Prepared: boolean read GetPrepared write SetPrepared;
|
|
property CachedUpdates: boolean read FCachedUpdates write SetCachedUpdates default False;
|
|
property UpdatesPending: boolean read GetUpdatesPending;
|
|
property LocalUpdate: boolean read FLocalUpdate write FLocalUpdate default False;
|
|
property UpdateRecordTypes: TUpdateRecordTypes read GetUpdateRecordSet write SetUpdateRecordSet;
|
|
property SparseArrays: boolean read GetSparseArrays write SetSparseArrays;
|
|
|
|
// obsolete
|
|
property LocalConstraints: boolean read FLocalConstraints write FLocalConstraints default True;
|
|
|
|
property OnUpdateError: TUpdateErrorEvent read FOnUpdateError write FOnUpdateError;
|
|
property OnUpdateRecord: TUpdateRecordEvent read FOnUpdateRecord write FOnUpdateRecord;
|
|
property IndexFieldNames: string read FIndexFieldNames write SetIndexFieldNames;
|
|
end;
|
|
|
|
{ TBlobStream }
|
|
|
|
TBlobStream = class(TStream)
|
|
protected
|
|
FField: TBlobField;
|
|
FDataSet: TMemDataSet;
|
|
FBuffer: TRecordBuffer;
|
|
FMode: TBlobStreamMode;
|
|
FFieldNo: integer;
|
|
FOpened: boolean;
|
|
FModified: boolean;
|
|
FPosition: longint;
|
|
function GetBlobSize: Longint;
|
|
|
|
protected
|
|
{$IFDEF CLR}
|
|
procedure SetSize(NewSize: Int64); override;
|
|
{$ELSE}
|
|
procedure SetSize(NewSize: Longint); override;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
destructor Destroy; override;
|
|
{$IFDEF CLR}
|
|
function Read(var Buffer: TBytes; Offset, Count: Longint): Longint; override;
|
|
function Write(const Buffer: TBytes; Offset, Count: Longint): Longint; override;
|
|
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
|
|
{$ELSE}
|
|
function Read(var Buffer; Count: longint): longint; override;
|
|
function Write(const Buffer; Count: Longint): Longint; override;
|
|
function Seek(Offset: Longint; Origin: Word): Longint; override;
|
|
{$ENDIF}
|
|
procedure Truncate;
|
|
end;
|
|
|
|
TMemDSUtils = class
|
|
public
|
|
class function SetBlob(Obj: TMemDataSet; Field: TField; Blob: TBlob): boolean;
|
|
class function GetBlob(Obj: TMemDataSet; FieldDesc: TFieldDesc): TBlob;
|
|
end;
|
|
|
|
function GetFieldType(DataType: word): TFieldType;
|
|
function GetDataType(FieldType: TFieldType): word;
|
|
|
|
function ChangeDecimalSeparator(const Value: string; OldSeparator, NewSeparator: string): string;
|
|
|
|
function XMLEncode(const AStr: String): String;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF VER6P}
|
|
DateUtils,FmtBcd,
|
|
{$ENDIF}
|
|
DBConsts, DAConsts, Math{$IFDEF MSWINDOWS}, Windows{$ENDIF};
|
|
|
|
const
|
|
{$IFDEF VER4}
|
|
DataTypeMap: array [TFieldType] of word = (
|
|
// ftUnknown, ftString, ftSmallint, ftInteger, ftWord
|
|
dtUnknown, dtString, dtInt16, dtInteger, dtUInt16,
|
|
// ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
|
|
dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime,
|
|
// ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
|
|
dtBytes, dtVarBytes, dtInteger, dtBlob, dtMemo, 0, 0,
|
|
// ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
|
|
0, 0, 0, 0, dtString, dtWideString,
|
|
// ftLargeint, ftADT, ftArray, ftReference, ftDataSet
|
|
dtInt64, dtObject, dtArray, dtReference, dtTable);
|
|
{$ENDIF}
|
|
{$IFDEF VER5}
|
|
DataTypeMap: array [TFieldType] of word = (
|
|
// ftUnknown, ftString, ftSmallint, ftInteger, ftWord
|
|
dtUnknown, dtString, dtInt16, dtInteger, dtUInt16,
|
|
// ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
|
|
dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime,
|
|
// ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
|
|
dtBytes, dtVarBytes, dtInteger, dtBlob, dtMemo, 0, 0,
|
|
// ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
|
|
0, 0, 0, 0, dtString, dtWideString,
|
|
// ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,
|
|
dtInt64, dtObject, dtArray, dtReference, dtTable, 0, 0,
|
|
// ftVariant, ftInterface, ftIDispatch, ftGuid
|
|
dtVariant, 0, 0, dtGuid);
|
|
{$ENDIF}
|
|
{$IFDEF VER6P}
|
|
{$IFNDEF VER10P}
|
|
DataTypeMap: array [TFieldType] of word = (
|
|
// ftUnknown, ftString, ftSmallint, ftInteger, ftWord
|
|
dtUnknown, dtString, dtInt16, dtInteger, dtUInt16,
|
|
// ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
|
|
dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime,
|
|
// ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
|
|
dtBytes, dtVarBytes, dtInteger, dtBlob, dtMemo, 0, 0,
|
|
// ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
|
|
0, 0, 0, 0, dtString, dtWideString,
|
|
// ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,
|
|
dtInt64, dtObject, dtArray, dtReference, dtTable, 0, 0,
|
|
// ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd
|
|
dtVariant, 0, 0, dtGuid, 0, dtFmtBCD);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VER10P}
|
|
DataTypeMap: array [TFieldType] of word = (
|
|
// ftUnknown, ftString, ftSmallint, ftInteger, ftWord
|
|
dtUnknown, dtString, dtInt16, dtInteger, dtUInt16,
|
|
// ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
|
|
dtBoolean, dtFloat, dtCurrency, dtBCD, dtDate, dtTime, dtDateTime,
|
|
// ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo,
|
|
dtBytes, dtVarBytes, dtInteger, dtBlob, dtMemo, 0, 0,
|
|
// ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString,
|
|
0, 0, 0, 0, dtString, dtWideString,
|
|
// ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob,
|
|
dtInt64, dtObject, dtArray, dtReference, dtTable, 0, 0,
|
|
// ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, ftFixedWideChar
|
|
dtVariant, 0, 0, dtGuid, 0, dtFmtBCD, dtWideString,
|
|
// ftWideMemo, ftOraTimeStamp, ftOraInterval
|
|
dtWideMemo, 0, 0);
|
|
{$ENDIF}
|
|
|
|
function GetFieldType(DataType: word): TFieldType;
|
|
begin
|
|
case DataType of
|
|
dtUnknown:
|
|
Result := ftUnknown;
|
|
dtString:
|
|
Result := ftString;
|
|
dtWideString:
|
|
Result := ftWideString;
|
|
dtInt8:
|
|
Result := ftSmallint;
|
|
dtInt16:
|
|
Result := ftSmallint;
|
|
dtWord:
|
|
Result := ftWord;
|
|
dtInteger:
|
|
Result := ftInteger;
|
|
dtUInt32:
|
|
Result := ftLargeInt;
|
|
dtLargeint:
|
|
Result := ftLargeInt;
|
|
dtFloat:
|
|
Result := ftFloat;
|
|
dtDate:
|
|
Result := ftDate;
|
|
dtTime:
|
|
Result := ftTime;
|
|
dtDateTime:
|
|
Result := ftDateTime;
|
|
dtMemo:
|
|
Result := ftMemo;
|
|
dtWideMemo:
|
|
Result := {$IFDEF VER10P}ftWideMemo;{$ELSE}ftMemo;{$ENDIF}
|
|
dtBlob:
|
|
Result := ftBlob;
|
|
dtObject:
|
|
Result := ftADT;
|
|
dtReference:
|
|
Result := ftReference;
|
|
dtArray:
|
|
Result := ftArray;
|
|
dtTable:
|
|
Result := ftDataSet;
|
|
dtBoolean:
|
|
Result := ftBoolean;
|
|
{$IFDEF VER5P}
|
|
dtVariant:
|
|
Result := ftVariant;
|
|
{$ENDIF}
|
|
dtExtString:
|
|
Result := ftString;
|
|
dtExtWideString:
|
|
Result := ftWideString;
|
|
dtBytes:
|
|
Result := ftBytes;
|
|
dtVarBytes:
|
|
Result := ftVarBytes;
|
|
dtExtVarBytes:
|
|
Result := ftVarBytes;
|
|
dtBCD:
|
|
Result := ftBCD;
|
|
{$IFDEF VER6P}
|
|
dtFmtBCD:
|
|
Result := ftFMTBcd;
|
|
{$ENDIF}
|
|
dtGuid:
|
|
Result := ftGuid;
|
|
dtCurrency:
|
|
Result := ftCurrency;
|
|
else
|
|
Assert(False, SUnknownDataType);
|
|
Result := ftUnknown;
|
|
end;
|
|
end;
|
|
|
|
function GetDataType(FieldType: TFieldType): word;
|
|
begin
|
|
Result := DataTypeMap[FieldType];
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
{ PRecInfo }
|
|
|
|
function PRecInfo.GetRecordNumber: longint;
|
|
begin
|
|
Result := Marshal.ReadInt32(Ptr);
|
|
end;
|
|
|
|
procedure PRecInfo.SetRecordNumber(const Value: longint);
|
|
begin
|
|
Marshal.WriteInt32(Ptr, Value);
|
|
end;
|
|
|
|
function PRecInfo.GetUpdateStatus: TUpdateStatus;
|
|
begin
|
|
Result := TUpdateStatus(Marshal.ReadByte(Ptr, sizeof(longint)));
|
|
end;
|
|
|
|
procedure PRecInfo.SetUpdateStatus(const Value: TUpdateStatus);
|
|
begin
|
|
Marshal.WriteByte(Ptr, sizeof(longint), byte(Value));
|
|
end;
|
|
|
|
function PRecInfo.GetBookmarkFlag: TBookmarkFlag;
|
|
begin
|
|
Result := TBookmarkFlag(Marshal.ReadByte(Ptr, sizeof(integer) + sizeof(TUpdateStatus)));
|
|
end;
|
|
|
|
procedure PRecInfo.SetBookmarkFlag(const Value: TBookmarkFlag);
|
|
begin
|
|
Marshal.WriteByte(Ptr, sizeof(integer) + sizeof(TUpdateStatus), byte(Value));
|
|
end;
|
|
|
|
function PRecInfo.GetRefComplexFields: boolean;
|
|
begin
|
|
Result := boolean(Marshal.ReadByte(Ptr, sizeof(integer) + sizeof(TUpdateStatus)
|
|
+ sizeof(TBookmarkFlag)));
|
|
end;
|
|
|
|
procedure PRecInfo.SetRefComplexFields(const Value: boolean);
|
|
begin
|
|
Marshal.WriteByte(Ptr, sizeof(integer) + sizeof(TUpdateStatus)
|
|
+ sizeof(TBookmarkFlag), byte(Value));
|
|
end;
|
|
|
|
class operator PRecInfo.Implicit(AValue: IntPtr): PRecInfo;
|
|
begin
|
|
Result.Ptr := AValue;
|
|
end;
|
|
|
|
class operator PRecInfo.Implicit(AValue: integer): PRecInfo;
|
|
begin
|
|
Result.Ptr := IntPtr(AValue);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ TMemDataSet }
|
|
|
|
constructor TMemDataSet.Create(aOwner:TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
|
|
FLocalConstraints := True;
|
|
FCreateCalcFieldDescs := True;
|
|
|
|
CreateIRecordSet;
|
|
end;
|
|
|
|
destructor TMemDataSet.Destroy;
|
|
begin
|
|
inherited;
|
|
|
|
UnPrepare;
|
|
|
|
FreeIRecordSet;
|
|
end;
|
|
|
|
procedure TMemDataSet.CreateIRecordSet;
|
|
begin
|
|
SetIRecordSet(TMemData.Create);
|
|
end;
|
|
|
|
procedure TMemDataSet.FreeIRecordSet;
|
|
begin
|
|
Data.Free;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetIRecordSet(Value: TData);
|
|
begin
|
|
Data := Value;
|
|
|
|
if Data <> nil then begin
|
|
Data.CachedUpdates := FCachedUpdates;
|
|
Data.OnAppend := DoPerformAppend;
|
|
Data.OnDelete := DoPerformDelete;
|
|
Data.OnUpdate := DoPerformUpdate;
|
|
Data.OnApplyRecord := DoApplyRecord;
|
|
if FCreateCalcFieldDescs then begin
|
|
TMemData(Data).OnGetCachedFields := DoGetCachedFields;
|
|
TMemData(Data).OnGetCachedBuffer := DoGetCachedBuffer;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ Open/Close DataSet }
|
|
|
|
procedure TMemDataSet.Prepare;
|
|
begin
|
|
if not Prepared then begin
|
|
Data.Prepare;
|
|
CreateFieldDefs;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.UnPrepare;
|
|
begin
|
|
if Active then
|
|
Close;
|
|
|
|
Data.UnPrepare;
|
|
|
|
if not (csDestroying in ComponentState) then // This line may be called after destroing FieldDefs. For details see TMemDataSet.Destroy
|
|
FieldDefs.Updated := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.CheckPrepared;
|
|
begin
|
|
if not Prepared then
|
|
DatabaseError(SDataSetIsNotPrepared);
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalOpen;
|
|
var
|
|
Field: TField;
|
|
i: integer;
|
|
begin
|
|
Data.Open;
|
|
|
|
CreateFieldDefs;
|
|
|
|
// Update FieldDefs once to avoid multiple Update calls when working with FieldDefsList
|
|
// (Perfomance optimization)
|
|
// FieldDefs.Updated := False;
|
|
// FieldDefs.Update;
|
|
|
|
if DefaultFields then
|
|
CreateFields
|
|
else // Setting actual size
|
|
for i := 0 to FieldDefs.Count - 1 do
|
|
if FieldDefs[i].DataType = ftString then begin
|
|
Field := FindField(FieldDefs[i].Name);
|
|
if (Field <> nil) and (Field.FieldKind = fkData) then begin
|
|
CheckFieldCompatibility(Field, FieldDefs[i]);
|
|
Field.Size := FieldDefs[i].Size;
|
|
end;
|
|
end;
|
|
|
|
// Set number specific
|
|
if FNumberRange then
|
|
for i := 0 to FieldDefs.Count - 1 do
|
|
SetNumberRange(FieldDefs[i]);
|
|
|
|
BindFields(True);
|
|
|
|
if (Data.Fields.Count > 0) and (Data.Fields[Data.Fields.Count - 1].FieldDescKind = fdkCached) then
|
|
TMemData(Data).UpdateCachedBuffer(nil, nil);
|
|
|
|
if ObjectView then
|
|
GetObjectTypeNames(Fields);
|
|
|
|
if (Data is TMemData) and (TMemData(Data).IndexFields.Count > 0) then
|
|
TMemData(Data).SortItems;
|
|
|
|
BookmarkSize := SizeOf(TRecBookmark);
|
|
|
|
//FBlobCacheOfs := Data.RecordSize + CalcFieldsSize;
|
|
if not FCreateCalcFieldDescs then
|
|
FRecInfoOfs := Data.RecordSize + CalcFieldsSize
|
|
else
|
|
if FCacheCalcFields then
|
|
FRecInfoOfs := Data.RecordSize
|
|
else
|
|
FRecInfoOfs := Data.RecordSize + Data.CalcRecordSize; //FBlobCacheOfs + BlobFieldCount * SizeOf(Pointer);
|
|
|
|
FBookmarkOfs := FRecInfoOfs + SizeOf(TRecInfo);
|
|
FRecBufSize := FBookmarkOfs + BookmarkSize;
|
|
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
if not FCreateCalcFieldDescs then begin
|
|
FWideStringOfs := FRecBufSize;
|
|
|
|
if CalcFieldsSize > 0 then
|
|
for i := 0 to Fields.Count - 1 do
|
|
if (Fields[i].DataType = ftWideString) and (Fields[i].FieldKind in [fkCalculated, fkLookUp]) then
|
|
FRecBufSize := FRecBufSize + (Fields[i].Size + 1) * sizeof(WideChar);
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
FInCacheProcessing := False;
|
|
|
|
if Filtered then begin
|
|
ActivateFilters;
|
|
Data.FilterUpdated;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.IsCursorOpen: boolean;
|
|
begin
|
|
Result := Data.Active;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalClose;
|
|
begin
|
|
BindFields(False);
|
|
if DefaultFields then
|
|
DestroyFields;
|
|
|
|
Data.Close;
|
|
end;
|
|
|
|
procedure TMemDataSet.OpenCursor(InfoQuery: boolean);
|
|
begin
|
|
inherited;
|
|
|
|
if not InfoQuery then begin
|
|
if FOldRecBuf <> nil then begin
|
|
FreeRecordBuffer(FOldRecBuf);
|
|
FOldRecBuf := nil;
|
|
end;
|
|
|
|
FOldRecBuf := AllocRecordBuffer;
|
|
end;
|
|
//DataEvent(deDataSetChange, 0); // Notify nested datasets // DEBUG
|
|
end;
|
|
|
|
procedure TMemDataSet.CloseCursor;
|
|
var
|
|
Buffer: IntPtr;
|
|
RecInfo: PRecInfo;
|
|
begin
|
|
// free complex fields if call Close in dsInsert or dsEdit mode
|
|
// TDataSet.Close doesn't call Cancel
|
|
if Data.HasComplexFields then begin
|
|
if FInInserting then begin
|
|
Buffer := ActiveBuffer;
|
|
RecInfo := PRecInfo(integer(Buffer) + FRecInfoOfs);
|
|
if RecInfo.RefComplexFields then begin
|
|
Data.FreeComplexFields(Buffer, True);
|
|
RecInfo.RefComplexFields := False;
|
|
end;
|
|
end;
|
|
if FInEditing then begin
|
|
Buffer := ActiveBuffer;
|
|
RecInfo := PRecInfo(integer(Buffer) + FRecInfoOfs);
|
|
if RecInfo.RefComplexFields then begin
|
|
Data.FreeComplexFields(Buffer, False); // Blobs isn't created
|
|
RecInfo.RefComplexFields := False;
|
|
end;
|
|
end;
|
|
|
|
if FInInserting then
|
|
Data.FreeComplexFields(ActiveBuffer, True);
|
|
if FInEditing then
|
|
Data.FreeComplexFields(ActiveBuffer, False); // Blobs isn't created
|
|
|
|
FInInserting := False;
|
|
FInEditing := False;
|
|
end;
|
|
|
|
if FOldRecBuf <> nil then begin
|
|
FreeRecordBuffer(FOldRecBuf);
|
|
FOldRecBuf := nil;
|
|
end;
|
|
|
|
try
|
|
inherited;
|
|
finally
|
|
FParentDataSet := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.DataReopen;
|
|
begin
|
|
Data.Reopen;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalRefresh;
|
|
begin
|
|
FreeRefBuffers;
|
|
//ClearBuffers; /// CR11512
|
|
DataReopen;
|
|
if (Data is TMemData) and (TMemData(Data).IndexFields.Count > 0) then
|
|
TMemData(Data).SortItems;
|
|
end;
|
|
|
|
procedure TMemDataSet.CheckFieldCompatibility(Field: TField; FieldDef: TFieldDef);
|
|
begin
|
|
with Field do
|
|
begin
|
|
{$IFDEF VER6P}
|
|
if (DataType <= ftFMTBcd) and (FieldDef.DataType <= ftFMTBcd) then
|
|
{$ELSE}
|
|
if (DataType <= ftGuid) and (FieldDef.DataType <= ftGuid) then
|
|
{$ENDIF}
|
|
inherited CheckFieldCompatibility(Field, FieldDef)
|
|
else
|
|
if DataType <> FieldDef.DataType then
|
|
DatabaseErrorFmt(SFieldTypeMismatch, [DisplayName,
|
|
FieldTypeNames[DataType], FieldTypeNames[FieldDef.DataType]], Self);
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoAfterOpen;
|
|
var
|
|
i: integer;
|
|
begin
|
|
inherited;
|
|
|
|
for i := 0 to NestedDataSets.Count - 1 do
|
|
with TDataSet(NestedDataSets[i]) do
|
|
if Active then
|
|
DataEvent(deParentScroll, {$IFDEF CLR}nil{$ELSE}0{$ENDIF});
|
|
end;
|
|
|
|
procedure TMemDataSet.FreeRefBuffers;
|
|
var
|
|
i: integer;
|
|
begin
|
|
if FNeedAddRef then
|
|
for i := 0 to BufferCount do
|
|
FreeRefComplexFields(Buffers[i]);
|
|
FreeRefComplexFields(TempBuffer);
|
|
end;
|
|
|
|
procedure TMemDataSet.FreeRefComplexFields(Buffer: TRecordBuffer; WithBlob: boolean);
|
|
var
|
|
RecInfo: PRecInfo;
|
|
begin
|
|
RecInfo := PRecInfo(integer(Buffer) + FRecInfoOfs);
|
|
if RecInfo.RefComplexFields then begin
|
|
Data.FreeComplexFields(Buffer, WithBlob);
|
|
RecInfo.RefComplexFields := False;
|
|
end;
|
|
end;
|
|
|
|
{ Field Management }
|
|
|
|
procedure TMemDataSet.InternalInitFieldDefs;
|
|
var
|
|
CheckDefs: boolean;
|
|
i: integer;
|
|
OldFieldNames: array of string;
|
|
OldFieldCount: integer;
|
|
|
|
begin
|
|
// can't CreateFieldDefs if FieldDefs.Update(InitFieldDefs)
|
|
if not Data.Active then begin
|
|
OldFieldCount := Data.Fields.Count;
|
|
CheckDefs := (FieldDefs <> nil) and not FieldDefs.Updated;
|
|
if CheckDefs then begin
|
|
SetLength(OldFieldNames, OldFieldCount);
|
|
for i := 0 to OldFieldCount - 1 do
|
|
OldFieldNames[i] := Data.Fields[i].Name;
|
|
end;
|
|
|
|
Data.InitFields;
|
|
|
|
if OldFieldCount <> Data.Fields.Count then
|
|
FieldDefs.Updated := False
|
|
else
|
|
if CheckDefs then
|
|
for i := 0 to OldFieldCount - 1 do
|
|
if OldFieldNames[i] <> Data.Fields[i].Name then begin
|
|
FieldDefs.Updated := False;
|
|
Break;
|
|
end;
|
|
|
|
CreateFieldDefs;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldType(DataType: word): TFieldType;
|
|
begin
|
|
Result := {$IFDEF CLR}CoreLab.Dac.{$ENDIF}MemDS.GetFieldType(DataType);
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldType(FieldDesc: TFieldDesc): TFieldType;
|
|
begin
|
|
Result := GetFieldType(FieldDesc.DataType);
|
|
end;
|
|
|
|
function TMemDataSet.GetObjectFieldDefName(Parent: TFieldDef; Index: integer; ObjType: TObjectType):string;
|
|
begin
|
|
Result := IntToStr(Index);
|
|
end;
|
|
|
|
function TMemDataSet.GetFielDefSize(FieldType: TFieldType; FieldDesc: TFieldDesc): integer;
|
|
begin
|
|
Result := 0;
|
|
case FieldType of
|
|
ftString, ftWideString{$IFDEF VER5P},ftGuid{$ENDIF}: begin
|
|
Result := FieldDesc.Length;
|
|
if Result = 0 then
|
|
Result := 1; // For SELECT NULL FROM ...
|
|
end;
|
|
ftBytes, ftVarBytes:
|
|
Result := FieldDesc.Length;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.CreateFieldDefs;
|
|
|
|
function GetFieldName(ParentFieldName, FieldName: string; Index: integer): string;
|
|
var
|
|
NewFieldName: string;
|
|
begin
|
|
if Index = 0 then
|
|
NewFieldName := FieldName
|
|
else
|
|
NewFieldName := FieldName + '_' + IntToStr(Index);
|
|
|
|
if (FieldDefs.IndexOf(ParentFieldName + '.' + NewFieldName) <> -1) then
|
|
Result := GetFieldName(ParentFieldName, FieldName, Index + 1)
|
|
else
|
|
Result := NewFieldName;
|
|
end;
|
|
|
|
procedure CreateObjectFields(ObjType: TObjectType; Parent: TFieldDef);
|
|
var
|
|
i: integer;
|
|
FieldDef: TFieldDef;
|
|
FieldType: TFieldType;
|
|
aSize: word;
|
|
Item,CountItem: integer;
|
|
FieldName: string;
|
|
begin
|
|
if (ObjType.DataType = dtObject) or SparseArrays then
|
|
CountItem := 1
|
|
else begin
|
|
CountItem := ObjType.Size;
|
|
if CountItem > MaxArrayItem then // Restriction of array length
|
|
CountItem := MaxArrayItem;
|
|
end;
|
|
|
|
for i := 0 to ObjType.AttributeCount - 1 do begin
|
|
for Item := 0 to CountItem - 1 do begin
|
|
with ObjType.Attributes[i] do begin
|
|
FieldType := GetFieldType(DataType);
|
|
|
|
aSize := 0;
|
|
case FieldType of
|
|
ftString:
|
|
aSize := Length;
|
|
end;
|
|
|
|
FieldDef := TFieldDef.Create(Parent.ChildDefs);
|
|
if ObjType.DataType = dtObject then
|
|
FieldName := Name
|
|
else
|
|
FieldName := GetObjectFieldDefName(Parent, Item, ObjType);
|
|
FieldDef.Name := GetFieldName(Parent.Name, FieldName, 0);
|
|
|
|
FieldDef.DataType := FieldType;
|
|
FieldDef.Size := aSize;
|
|
FieldDef.Required := False;
|
|
if DB.faReadonly in Parent.Attributes then
|
|
FieldDef.Attributes := FieldDef.Attributes + [DB.faReadonly];
|
|
|
|
if FieldType in [ftADT,ftArray] then
|
|
CreateObjectFields(ObjectType, FieldDef);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
FieldType: TFieldType;
|
|
aSize: word;
|
|
i: integer;
|
|
FieldDef: TFieldDef;
|
|
begin
|
|
if FieldDefs.Updated then Exit;
|
|
FieldDefs.BeginUpdate;
|
|
try
|
|
FieldDefs.Clear;
|
|
for i := 0 to Data.FieldCount - 1 do
|
|
with Data.Fields[i] do
|
|
if not HiddenObject and (FieldDescKind = fdkData) and (not HasParent or ParentField.HiddenObject) then begin
|
|
// FieldNo 1..
|
|
FieldType := GetFieldType(Data.Fields[i]);
|
|
aSize := GetFielDefSize(FieldType, Data.Fields[i]);
|
|
if FieldType <> ftUnknown then begin
|
|
FieldDef := TFieldDef.Create(FieldDefs, Name, FieldType, aSize,
|
|
Required and FLocalConstraints, i + 1);
|
|
|
|
if ReadOnly then
|
|
FieldDef.Attributes := FieldDef.Attributes + [DB.faReadonly];
|
|
|
|
if FieldType in [ftFloat, ftInteger] then
|
|
FieldDef.Precision := Length
|
|
else
|
|
if FieldType in [ftBCD{$IFDEF VER6P}, ftFMTBCD{$ENDIF}] then begin
|
|
FieldDef.Precision := Length;
|
|
FieldDef.Size := Scale;
|
|
end
|
|
else
|
|
if FieldType in [ftADT, ftArray] then
|
|
CreateObjectFields(ObjectType, FieldDef);
|
|
|
|
if Hidden then
|
|
FieldDef.Attributes := FieldDef.Attributes + [DB.faHiddenCol];
|
|
{$IFDEF VER5P}
|
|
if Fixed then
|
|
FieldDef.Attributes := FieldDef.Attributes + [DB.faFixed];
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
finally
|
|
FieldDefs.EndUpdate;
|
|
end;
|
|
FieldDefList.Update;
|
|
FieldDefs.Updated := True;
|
|
end;
|
|
|
|
procedure TMemDataSet.GetObjectTypeNames(Fields: TFields);
|
|
var
|
|
i: integer;
|
|
ObjectField: TObjectField;
|
|
begin
|
|
for i := 0 to Fields.Count - 1 do
|
|
if Fields[i] is TObjectField then begin
|
|
ObjectField := TObjectField(Fields[i]);
|
|
|
|
ObjectField.ObjectType := Data.Fields[Fields[i].FieldNo - 1].ObjectType.Name;
|
|
|
|
with ObjectField do
|
|
if DataType in [ftADT, ftArray] then begin
|
|
if (DataType = ftArray) and SparseArrays and
|
|
(Fields[0].DataType = ftADT)
|
|
then
|
|
GetObjectTypeNames(TObjectField(Fields[0]).Fields)
|
|
else
|
|
GetObjectTypeNames(Fields);
|
|
end;
|
|
end
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldDescNo(Field: TField): integer;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
FieldDesc := GetFieldDesc(Field);
|
|
if FieldDesc <> nil then
|
|
Result := FieldDesc.FieldNo
|
|
else
|
|
raise Exception.Create(Format(SFieldNotFound, [Field.FieldName]));
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldDesc(const Field: TField): TFieldDesc;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
i: integer;
|
|
Found: boolean;
|
|
begin
|
|
Assert(Data <> nil, 'FIRecordSet must be setted to this time');
|
|
Assert(Field <> nil, 'Field cannot be nil');
|
|
Assert((Field.DataSet = Self) or (Field.DataSet = nil {CR 22356}), 'Wrong DataSet');
|
|
{if Field.DataSet <> Self then
|
|
for i := 0 to Data.FieldCount - 1 do
|
|
if AnsiLowerCase(Field.FieldName) = AnsiLowerCase(Data.Fields[i].Name) then begin /// Field.FieldName must be equal with FieldDesc.Name
|
|
Result := Data.Fields[i];
|
|
Exit;
|
|
end;}
|
|
|
|
Result := nil;
|
|
if Field.FieldNo > 0 then
|
|
Result := TFieldDesc(Data.Fields[Field.FieldNo - 1])
|
|
else
|
|
begin
|
|
if DefaultFields and (Fields.Count = Data.Fields.Count {just in case; should be moved to Assert}) then begin
|
|
i := Fields.IndexOf(Field);
|
|
Result := Data.Fields[i];
|
|
end
|
|
else
|
|
for i := 0 to Data.FieldCount - 1 do begin
|
|
FieldDesc := Data.Fields[i];
|
|
Found := AnsiLowerCase(Field.FieldName) = AnsiLowerCase(FieldDesc.Name); /// Field.FieldName must be equal with FieldDesc.Name
|
|
if (Field.FieldKind <> fkData) then begin
|
|
if FieldDesc.FieldDescKind = fdkData then
|
|
Found := False
|
|
else
|
|
if not Found then
|
|
Found := AnsiLowerCase(Field.FieldName) = AnsiLowerCase(FieldDesc.ActualName);
|
|
end;
|
|
if Found then begin
|
|
Result := FieldDesc;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
// Assert(AnsiLowerCase(Field.FieldName) = AnsiLowerCase(Result.Name), Format('Field.FieldName <> FieldDesc.Name' + LineSeparator + '"%s" <> "%s"' + LineSeparator, [Field.FieldName, Result.Name]));
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldData(Field: TField; Buffer: TValueBuffer): boolean;
|
|
var
|
|
IsBlank: boolean;
|
|
RecBuf: TRecordBuffer;
|
|
FieldBuf: IntPtr;
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
DataOffset: LongInt;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
i: integer;
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
Result := False;
|
|
if not GetActiveRecBuf(RecBuf) then
|
|
Exit;
|
|
|
|
with Field do
|
|
if FieldNo > 0 then begin
|
|
Data.GetField(FieldNo, RecBuf, Buffer, IsBlank);
|
|
Result := not IsBlank;
|
|
end
|
|
else
|
|
if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields, dsFilter, dsBlockRead] then
|
|
if FCreateCalcFieldDescs then begin
|
|
FieldDesc := nil;
|
|
for i := 0 to Length(FCalcFieldsMapping) - 1 do
|
|
if FCalcFieldsMapping[i].Field = Field then begin
|
|
FieldDesc := FCalcFieldsMapping[i].FieldDesc;
|
|
break;
|
|
end;
|
|
if FieldDesc <> nil then
|
|
Data.GetField(FieldDesc.FieldNo, RecBuf, Buffer, IsBlank)
|
|
else
|
|
Data.GetField(GetFieldDescNo(Field), RecBuf, Buffer, IsBlank);
|
|
Result := not IsBlank;
|
|
end
|
|
else begin
|
|
FieldBuf := IntPtr(integer(RecBuf) + RecordSize + Offset);
|
|
Result := Boolean(Marshal.ReadByte(FieldBuf));
|
|
if Result and (Buffer <> nil) then
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
if Field.DataType = ftWideString then begin
|
|
DataOffset := Integer(IntPtr(Integer(FieldBuf) + 1)^);
|
|
CopyBuffer(IntPtr(Integer(RecBuf) + FWideStringOfs + DataOffset), Buffer, (Size + 1) * SizeOf(WideChar));
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
CopyBuffer(IntPtr(integer(FieldBuf) + 1), Buffer, DataSize);
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldData(FieldNo: integer; Buffer: TValueBuffer): boolean;
|
|
var
|
|
IsBlank: boolean;
|
|
RecBuf: TRecordBuffer;
|
|
begin
|
|
//if BlockReadSize > 0 then
|
|
|
|
Result := GetActiveRecBuf(RecBuf);
|
|
if Result then begin
|
|
Data.GetField(FieldNo, RecBuf, Buffer, IsBlank);
|
|
Result := not IsBlank;
|
|
end
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFieldData(Field: TField; Buffer: TValueBuffer);
|
|
var
|
|
RecBuf: TRecordBuffer;
|
|
FieldBuf: IntPtr;
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
DataOffset, WideStringSize: integer;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
FieldDesc: TFieldDesc;
|
|
i: integer;
|
|
begin
|
|
with Field do begin
|
|
if not (State in dsWriteModes) then
|
|
DatabaseError(SNotEditing);
|
|
GetActiveRecBuf(RecBuf);
|
|
if FieldNo > 0 then begin
|
|
if State = dsCalcFields then
|
|
DatabaseError(SNotEditing);
|
|
if ReadOnly and not (State in [dsSetKey, dsFilter]) then
|
|
DatabaseErrorFmt(SFieldReadOnly, [DisplayName]);
|
|
Validate(Buffer);
|
|
if FieldKind <> fkInternalCalc then begin
|
|
Data.PutField(FieldNo, RecBuf, Buffer);
|
|
end;
|
|
end
|
|
else
|
|
if FCreateCalcFieldDescs then begin
|
|
FieldDesc := nil;
|
|
for i := 0 to Length(FCalcFieldsMapping) - 1 do
|
|
if FCalcFieldsMapping[i].Field = Field then begin
|
|
FieldDesc := FCalcFieldsMapping[i].FieldDesc;
|
|
break;
|
|
end;
|
|
if FieldDesc <> nil then
|
|
Data.PutField(FieldDesc.FieldNo, RecBuf, Buffer)
|
|
else
|
|
Data.PutField(GetFieldDescNo(Field), RecBuf, Buffer);
|
|
end
|
|
else begin
|
|
FieldBuf := IntPtr(integer(RecBuf) + RecordSize + Offset);
|
|
Marshal.WriteByte(FieldBuf, Integer(Integer(Buffer) <> 0) );
|
|
if Integer(Buffer) <> 0 then
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
if Field.DataType = ftWideString then begin
|
|
WideStringSize := Length(WideString(Buffer^)) * Sizeof(WideChar);
|
|
DataOffset := Integer(IntPtr(integer(FieldBuf) + 1)^);
|
|
|
|
CopyBuffer(Pointer(Buffer^), IntPtr(Integer(RecBuf) + FWideStringOfs + DataOffset), WideStringSize);
|
|
Marshal.WriteInt16(IntPtr(Integer(RecBuf) + FWideStringOfs + DataOffset + WideStringSize), 0);
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
CopyBuffer(Buffer, IntPtr(integer(FieldBuf) + 1), DataSize);
|
|
end;
|
|
|
|
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
|
|
{$IFDEF CLR}
|
|
DataEvent(deFieldChange, Field);
|
|
{$ELSE}
|
|
DataEvent(deFieldChange, longint(Field));
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldData(Field: TField; Buffer: TValueBuffer;
|
|
NativeFormat: Boolean): Boolean;
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
var
|
|
Temp: PWideChar;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
begin
|
|
if (Field.DataType = ftWideString) and (Buffer <> nil) then begin
|
|
{$IFDEF CLR}
|
|
Result := inherited GetFieldData(Field, Buffer, True);
|
|
{$ELSE}
|
|
{$IFDEF VER10P}
|
|
Result := inherited GetFieldData(Field, Buffer, True);
|
|
{$ELSE}
|
|
{ Cannot copy direct - may be conflict with Delphi string manager
|
|
SetLength(WideString(Buffer^), Field.Size * sizeof(WideChar));
|
|
Result := inherited GetFieldData(Field, PWideChar(WideString(Buffer^)), True);}
|
|
GetMem(Temp, (Field.Size + 1 {#0} + 8) * sizeof(WideChar));//+ 8 for numbers
|
|
try
|
|
Result := inherited GetFieldData(Field, Temp, True);
|
|
if Result then
|
|
WideString(Buffer^) := Temp
|
|
else
|
|
WideString(Buffer^) := '';
|
|
finally
|
|
FreeMem(Temp);
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
Result := inherited GetFieldData(Field, Buffer, NativeFormat);
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFieldData(Field: TField; Buffer: TValueBuffer; NativeFormat: Boolean);
|
|
begin
|
|
if Field is TWideStringField then begin
|
|
//Assert(Buffer <> nil);
|
|
inherited SetFieldData(Field, Buffer, True);
|
|
end
|
|
else
|
|
inherited SetFieldData(Field, Buffer, NativeFormat);
|
|
end;
|
|
|
|
function TMemDataSet.GetStateFieldValue(State: TDataSetState; Field: TField): Variant;
|
|
begin
|
|
if ((Self.State = dsInsert) and (State = dsOldValue)) or (State = dsInsert) then
|
|
Result := NULL
|
|
else
|
|
Result := inherited GetStateFieldValue(State, Field);
|
|
end;
|
|
|
|
procedure TMemDataSet.DataConvert(Field: TField; Source, Dest: TValueBuffer; ToNative: Boolean);
|
|
{$IFDEF CLR}
|
|
var
|
|
TimeStamp: TTimeStamp;
|
|
TempDouble: Double;
|
|
{$ENDIF}
|
|
begin
|
|
case Field.DataType of
|
|
{$IFDEF CLR}
|
|
ftDate:
|
|
if ToNative then
|
|
begin
|
|
TimeStamp := DateTimeToTimeStamp(
|
|
BitConverter.Int64BitsToDouble(Marshal.ReadInt64(Source)));
|
|
Marshal.WriteInt32(Dest, TimeStamp.Date);
|
|
end
|
|
else
|
|
begin
|
|
TimeStamp.Time := 0;
|
|
TimeStamp.Date := Marshal.ReadInt32(Source);
|
|
Marshal.WriteInt64(Dest,
|
|
BitConverter.DoubleToInt64Bits(MemUtils.TimeStampToDateTime(TimeStamp)));
|
|
end;
|
|
ftTime:
|
|
if ToNative then
|
|
begin
|
|
TimeStamp := DateTimeToTimeStamp(
|
|
BitConverter.Int64BitsToDouble(Marshal.ReadInt64(Source)));
|
|
Marshal.WriteInt32(Dest, TimeStamp.Time);
|
|
end
|
|
else
|
|
begin
|
|
TimeStamp.Time := Marshal.ReadInt32(Source);
|
|
TimeStamp.Date := DateDelta;
|
|
Marshal.WriteInt64(Dest,
|
|
BitConverter.DoubleToInt64Bits(MemUtils.TimeStampToDateTime(TimeStamp)));
|
|
end;
|
|
ftDateTime:
|
|
if ToNative then
|
|
begin
|
|
TempDouble := TimeStampToMSecs(DateTimeToTimeStamp(
|
|
BitConverter.Int64BitsToDouble(Marshal.ReadInt64(Source))));
|
|
Marshal.WriteInt64(Dest, BitConverter.DoubleToInt64Bits(TempDouble));
|
|
end
|
|
else
|
|
begin
|
|
TimeStamp := MSecsToTimeStamp(
|
|
Trunc(BitConverter.Int64BitsToDouble(Marshal.ReadInt64(Source))));
|
|
Marshal.WriteInt64(Dest,
|
|
BitConverter.DoubleToInt64Bits(MemUtils.TimeStampToDateTime(TimeStamp)));
|
|
end;
|
|
{$ENDIF}
|
|
ftBCD:
|
|
Marshal.WriteInt64(Dest, Marshal.ReadInt64(Source));
|
|
else
|
|
inherited DataConvert(Field, Source, Dest, ToNative);
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetSparseArrays: boolean;
|
|
begin
|
|
Result := inherited SparseArrays;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetSparseArrays(Value: boolean);
|
|
begin
|
|
if SparseArrays <> Value then begin
|
|
UnPrepare;
|
|
|
|
inherited SparseArrays := Value;
|
|
|
|
if Data <> nil then
|
|
Data.SparseArrays := Value;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.InternalGetBlob(FieldDesc: TFieldDesc): TBlob;
|
|
var
|
|
RecBuf: TRecordBuffer;
|
|
Ptr: IntPtr;
|
|
IsBlank: boolean;
|
|
begin
|
|
Ptr := Marshal.AllocHGlobal(sizeof(IntPtr));
|
|
try
|
|
if GetActiveRecBuf(RecBuf) then begin
|
|
if not Data.IsBlobFieldType(FieldDesc.DataType) then
|
|
DatabaseError(SNeedBlobType);
|
|
|
|
Data.GetField(FieldDesc.FieldNo, RecBuf, Ptr, IsBlank);
|
|
Result := TBlob(GetGCHandleTarget(Marshal.ReadIntPtr(Ptr)));
|
|
end
|
|
else
|
|
Result := nil;
|
|
finally
|
|
Marshal.FreeHGlobal(Ptr);
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetBlob(const FieldName: string): TBlob;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
FieldDesc := Data.FieldByName(FieldName);
|
|
Result := InternalGetBlob(FieldDesc);
|
|
end;
|
|
|
|
function TMemDataSet.GetBlob(Field: TField): TBlob;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
if Field <> nil then begin
|
|
FieldDesc := GetFieldDesc(Field);
|
|
if FieldDesc = nil then
|
|
raise Exception.Create(Format(SFieldNotFound, [Field.FieldName]));
|
|
Result := InternalGetBlob(FieldDesc);
|
|
end
|
|
else
|
|
Result := nil;
|
|
end;
|
|
|
|
function TMemDataSet.InternalSetBlob(FieldDesc: TFieldDesc; Blob: TBlob): boolean;
|
|
var
|
|
OldBlob: TBlob;
|
|
RecBuf: TRecordBuffer;
|
|
begin
|
|
Assert(FieldDesc <> nil);
|
|
Assert(Blob <> nil);
|
|
OldBlob := InternalGetBlob(FieldDesc);
|
|
Assert(OldBlob <> nil);
|
|
Result := Blob.ClassType = OldBlob.ClassType;
|
|
if GetActiveRecBuf(RecBuf) then begin
|
|
if not Data.IsBlobFieldType(FieldDesc.DataType) then
|
|
DatabaseError(SNeedBlobType);
|
|
|
|
Assert((Blob.RefCount = 1) and (OldBlob.RefCount = 1));
|
|
OldBlob.Free;
|
|
Blob.AddRef;
|
|
Marshal.WriteIntPtr(RecBuf, FieldDesc.Offset, Blob.GCHandle);
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function TMemDataSet.SetBlob(Field: TField; Blob: TBlob): boolean;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
if Field <> nil then begin
|
|
FieldDesc := GetFieldDesc(Field);
|
|
if FieldDesc = nil then
|
|
raise Exception.Create(Format(SFieldNotFound, [Field.FieldName]));
|
|
Result := InternalSetBlob(FieldDesc, Blob);
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetNumberRange(FieldDef: TFieldDef);
|
|
var
|
|
Field: TField;
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
if FieldDef.DataType in [ftInteger, ftFloat] then begin
|
|
Field := FindField(FieldDef.Name);
|
|
if Field <> nil then begin
|
|
CheckFieldCompatibility(Field, FieldDef);
|
|
FieldDesc := Data.FindField(FieldDef.Name);
|
|
if FieldDef.DataType = ftInteger then begin
|
|
Assert(Field is TIntegerField);
|
|
TIntegerField(Field).MaxValue := Round(IntPower(10, FieldDesc.Length)) - 1;
|
|
TIntegerField(Field).MinValue := -TIntegerField(Field).MaxValue;
|
|
end
|
|
else
|
|
if (FieldDesc.Length > 0) and (FieldDesc.Length <= 15) then begin
|
|
Assert(Field is TFloatField);
|
|
TFloatField(Field).Precision := FieldDesc.Length;
|
|
TFloatField(Field).MaxValue :=
|
|
IntPower(10, FieldDesc.Length - FieldDesc.Scale) -
|
|
IntPower(10, - FieldDesc.Scale);
|
|
TFloatField(Field).MinValue := - TFloatField(Field).MaxValue;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{function TMemDataSet.Translate(const Src: string; var Dest: string; boolean): integer;
|
|
begin
|
|
inherited Translate(Src, Dest, ToOem);
|
|
Result := StrLen(Src);
|
|
{ if ToOem then
|
|
AnsiToNativeBuf(Locale, Src, Dest, Result)
|
|
else
|
|
NativeToAnsiBuf(Locale, Src, Dest, Result);
|
|
if Src <> Dest then
|
|
Dest[Result] := #0;
|
|
end;}
|
|
|
|
{ Buffer/Record Management }
|
|
|
|
function TMemDataSet.AllocRecordBuffer: TRecordBuffer;
|
|
begin
|
|
Result := Marshal.AllocHGlobal(FRecBufSize);
|
|
PRecInfo(integer(Result) + FRecInfoOfs).RefComplexFields := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.FreeRecordBuffer(var Buffer: TRecordBuffer);
|
|
begin
|
|
FreeRefComplexFields(Buffer);
|
|
Marshal.FreeHGlobal(Buffer);
|
|
Buffer := nil;
|
|
end;
|
|
|
|
procedure TMemDataSet.CopyRecordBuffer(SrcBuffer: IntPtr; DstBuffer: IntPtr);
|
|
begin
|
|
Data.FreeComplexFields(DstBuffer, False);
|
|
CopyBuffer(SrcBuffer, DstBuffer, FRecBufSize);
|
|
PRecInfo(integer(DstBuffer) + FRecInfoOfs).RefComplexFields := True;
|
|
Data.CreateComplexFields(DstBuffer, False); //copy complex fields
|
|
Data.CopyComplexFields(SrcBuffer, DstBuffer, False);
|
|
end;
|
|
|
|
function TMemDataSet.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode;
|
|
DoCheck: Boolean): TGetResult;
|
|
var
|
|
{$IFDEF CLR}
|
|
RecInfo: IntPtr;
|
|
{$ELSE}
|
|
RecInfo: PRecInfo;
|
|
{$ENDIF}
|
|
begin
|
|
FreeRefComplexFields(Buffer);
|
|
case GetMode of
|
|
gmCurrent:
|
|
Data.GetRecord(Buffer);
|
|
gmNext:
|
|
Data.GetNextRecord(Buffer);
|
|
gmPrior:
|
|
Data.GetPriorRecord(Buffer);
|
|
end;
|
|
if Data.BOF then
|
|
Result := grBOF
|
|
else
|
|
if Data.EOF then
|
|
Result := grEOF
|
|
else begin
|
|
{$IFDEF CLR}
|
|
RecInfo := IntPtr(Integer(Buffer) + FRecInfoOfs);
|
|
Marshal.WriteInt32(RecInfo, Data.RecordNo); //RecordNumber
|
|
Marshal.WriteInt16(RecInfo, sizeof(longint), (byte(bfCurrent) shl 8) or byte(Data.GetUpdateStatus)); //UpdateStatus
|
|
if FNeedAddRef then begin
|
|
Marshal.WriteByte(RecInfo, sizeof(integer) + sizeof(TUpdateStatus)
|
|
+ sizeof(TBookmarkFlag), byte(True)); //RefComplexFields
|
|
Data.AddRefComplexFields(Buffer);
|
|
end;
|
|
{$ELSE}
|
|
RecInfo := PRecInfo(Integer(Buffer) + FRecInfoOfs);
|
|
RecInfo.RecordNumber := Data.RecordNo;
|
|
RecInfo.UpdateStatus := TUpdateStatus(Data.GetUpdateStatus);
|
|
RecInfo.BookmarkFlag := bfCurrent;
|
|
if FNeedAddRef then begin
|
|
RecInfo.RefComplexFields := True;
|
|
Data.AddRefComplexFields(Buffer);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
//ClearBlobCache(Buffer);
|
|
if not FCacheCalcFields then
|
|
GetCalcFields(Buffer);
|
|
//SetBookmarkFlag(Buffer, bfCurrent);
|
|
Data.GetBookmark(PRecBookmark(Integer(Buffer) + FBookmarkOfs));
|
|
|
|
Result := grOK;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalInitRecord(Buffer: TRecordBuffer);
|
|
begin
|
|
//FInDeferredPost := False; moved to InternalInsert
|
|
//FInInserting := True;
|
|
FreeRefComplexFields(Buffer);
|
|
Data.InitRecord(Buffer);
|
|
if Data.HasComplexFields then
|
|
Data.CreateComplexFields(Buffer, True);
|
|
end;
|
|
|
|
procedure TMemDataSet.InitRecord(Buffer: TRecordBuffer);
|
|
var
|
|
RecInfo: PRecInfo;
|
|
begin
|
|
inherited InitRecord(Buffer);
|
|
//ClearBlobCache(Buffer);
|
|
RecInfo := PRecInfo(integer(Buffer) + FRecInfoOfs);
|
|
RecInfo.RecordNumber := 0;
|
|
RecInfo.UpdateStatus := TUpdateStatus(usInserted);
|
|
RecInfo.BookMarkFlag := bfInserted;
|
|
Data.InitRecord(FOldRecBuf); // clear OldRecBuf
|
|
end;
|
|
|
|
function TMemDataSet.GetActiveRecBuf(var RecBuf: TRecordBuffer): boolean;
|
|
begin
|
|
case State of
|
|
dsBlockRead:
|
|
if IsEmpty then
|
|
RecBuf := nil
|
|
else
|
|
RecBuf := ActiveBuffer;
|
|
dsBrowse:
|
|
if FInCacheProcessing then
|
|
RecBuf := NewCacheRecBuf
|
|
else
|
|
if IsEmpty then
|
|
RecBuf := nil
|
|
else
|
|
RecBuf := ActiveBuffer;
|
|
dsEdit,dsInsert:
|
|
RecBuf := ActiveBuffer;
|
|
dsCalcFields:
|
|
RecBuf := CalcBuffer;
|
|
dsFilter:
|
|
RecBuf := FFilterBuffer;
|
|
dsNewValue:
|
|
if FInCacheProcessing then
|
|
RecBuf := NewCacheRecBuf
|
|
else
|
|
RecBuf := ActiveBuffer;
|
|
dsOldValue:
|
|
if FInDeferredPost then
|
|
RecBuf := OldDeferredPostBuf
|
|
else
|
|
if FInCacheProcessing then
|
|
RecBuf := OldCacheRecBuf
|
|
else
|
|
RecBuf := GetOldRecord;
|
|
// dsSetKey: RecBuf := PChar(FKeyBuffer) + SizeOf(TKeyBuffer);
|
|
else
|
|
RecBuf := nil;
|
|
end;
|
|
Result := RecBuf <> nil;
|
|
end;
|
|
|
|
function TMemDataSet.GetOldRecord: TRecordBuffer;
|
|
begin
|
|
UpdateCursorPos;
|
|
Data.GetOldRecord(FOldRecBuf);
|
|
Result := FOldRecBuf;
|
|
end;
|
|
|
|
procedure TMemDataSet.ClearCalcFields(Buffer: TRecordBuffer);
|
|
var
|
|
i: integer;
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
DataOffset: integer;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
begin
|
|
if FCreateCalcFieldDescs then begin
|
|
for i := 0 to Data.Fields.Count - 1 do
|
|
if Data.Fields[i].FieldDescKind <> fdkData then
|
|
Data.SetNull(i + 1, Buffer, True);
|
|
end
|
|
else begin
|
|
FillChar(IntPtr(integer(Buffer) + RecordSize), CalcFieldsSize, 0);
|
|
|
|
{$IFNDEF CLR}
|
|
{$IFNDEF VER10P}
|
|
DataOffset := 0;
|
|
for i := 0 to Fields.Count - 1 do
|
|
if (Fields[i].DataType = ftWideString) and (Fields[i].FieldKind in [fkCalculated, fkLookUp]) then begin
|
|
Marshal.WriteInt32(Pointer(Integer(Buffer) + RecordSize + Fields[i].Offset + 1), DataOffset);
|
|
DataOffset := DataOffset + (Fields[i].Size + 1) * sizeof(WideChar);
|
|
end;
|
|
FillChar(IntPtr(integer(Buffer) + FWideStringOfs), DataOffset, 0);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
// WAR don't support BlockRead
|
|
|
|
procedure TMemDataSet.SetBlockReadSize(Value: Integer);
|
|
begin
|
|
if Value <> BlockReadSize then
|
|
if (Value > 0) or (Value < -1) then begin
|
|
UpdateCursorPos;
|
|
inherited;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TMemDataSet.BlockReadNext;
|
|
begin
|
|
inherited;
|
|
end;
|
|
|
|
{ Bookmarks }
|
|
|
|
function TMemDataSet.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
|
|
begin
|
|
Result := PRecInfo(integer(Buffer) + FRecInfoOfs).BookmarkFlag;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag);
|
|
begin
|
|
PRecInfo(integer(Buffer) + FRecInfoOfs).BookmarkFlag := Value
|
|
end;
|
|
|
|
// Data - pointer to bookmark
|
|
procedure TMemDataSet.GetBookmarkData(Buffer: TRecordBuffer;
|
|
{$IFDEF CLR}var{$ENDIF} Bookmark: TBookmark);
|
|
begin
|
|
CopyBuffer(IntPtr(integer(Buffer) + FBookmarkOfs), Bookmark, BookmarkSize);
|
|
end;
|
|
|
|
procedure TMemDataSet.SetBookmarkData(Buffer: TRecordBuffer;
|
|
{$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark);
|
|
begin
|
|
CopyBuffer(Bookmark, IntPtr(integer(Buffer) + FBookmarkOfs), BookmarkSize);
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalGotoBookmark({$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark);
|
|
begin
|
|
Data.SetToBookMark(PRecBookmark(Bookmark));
|
|
end;
|
|
|
|
{function TMemDataSet.GetBookmarkStr: TBookmarkStr;
|
|
begin
|
|
if State in [dsFilter] then begin
|
|
SetLength(Result, BookmarkSize);
|
|
Data.GetBookmark(Pointer(Result));
|
|
end
|
|
else
|
|
Result := inherited GetBookmarkStr;
|
|
end;}
|
|
|
|
function ChangeDecimalSeparator(const Value: string; OldSeparator, NewSeparator: string): string;
|
|
begin
|
|
if OldSeparator <> NewSeparator then
|
|
Result := StringReplace(Value, OldSeparator, NewSeparator, [rfReplaceAll])
|
|
else
|
|
Result := Value;
|
|
end;
|
|
|
|
function XMLEncode(const AStr: String): String;
|
|
var
|
|
sb: StringBuilder;
|
|
begin
|
|
sb := StringBuilder.Create(AStr, Length(AStr));
|
|
try
|
|
sb.Replace('&', '&');
|
|
sb.Replace('''', ''');
|
|
sb.Replace('"', '"');
|
|
sb.Replace('<', '<');
|
|
sb.Replace('>', '>');
|
|
Result := sb.ToString;
|
|
finally
|
|
sb.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.SaveToXML(const FileName: string);
|
|
var
|
|
FileStream: TFileStream;
|
|
begin
|
|
FileStream := TFileStream.Create(FileName, fmCreate);
|
|
try
|
|
SaveToXML(FileStream);
|
|
finally
|
|
FileStream.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.SaveToXML(Destination: TStream);
|
|
var
|
|
FieldAliases: TStringList;
|
|
|
|
function IsValidFieldName(const FldName: string): boolean;
|
|
var
|
|
i: integer;
|
|
ch: char;
|
|
begin
|
|
for i := 1 to Length(FldName) do begin
|
|
ch := FldName[i];
|
|
if not ((ch = '_') or (ch >= 'A') and (ch <= 'Z') or (ch >= 'a') and (ch <= 'z') or
|
|
(i > 1) and (ch >= '0') and (ch <= '9'))
|
|
then begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function FindFieldAlias(FldName: string): string;
|
|
var
|
|
i, p: integer;
|
|
Attr: string;
|
|
ActualName: string;
|
|
begin
|
|
Result := '';
|
|
if FieldAliases <> nil then
|
|
for i := 0 to FieldAliases.Count - 1 do begin
|
|
Attr := FieldAliases[i];
|
|
p := Pos('''=c', Attr);
|
|
Assert(p <> 0);
|
|
ActualName := Copy(Attr, 2, p - 2);
|
|
if ActualName = FldName then begin
|
|
Result := Copy(Attr, p + 2, Length(Attr) - p - 1);
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
OldActive: boolean;
|
|
Bookmark: DB.TBookmark;
|
|
DestWriter: StreamWriter;
|
|
XMLWriter: XmlTextWriter;
|
|
XML: string;
|
|
FldName, FldAlias: string;
|
|
i: integer;
|
|
FieldDesc: TFieldDesc;
|
|
{$IFDEF VER8}
|
|
DestStream: Stream;
|
|
{$ENDIF}
|
|
begin
|
|
OldActive := Active;
|
|
Bookmark := nil;
|
|
FieldAliases := nil;
|
|
DestWriter := nil;
|
|
XmlWriter := nil;
|
|
{$IFDEF VER8}
|
|
DestStream := nil;
|
|
{$ENDIF}
|
|
try
|
|
DisableControls;
|
|
Active := True;
|
|
{$IFDEF CLR}
|
|
{$IFDEF VER9P}
|
|
{$DEFINE OWNGETBOOKMARK}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF OWNGETBOOKMARK}
|
|
if BookmarkAvailable then
|
|
begin
|
|
Bookmark := Marshal.AllocHGlobal(BookmarkSize);
|
|
GetBookmarkData(ActiveBuffer, Bookmark);
|
|
end else
|
|
Bookmark := nil;
|
|
{$ELSE}
|
|
Bookmark := GetBookmark;
|
|
{$ENDIF}
|
|
|
|
FieldAliases := TStringList.Create;
|
|
|
|
{$IFDEF VER8}
|
|
DestStream := TStreamToCLRStream.GetStream(Destination);
|
|
{$ENDIF}
|
|
DestWriter := StreamWriter.Create({$IFDEF VER8}DestStream{$ELSE}Destination{$ENDIF}, Encoding.Default);
|
|
XmlWriter := XmlTextWriter.Create(DestWriter);
|
|
|
|
XmlWriter.QuoteChar := '''';
|
|
XmlWriter.Formatting := fmtIndented;
|
|
XmlWriter.Indentation := 2;
|
|
XmlWriter.IndentChar := ' ';
|
|
|
|
// Header
|
|
XmlWriter.WriteStartElement('xml');
|
|
|
|
XmlWriter.WriteAttributeString('xmlns:s', 'uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882');
|
|
XmlWriter.WriteAttributeString('xmlns:dt', 'uuid:C2F41010-65B3-11d1-A29F-00AA00C14882');
|
|
XmlWriter.WriteAttributeString('xmlns:rs', 'urn:schemas-microsoft-com:rowset');
|
|
XmlWriter.WriteAttributeString('xmlns:z', '#RowsetSchema');
|
|
|
|
// Fields
|
|
XmlWriter.WriteStartElement('s:Schema');
|
|
XmlWriter.WriteAttributeString('id', 'RowsetSchema');
|
|
|
|
XmlWriter.WriteStartElement('s:ElementType');
|
|
XmlWriter.WriteAttributeString('name', 'row');
|
|
XmlWriter.WriteAttributeString('content', 'eltOnly');
|
|
XmlWriter.WriteAttributeString('rs:updatable', 'true');
|
|
|
|
for i := 0 to Fields.Count - 1 do
|
|
if not (Fields[i].FieldKind in [fkCalculated, fkLookup]) then begin
|
|
FieldDesc := GetFieldDesc(Fields[i]);
|
|
if FieldDesc <> nil then begin
|
|
FldName := FieldDesc.Name;
|
|
if not IsValidFieldName(FldName) then begin
|
|
FldAlias := 'c' + IntToStr(FieldAliases.Count + 1);
|
|
FieldAliases.Add(QuotedStr({$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(FldName))) + '=' + FldAlias);
|
|
end
|
|
else
|
|
FldAlias := '';
|
|
XmlWriter.WriteStartElement('s:AttributeType');
|
|
WriteFieldXMLAttributeType(Fields[i], FieldDesc, FldAlias, XmlWriter);
|
|
XmlWriter.WriteStartElement('s:datatype');
|
|
WriteFieldXMLDataType(Fields[i], FieldDesc, FldAlias, XmlWriter);
|
|
XmlWriter.WriteEndElement; // s:datatype
|
|
XmlWriter.WriteFullEndElement; // s:AttributeType
|
|
end;
|
|
end;
|
|
|
|
XmlWriter.WriteStartElement('s:extends');
|
|
XmlWriter.WriteAttributeString('type', 'rs:rowbase');
|
|
XmlWriter.WriteEndElement; // s:extends
|
|
XmlWriter.WriteFullEndElement; // s:ElementType
|
|
XmlWriter.WriteFullEndElement; // s:Schema
|
|
|
|
// Data
|
|
XmlWriter.WriteStartElement('rs:data');
|
|
|
|
First;
|
|
while not EOF do begin
|
|
XmlWriter.WriteStartElement('z:row');
|
|
for i := 0 to Fields.Count - 1 do
|
|
if not (Fields[i].FieldKind in [fkCalculated, fkLookup]) then begin
|
|
if not Fields[i].IsNull then begin
|
|
XML := GetFieldXMLValue(Fields[i], GetFieldDesc(Fields[i]));
|
|
FldName := {$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(Fields[i].FieldName));
|
|
if not IsValidFieldName(FldName) then
|
|
FldName := FindFieldAlias(FldName);
|
|
XmlWriter.WriteAttributeString(FldName, XML);
|
|
end;
|
|
end;
|
|
XmlWriter.WriteEndElement;
|
|
Next;
|
|
end;
|
|
|
|
XmlWriter.WriteFullEndElement; // rs:data
|
|
XmlWriter.WriteFullEndElement; // xml
|
|
|
|
XmlWriter.Close;
|
|
finally
|
|
Active := OldActive;
|
|
if OldActive and (Bookmark <> nil) then
|
|
GotoBookmark(Bookmark);
|
|
if Bookmark <> nil then
|
|
{$IFDEF OWNGETBOOKMARK}
|
|
Marshal.FreeHGlobal(Bookmark);
|
|
{$ELSE}
|
|
FreeBookmark(Bookmark);
|
|
{$ENDIF}
|
|
FieldAliases.Free;
|
|
XmlWriter.Free;
|
|
DestWriter.Free;
|
|
{$IFDEF VER8}
|
|
DestStream.Free;
|
|
{$ENDIF}
|
|
|
|
EnableControls;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.WriteFieldXMLDataType(Field: TField; FieldDesc: TFieldDesc;
|
|
const FieldAlias: string; XmlWriter: XMLTextWriter);
|
|
begin
|
|
case FieldDesc.DataType of
|
|
dtInt64: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'i8');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', '19');
|
|
end;
|
|
dtBlob, dtBytes, dtVarBytes, dtExtVarBytes: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'bin.hex');
|
|
if (FieldDesc.DataType = dtBlob) then
|
|
XmlWriter.WriteAttributeString('dt:maxLength', '2147483647')
|
|
else
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Length));
|
|
if Field.IsBlob and not FieldDesc.Fixed then
|
|
XmlWriter.WriteAttributeString('rs:long', 'true');
|
|
end;
|
|
dtBoolean: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'boolean');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
end;
|
|
dtString, dtExtString, dtMemo, dtWideString, dtExtWideString, dtWideMemo: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'string');
|
|
if FieldDesc.DataType in [dtMemo, dtWideMemo] then
|
|
XmlWriter.WriteAttributeString('dt:maxLength', '2147483647')
|
|
else
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Length));
|
|
if not (FieldDesc.DataType in [dtWideString, dtExtWideString, dtWideMemo]) then
|
|
XmlWriter.WriteAttributeString('rs:dbtype', 'str');
|
|
if Field.IsBlob and not FieldDesc.Fixed then
|
|
XmlWriter.WriteAttributeString('rs:long', 'true');
|
|
end;
|
|
dtCurrency, dtBCD: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'number');
|
|
XmlWriter.WriteAttributeString('rs:dbtype', 'currency');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtDateTime: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'datetime');
|
|
XmlWriter.WriteAttributeString('rs:dbtype', 'variantdate');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:scale', IntToStr(FieldDesc.Scale));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtDate: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'date');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:scale', IntToStr(FieldDesc.Scale));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtTime: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'time');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:scale', IntToStr(FieldDesc.Scale));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtFloat: begin
|
|
if FieldDesc.Length <= 7 then begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'r4');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', '4');
|
|
end
|
|
else begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'float');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
end;
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
{$IFDEF VER5P}
|
|
dtGuid: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'uuid');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', '16');
|
|
end;
|
|
{$ENDIF}
|
|
dtInt32: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'int');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', '10');
|
|
end;
|
|
{$IFDEF VER6P}
|
|
dtFmtBCD: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'number');
|
|
XmlWriter.WriteAttributeString('rs:dbtype', 'numeric');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:scale', IntToStr(FieldDesc.Scale));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
{$ENDIF}
|
|
dtInt16: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'i2');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', '5');
|
|
end;
|
|
dtInt8: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'i1');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtLongword: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'ui4');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtWord: begin
|
|
XmlWriter.WriteAttributeString('dt:type', 'ui2');
|
|
XmlWriter.WriteAttributeString('dt:maxLength', IntToStr(FieldDesc.Size));
|
|
XmlWriter.WriteAttributeString('rs:precision', IntToStr(FieldDesc.Length));
|
|
end;
|
|
dtUnknown{$IFDEF VER5P}, dtVariant{$ENDIF}:
|
|
XmlWriter.WriteAttributeString('dt:type', 'string')
|
|
else
|
|
DatabaseError(SDataTypeNotSupported, Self);
|
|
end;
|
|
|
|
if FieldDesc.Fixed and not (FieldDesc.DataType in [dtUnknown{$IFDEF VER5P}, dtVariant{$ENDIF}]) then
|
|
XmlWriter.WriteAttributeString('rs:fixedlength', 'true');
|
|
|
|
if Field.Required and not Field.ReadOnly then
|
|
XmlWriter.WriteAttributeString('rs:maybenull', 'false');
|
|
end;
|
|
|
|
procedure TMemDataSet.WriteFieldXMLAttributeType(Field: TField; FieldDesc: TFieldDesc;
|
|
const FieldAlias: string; XmlWriter: XMLTextWriter);
|
|
begin
|
|
if FieldAlias = '' then
|
|
XmlWriter.WriteAttributeString('name', {$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(FieldDesc.Name)))
|
|
else begin
|
|
XmlWriter.WriteAttributeString('name', FieldAlias);
|
|
XmlWriter.WriteAttributeString('rs:name', {$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(FieldDesc.Name)));
|
|
end;
|
|
|
|
XmlWriter.WriteAttributeString('rs:number', IntToStr(FieldDesc.FieldNo));
|
|
if not Field.Required and not Field.ReadOnly then /// Can't use FieldDesc.Required, see "Required and FLocalConstraints" line in TMemDataSet.CreateFieldDefs for details
|
|
XmlWriter.WriteAttributeString('rs:nullable', 'true');
|
|
if not Field.ReadOnly then
|
|
XmlWriter.WriteAttributeString('rs:writeunknown', 'true');
|
|
// XmlWriter.WriteAttributeString('rs:basecatalog', '');
|
|
|
|
if FieldDesc.ActualName <> '' then
|
|
XmlWriter.WriteAttributeString('rs:basecolumn', {$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(FieldDesc.ActualName)));
|
|
if FieldDesc.IsKey then
|
|
XmlWriter.WriteAttributeString('rs:keycolumn', 'true');
|
|
if Field.AutoGenerateValue = arAutoInc then
|
|
XmlWriter.WriteAttributeString('rs:autoincrement', 'true');
|
|
end;
|
|
|
|
function TMemDataSet.GetFieldXMLValue(Field: TField; FieldDesc: TFieldDesc): string;
|
|
var
|
|
Buffer: TBytes;
|
|
Blob: TBlob;
|
|
Piece: PPieceHeader;
|
|
{$IFDEF CLR}
|
|
sb: StringBuilder;
|
|
Bytes: TBytes;
|
|
{$ELSE}
|
|
sbOffset: integer;
|
|
{$ENDIF}
|
|
|
|
function EncodeXMLDateTime(Value: TDateTime): string;
|
|
var
|
|
Year, Month, Day, Hour, Minute, Second, MilliSecond: Word;
|
|
begin
|
|
DecodeDateTime(Value, Year, Month, Day, Hour, Minute, Second, MilliSecond);
|
|
Result := StringReplace(Format('%4d%s%2d%s%2d', [Year, '-', Month, '-', Day]),
|
|
' ', '0', [rfReplaceAll]);
|
|
Result := Result + 'T';
|
|
Result := StringReplace(Result + Format('%2d%s%2d%s%2d', [Hour, ':', Minute, ':', Second]),
|
|
' ', '0', [rfReplaceAll]);
|
|
end;
|
|
|
|
function EncodeXMLTime(Value: TDateTime): string;
|
|
var
|
|
Hour, Minute, Second, MilliSecond: Word;
|
|
begin
|
|
DecodeTime(Value, Hour, Minute, Second, MilliSecond);
|
|
Result := StringReplace(Format('%2d%s%2d%s%2d', [Hour, ':', Minute, ':', Second]),
|
|
' ', '0', [rfReplaceAll]);
|
|
end;
|
|
|
|
begin
|
|
Result := '';
|
|
SetLength(Buffer, 0);
|
|
case FieldDesc.DataType of
|
|
dtBoolean:
|
|
Result := BoolToStr(Field.AsBoolean, True);
|
|
dtInt8, dtInt16, dtInt32, dtUInt16, dtUInt32, dtInt64:
|
|
Result := Field.AsString;
|
|
dtFloat:
|
|
Result := ChangeDecimalSeparator(FloatToStr(Field.AsFloat), DecimalSeparator, '.');
|
|
dtCurrency, dtBcd:
|
|
Result := ChangeDecimalSeparator(CurrToStr(Field.Value), DecimalSeparator, '.');
|
|
dtDate, dtDateTime:
|
|
Result := EncodeXMLDateTime(Field.AsDateTime);
|
|
dtTime:
|
|
Result := EncodeXMLTime(Field.AsDateTime);
|
|
{$IFDEF VER6P}
|
|
dtFmtBCD:
|
|
Result := BcdToStr(Field.AsBCD);
|
|
{$ENDIF}
|
|
dtBytes, dtVarBytes, dtExtVarBytes: begin
|
|
Buffer := Field.Value;
|
|
SetLength(Result, Length(Buffer) * 2);
|
|
{$IFDEF CLR}
|
|
Bytes := Encoding.Default.GetBytes(Result);
|
|
BinToHex(Buffer, 0, Bytes, 0, Length(Buffer));
|
|
Result := Encoding.Default.GetString(Bytes);
|
|
{$ELSE}
|
|
BinToHex(@Buffer[0], PChar(Result), Length(Buffer));
|
|
{$ENDIF}
|
|
end;
|
|
dtBlob: begin
|
|
Blob := InternalGetBlob(FieldDesc);
|
|
SetLength(Result, Integer(Blob.Size) * 2);
|
|
Piece := Blob.FirstPiece;
|
|
{$IFDEF CLR}
|
|
sb := StringBuilder.Create;
|
|
try
|
|
while IntPtr(Piece) <> nil do begin
|
|
SetLength(Buffer, Piece.Used);
|
|
Marshal.Copy(IntPtr(Integer(Piece) + sizeof(TPieceHeader)), Buffer, 0, Piece.Used);
|
|
SetLength(Bytes, Length(Buffer) * 2);
|
|
BinToHex(Buffer, 0, Bytes, 0, Length(Buffer));
|
|
sb.Append(Encoding.Default.GetString(Bytes));
|
|
Piece := Piece.Next;
|
|
end;
|
|
Result := sb.ToString;
|
|
finally
|
|
sb.Free;
|
|
end;
|
|
{$ELSE}
|
|
sbOffset := 0;
|
|
while Piece <> nil do begin
|
|
BinToHex(IntPtr(Integer(Piece) + sizeof(TPieceHeader)),
|
|
IntPtr(Integer(Result) + sbOffset), Piece.Used);
|
|
sbOffset := sbOffset + Integer(Piece.Used);
|
|
Piece := Piece.Next;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
else
|
|
Result := Field.AsString;
|
|
end;
|
|
Result := {$IFNDEF CLR}XMLEncode{$ENDIF}(UTF8Encode(Result));
|
|
end;
|
|
|
|
{$IFDEF CLR} // TDataSet bug
|
|
var
|
|
NativeDBBuffers: TDBBufferList;
|
|
|
|
function NativeBuffers: TDBBufferList;
|
|
begin
|
|
if NativeDBBuffers <> nil then
|
|
Result := NativeDBBuffers
|
|
else
|
|
begin
|
|
Result := TDBBufferList.Create;
|
|
NativeDBBuffers := Result; // fix d9 bug
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetBookmark: TBookmark;
|
|
begin
|
|
if BookmarkAvailable then
|
|
begin
|
|
Result := NativeBuffers.AllocHGlobal(BookmarkSize);
|
|
GetBookmarkData(ActiveBuffer, Result);
|
|
end else
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TMemDataSet.FreeBookmark(var Bookmark: TBookmark);
|
|
begin
|
|
NativeBuffers.FreeHGlobal(Bookmark);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TMemDataSet.BookmarkValid({$IFDEF CLR}const{$ENDIF} Bookmark: TBookmark): boolean;
|
|
begin
|
|
Result := Data.BookmarkValid(PRecBookmark(Bookmark));
|
|
end;
|
|
|
|
function TMemDataSet.CompareBookmarks({$IFDEF CLR}const{$ENDIF} Bookmark1, Bookmark2: TBookmark): integer;
|
|
begin
|
|
Result := Data.CompareBookmarks(PRecBookmark(Bookmark1), PRecBookmark(Bookmark2));
|
|
end;
|
|
|
|
{ Navigation }
|
|
|
|
procedure TMemDataSet.InternalSetToRecord(Buffer: TRecordBuffer);
|
|
begin
|
|
InternalGotoBookmark(IntPtr(integer(Buffer) + FBookmarkOfs));
|
|
end;
|
|
|
|
procedure TMemDataSet.SetIndexFieldNames(Value: string);
|
|
begin
|
|
if Active then
|
|
CheckBrowseMode;
|
|
TMemData(Data).SetIndexFieldNames(Value);
|
|
if Active and (TMemData(Data).IndexFields.Count > 0) then
|
|
Resync([]);
|
|
FIndexFieldNames := Value;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalFirst;
|
|
begin
|
|
Data.SetToBegin;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalLast;
|
|
begin
|
|
Data.SetToEnd;
|
|
end;
|
|
|
|
{ Editing }
|
|
|
|
procedure TMemDataSet.InternalAddRecord(Buffer: IntPtr; Append: Boolean);
|
|
begin
|
|
if Append then
|
|
Data.AppendRecord(Buffer)
|
|
else
|
|
Data.InsertRecord(Buffer);
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalInsert;
|
|
begin
|
|
FInDeferredPost := False;
|
|
if OldDeferredPostBuf <> nil then begin
|
|
FreeRefComplexFields(OldDeferredPostBuf, False);
|
|
Marshal.FreeHGlobal(OldDeferredPostBuf);
|
|
OldDeferredPostBuf := nil;
|
|
end;
|
|
FInInserting := True;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalEdit;
|
|
begin
|
|
FInDeferredPost := False;
|
|
if OldDeferredPostBuf <> nil then begin
|
|
FreeRefComplexFields(OldDeferredPostBuf, False);
|
|
Marshal.FreeHGlobal(OldDeferredPostBuf);
|
|
OldDeferredPostBuf := nil;
|
|
end;
|
|
FInEditing := True;
|
|
|
|
FreeRefComplexFields(ActiveBuffer);
|
|
Data.EditRecord(ActiveBuffer);
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalDelete;
|
|
begin
|
|
if not CanModify then DatabaseError(SDataSetReadOnly, Self);
|
|
Data.DeleteRecord;
|
|
|
|
// CR M8107
|
|
FInInserting := False;
|
|
FInEditing := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalPost;
|
|
var
|
|
i: integer;
|
|
Blob: TBlob;
|
|
Field: TField;
|
|
FieldDesc: TFieldDesc;
|
|
begin
|
|
{$IFDEF VER6P}
|
|
inherited;
|
|
{$ENDIF}
|
|
|
|
for i := 0 to FieldCount - 1 do begin
|
|
Field := Fields[i];
|
|
FieldDesc := GetFieldDesc(Field);
|
|
if (FieldDesc <> nil) and Data.IsBlobFieldType(FieldDesc.DataType) then begin
|
|
Blob := Data.GetObject(FieldDesc.FieldNo, ActiveBuffer) as TBlob;
|
|
if Blob.Modified then
|
|
TBlobField(Field).Modified := True;
|
|
end;
|
|
end;
|
|
if State = dsEdit then begin
|
|
Data.PostRecord(ActiveBuffer);
|
|
end
|
|
else
|
|
Data.InsertRecord(ActiveBuffer);
|
|
|
|
FInDeferredPost := False;
|
|
if OldDeferredPostBuf <> nil then begin
|
|
FreeRefComplexFields(OldDeferredPostBuf, False);
|
|
Marshal.FreeHGlobal(OldDeferredPostBuf);
|
|
OldDeferredPostBuf := nil;
|
|
end;
|
|
FInInserting := False;
|
|
FInEditing := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.Cancel;
|
|
var
|
|
CancelBuf : IntPtr;
|
|
begin
|
|
if ((State = dsEdit) or (State = dsInsert)) and (Data.HasComplexFields) then begin
|
|
CancelBuf := AllocRecordBuffer;
|
|
CopyBuffer(ActiveBuffer, CancelBuf, FRecBufSize);
|
|
Data.AddRefComplexFields(CancelBuf);
|
|
end
|
|
else
|
|
CancelBuf := nil;
|
|
try
|
|
{$IFDEF D3}
|
|
if State = dsInsert then
|
|
if Data.HasComplexFields then
|
|
Data.FreeComplexFields(ActiveBuffer, True);
|
|
{$ENDIF}
|
|
|
|
|
|
inherited;
|
|
finally
|
|
if CancelBuf <> nil then begin
|
|
Data.FreeComplexFields(CancelBuf, True);
|
|
Marshal.FreeHGlobal(CancelBuf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TMemDataSet.InternalCancel;
|
|
begin
|
|
FInDeferredPost := False;
|
|
if OldDeferredPostBuf <> nil then begin
|
|
FreeRefComplexFields(OldDeferredPostBuf, False);
|
|
Marshal.FreeHGlobal(OldDeferredPostBuf);
|
|
OldDeferredPostBuf := nil;
|
|
end;
|
|
FInInserting := False;
|
|
FInEditing := False;
|
|
|
|
if State = dsEdit then
|
|
Data.CancelRecord(ActiveBuffer);
|
|
{$IFNDEF D3}
|
|
if State = dsInsert then
|
|
if Data.HasComplexFields then
|
|
Data.FreeComplexFields(ActiveBuffer, True);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TMemDataSet.InternalDeferredPost;
|
|
begin
|
|
if State = dsEdit then
|
|
DoPerformUpdate
|
|
else
|
|
DoPerformAppend;
|
|
end;
|
|
|
|
procedure TMemDataSet.DeferredPost;
|
|
procedure CheckRequiredFields;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Fields.Count - 1 do
|
|
with Fields[I] do
|
|
if Required and not ReadOnly and (FieldKind = fkData) and IsNull then
|
|
begin
|
|
FocusControl;
|
|
DatabaseErrorFmt(SFieldRequired, [DisplayName]);
|
|
end;
|
|
end;
|
|
begin
|
|
if not CachedUpdates then begin
|
|
UpdateRecord;
|
|
case State of
|
|
dsEdit, dsInsert:
|
|
begin
|
|
{$IFDEF CLR}
|
|
DataEvent(deCheckBrowseMode, nil);
|
|
{$ELSE}
|
|
DataEvent(deCheckBrowseMode, 0);
|
|
{$ENDIF}
|
|
CheckRequiredFields;
|
|
UpdateCursorPos;
|
|
|
|
InternalDeferredPost;
|
|
|
|
if OldDeferredPostBuf = nil then begin
|
|
OldDeferredPostBuf := AllocRecordBuffer;
|
|
Data.CreateComplexFields(OldDeferredPostBuf, False);
|
|
PRecInfo(Integer(OldDeferredPostBuf) + FRecInfoOfs).RefComplexFields := True;//own complex fields
|
|
end;
|
|
CopyRecordBuffer(ActiveBuffer, OldDeferredPostBuf);
|
|
FInDeferredPost := True;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetDefaultExpressionValue(Field: TField);
|
|
begin
|
|
Field.AsString := Field.DefaultExpression;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoOnNewRecord;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to FieldCount - 1 do
|
|
if Fields[i].DefaultExpression <> '' then
|
|
SetDefaultExpressionValue(Fields[i]);
|
|
try
|
|
inherited;
|
|
except
|
|
InternalCancel;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.PerformAppend: boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TMemDataSet.PerformDelete: boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TMemDataSet.PerformUpdate: boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoPerformAppend;
|
|
var
|
|
OldModified: boolean;
|
|
begin
|
|
OldModified := Modified;
|
|
try
|
|
if not FLocalUpdate then
|
|
if not FInDeferredPost then // WAR supports defer posting
|
|
PerformAppend
|
|
else
|
|
DoPerformUpdate;
|
|
finally
|
|
SetModified(OldModified);
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoPerformDelete;
|
|
var
|
|
OldModified: boolean;
|
|
begin
|
|
OldModified := Modified;
|
|
try
|
|
if not FLocalUpdate then
|
|
PerformDelete
|
|
finally
|
|
SetModified(OldModified);
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoPerformUpdate;
|
|
var
|
|
OldModified: boolean;
|
|
begin
|
|
OldModified := Modified;
|
|
try
|
|
if not FLocalUpdate then
|
|
PerformUpdate
|
|
finally
|
|
SetModified(OldModified);
|
|
end;
|
|
end;
|
|
|
|
{ Filter / Locate / Find }
|
|
procedure TMemDataSet.DoGetCachedFields;
|
|
var
|
|
i: Integer;
|
|
FieldDesc: TFieldDesc;
|
|
CalcFieldCount: integer;
|
|
begin
|
|
CalcFieldCount := 0;
|
|
if not DefaultFields then begin
|
|
for i := 0 to Fields.Count - 1 do
|
|
case Fields[i].FieldKind of
|
|
fkCalculated, fkLookup: begin
|
|
FieldDesc := Data.GetFieldDescType.Create;
|
|
try
|
|
FieldDesc.ActualName := Fields[i].FullName;
|
|
FieldDesc.Name := Fields[i].FullName;
|
|
FieldDesc.FieldNo := Data.FieldCount + 1;
|
|
FieldDesc.DataType := GetDataType(Fields[i].DataType);
|
|
case Fields[i].DataType of
|
|
ftWideString:
|
|
FieldDesc.Size := (Fields[i].Size + 1) * SizeOf(WideChar);
|
|
ftDate, ftTime:
|
|
FieldDesc.Size := Fields[i].DataSize * 2;
|
|
else
|
|
FieldDesc.Size := Fields[i].DataSize;
|
|
end;
|
|
FieldDesc.Length := Fields[i].Size;
|
|
if FCacheCalcFields then
|
|
FieldDesc.FieldDescKind := fdkCached
|
|
else
|
|
FieldDesc.FieldDescKind := fdkCalculated;
|
|
|
|
// FieldDescs with CachedField=True must be positioned after data FieldDescs
|
|
Data.Fields.Add(FieldDesc);
|
|
Inc(CalcFieldCount);
|
|
SetLength(FCalcFieldsMapping, CalcFieldCount);
|
|
FCalcFieldsMapping[CalcFieldCount - 1].Field := Fields[i];
|
|
FCalcFieldsMapping[CalcFieldCount - 1].FieldDesc := FieldDesc;
|
|
except
|
|
FieldDesc.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.DoGetCachedBuffer(Buffer: IntPtr; Source: IntPtr = nil);
|
|
var
|
|
RecBuf: IntPtr;
|
|
begin
|
|
if (CalcFieldsSize > 0) then begin
|
|
RecBuf := Marshal.AllocHGlobal(Data.RecordSize + Data.CalcRecordSize + SizeOf(TRecInfo) + BookmarkSize);
|
|
try
|
|
if Source = nil then
|
|
CopyBuffer(Buffer, RecBuf, Data.RecordSize)
|
|
else
|
|
CopyBuffer(Source, RecBuf, Data.RecordSize);
|
|
|
|
GetCalcFields(RecBuf);
|
|
CopyBuffer(RecBuf, Buffer, Data.RecordSize + Data.CalcRecordSize);
|
|
finally
|
|
Marshal.FreeHGlobal(RecBuf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.ActivateFilters;
|
|
begin
|
|
DeactivateFilters;
|
|
|
|
if Assigned(OnFilterRecord) then
|
|
Data.FilterFunc := RecordFilter;
|
|
if Trim(Filter) <> '' then
|
|
Data.FilterText := Filter;
|
|
end;
|
|
|
|
procedure TMemDataSet.DeactivateFilters;
|
|
begin
|
|
Data.FilterFunc := nil;
|
|
Data.FilterText := '';
|
|
end;
|
|
|
|
function TMemDataSet.RecordFilter(RecBuf: IntPtr): boolean;
|
|
var
|
|
Accept: boolean;
|
|
SaveState: TDataSetState;
|
|
begin
|
|
SaveState := SetTempState(dsFilter);
|
|
FFilterBuffer := RecBuf;
|
|
try
|
|
Accept := True;
|
|
OnFilterRecord(Self, Accept);
|
|
except
|
|
InternalHandleException;
|
|
end;
|
|
RestoreState(SaveState);
|
|
Result := Accept;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFiltered(Value: boolean);
|
|
begin
|
|
if Active then begin
|
|
CheckBrowseMode;
|
|
UpdateCursorPos;
|
|
end;
|
|
|
|
if Value <> Filtered then begin
|
|
if Value then
|
|
ActivateFilters
|
|
else
|
|
DeactivateFilters;
|
|
|
|
inherited SetFiltered(Value);
|
|
|
|
if Active then begin
|
|
Data.FilterUpdated;
|
|
Resync([]);
|
|
First;
|
|
//DoAfterScroll;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFilterData(const Text: string; Options: TFilterOptions);
|
|
begin
|
|
if Active then begin
|
|
CheckBrowseMode;
|
|
UpdateCursorPos;
|
|
end;
|
|
|
|
if (Text <> Filter) or (Options <> FilterOptions) then begin
|
|
Data.FilterCaseInsensitive := foCaseInsensitive in Options;
|
|
Data.FilterNoPartialCompare := foNoPartialCompare in Options;
|
|
|
|
if Filtered and (Trim(Text) <> '') then
|
|
Data.FilterText := Text
|
|
else
|
|
Data.FilterText := '';
|
|
|
|
inherited SetFilterText(Text);
|
|
inherited SetFilterOptions(Options);
|
|
|
|
if Active and Filtered then begin
|
|
Data.FilterUpdated;
|
|
Resync([]);
|
|
First;
|
|
//DoAfterScroll;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFilterOptions(Value: TFilterOptions);
|
|
begin
|
|
SetFilterData(Filter, Value);
|
|
end;
|
|
|
|
procedure TMemDataSet.SetFilterText(const Value: string);
|
|
begin
|
|
SetFilterData(Value, FilterOptions);
|
|
end;
|
|
|
|
procedure TMemDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
|
|
begin
|
|
if Active then begin
|
|
CheckBrowseMode;
|
|
UpdateCursorPos;
|
|
end;
|
|
|
|
inherited SetOnFilterRecord(Value);
|
|
|
|
if Filtered and Assigned(OnFilterRecord) then
|
|
Data.FilterFunc := RecordFilter
|
|
else
|
|
Data.FilterFunc := nil;
|
|
|
|
if Active then begin
|
|
Data.FilterUpdated;
|
|
Resync([]);
|
|
First;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.FindRecord(Restart, GoForward: boolean): boolean;
|
|
begin
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
SetFound(False);
|
|
UpdateCursorPos;
|
|
CursorPosChanged;
|
|
if not Filtered then
|
|
ActivateFilters;
|
|
try
|
|
if GoForward then begin
|
|
if Restart then
|
|
Data.SetToBegin;
|
|
Data.GetNextRecord(nil);
|
|
end
|
|
else begin
|
|
if Restart then
|
|
Data.SetToEnd;
|
|
Data.GetPriorRecord(nil);
|
|
end;
|
|
finally
|
|
if not Filtered then
|
|
DeactivateFilters;
|
|
end;
|
|
|
|
if not Data.BOF and not Data.EOF then begin
|
|
Resync([rmExact, rmCenter]);
|
|
SetFound(True);
|
|
end;
|
|
Result := Found;
|
|
if Result then
|
|
DoAfterScroll;
|
|
end;
|
|
|
|
// Allocate memory for Value (ValuePtr - must call FreeMem!) and copy Value to ValuePtr
|
|
procedure TMemDataSet.CopyFieldValue(const Value: variant; out ValuePtr: IntPtr;
|
|
out ValueType: integer; FieldDesc: TFieldDesc); // Allocate memory for Value (ValuePtr - must call FreeMem!) and copy Value to ValuePtr
|
|
var
|
|
BoolValue: boolean;
|
|
s: string;
|
|
l: integer;
|
|
Temp: IntPtr;
|
|
ws: WideString;
|
|
{$IFDEF CLR}
|
|
Data: TBytes;
|
|
{$ENDIF}
|
|
{$IFDEF VER6P}
|
|
i64: Int64;
|
|
bcd: TBcd;
|
|
{$ENDIF}
|
|
begin
|
|
case VarType(Value) of
|
|
varEmpty,varNull:
|
|
ValuePtr := nil;
|
|
varString{$IFDEF CLR}, varChar{$ELSE}, varOleStr{$ENDIF}:
|
|
case FieldDesc.DataType of
|
|
dtBoolean: begin
|
|
BoolValue := Value;
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Boolean));
|
|
Marshal.WriteByte(ValuePtr, integer(BoolValue));
|
|
ValueType := dtBoolean;
|
|
end;
|
|
dtBytes, dtVarBytes, dtExtVarBytes: begin
|
|
s := Value;
|
|
l := Length(s);
|
|
ValuePtr := Marshal.AllocHGlobal(l + SizeOf(Word));
|
|
|
|
Temp := Marshal.StringToHGlobalAnsi(s);
|
|
try
|
|
CopyBuffer(Temp, IntPtr(integer(ValuePtr) + SizeOf(Word)), l);
|
|
finally
|
|
Marshal.FreeCoTaskMem(Temp);
|
|
end;
|
|
Marshal.WriteInt16(ValuePtr, l);
|
|
ValueType := FieldDesc.DataType;
|
|
end;
|
|
dtWideString:
|
|
begin
|
|
ws := Value;
|
|
l := (Length(ws) + 1) * SizeOf(WideChar);
|
|
ValuePtr := Marshal.AllocHGlobal(l);
|
|
CopyBufferUni(ws, ValuePtr, l);
|
|
ValueType := dtWideString;
|
|
end;
|
|
else
|
|
begin
|
|
s := Value;
|
|
l := Length(s) + 1;
|
|
ValuePtr := Marshal.AllocHGlobal(l);
|
|
CopyBufferAnsi(s, ValuePtr, l);
|
|
ValueType := dtString;
|
|
end;
|
|
end;
|
|
else
|
|
ValueType := FieldDesc.DataType;
|
|
case ValueType of
|
|
dtInt32, dtInt8, dtInt16, dtUInt16: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(integer));
|
|
Marshal.WriteInt32(ValuePtr, Value);
|
|
end;
|
|
dtUInt32: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(longword));
|
|
Marshal.WriteInt32(ValuePtr, Value);
|
|
end;
|
|
dtBoolean: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Boolean));
|
|
Marshal.WriteByte(ValuePtr, Integer(Boolean(Value)));
|
|
end;
|
|
dtInt64: begin
|
|
{$IFDEF VER6P}
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Int64));
|
|
i64 := Value;
|
|
Marshal.WriteInt64(ValuePtr, i64);
|
|
{$ELSE}
|
|
GetMem(ValuePtr, SizeOf(Int64));
|
|
if TVarData(Value).VType = varDecimal then
|
|
Int64(ValuePtr^) := TVarDataD6(Value).VInt64
|
|
else
|
|
Int64(ValuePtr^) := StrToInt64(Value);
|
|
{$ENDIF}
|
|
end;
|
|
dtFloat, dtCurrency: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Int64));
|
|
Marshal.WriteInt64(ValuePtr, BitConverter.DoubleToInt64Bits(Value));
|
|
end;
|
|
dtBCD: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Currency));
|
|
Marshal.WriteInt64(ValuePtr, BitConverter.DoubleToInt64Bits(Value));
|
|
end;
|
|
{$IFDEF VER6P}
|
|
dtFmtBCD: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOfTBcd);
|
|
bcd := VarToBcd(Value);
|
|
{$IFDEF CLR}
|
|
Data := TBcd.ToBytes(bcd);
|
|
Marshal.Copy(Data, 0, ValuePtr, SizeOfTBcd);
|
|
{$ELSE}
|
|
PBcd(ValuePtr)^ := bcd;
|
|
{$ENDIF}
|
|
end;
|
|
{$ENDIF}
|
|
dtString, dtExtString: begin
|
|
s := Value;
|
|
l := Length(s) + 1;
|
|
ValuePtr := Marshal.AllocHGlobal(l);
|
|
CopyBufferAnsi(s, ValuePtr, l);
|
|
ValueType := dtString;
|
|
end;
|
|
dtWideString, dtExtWideString: begin
|
|
ws := Value;
|
|
l := (Length(ws) + 1) * SizeOf(WideChar);
|
|
ValuePtr := Marshal.AllocHGlobal(l);
|
|
CopyBufferUni(ws, ValuePtr, l);
|
|
ValueType := dtWideString;
|
|
end;
|
|
dtDateTime, dtDate, dtTime: begin
|
|
ValuePtr := Marshal.AllocHGlobal(SizeOf(Int64));
|
|
Marshal.WriteInt64(ValuePtr, BitConverter.DoubleToInt64Bits(TDateTime(Value)));
|
|
end;
|
|
dtBytes, dtVarBytes, dtExtVarBytes: begin
|
|
Assert(VarType(Value) = varArray + varByte);
|
|
{$IFDEF CLR}
|
|
SetLength(Data, VarArrayHighBound(Value, 1) + 1);
|
|
for l := 0 to High(Data) do
|
|
Data[l] := VarArrayGet(Value, l);
|
|
ValuePtr := Marshal.AllocHGlobal(Length(Data) + sizeof(word));
|
|
Marshal.WriteInt16(ValuePtr, Length(Data));
|
|
Marshal.Copy(Data, 0, IntPtr(integer(ValuePtr) + sizeof(word)), Length(Data));
|
|
{$ELSE}
|
|
GetMem(ValuePtr, TVarData(Value).VArray.Bounds[0].ElementCount + SizeOf(Word));
|
|
Move(TVarData(Value).VArray.Data^, (PChar(ValuePtr) + SizeOf(Word))^, TVarData(Value).VArray.Bounds[0].ElementCount);
|
|
Word(ValuePtr^) := TVarData(Value).VArray.Bounds[0].ElementCount;
|
|
{$ENDIF}
|
|
end;
|
|
else
|
|
raise EConvertError.Create(SCannotConvertType);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.InternalLocateRecord(KeyFields: TDAList; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean;
|
|
var
|
|
FieldDesc: TFieldDesc;
|
|
RecBuf: TRecordBuffer;
|
|
Values: array of IntPtr;
|
|
Types: array of integer;
|
|
i, FieldCount: integer;
|
|
IndexedFieldCount: integer;
|
|
Bookmark: PRecBookmark;
|
|
Res: integer;
|
|
CalcKeyFields: boolean;
|
|
FirstRecNo, LastRecNo: Integer;
|
|
|
|
procedure SetKeyFields;
|
|
var
|
|
i: integer;
|
|
Index: integer;
|
|
TmpValue: IntPtr;
|
|
TmpType: integer;
|
|
Value: variant;
|
|
begin
|
|
CalcKeyFields := False;
|
|
FieldCount := KeyFields.Count;
|
|
SetLength(Values, FieldCount);
|
|
for i := 0 to FieldCount - 1 do begin
|
|
Values[i] := nil; // Clear Values array to prevent AV in 'finally' section after Exception
|
|
|
|
if TFieldDesc(KeyFields[i]).FieldDescKind = fdkCalculated then
|
|
CalcKeyFields := True;
|
|
end;
|
|
|
|
SetLength(Types, FieldCount);
|
|
for i := 0 to FieldCount - 1 do begin
|
|
Value := Unassigned;
|
|
if VarIsArray(KeyValues)
|
|
and ((FieldCount > 1) or (VarArrayHighBound(KeyValues, 1) = 0)) then
|
|
if i <= VarArrayHighBound(KeyValues, 1) then
|
|
Value := KeyValues[i]
|
|
else
|
|
Value := Null
|
|
else
|
|
if i = 0 then
|
|
Value := KeyValues
|
|
else
|
|
Value := Null;
|
|
|
|
CopyFieldValue(Value, Values[i], Types[i], TFieldDesc(KeyFields[i]));
|
|
end;
|
|
|
|
|
|
IndexedFieldCount := 0;
|
|
if not ((lxPartialKey in Options) or (lxPartialCompare in Options) or (lxNearest in Options))then //lxPartialKey and lxPartialCompare incompatible with ordered locate
|
|
//lxNearest can be partially supported in the next versions
|
|
for i := 0 to TMemData(Data).IndexFields.Count - 1 do begin
|
|
//Check ordered locate posibility for current Index field
|
|
if (not TMemData(Data).IndexFields[i].CaseSensitive) xor
|
|
(lxCaseInsensitive in Options) then
|
|
break;
|
|
|
|
//First IndexFields should be in KeyFields if not then we can't use ordered Locate
|
|
Index := KeyFields.IndexOf(TMemData(Data).IndexFields[i].FieldDesc);
|
|
if (Index > -1) then begin
|
|
if IndexedFieldCount <> Index then begin
|
|
FieldDesc := TFieldDesc(KeyFields[IndexedFieldCount]);
|
|
KeyFields[IndexedFieldCount] := KeyFields[Index];
|
|
KeyFields[Index] := FieldDesc;
|
|
|
|
TmpValue := Values[IndexedFieldCount];
|
|
Values[IndexedFieldCount] := Values[Index];
|
|
Values[Index] := TmpValue;
|
|
|
|
TmpType := Types[IndexedFieldCount];
|
|
Types[IndexedFieldCount] := Types[Index];
|
|
Types[Index] := TmpType;
|
|
end;
|
|
inc(IndexedFieldCount);
|
|
end
|
|
else
|
|
break;
|
|
|
|
end;
|
|
|
|
end;
|
|
|
|
function GetGoldenSectionDir(ReadRecBuf: boolean): integer;
|
|
var
|
|
i: integer;
|
|
FieldBlank: boolean;
|
|
Dir: Integer;
|
|
begin
|
|
Result := 0;
|
|
i := 0;
|
|
if ReadRecBuf then
|
|
Data.GetRecord(RecBuf);
|
|
|
|
if CalcKeyFields then
|
|
GetCalcFields(RecBuf);
|
|
|
|
while (Result = 0) and (i < IndexedFieldCount) do begin
|
|
FieldDesc := TFieldDesc(KeyFields[i]);
|
|
|
|
FieldBlank := TMemData(Data).GetNull(FieldDesc.FieldNo, RecBuf);
|
|
|
|
if TMemData(Data).IndexFields[i].DescendingOrder then
|
|
Dir := -1
|
|
else
|
|
Dir := 1;
|
|
|
|
if FieldBlank and (Values[i] = nil) then
|
|
Result := 0
|
|
else
|
|
if FieldBlank and not (Values[i] = nil) then
|
|
Result := 1
|
|
else
|
|
if not FieldBlank and (Values[i] = nil) then
|
|
Result := -1
|
|
else
|
|
Result := TMemData(Data).CompareFieldValue(Values[i], Types[i], FieldDesc, RecBuf, Options);
|
|
|
|
if Result <> 0 then
|
|
Result := Result * Dir;
|
|
Inc(i);
|
|
end;
|
|
end;
|
|
|
|
function ExecGoldenSection: boolean;
|
|
var
|
|
First, Last, Current: Integer;
|
|
Dir: Integer;
|
|
|
|
begin
|
|
Result := False;
|
|
|
|
First := FirstRecNo;
|
|
Last := LastRecNo;
|
|
|
|
Data.RecordNo := First;
|
|
Dir := GetGoldenSectionDir(True);
|
|
if Dir <= 0 then begin
|
|
Result := Dir = 0;
|
|
Exit;
|
|
end;
|
|
|
|
Data.RecordNo := Last;
|
|
Dir := GetGoldenSectionDir(True);
|
|
if Dir >= 0 then begin
|
|
Result := Dir = 0;
|
|
Exit;
|
|
end;
|
|
|
|
repeat
|
|
Current := (Last + First) div 2;
|
|
TMemData(Data).RecordNo := Current;
|
|
Dir := GetGoldenSectionDir(True);
|
|
if Dir < 0 then
|
|
Last := Current
|
|
else
|
|
if Dir > 0 then
|
|
First := Current
|
|
else begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
until Last - First <= 1;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
if KeyFields.Count = 0 then
|
|
Exit;
|
|
|
|
CheckBrowseMode;
|
|
CursorPosChanged;
|
|
UpdateCursorPos;
|
|
|
|
FieldCount := 0;
|
|
|
|
RecBuf := TempBuffer;
|
|
FreeRefComplexFields(RecBuf);
|
|
|
|
Values := nil;
|
|
Bookmark := Marshal.AllocHGlobal(sizeof(TRecBookmark));
|
|
try
|
|
SetKeyFields;
|
|
Data.GetBookmark(Bookmark);
|
|
|
|
//Set locate dimensions. This dimensions should be used for lxNearest ordered implementation
|
|
FirstRecNo := 1;
|
|
LastRecNo := Data.RecordCount;
|
|
|
|
if (lxNext in Options) then begin//Search from current position
|
|
if IndexedFieldCount > 0 then
|
|
Data.GetNextRecord(RecBuf); //Next RecNo in case of Ordered Search
|
|
FirstRecNo := Data.RecordNo;
|
|
end;
|
|
|
|
if (lxUp in Options) then begin //Search from current position downto first
|
|
if IndexedFieldCount > 0 then
|
|
Data.GetPriorRecord(RecBuf); //Prior RecNo in case of Ordered Search
|
|
LastRecNo := Data.RecordNo;
|
|
end;
|
|
|
|
if IndexedFieldCount > 0 then begin
|
|
TMemData(Data).PrepareRecNoCache;
|
|
Result := ExecGoldenSection;
|
|
|
|
//Find the first occurence of located data
|
|
if Result then
|
|
repeat
|
|
|
|
if (lxUp in Options) then begin
|
|
if Data.RecordNo >= LastRecNo then //top limit of first occurrence search
|
|
break
|
|
else begin
|
|
Data.GetNextRecord(RecBuf);
|
|
if Data.Eof or (GetGoldenSectionDir(False) <> 0) then begin
|
|
if IndexedFieldCount >= FieldCount then //we shouldn't restore correct position in case of mixed locate
|
|
Data.GetPriorRecord(RecBuf); //Restore correct position
|
|
break;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
if Data.RecordNo <= FirstRecNo then //bottom limit of first occurrence search
|
|
break
|
|
else begin
|
|
Data.GetPriorRecord(RecBuf);
|
|
if (GetGoldenSectionDir(False) <> 0) then begin
|
|
if IndexedFieldCount >= FieldCount then //we shouldn't restore correct position in case of mixed locate
|
|
Data.GetNextRecord(RecBuf); //Restore correct position
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
until Data.Bof or Data.Eof;
|
|
end;
|
|
|
|
|
|
if (IndexedFieldCount = 0) or ((IndexedFieldCount < FieldCount) and Result) then begin
|
|
|
|
if not((lxNext in Options) or (lxUp in Options)) and not (IndexedFieldCount > 0) then
|
|
Data.SetToBegin;
|
|
|
|
while True do begin
|
|
if lxUp in Options then
|
|
Data.GetPriorRecord(RecBuf)
|
|
else
|
|
Data.GetNextRecord(RecBuf);
|
|
|
|
if CalcKeyFields then
|
|
GetCalcFields(RecBuf);
|
|
|
|
if not (Data.EOF or Data.BOF) then begin
|
|
Result := True;
|
|
i := 0;
|
|
while Result and (i < FieldCount) do begin
|
|
FieldDesc := TFieldDesc(KeyFields[i]);
|
|
if (Values[i] = nil) or Data.GetNull(FieldDesc.FieldNo, RecBuf) then
|
|
Result := (Values[i] = nil) and Data.GetNull(FieldDesc.FieldNo, RecBuf)
|
|
else begin
|
|
Res := TMemData(Data).CompareFieldValue(Values[i], Types[i], FieldDesc, RecBuf, Options);
|
|
Result := (Res = 0) or (Res < 0) and (lxNearest in Options);
|
|
end;
|
|
Inc(i);
|
|
end;
|
|
|
|
if Result then
|
|
break;
|
|
end
|
|
else begin
|
|
Result := False;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if (SavePos or not Result)
|
|
and not (Data.Eof and Data.Bof {Empty Data}) then
|
|
Data.SetToBookmark(Bookmark);
|
|
finally
|
|
Marshal.FreeHGlobal(Bookmark);
|
|
for i := 0 to FieldCount - 1 do
|
|
Marshal.FreeHGlobal(Values[i]);
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.LocateRecord(const KeyFields: string; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean;
|
|
var
|
|
Fields: TDAList;
|
|
FieldDesc: TFieldDesc;
|
|
|
|
procedure ParseKeyFields;
|
|
var
|
|
St: string;
|
|
i: integer;
|
|
begin
|
|
i := 1;
|
|
while True do begin
|
|
St := ExtractFieldName(KeyFields, i);
|
|
if St <> '' then begin
|
|
FieldDesc := Data.FieldByName(St);
|
|
if FieldDesc <> nil then
|
|
Fields.Add(FieldDesc);
|
|
end
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Fields := TDAList.Create;
|
|
try
|
|
ParseKeyFields;
|
|
Result := InternalLocateRecord(Fields, KeyValues, Options, SavePos);
|
|
finally
|
|
Fields.Free;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.LocateRecord(const KeyFields: array of TField; const KeyValues: variant;
|
|
Options: TLocateExOptions; SavePos: boolean): boolean;
|
|
var
|
|
Fields: TDAList;
|
|
i: integer;
|
|
begin
|
|
Fields := TDAList.Create;
|
|
try
|
|
for i := 0 to Length(KeyFields) - 1 do begin
|
|
if KeyFields[i] <> nil then
|
|
Fields.Add(GetFieldDesc(KeyFields[i]));
|
|
end;
|
|
|
|
Result := InternalLocateRecord(Fields, KeyValues, Options, SavePos);
|
|
finally
|
|
Fields.Free;
|
|
end;
|
|
end;
|
|
|
|
function LocateExOptions(Options: TLocateOptions): TLocateExOptions;
|
|
begin
|
|
Result := [];
|
|
if loCaseInsensitive in Options then
|
|
Result := Result + [lxCaseInsensitive];
|
|
|
|
if loPartialKey in Options then
|
|
Result := Result + [lxPartialKey];
|
|
end;
|
|
|
|
function TMemDataSet.Locate(const KeyFields: array of TField; const KeyValues: variant;
|
|
Options: TLocateOptions): boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
|
|
Result := LocateRecord(KeyFields, KeyValues, LocateExOptions(Options), False);
|
|
|
|
if Result then begin
|
|
Resync([{rmExact, rmCenter}]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.Locate(const KeyFields: string;
|
|
const KeyValues: variant; Options: TLocateOptions): boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
|
|
Result := LocateRecord(KeyFields, KeyValues, LocateExOptions(Options), False);
|
|
|
|
if Result then begin
|
|
Resync([{rmExact, rmCenter}]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.LocateEx(const KeyFields: string;
|
|
const KeyValues: variant; Options: TLocateExOptions): boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
|
|
Result := LocateRecord(KeyFields, KeyValues, Options, False);
|
|
|
|
if Result then begin
|
|
Resync([{rmExact, rmCenter}]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.LocateEx(const KeyFields: array of TField;
|
|
const KeyValues: variant; Options: TLocateExOptions): boolean;
|
|
begin
|
|
DoBeforeScroll;
|
|
|
|
Result := LocateRecord(KeyFields, KeyValues, Options, False);
|
|
|
|
if Result then begin
|
|
Resync([{rmExact, rmCenter}]);
|
|
DoAfterScroll;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.Lookup(const KeyFields: string; const KeyValues: variant;
|
|
const ResultFields: string): variant;
|
|
begin
|
|
Result := Null;
|
|
if LocateRecord(KeyFields, KeyValues, [], True) then begin
|
|
SetTempState(dsCalcFields);
|
|
try
|
|
CalculateFields(TempBuffer);
|
|
Result := FieldValues[ResultFields];
|
|
finally
|
|
RestoreState(dsBrowse);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ CachedUpdates }
|
|
|
|
procedure TMemDataSet.CheckCachedUpdateMode;
|
|
begin
|
|
if not CachedUpdates then
|
|
DatabaseError(SNotCachedUpdate);
|
|
end;
|
|
|
|
function TMemDataSet.UpdateStatus: TUpdateStatus;
|
|
var
|
|
RecBuf: TRecordBuffer;
|
|
begin
|
|
if CachedUpdates and not IsEmpty then begin
|
|
if State = dsCalcFields then
|
|
RecBuf := CalcBuffer
|
|
else
|
|
RecBuf := ActiveBuffer;
|
|
|
|
Result := PRecInfo(integer(RecBuf) + FRecInfoOfs).UpdateStatus;
|
|
end
|
|
else
|
|
Result := usUnModified;
|
|
end;
|
|
|
|
function TMemDataSet.UpdateResult: TUpdateAction;
|
|
begin
|
|
UpdateCursorPos;
|
|
|
|
if Data.GetUpdateResult = urNone then
|
|
Result := uaApplied
|
|
else
|
|
Result := TUpdateAction(Data.GetUpdateResult);
|
|
end;
|
|
|
|
procedure TMemDataSet.ApplyUpdates;
|
|
begin
|
|
CheckActive;
|
|
FreeRefBuffers;
|
|
if State <> dsBrowse then
|
|
Post;
|
|
CheckCachedUpdateMode;
|
|
UpdateCursorPos;
|
|
|
|
NewCacheRecBuf := AllocRecordBuffer;
|
|
OldCacheRecBuf := AllocRecordBuffer;
|
|
FInCacheProcessing := True;
|
|
try
|
|
Data.SetCacheRecBuf(NewCacheRecBuf, OldCacheRecBuf);
|
|
Data.ApplyUpdates;
|
|
finally
|
|
FInCacheProcessing := False;
|
|
FreeRecordBuffer(NewCacheRecBuf);
|
|
FreeRecordBuffer(OldCacheRecBuf);
|
|
Resync([]);
|
|
end;
|
|
end;
|
|
|
|
procedure TMemDataSet.CommitUpdates;
|
|
begin
|
|
CheckActive;
|
|
CheckCachedUpdateMode;
|
|
FreeRefBuffers;
|
|
UpdateCursorPos;
|
|
|
|
NewCacheRecBuf := AllocRecordBuffer;
|
|
OldCacheRecBuf := AllocRecordBuffer;
|
|
FInCacheProcessing := True;
|
|
try
|
|
Data.SetCacheRecBuf(NewCacheRecBuf, OldCacheRecBuf);
|
|
Data.CommitUpdates;
|
|
finally
|
|
FInCacheProcessing := False;
|
|
FreeRecordBuffer(NewCacheRecBuf);
|
|
FreeRecordBuffer(OldCacheRecBuf);
|
|
end;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TMemDataSet.CancelUpdates;
|
|
begin
|
|
CheckActive;
|
|
FreeRefBuffers;
|
|
Cancel;
|
|
CheckCachedUpdateMode;
|
|
UpdateCursorPos;
|
|
Data.CancelUpdates;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TMemDataSet.RestoreUpdates;
|
|
begin
|
|
CheckActive;
|
|
FreeRefBuffers;
|
|
Cancel;
|
|
CheckCachedUpdateMode;
|
|
UpdateCursorPos;
|
|
Data.RestoreUpdates;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TMemDataSet.RevertRecord;
|
|
begin
|
|
CheckActive;
|
|
FreeRefComplexFields(ActiveBuffer);
|
|
if State in dsEditModes then
|
|
Cancel;
|
|
CheckCachedUpdateMode;
|
|
UpdateCursorPos;
|
|
Data.RevertRecord;
|
|
Resync([]);
|
|
end;
|
|
|
|
procedure TMemDataSet.DoApplyRecord(UpdateKind: TUpdateRecKind; var Action: TUpdateRecAction; LastItem: boolean);
|
|
var
|
|
OldModified: boolean;
|
|
UpdateAction: TUpdateAction;
|
|
begin
|
|
OldModified := Modified; // NewValue change Modified ??? or MemDS
|
|
try
|
|
UpdateAction := uaFail;
|
|
try
|
|
if Assigned(OnUpdateRecord) then begin
|
|
OnUpdateRecord(Self, TUpdateKind(UpdateKind), UpdateAction);
|
|
if UpdateAction in [uaAbort] then
|
|
Abort;
|
|
end;
|
|
//else begin
|
|
if not Assigned(OnUpdateRecord) or (UpdateAction = TUpdateAction(uaDefault)) then begin
|
|
case UpdateKind of
|
|
ukUpdate:
|
|
PerformUpdate;
|
|
ukInsert:
|
|
PerformAppend;
|
|
ukDelete:
|
|
PerformDelete;
|
|
end;
|
|
|
|
if BatchUpdate then
|
|
if CanFlushBatch or LastItem then
|
|
// Should be flushed here because of Action parameter that should be returned
|
|
// to TMemData.ApplyUpdates function
|
|
FlushBatch
|
|
else begin
|
|
Action := urSuspended;
|
|
Exit;
|
|
end;
|
|
|
|
UpdateAction := uaApplied;
|
|
end;
|
|
except
|
|
on E: Exception do
|
|
if IsClass(E, EDatabaseError) and Assigned(OnUpdateError) then begin
|
|
OnUpdateError(Self, EDatabaseError(E), TUpdateKind(UpdateKind), UpdateAction);
|
|
case UpdateAction of
|
|
uaFail:
|
|
raise;
|
|
uaAbort:
|
|
Abort;
|
|
end;
|
|
end
|
|
else
|
|
raise;
|
|
end;
|
|
finally
|
|
SetModified(OldModified);
|
|
end;
|
|
Action := TUpdateRecAction(UpdateAction);
|
|
end;
|
|
|
|
function TMemDataSet.BatchUpdate: boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TMemDataSet.CanFlushBatch: boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TMemDataSet.FlushBatch;
|
|
begin
|
|
Assert(False, 'Should be overridden');
|
|
end;
|
|
|
|
{ BLOB Support }
|
|
|
|
{function TMemDataSet.GetBlobData(Field:TField; Buffer: PChar):TBlobData;
|
|
begin
|
|
Result := PBlobDataArray(Buffer + FBlobCacheOfs)[Field.Offset];
|
|
end;
|
|
|
|
procedure TMemDataSet.SetBlobData(Field:TField; Buffer: PChar; Value:TBlobData);
|
|
begin
|
|
if Buffer = ActiveBuffer then
|
|
PBlobDataArray(Buffer + FBlobCacheOfs)[Field.Offset] := Value;
|
|
end;
|
|
|
|
procedure TMemDataSet.ClearBlobCache(Buffer: PChar);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to BlobFieldCount - 1 do
|
|
PBlobDataArray(Buffer + FBlobCacheOfs)[i] := '';
|
|
end;}
|
|
|
|
procedure TMemDataSet.CloseBlob(Field: TField);
|
|
begin
|
|
end;
|
|
|
|
function TMemDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
|
|
begin
|
|
Result := TBlobStream.Create(Field as TBlobField, Mode);
|
|
end;
|
|
|
|
{ Informational }
|
|
|
|
function TMemDataSet.IsSequenced: boolean;
|
|
begin
|
|
Result := True;
|
|
end;
|
|
|
|
function TMemDataSet.GetRecordSize: word;
|
|
begin
|
|
Result := word(Data.RecordSize);
|
|
end;
|
|
|
|
function TMemDataSet.GetRecordCount: integer;
|
|
begin
|
|
if Active then
|
|
Result := Data.RecordCount
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
function TMemDataSet.GetRecNo: integer;
|
|
var
|
|
RecBuf: TRecordBuffer;
|
|
begin
|
|
if GetActiveRecBuf(RecBuf) then
|
|
Result := PRecInfo(integer(RecBuf) + FRecInfoOfs).RecordNumber
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetRecNo(Value: integer);
|
|
begin
|
|
CheckBrowseMode;
|
|
DoBeforeScroll;
|
|
Data.RecordNo := Value;
|
|
Resync([{rmCenter}]);
|
|
DoAfterScroll;
|
|
end;
|
|
|
|
{ More }
|
|
|
|
procedure TMemDataSet.InternalHandleException;
|
|
begin
|
|
{$IFDEF VER6P}
|
|
if Assigned(Classes.ApplicationHandleException) then
|
|
Classes.ApplicationHandleException(ExceptObject)
|
|
else
|
|
ShowException(ExceptObject, ExceptAddr)
|
|
{$ELSE}
|
|
ApplicationHandleException(Self);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
procedure TMemDataSet.DataEvent(Event: TDataEvent; Info: TObject);
|
|
{$ELSE}
|
|
procedure TMemDataSet.DataEvent(Event: TDataEvent; Info: longint);
|
|
{$ENDIF}
|
|
procedure CheckIfParentScrolled;
|
|
var
|
|
ParentPosition, I: Integer;
|
|
begin
|
|
if FParentDataSet = nil then
|
|
Exit;
|
|
ParentPosition := 0;
|
|
with FParentDataSet do
|
|
if not IsEmpty then
|
|
for I := 0 to BookmarkSize - 1 do
|
|
ParentPosition := ParentPosition +
|
|
Marshal.ReadByte(ActiveBuffer, FBookmarkOfs + I);
|
|
if (FLastParentPos = 0) or (ParentPosition <> FLastParentPos) then
|
|
begin
|
|
First;
|
|
FLastParentPos := ParentPosition;
|
|
end else
|
|
begin
|
|
UpdateCursorPos;
|
|
Resync([]);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if Event = deParentScroll then
|
|
CheckIfParentScrolled;
|
|
inherited DataEvent(Event, Info);
|
|
end;
|
|
|
|
procedure TMemDataSet.AssignTo(Dest: TPersistent);
|
|
begin
|
|
if Dest is TMemDataSet then begin
|
|
TMemDataSet(Dest).CachedUpdates := CachedUpdates;
|
|
TMemDataSet(Dest).LocalConstraints := LocalConstraints;
|
|
TMemDataSet(Dest).LocalUpdate := LocalUpdate;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetCachedUpdates(Value: boolean);
|
|
begin
|
|
if FCachedUpdates <> Value then begin
|
|
CheckInactive;
|
|
FCachedUpdates := Value;
|
|
Data.CachedUpdates := FCachedUpdates;
|
|
end;
|
|
end;
|
|
|
|
function TMemDataSet.GetUpdatesPending: boolean;
|
|
begin
|
|
Result := Data.UpdatesPending;
|
|
end;
|
|
|
|
function TMemDataSet.GetPrepared: boolean;
|
|
begin
|
|
Result := Data.Prepared;
|
|
end;
|
|
|
|
procedure TMemDataSet.SetPrepared(Value: boolean);
|
|
begin
|
|
if Value then
|
|
Prepare
|
|
else
|
|
UnPrepare;
|
|
end;
|
|
|
|
function TMemDataSet.GetUpdateRecordSet: TUpdateRecordTypes;
|
|
var
|
|
ItemTypes: TItemTypes;
|
|
begin
|
|
// if Active then begin
|
|
CheckCachedUpdateMode;
|
|
ItemTypes := Data.FilterItemTypes;
|
|
|
|
Result := [];
|
|
if isUnmodified in ItemTypes then
|
|
Result := Result + [rtUnmodified];
|
|
if isUpdated in ItemTypes then
|
|
Result := Result + [rtModified];
|
|
if isAppended in ItemTypes then
|
|
Result := Result + [rtInserted];
|
|
if isDeleted in ItemTypes then
|
|
Result := Result + [rtDeleted];
|
|
{ end
|
|
else
|
|
Result := [];}
|
|
end;
|
|
|
|
procedure TMemDataSet.SetUpdateRecordSet(Value: TUpdateRecordTypes);
|
|
var
|
|
ItemTypes: TItemTypes;
|
|
begin
|
|
CheckCachedUpdateMode;
|
|
|
|
//CheckBrowseMode;
|
|
if Active then
|
|
UpdateCursorPos;
|
|
|
|
ItemTypes := [];
|
|
if rtUnmodified in Value then
|
|
ItemTypes := ItemTypes + [isUnmodified];
|
|
if rtModified in Value then
|
|
ItemTypes := ItemTypes + [isUpdated];
|
|
if rtInserted in Value then
|
|
ItemTypes := ItemTypes + [isAppended];
|
|
if rtDeleted in Value then
|
|
ItemTypes := ItemTypes + [isDeleted];
|
|
|
|
Data.FilterItemTypes := ItemTypes;
|
|
|
|
if Active then
|
|
Resync([]);
|
|
end;
|
|
|
|
{ TBlobStream }
|
|
|
|
constructor TBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
|
|
begin
|
|
inherited Create;
|
|
|
|
FMode := Mode;
|
|
FField := Field;
|
|
FDataSet := FField.DataSet as TMemDataSet;
|
|
FFieldNo := FField.FieldNo;
|
|
if not FDataSet.GetActiveRecBuf(FBuffer) then
|
|
Exit;
|
|
{ if FDataSet.State = dsFilter then
|
|
DatabaseErrorFmt('SNoFieldAccess', [FField.DisplayName]);}
|
|
if not FField.Modified then begin
|
|
if Mode = bmRead then begin
|
|
{ FCached := FDataSet.FCacheBlobs and (FBuffer = FDataSet.ActiveBuffer) and
|
|
(FField.IsNull or (FDataSet.GetBlobData(FField, FBuffer) <> ''));}
|
|
end
|
|
else begin
|
|
// FDataSet.SetBlobData(FField, FBuffer, '');
|
|
if FField.ReadOnly then
|
|
DatabaseErrorFmt(SFieldReadOnly, [FField.DisplayName]);
|
|
if not (FDataSet.State in [dsNewValue, dsEdit, dsInsert]) then
|
|
DatabaseError(SNotEditing);
|
|
end;
|
|
end;
|
|
FOpened := True;
|
|
if Mode = bmWrite then
|
|
Truncate;
|
|
end;
|
|
|
|
destructor TBlobStream.Destroy;
|
|
begin
|
|
if FOpened then begin
|
|
if FModified then
|
|
FField.Modified := True;
|
|
end;
|
|
if FModified then
|
|
//try
|
|
{$IFDEF CLR}
|
|
FDataSet.DataEvent(deFieldChange, FField);
|
|
{$ELSE}
|
|
FDataSet.DataEvent(deFieldChange, longint(FField));
|
|
{$ENDIF}
|
|
{except
|
|
Application.HandleException(Self);
|
|
end;}
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
function TBlobStream.Read(var Buffer: TBytes; Offset, Count: Longint): Longint;
|
|
var
|
|
Handle: IntPtr;
|
|
{$ELSE}
|
|
function TBlobStream.Read(var Buffer; Count: longint): longint;
|
|
{$ENDIF}
|
|
begin
|
|
Result := 0;
|
|
if FOpened then begin
|
|
if Count > Size - FPosition then
|
|
Result := Size - FPosition
|
|
else
|
|
Result := Count;
|
|
if Result > 0 then begin
|
|
{$IFDEF CLR}
|
|
Handle := AllocGCHandle(Buffer, True);
|
|
try
|
|
Result := FDataSet.Data.ReadBlob(FFieldNo, FBuffer, FPosition, Count,
|
|
GetAddrOfPinnedObject(Handle), FDataSet.State = dsOldValue{$IFDEF VER10P}, (FField is TWideMemoField){$ENDIF});
|
|
finally
|
|
FreeGCHandle(Handle);
|
|
end;
|
|
{$ELSE}
|
|
Result := FDataSet.Data.ReadBlob(FFieldNo, FBuffer, FPosition, Count, @Buffer,
|
|
(FDataSet.State = dsOldValue){$IFDEF VER10P}, (FField is TWideMemoField){$ENDIF});
|
|
{$ENDIF}
|
|
Inc(FPosition, Result);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
function TBlobStream.Write(const Buffer: TBytes; Offset, Count: Longint): Longint;
|
|
var
|
|
Handle: IntPtr;
|
|
{$ELSE}
|
|
function TBlobStream.Write(const Buffer; Count: Longint): Longint;
|
|
{$ENDIF}
|
|
begin
|
|
Result := 0;
|
|
if FOpened then begin
|
|
{$IFDEF CLR}
|
|
Handle := AllocGCHandle(Buffer, True);
|
|
try
|
|
FDataSet.Data.WriteBlob(FFieldNo, FBuffer, FPosition, Count,
|
|
GetAddrOfPinnedObject(Handle){$IFDEF VER10P}, FField is TWideMemoField{$ENDIF});
|
|
finally
|
|
FreeGCHandle(Handle);
|
|
end;
|
|
|
|
{$ELSE}
|
|
FDataSet.Data.WriteBlob(FFieldNo, FBuffer, FPosition, Count, @Buffer
|
|
{$IFDEF VER10P}, FField is TWideMemoField{$ENDIF});
|
|
{$ENDIF}
|
|
Inc(FPosition, Count);
|
|
Result := Count;
|
|
FModified := True;
|
|
{ FDataSet.SetBlobData(FField, FBuffer, '');}
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
function TBlobStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
|
|
{$ELSE}
|
|
function TBlobStream.Seek(Offset: Longint; Origin: Word): Longint;
|
|
{$ENDIF}
|
|
begin
|
|
case Origin of
|
|
soFromBeginning:
|
|
FPosition := Offset;
|
|
soFromCurrent:
|
|
Inc(FPosition, Offset);
|
|
soFromEnd:
|
|
FPosition := GetBlobSize + Offset;
|
|
end;
|
|
Result := FPosition;
|
|
end;
|
|
|
|
procedure TBlobStream.Truncate;
|
|
begin
|
|
if FOpened then begin
|
|
FDataSet.Data.TruncateBlob(FFieldNo, FBuffer, FPosition
|
|
{$IFDEF VER10P}, FField is TWideMemoField{$ENDIF});
|
|
FModified := True;
|
|
// FDataSet.SetBlobData(FField, FBuffer, '');
|
|
end;
|
|
end;
|
|
|
|
function TBlobStream.GetBlobSize: longint;
|
|
begin
|
|
Result := 0;
|
|
if FOpened then
|
|
Result := FDataSet.Data.GetBlobSize(FFieldNo, FBuffer, (FDataSet.State = dsOldValue)
|
|
{$IFDEF VER10P}, FField is TWideMemoField{$ENDIF});
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
procedure TBlobStream.SetSize(NewSize: Int64);
|
|
{$ELSE}
|
|
procedure TBlobStream.SetSize(NewSize: Longint);
|
|
{$ENDIF}
|
|
begin
|
|
if FOpened then
|
|
FDataSet.Data.SetBlobSize(FFieldNo, FBuffer, NewSize, (FDataSet.State = dsOldValue)
|
|
{$IFDEF VER10P}, (FField is TWideMemoField){$ENDIF});
|
|
end;
|
|
|
|
class function TMemDSUtils.SetBlob(Obj: TMemDataSet; Field: TField; Blob: TBlob): boolean;
|
|
begin
|
|
Result := Obj.SetBlob(Field, Blob);
|
|
end;
|
|
|
|
class function TMemDSUtils.GetBlob(Obj: TMemDataSet; FieldDesc: TFieldDesc): TBlob;
|
|
begin
|
|
Result := Obj.InternalGetBlob(FieldDesc);
|
|
end;
|
|
|
|
end.
|