SynVirtualDataSet.pas

/// 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.