Permalink
Cannot retrieve contributors at this time
/// DB VCL read-only virtual dataset | |
// - this unit is a part of the freeware Synopse framework, | |
// licensed under a MPL/GPL/LGPL tri-license; version 1.18 | |
unit SynVirtualDataSet; | |
{ | |
This file is part of Synopse framework. | |
Synopse framework. Copyright (C) 2021 Arnaud Bouchez | |
Synopse Informatique - https://synopse.info | |
*** BEGIN LICENSE BLOCK ***** | |
Version: MPL 1.1/GPL 2.0/LGPL 2.1 | |
The contents of this file are subject to the Mozilla Public License Version | |
1.1 (the "License"); you may not use this file except in compliance with | |
the License. You may obtain a copy of the License at | |
http://www.mozilla.org/MPL | |
Software distributed under the License is distributed on an "AS IS" basis, | |
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License | |
for the specific language governing rights and limitations under the License. | |
The Original Code is Synopse mORMot framework. | |
The Initial Developer of the Original Code is Arnaud Bouchez. | |
Portions created by the Initial Developer are Copyright (C) 2021 | |
the Initial Developer. All Rights Reserved. | |
Contributor(s): | |
- Alfred Glaenzer (alf) | |
- Esteban Martin (EMartin) | |
- mingda | |
- Murat Ak | |
- Valentin (StxLog) | |
Alternatively, the contents of this file may be used under the terms of | |
either the GNU General Public License Version 2 or later (the "GPL"), or | |
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), | |
in which case the provisions of the GPL or the LGPL are applicable instead | |
of those above. If you wish to allow use of your version of this file only | |
under the terms of either the GPL or the LGPL, and not to allow others to | |
use your version of this file under the terms of the MPL, indicate your | |
decision by deleting the provisions above and replace them with the notice | |
and other provisions required by the GPL or the LGPL. If you do not delete | |
the provisions above, a recipient may use your version of this file under | |
the terms of any one of the MPL, the GPL or the LGPL. | |
***** END LICENSE BLOCK ***** | |
} | |
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER | |
interface | |
uses | |
SysUtils, | |
Classes, | |
{$ifndef FPC} | |
Contnrs, | |
{$endif} | |
{$ifndef NOVARIANTS} | |
Variants, | |
{$endif} | |
SynCommons, | |
SynTable, | |
{$ifdef ISDELPHIXE2} | |
System.Generics.Collections, | |
Data.DB, Data.FMTBcd; | |
{$else} | |
DB, FMTBcd; | |
{$endif} | |
type | |
{$ifndef UNICODE} // defined as TRecordBuffer = PByte in newer DB.pas | |
TRecordBuffer = PChar; | |
{$endif UNICODE} | |
PDateTimeRec = ^TDateTimeRec; | |
/// read-only virtual TDataSet able to access any content | |
TSynVirtualDataSet = class(TDataSet) | |
protected | |
fCurrentRow: integer; | |
fIsCursorOpen: boolean; | |
// TDataSet overridden methods | |
function AllocRecordBuffer: TRecordBuffer; override; | |
procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override; | |
procedure InternalInitRecord(Buffer: TRecordBuffer); override; | |
function GetCanModify: Boolean; override; | |
procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; | |
function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override; | |
function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; | |
function GetRecordSize: Word; override; | |
procedure InternalClose; override; | |
procedure InternalFirst; override; | |
procedure InternalGotoBookmark(Bookmark: Pointer); override; | |
procedure InternalHandleException; override; | |
procedure InternalLast; override; | |
procedure InternalSetToRecord(Buffer: TRecordBuffer); override; | |
function IsCursorOpen: Boolean; override; | |
procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override; | |
procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; | |
procedure SetRecNo(Value: Integer); override; | |
function GetRecNo: Integer; override; | |
// classses should override all those following methods: | |
// - to read the data e.g. into memory: | |
procedure InternalOpen; override; | |
// - to initialize FieldDefs: | |
// procedure InternalInitFieldDefs; override; | |
// - to return row count: | |
// function GetRecordCount: Integer; override; | |
// - result should point to Int64,Double,Blob,UTF8 data (if ResultLen<>nil) | |
function GetRowFieldData(Field: TField; RowIndex: integer; out ResultLen: Integer; | |
OnlyCheckNull: boolean): Pointer; virtual; abstract; | |
// - to search for a field, returning RecNo (0 = not found by default) | |
function SearchForField(const aLookupFieldName: RawUTF8; const aLookupValue: variant; | |
aOptions: TLocateOptions): integer; virtual; | |
{$ifndef NOVARIANTS} | |
// used to serialize TBCDVariant as JSON - BcdRead will always fail | |
class procedure BcdWrite(const aWriter: TTextWriter; const aValue); | |
//class function BcdRead(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char; | |
{$endif} | |
public | |
/// this overridden constructor will compute an unique Name property | |
constructor Create(Owner: TComponent); override; | |
/// get BLOB column data for the current active row | |
// - handle ftBlob,ftMemo,ftWideMemo via GetRowFieldData() | |
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; | |
/// get BLOB column data for a given row (may not the active row) | |
// - handle ftBlob,ftMemo,ftWideMemo via GetRowFieldData() | |
function GetBlobStream(Field: TField; RowIndex: integer): TStream; | |
/// get column data for the current active row | |
// - handle ftBoolean,ftInteger,ftLargeint,ftFloat,ftCurrency,ftDate,ftTime, | |
// ftDateTime,ftString,ftWideString kind of fields via GetRowFieldData() | |
{$ifdef ISDELPHIXE3} | |
{$ifdef ISDELPHIXE4} | |
function GetFieldData(Field: TField; var Buffer: TValueBuffer): Boolean; override; | |
{$else} | |
function GetFieldData(Field: TField; Buffer: TValueBuffer): Boolean; override; | |
{$endif} | |
{$else} | |
function GetFieldData(Field: TField; Buffer: pointer): Boolean; override; | |
{$endif} | |
{$ifndef UNICODE} | |
function GetFieldData(Field: TField; Buffer: pointer; NativeFormat: Boolean): Boolean; override; | |
{$endif} | |
/// searching a dataset for a specified record and making it the active record | |
// - will call SearchForField protected virtual method for actual lookup | |
function Locate(const KeyFields: string; const KeyValues: Variant; | |
Options: TLocateOptions) : boolean; override; | |
published | |
property Active; | |
property BeforeOpen; | |
property AfterOpen; | |
property BeforeClose; | |
property AfterClose; | |
property BeforeInsert; | |
property AfterInsert; | |
property BeforeEdit; | |
property AfterEdit; | |
property BeforePost; | |
property AfterPost; | |
property BeforeCancel; | |
property AfterCancel; | |
property BeforeDelete; | |
property AfterDelete; | |
property BeforeScroll; | |
property AfterScroll; | |
property OnCalcFields; | |
property OnDeleteError; | |
property OnEditError; | |
property OnFilterRecord; | |
property OnNewRecord; | |
property OnPostError; | |
end; | |
{$ifndef NOVARIANTS} | |
/// read-only virtual TDataSet able to access a dynamic array of TDocVariant | |
// - could be used e.g. from the result of TMongoCollection.FindDocs() to | |
// avoid most temporary conversion into JSON or TClientDataSet buffers | |
TDocVariantArrayDataSet = class(TSynVirtualDataSet) | |
protected | |
fValues: TVariantDynArray; | |
fColumns: array of record | |
Name: RawUTF8; | |
FieldType: TSQLDBFieldType; | |
end; | |
fTemp64: Int64; | |
fTempUTF8: RawUTF8; | |
fTempBlob: RawByteString; | |
procedure InternalInitFieldDefs; override; | |
function GetRecordCount: Integer; override; | |
function GetRowFieldData(Field: TField; RowIndex: integer; | |
out ResultLen: Integer; OnlyCheckNull: boolean): Pointer; override; | |
function SearchForField(const aLookupFieldName: RawUTF8; const aLookupValue: variant; | |
aOptions: TLocateOptions): integer; override; | |
public | |
/// initialize the virtual TDataSet from a dynamic array of TDocVariant | |
// - you can set the expected column names and types matching the results | |
// document layout - if no column information is specified, the first | |
// TDocVariant will be used as reference | |
constructor Create(Owner: TComponent; const Data: TVariantDynArray; | |
const ColumnNames: array of RawUTF8; const ColumnTypes: array of TSQLDBFieldType); reintroduce; | |
end; | |
{$endif} | |
const | |
/// map the VCL string type, depending on the Delphi compiler version | |
{$ifdef UNICODE} | |
ftDefaultVCLString = ftWideString; | |
{$else} | |
ftDefaultVCLString = ftString; | |
{$endif} | |
/// map the best ft*Memo type available, depending on the Delphi compiler version | |
{$ifdef ISDELPHI2007ANDUP} | |
ftDefaultMemo = ftWideMemo; | |
{$else} | |
ftDefaultMemo = ftMemo; | |
{$endif} | |
/// append a TBcd value as text to the output buffer | |
// - very optimized for speed | |
procedure AddBcd(WR: TTextWriter; const AValue: TBcd); | |
type | |
/// a string buffer, used by InternalBCDToBuffer to store its output text | |
TBCDBuffer = array[0..66] of AnsiChar; | |
/// convert a TBcd value as text to the output buffer | |
// - buffer is to be array[0..66] of AnsiChar | |
// - returns the resulting text start in PBeg, and the length as function result | |
// - does not handle negative sign and 0 value - see AddBcd() function use case | |
// - very optimized for speed | |
function InternalBCDToBuffer(const AValue: TBcd; out ADest: TBCDBuffer; var PBeg: PAnsiChar): integer; | |
/// convert a TBcd value into a currency | |
// - purepascal version included in latest Delphi versions is slower than this | |
function BCDToCurr(const AValue: TBcd; var Curr: Currency): boolean; | |
/// convert a TBcd value into a RawUTF8 text | |
// - will call fast InternalBCDToBuffer function | |
procedure BCDToUTF8(const AValue: TBcd; var result: RawUTF8); overload; | |
/// convert a TBcd value into a RawUTF8 text | |
// - will call fast InternalBCDToBuffer function | |
function BCDToUTF8(const AValue: TBcd): RawUTF8; overload; | |
{$ifdef HASINLINE}inline;{$endif} | |
/// convert a TBcd value into a VCL string text | |
// - will call fast InternalBCDToBuffer function | |
function BCDToString(const AValue: TBcd): string; | |
/// export all rows of a TDataSet into JSON | |
// - will work for any kind of TDataSet | |
function DataSetToJSON(Data: TDataSet): RawUTF8; | |
{$ifndef NOVARIANTS} | |
/// convert a dynamic array of TDocVariant result into a VCL DataSet | |
// - this function is just a wrapper around TDocVariantArrayDataSet.Create() | |
// - the TDataSet will be opened once created | |
function ToDataSet(aOwner: TComponent; const Data: TVariantDynArray; | |
const ColumnNames: array of RawUTF8; const ColumnTypes: array of TSQLDBFieldType): TDocVariantArrayDataSet; overload; | |
{$endif} | |
implementation | |
function InternalBCDToBuffer(const AValue: TBcd; out ADest: TBCDBuffer; var PBeg: PAnsiChar): integer; | |
var i,DecimalPos: integer; | |
P,Frac: PByte; | |
PEnd: PAnsiChar; | |
begin | |
result := 0; | |
if AValue.Precision=0 then | |
exit; | |
DecimalPos := AValue.Precision-(AValue.SignSpecialPlaces and $3F); | |
P := @ADest; | |
Frac := @Avalue.Fraction; | |
for i := 0 to AValue.Precision-1 do begin | |
if i=DecimalPos then | |
if i=0 then begin | |
PWord(P)^ := ord('0')+ord('.')shl 8; | |
inc(P,2); | |
end else begin | |
P^ := ord('.'); | |
inc(P); | |
end; | |
if (i and 1)=0 then | |
P^ := ((Frac^ and $F0) shr 4)+ord('0') else begin | |
P^ := ((Frac^ and $0F))+ord('0'); | |
inc(Frac); | |
end; | |
inc(P); | |
end; | |
// remove trailing 0 after decimal | |
if AValue.Precision>DecimalPos then begin | |
repeat dec(P) until (P^<>ord('0')) or (P=@ADest); | |
PEnd := pointer(P); | |
if PEnd^<>'.' then | |
inc(PEnd); | |
end else | |
PEnd := pointer(P); | |
PEnd^ := #0; | |
// remove leading 0 | |
PBeg := @ADest; | |
while (PBeg[0]='0') and (PBeg[1] in ['0'..'9']) do inc(PBeg); | |
result := PEnd-PBeg; | |
end; | |
procedure AddBcd(WR: TTextWriter; const AValue: TBcd); | |
var len: integer; | |
PBeg: PAnsiChar; | |
tmp: TBCDBuffer; | |
begin | |
len := InternalBCDToBuffer(AValue,tmp,PBeg); | |
if len<=0 then | |
WR.Add('0') else begin | |
if AValue.SignSpecialPlaces and $80=$80 then | |
WR.Add('-'); | |
WR.AddNoJSONEscape(PBeg,len); | |
end; | |
end; | |
function BCDToCurr(const AValue: TBcd; var Curr: Currency): boolean; | |
var len: integer; | |
PBeg: PAnsiChar; | |
tmp: TBCDBuffer; | |
begin | |
len := InternalBCDToBuffer(AValue,tmp,PBeg); | |
if len<=0 then | |
Curr := 0 else begin | |
PInt64(@Curr)^ := StrToCurr64(pointer(PBeg)); | |
if AValue.SignSpecialPlaces and $80=$80 then | |
Curr := -Curr; | |
end; | |
result := true; | |
end; | |
procedure BCDToUTF8(const AValue: TBcd; var result: RawUTF8); | |
var len: integer; | |
PBeg: PAnsiChar; | |
tmp: TBCDBuffer; | |
begin | |
len := InternalBCDToBuffer(AValue,tmp,PBeg); | |
SetString(result,PBeg,len); | |
end; | |
function BCDToUTF8(const AValue: TBcd): RawUTF8; | |
begin | |
BCDToUTF8(AValue,result); | |
end; | |
function BCDToString(const AValue: TBcd): string; | |
var len: integer; | |
PBeg: PAnsiChar; | |
tmp: TBCDBuffer; | |
begin | |
len := InternalBCDToBuffer(AValue,tmp,PBeg); | |
Ansi7ToString(PWinAnsiChar(PBeg),len,result); | |
end; | |
var | |
GlobalDataSetCount: integer; | |
type | |
/// define how a single row is identified | |
// - for TSynVirtualDataSet, it is just the row index (starting at 0) | |
TRecInfoIdentifier = integer; | |
PRecInfoIdentifier = ^TRecInfoIdentifier; | |
/// pointer to an internal structure used to identify a row position | |
PRecInfo = ^TRecInfo; | |
/// internal structure used to identify a row position | |
TRecInfo = record | |
/// define how a single row is identified | |
RowIndentifier: TRecInfoIdentifier; | |
/// any associated bookmark | |
Bookmark: TRecInfoIdentifier; | |
/// any associated bookmark flag | |
BookmarkFlag: TBookmarkFlag; | |
end; | |
{ TSynVirtualDataSet } | |
function TSynVirtualDataSet.AllocRecordBuffer: TRecordBuffer; | |
begin | |
result := AllocMem(sizeof(TRecInfo)); | |
end; | |
procedure TSynVirtualDataSet.FreeRecordBuffer(var Buffer: TRecordBuffer); | |
begin | |
FreeMem(Buffer); | |
Buffer := nil; | |
end; | |
procedure TSynVirtualDataSet.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); | |
begin | |
PRecInfoIdentifier(Data)^ := PRecInfo(Buffer)^.Bookmark; | |
end; | |
function TSynVirtualDataSet.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; | |
begin | |
result := PRecInfo(Buffer)^.BookmarkFlag; | |
end; | |
function TSynVirtualDataSet.GetCanModify: Boolean; | |
begin | |
result := false; // we define a READ-ONLY TDataSet | |
end; | |
{$ifndef UNICODE} | |
function TSynVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer; | |
NativeFormat: Boolean): Boolean; | |
begin | |
if Field.DataType in [ftWideString] then | |
NativeFormat := true; // to force Buffer as PWideString | |
Result := inherited GetFieldData(Field, Buffer, NativeFormat); | |
end; | |
{$endif} | |
{$ifdef ISDELPHIXE3} | |
{$ifdef ISDELPHIXE4} | |
function TSynVirtualDataSet.GetFieldData(Field: TField; var Buffer: TValueBuffer): Boolean; | |
{$else} | |
function TSynVirtualDataSet.GetFieldData(Field: TField; Buffer: TValueBuffer): Boolean; | |
{$endif} | |
{$else} | |
function TSynVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; | |
{$endif} | |
var Data, Dest: pointer; | |
RowIndex, DataLen, MaxLen: integer; | |
Temp: RawByteString; | |
OnlyTestForNull: boolean; | |
TS: TTimeStamp; | |
begin | |
OnlyTestForNull := (Buffer=nil); | |
RowIndex := PRecInfo(ActiveBuffer).RowIndentifier; | |
Data := GetRowFieldData(Field,RowIndex,DataLen,OnlyTestForNull); | |
result := Data<>nil; // null field or out-of-range RowIndex/Field | |
if OnlyTestForNull or not result then | |
exit; | |
Dest := pointer(Buffer); // works also if Buffer is [var] TValueBuffer | |
case Field.DataType of // Data^ points to Int64,Double,Blob,UTF8 | |
ftBoolean: | |
PWORDBOOL(Dest)^ := PBoolean(Data)^; | |
ftInteger: | |
PInteger(Dest)^ := PInteger(Data)^; | |
ftLargeint, ftFloat, ftCurrency: | |
PInt64(Dest)^ := PInt64(Data)^; | |
ftDate, ftTime, ftDateTime: | |
if PDateTime(Data)^=0 then // handle 30/12/1899 date as NULL | |
result := false else begin // inlined DataConvert(Field,Data,Dest,true) | |
TS := DateTimeToTimeStamp(PDateTime(Data)^); | |
case Field.DataType of | |
ftDate: PDateTimeRec(Dest)^.Date := TS.Date; | |
ftTime: PDateTimeRec(Dest)^.Time := TS.Time; | |
ftDateTime: | |
if (TS.Time<0) or (TS.Date<=0) then | |
result := false else // matches ValidateTimeStamp() expectations | |
PDateTimeRec(Dest)^.DateTime := TimeStampToMSecs(TS); | |
end; // see NativeToDateTime/DateTimeToNative in TDataSet.DataConvert | |
end; | |
ftString: begin | |
if DataLen<>0 then begin | |
CurrentAnsiConvert.UTF8BufferToAnsi(Data,DataLen,Temp); | |
DataLen := length(Temp); | |
MaxLen := Field.DataSize-1; // without trailing #0 | |
if DataLen>MaxLen then | |
DataLen := MaxLen; | |
move(pointer(Temp)^,Dest^,DataLen); | |
end; | |
PAnsiChar(Dest)[DataLen] := #0; | |
end; | |
ftWideString: begin | |
{$ifdef ISDELPHI2007ANDUP} // here Dest = PWideChar[] of DataSize bytes | |
if DataLen=0 then | |
PWideChar(Dest)^ := #0 else | |
UTF8ToWideChar(Dest,Data,(Field.DataSize-2)shr 1,DataLen); | |
{$else} // here Dest is PWideString | |
UTF8ToWideString(Data,DataLen,WideString(Dest^)); | |
{$endif} | |
end; | |
// ftBlob,ftMemo,ftWideMemo should be retrieved by CreateBlobStream() | |
else raise EDatabaseError.CreateFmt('%s.GetFieldData unhandled DataType=%s (%d)', | |
[ClassName,GetEnumName(TypeInfo(TFieldType),ord(Field.DataType))^,ord(Field.DataType)]); | |
end; | |
end; | |
function TSynVirtualDataSet.GetBlobStream(Field: TField; RowIndex: integer): TStream; | |
var Data: pointer; | |
DataLen: integer; | |
begin | |
Data := GetRowFieldData(Field,RowIndex,DataLen,false); | |
if Data=nil then // should point to Blob or UTF8 data | |
result := nil else | |
case Field.DataType of | |
ftBlob: | |
result := TSynMemoryStream.Create(Data,DataLen); | |
ftMemo, ftString: | |
result := TRawByteStringStream.Create(CurrentAnsiConvert.UTF8BufferToAnsi(Data,DataLen)); | |
{$ifdef ISDELPHI2007ANDUP} ftWideMemo, {$endif} ftWideString: | |
result := TRawByteStringStream.Create(Utf8DecodeToRawUnicode(Data,DataLen)); | |
else raise EDatabaseError.CreateFmt('%s.CreateBlobStream DataType=%d', | |
[ClassName,ord(Field.DataType)]); | |
end; | |
end; | |
function TSynVirtualDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; | |
begin | |
if Mode<>bmRead then | |
raise EDatabaseError.CreateFmt('%s BLOB should be ReadOnly',[ClassName]); | |
result := GetBlobStream(Field,PRecInfo(ActiveBuffer).RowIndentifier); | |
if result=nil then | |
result := TSynMemoryStream.Create; // null BLOB returns a void TStream | |
end; | |
function TSynVirtualDataSet.GetRecNo: Integer; | |
begin | |
result := fCurrentRow+1; | |
end; | |
function TSynVirtualDataSet.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; | |
DoCheck: Boolean): TGetResult; | |
begin | |
result := grOK; | |
case GetMode of | |
gmPrior: | |
if fCurrentRow>0 then | |
dec(fCurrentRow) else | |
result := grBOF; | |
gmCurrent: | |
if fCurrentRow<0 then | |
result := grBOF else | |
if fCurrentRow>=GetRecordCount then | |
result := grEOF; | |
gmNext: | |
if fCurrentRow<GetRecordCount-1 then | |
inc(fCurrentRow) else | |
result := grEOF; | |
end; | |
if result=grOK then | |
with PRecInfo(Buffer)^ do begin | |
RowIndentifier := fCurrentRow; | |
BookmarkFlag := bfCurrent; | |
Bookmark := fCurrentRow; | |
end; | |
end; | |
function TSynVirtualDataSet.GetRecordSize: Word; | |
begin | |
result := SizeOf(TRecInfoIdentifier); // excluding Bookmark information | |
end; | |
procedure TSynVirtualDataSet.InternalClose; | |
begin | |
BindFields(false); | |
{$ifdef ISDELPHIXE6} | |
if not(lcPersistent in Fields.LifeCycles) then | |
{$else} | |
if DefaultFields then | |
{$endif} | |
DestroyFields; | |
fIsCursorOpen := False; | |
end; | |
procedure TSynVirtualDataSet.InternalFirst; | |
begin | |
fCurrentRow := -1; | |
end; | |
procedure TSynVirtualDataSet.InternalGotoBookmark(Bookmark: Pointer); | |
begin | |
fCurrentRow := PRecInfoIdentifier(Bookmark)^; | |
end; | |
procedure TSynVirtualDataSet.InternalHandleException; | |
begin | |
if Assigned(Classes.ApplicationHandleException) then | |
Classes.ApplicationHandleException(ExceptObject) else | |
SysUtils.ShowException(ExceptObject,ExceptAddr); | |
end; | |
procedure TSynVirtualDataSet.InternalInitRecord(Buffer: TRecordBuffer); | |
begin | |
FillcharFast(Buffer^,sizeof(TRecInfo),0); | |
end; | |
procedure TSynVirtualDataSet.InternalLast; | |
begin | |
fCurrentRow := GetRecordCount; | |
end; | |
procedure TSynVirtualDataSet.InternalOpen; | |
begin | |
BookmarkSize := SizeOf(TRecInfo)-sizeof(TRecInfoIdentifier); | |
InternalInitFieldDefs; | |
{$ifdef ISDELPHIXE6} | |
if not(lcPersistent in Fields.LifeCycles) then | |
{$else} | |
if DefaultFields then | |
{$endif} | |
CreateFields; | |
BindFields(true); | |
fCurrentRow := -1; | |
fIsCursorOpen := True; | |
end; | |
procedure TSynVirtualDataSet.InternalSetToRecord(Buffer: TRecordBuffer); | |
begin | |
fCurrentRow := PRecInfo(Buffer).RowIndentifier; | |
end; | |
function TSynVirtualDataSet.IsCursorOpen: Boolean; | |
begin | |
result := fIsCursorOpen; | |
end; | |
procedure TSynVirtualDataSet.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); | |
begin | |
PRecInfo(Buffer)^.Bookmark := PRecInfoIdentifier(Data)^; | |
end; | |
procedure TSynVirtualDataSet.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); | |
begin | |
PRecInfo(Buffer)^.BookmarkFlag := Value; | |
end; | |
procedure TSynVirtualDataSet.SetRecNo(Value: Integer); | |
begin | |
CheckBrowseMode; | |
if Value<>RecNo then begin | |
dec(Value); | |
if cardinal(Value)>=cardinal(GetRecordCount) then | |
raise ERangeError.CreateFmt('%s.SetRecNo(%d) with Count=%d', | |
[ClassName,Value+1,GetRecordCount]); | |
DoBeforeScroll; | |
fCurrentRow := Value; | |
Resync([rmCenter]); | |
DoAfterScroll; | |
end; | |
end; | |
constructor TSynVirtualDataSet.Create(Owner: TComponent); | |
begin | |
inherited Create(Owner); | |
inc(GlobalDataSetCount); | |
Name := ClassName+IntToStr(GlobalDataSetCount); // force unique name | |
end; | |
function TSynVirtualDataSet.SearchForField(const aLookupFieldName: RawUTF8; | |
const aLookupValue: variant; aOptions: TLocateOptions): integer; | |
begin | |
result := 0; // nothing found | |
end; | |
function TSynVirtualDataSet.Locate(const KeyFields: string; | |
const KeyValues: Variant; Options: TLocateOptions) : boolean; | |
var i, l, h, found: Integer; | |
{$ifdef ISDELPHIXE4} | |
FieldList: TList<TField>; | |
{$else} | |
FieldList: TList; | |
{$endif} | |
begin | |
CheckActive; | |
result := true; | |
if not IsEmpty then | |
if VarIsArray(KeyValues) then begin | |
{$ifdef ISDELPHIXE4} | |
FieldList := TList<TField>.Create; | |
{$else} | |
FieldList := TList.Create; | |
{$endif} | |
try | |
GetFieldList(FieldList,KeyFields); | |
l := VarArrayLowBound(KeyValues,1); | |
h := VarArrayHighBound(KeyValues,1); | |
if (FieldList.Count = 1) and (l < h) then begin | |
found := SearchForField(StringToUTF8(KeyFields),KeyValues,Options); | |
if found>0 then begin | |
RecNo := found; | |
exit; | |
end; | |
end | |
else for i := 0 to FieldList.Count - 1 do begin | |
found := SearchForField(StringToUTF8(TField(FieldList[i]).FieldName), | |
KeyValues[l+i],Options); | |
if found>0 then begin | |
RecNo := found; | |
exit; | |
end; | |
end; | |
finally | |
FieldList.Free; | |
end; | |
end else begin | |
found := SearchForField(StringToUTF8(KeyFields),KeyValues,Options); | |
if found>0 then begin | |
RecNo := found; | |
exit; | |
end; | |
end; | |
result := false; | |
end; | |
{$ifndef NOVARIANTS} | |
type // as in FMTBcd.pas | |
TFMTBcdData = class(TPersistent) | |
private | |
FBcd: TBcd; | |
end; | |
TFMTBcdVarData = packed record | |
VType: TVarType; | |
Reserved1, Reserved2, Reserved3: Word; | |
VBcd: TFMTBcdData; | |
Reserved4: Cardinal; | |
end; | |
class procedure TSynVirtualDataSet.BcdWrite(const aWriter: TTextWriter; const aValue); | |
begin | |
AddBCD(aWriter,TFMTBcdVarData(aValue).VBcd.FBcd); | |
end; | |
{$endif NOVARIANTS} | |
function DataSetToJSON(Data: TDataSet): RawUTF8; | |
var W: TJSONWriter; | |
f: integer; | |
blob: TRawByteStringStream; | |
begin | |
result := 'null'; | |
if Data=nil then | |
exit; | |
Data.First; | |
if Data.Eof then | |
exit; | |
W := TJSONWriter.Create(nil,true,false); | |
try | |
// get col names and types | |
SetLength(W.ColNames,Data.FieldCount); | |
for f := 0 to high(W.ColNames) do | |
StringToUTF8(Data.FieldDefs[f].Name,W.ColNames[f]); | |
W.AddColumns; | |
W.Add('['); | |
repeat | |
W.Add('{'); | |
for f := 0 to Data.FieldCount-1 do begin | |
W.AddString(W.ColNames[f]); | |
with Data.Fields[f] do | |
if IsNull then | |
W.AddShort('null') else | |
case DataType of | |
ftBoolean: | |
W.Add(AsBoolean); | |
ftSmallint, ftInteger, ftWord, ftAutoInc: | |
W.Add(AsInteger); | |
ftLargeint: | |
W.Add(TLargeintField(Data.Fields[f]).AsLargeInt); | |
ftFloat, ftCurrency: // TCurrencyField is sadly a TFloatField | |
W.Add(AsFloat,TFloatField(Data.Fields[f]).Precision); | |
ftBCD: | |
W.AddCurr64(AsCurrency); | |
ftFMTBcd: | |
AddBcd(W,AsBCD); | |
ftTimeStamp, ftDate, ftTime, ftDateTime: begin | |
W.Add('"'); | |
W.AddDateTime(AsDateTime); | |
W.Add('"'); | |
end; | |
ftString, ftFixedChar, ftMemo, ftGuid: begin | |
W.Add('"'); | |
W.AddAnsiString({$ifdef UNICODE}AsAnsiString{$else}AsString{$endif}, | |
twJSONEscape); | |
W.Add('"'); | |
end; | |
ftWideString: begin | |
W.Add('"'); | |
W.AddJSONEscapeW(pointer(TWideStringField(Data.Fields[f]).Value)); | |
W.Add('"'); | |
end; | |
ftVariant: | |
W.AddVariant(AsVariant); | |
ftBytes, ftVarBytes, ftBlob, ftGraphic, ftOraBlob, ftOraClob: begin | |
blob := TRawByteStringStream.Create; | |
try | |
(Data.Fields[f] as TBlobField).SaveToStream(blob); | |
W.WrBase64(pointer(blob.DataString),length(blob.DataString),true); | |
finally | |
blob.Free; | |
end; | |
end; | |
{$ifdef ISDELPHI2007ANDUP} | |
ftWideMemo, ftFixedWideChar: begin | |
W.Add('"'); | |
W.AddJSONEscapeW(pointer(AsWideString)); | |
W.Add('"'); | |
end; | |
{$endif} | |
{$ifdef UNICODE} | |
ftShortint, ftByte: | |
W.Add(AsInteger); | |
ftLongWord: | |
W.AddU(TLongWordField(Data.Fields[f]).Value); | |
ftExtended: | |
W.AddDouble(AsFloat); | |
ftSingle: | |
W.Add(AsFloat,SINGLE_PRECISION); | |
{$endif} | |
else W.AddShort('null'); // unhandled field type | |
end; | |
W.Add(','); | |
end; | |
W.CancelLastComma; | |
W.Add('}',','); | |
Data.Next; | |
until Data.Eof; | |
W.CancelLastComma; | |
W.Add(']'); | |
W.SetText(result); | |
finally | |
W.Free; | |
end; | |
end; | |
{ TDocVariantArrayDataSet } | |
constructor TDocVariantArrayDataSet.Create(Owner: TComponent; | |
const Data: TVariantDynArray; const ColumnNames: array of RawUTF8; | |
const ColumnTypes: array of TSQLDBFieldType); | |
var n,ndx,j: PtrInt; | |
first: PDocVariantData; | |
begin | |
fValues := Data; | |
n := Length(ColumnNames); | |
if n>0 then begin | |
if n<>length(ColumnTypes) then | |
raise ESynException.CreateUTF8('%.Create(ColumnNames<>ColumnTypes)',[self]); | |
SetLength(fColumns,n); | |
for ndx := 0 to n-1 do begin | |
fColumns[ndx].Name := ColumnNames[ndx]; | |
fColumns[ndx].FieldType := ColumnTypes[ndx]; | |
end; | |
end else | |
if fValues<>nil then begin | |
first := _Safe(fValues[0],dvObject); | |
SetLength(fColumns,first^.Count); | |
for ndx := 0 to first^.Count-1 do begin | |
fColumns[ndx].Name := first^.Names[ndx]; | |
fColumns[ndx].FieldType := VariantTypeToSQLDBFieldType(first^.Values[ndx]); | |
case fColumns[ndx].FieldType of | |
SynTable.ftNull: | |
fColumns[ndx].FieldType := SynTable.ftBlob; | |
SynTable.ftCurrency: | |
fColumns[ndx].FieldType := SynTable.ftDouble; | |
SynTable.ftInt64: // ensure type coherency of whole column | |
for j := 1 to first^.Count-1 do | |
if j>=Length(fValues) then // check objects are consistent | |
break else | |
with _Safe(fValues[j],dvObject)^ do | |
if (ndx<Length(Names)) and IdemPropNameU(Names[ndx],fColumns[ndx].Name) then | |
if VariantTypeToSQLDBFieldType(Values[ndx]) in | |
[SynTable.ftNull,SynTable.ftDouble,SynTable.ftCurrency] then begin | |
fColumns[ndx].FieldType := SynTable.ftDouble; | |
break; | |
end; | |
end; | |
end; | |
end; | |
inherited Create(Owner); | |
end; | |
function TDocVariantArrayDataSet.GetRecordCount: Integer; | |
begin | |
result := length(fValues); | |
end; | |
function TDocVariantArrayDataSet.GetRowFieldData(Field: TField; | |
RowIndex: integer; out ResultLen: Integer; OnlyCheckNull: boolean): Pointer; | |
var F,ndx: integer; | |
wasString: Boolean; | |
begin | |
result := nil; | |
F := Field.Index; | |
if (cardinal(RowIndex)<cardinal(length(fValues))) and | |
(cardinal(F)<cardinal(length(fColumns))) and | |
not (fColumns[F].FieldType in [ftNull,SynTable.ftUnknown,SynTable.ftCurrency]) then | |
with _Safe(fValues[RowIndex])^ do | |
if (Kind=dvObject) and (Count>0) then begin | |
if IdemPropNameU(fColumns[F].Name,Names[F]) then | |
ndx := F else // optimistic match | |
ndx := GetValueIndex(fColumns[F].Name); | |
if ndx>=0 then | |
if VarIsEmptyOrNull(Values[ndx]) then | |
exit else begin | |
result := @fTemp64; | |
if not OnlyCheckNull then | |
case fColumns[F].FieldType of | |
ftInt64: | |
VariantToInt64(Values[ndx],fTemp64); | |
ftDouble,SynTable.ftDate: | |
VariantToDouble(Values[ndx],unaligned(PDouble(@fTemp64)^)); | |
ftUTF8: begin | |
VariantToUTF8(Values[ndx],fTempUTF8,wasString); | |
result := pointer(fTempUTF8); | |
ResultLen := length(fTempUTF8); | |
end; | |
SynTable.ftBlob: begin | |
VariantToUTF8(Values[ndx],fTempUTF8,wasString); | |
if Base64MagicCheckAndDecode(pointer(fTempUTF8),length(fTempUTF8),fTempBlob) then begin | |
result := pointer(fTempBlob); | |
ResultLen := length(fTempBlob); | |
end; | |
end; | |
end; | |
end; | |
end; | |
end; | |
procedure TDocVariantArrayDataSet.InternalInitFieldDefs; | |
const TYPES: array[TSQLDBFieldType] of TFieldType = ( | |
// ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob | |
ftWideString,ftWideString,ftLargeint,ftFloat,ftFloat,ftDate,ftWideString,ftBlob); | |
var F,siz: integer; | |
begin | |
FieldDefs.Clear; | |
for F := 0 to high(fColumns) do begin | |
if fColumns[F].FieldType=ftUTF8 then | |
siz := 16 else | |
siz := 0; | |
FieldDefs.Add(UTF8ToString(fColumns[F].Name),TYPES[fColumns[F].FieldType],siz); | |
end; | |
end; | |
function TDocVariantArrayDataSet.SearchForField(const aLookupFieldName: RawUTF8; | |
const aLookupValue: variant; aOptions: TLocateOptions): integer; | |
var f: integer; | |
begin | |
f := -1; // allows O(1) field lookup for invariant object columns | |
for result := 1 to length(fValues) do | |
with _Safe(fValues[result-1])^ do | |
if (Kind=dvObject) and (Count>0) then begin | |
if (cardinal(f)>=cardinal(Count)) or | |
not IdemPropNameU(aLookupFieldName,Names[f]) then | |
f := GetValueIndex(aLookupFieldName); | |
if (f>=0) and (SortDynArrayVariantComp(TVarData(Values[f]), | |
TVarData(aLookupValue),loCaseInsensitive in aOptions)=0) then | |
exit; | |
end; | |
result := 0; | |
end; | |
function ToDataSet(aOwner: TComponent; const Data: TVariantDynArray; | |
const ColumnNames: array of RawUTF8; const ColumnTypes: array of TSQLDBFieldType): TDocVariantArrayDataSet; overload; | |
begin | |
result := TDocVariantArrayDataSet.Create(aOwner,Data,ColumnNames,ColumnTypes); | |
result.Open; | |
end; | |
initialization | |
{$ifndef NOVARIANTS} | |
TTextWriter.RegisterCustomJSONSerializerForVariantByType( | |
VarFMTBcd,nil,TSynVirtualDataSet.BcdWrite); | |
{$endif} | |
end. |