/packages/fcl-db/src/json/fpjsondataset.pp

   1{$mode objfpc}
   2{$h+}
   3unit fpjsondataset;
   4
   5interface
   6
   7uses
   8  DB, typinfo, Classes, SysUtils, fpjson;
   9
  10type
  11
  12  { TJSONFieldMapper }
  13  // This class is responsible for mapping the field objects of the records.
  14  TJSONFieldMapper = Class(TObject)
  15    // Return row TJSONData instance with data for field 'FieldName' or 'FieldIndex'.
  16    Function GetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row : TJSONData) : TJSONData; virtual; abstract;
  17    // Same, but now based on TField.
  18    Function GetJSONDataForField(F : TField; Row : TJSONData) : TJSONData; virtual;
  19    // Set data for field 'FieldName' or 'FieldIndex' to supplied TJSONData instance in row
  20    procedure SetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row,Data : TJSONData); virtual; abstract;
  21    // Set data for field TField to supplied TJSONData instance
  22    procedure SetJSONDataForField(F : TField; Row,Data : TJSONData); virtual;
  23    // Create a new row.
  24    Function CreateRow : TJSONData; virtual; abstract;
  25  end;
  26
  27  // JSON has no date/time type, so we use a string field.
  28  // ExtJS provides the date/time  format in it's field config: 'dateFormat'
  29  // The below field classes store this in the NNNFormat field.
  30  { TJSONDateField }
  31
  32  TJSONDateField = Class(TDateField)
  33  private
  34    FDateFormat: String;
  35  Published
  36    Property DateFormat : String Read FDateFormat Write FDateFormat;
  37  end;
  38
  39  { TJSONTimeField }
  40
  41  TJSONTimeField = Class(TTimeField)
  42  private
  43    FTimeFormat: String;
  44  Published
  45    Property TimeFormat : String Read FTimeFormat Write FTimeFormat;
  46  end;
  47
  48  { TJSONDateTimeField }
  49
  50  TJSONDateTimeField = Class(TDateTimeField)
  51  private
  52    FDateTimeFormat: String;
  53  Published
  54    Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat;
  55  end;
  56
  57  { TBaseJSONDataSet }
  58
  59  // basic JSON dataset. Does nothing ExtJS specific.
  60  TBaseJSONDataSet = class (TDataSet)
  61  private
  62    FMUS: Boolean;
  63    FOwnsData : Boolean;
  64    FDefaultList : TFPList;
  65    FCurrentList: TFPList;
  66    FRecordSize: Integer;
  67    FCurrent: Integer;
  68    // Possible metadata to configure fields from.
  69    FMetaData : TJSONObject;
  70    // This will contain the rows.
  71    FRows : TJSONArray;
  72    FFieldMapper : TJSONFieldMapper;
  73    // When editing, this object is edited.
  74    FEditRow : TJSONData;
  75    procedure SetMetaData(AValue: TJSONObject);
  76    procedure SetRows(AValue: TJSONArray);
  77  protected
  78    // dataset virtual methods
  79    function AllocRecordBuffer: TRecordBuffer; override;
  80    procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override;
  81    procedure InternalInitRecord(Buffer: TRecordBuffer); override;
  82    procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
  83    function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override;
  84    function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
  85    function GetRecordSize: Word; override;
  86    procedure InternalClose; override;
  87    procedure InternalDelete; override;
  88    procedure InternalFirst; override;
  89    procedure InternalGotoBookmark(ABookmark: Pointer); override;
  90    procedure InternalLast; override;
  91    procedure InternalOpen; override;
  92    procedure InternalPost; override;
  93    procedure InternalInsert; override;
  94    procedure InternalEdit; override;
  95    procedure InternalCancel; override;
  96    procedure InternalInitFieldDefs; override;
  97    procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
  98    function  GetFieldClass(FieldType: TFieldType): TFieldClass; override;
  99    function IsCursorOpen: Boolean; override;
 100    procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
 101    procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
 102    function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat : Boolean): Boolean; override;
 103    procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat : Boolean); override;
 104    function GetRecordCount: Integer; override;
 105    procedure SetRecNo(Value: Integer); override;
 106    function GetRecNo: Integer; override;
 107  Protected
 108    // New methods.
 109    // Called when dataset is closed. If OwnsData is true, metadata and rows are freed.
 110    Procedure FreeData; virtual;
 111    // Fill default list.
 112    Procedure FillList; virtual;
 113    // Convert MetaData object to FieldDefs.
 114    Procedure MetaDataToFieldDefs; virtual; abstract;
 115    // Initialize Date/Time info in all date/time fields. Called during InternalOpen
 116    procedure InitDateTimeFields; virtual;
 117    // Convert JSON date S to DateTime for Field F
 118    function ConvertDateTimeField(S: String; F: TField): TDateTime; virtual;
 119    // Format JSON date to from DT for Field F
 120    function FormatDateTimeField(DT : TDateTime; F: TField): String; virtual;
 121    // Create fieldmapper. A descendent MUST implement this.
 122    Function CreateFieldMapper : TJSONFieldMapper; virtual; abstract;
 123    // If True, then the dataset will free MetaData and FRows when it is closed.
 124    Property OwnsData : Boolean Read FownsData Write FOwnsData;
 125    // set to true if unknown field types should be handled as string fields.
 126    Property MapUnknownToStringType : Boolean Read FMUS Write FMUS;
 127    // Metadata
 128    Property MetaData : TJSONObject Read FMetaData Write SetMetaData;
 129    // Rows
 130    Property Rows : TJSONArray Read FRows Write SetRows;
 131  public
 132    constructor Create (AOwner: TComponent); override;
 133    destructor Destroy; override;
 134  published
 135    Property FieldDefs;
 136    // redeclared data set properties
 137    property Active;
 138    property BeforeOpen;
 139    property AfterOpen;
 140    property BeforeClose;
 141    property AfterClose;
 142    property BeforeInsert;
 143    property AfterInsert;
 144    property BeforeEdit;
 145    property AfterEdit;
 146    property BeforePost;
 147    property AfterPost;
 148    property BeforeCancel;
 149    property AfterCancel;
 150    property BeforeDelete;
 151    property AfterDelete;
 152    property BeforeScroll;
 153    property AfterScroll;
 154    property OnCalcFields;
 155    property OnDeleteError;
 156    property OnEditError;
 157    property OnFilterRecord;
 158    property OnNewRecord;
 159    property OnPostError;
 160  end;
 161
 162  { TExtJSJSONDataSet }
 163
 164  // Base for ExtJS datasets. It handles MetaData conversion.
 165  TExtJSJSONDataSet = Class(TBaseJSONDataset)
 166  Private
 167    FFields : TJSONArray;
 168  Protected
 169    Function GenerateMetaData : TJSONObject;
 170    function ConvertDateFormat(S: String): String; virtual;
 171    Procedure MetaDataToFieldDefs; override;
 172    procedure InitDateTimeFields; override;
 173    function StringToFieldType(S: String): TFieldType;virtual;
 174    function GetStringFieldLength(F: TJSONObject; AName: String; AIndex: Integer): integer; virtual;
 175  Public
 176    // Use this to load MetaData/Rows from stream.
 177    // If no metadata is present in the stream, FieldDefs must be filled manually.
 178    Procedure LoadFromStream(S : TStream);
 179    // Use this to load MetaData/Rows from file.
 180    // If no metadata is present in the file, FieldDefs must be filled manually.
 181    Procedure LoadFromFile(Const AFileName: string);
 182    // Use this to save Rows and optionally metadata to Stream.
 183    // Note that MetaData must be set.
 184    Procedure SaveToStream(S : TStream; SaveMetaData : Boolean);
 185    // Use this to save Rows and optionally metadata to Stream.
 186    // Note that MetaData must be set.
 187    Procedure SaveToFile(Const AFileName : String; SaveMetaData : Boolean);
 188    // Can be set directly if the dataset is closed.
 189    Property MetaData;
 190    // Can be set directly if the dataset is closed. If metadata is set, it must match the data.
 191    Property Rows;
 192  Published
 193    Property OwnsData;
 194  end;
 195
 196  { TExtJSJSONObjectDataSet }
 197  // Use this dataset for data where the data is an array of objects.
 198  TExtJSJSONObjectDataSet = Class(TExtJSJSONDataSet)
 199    Function CreateFieldMapper : TJSONFieldMapper; override;
 200  end;
 201
 202  { TExtJSJSONArrayDataSet }
 203  // Use this dataset for data where the data is an array of arrays.
 204  TExtJSJSONArrayDataSet = Class(TExtJSJSONDataSet)
 205    Function CreateFieldMapper : TJSONFieldMapper; override;
 206  end;
 207
 208  { TJSONObjectFieldMapper }
 209  // Fieldmapper to be used when the data is in an object
 210  TJSONObjectFieldMapper = Class(TJSONFieldMapper)
 211    procedure SetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row,Data : TJSONData); override;
 212    Function GetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row : TJSONData) : TJSONData; override;
 213    Function CreateRow : TJSONData; override;
 214  end;
 215
 216  { TJSONArrayFieldMapper }
 217  // Fieldmapper to be used when the data is in an array
 218  TJSONArrayFieldMapper = Class(TJSONFieldMapper)
 219    procedure SetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row,Data : TJSONData); override;
 220    Function GetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row : TJSONData) : TJSONData; override;
 221    Function CreateRow : TJSONData; override;
 222  end;
 223
 224  EJSONDataset = Class(EDatabaseError);
 225  
 226implementation
 227
 228uses dateutils, jsonparser;
 229
 230type
 231  PRecInfo = ^TRecInfo;
 232  TRecInfo = record
 233    Index: Integer;
 234    Bookmark: Longint;
 235    BookmarkFlag: TBookmarkFlag;
 236  end;
 237
 238
 239{ TJSONFieldMapper }
 240
 241function TJSONFieldMapper.GetJSONDataForField(F: TField; Row: TJSONData
 242  ): TJSONData;
 243begin
 244  // This supposes that Index is correct, i.e. the field positions have not been changed.
 245  Result:=GetJSONDataForField(F.FieldName,F.Index,Row);
 246end;
 247
 248procedure TJSONFieldMapper.SetJSONDataForField(F: TField; Row,Data: TJSONData);
 249begin
 250  SetJSONDataForField(F.FieldName,F.Index,Row,Data);
 251end;
 252
 253{ TJSONArrayDataSet }
 254
 255function TExtJSJSONArrayDataSet.CreateFieldMapper: TJSONFieldMapper;
 256begin
 257  Result:=TJSONArrayFieldMapper.Create;
 258end;
 259
 260{ TJSONObjectDataSet }
 261
 262function TExtJSJSONObjectDataSet.CreateFieldMapper: TJSONFieldMapper;
 263begin
 264  Result:=TJSONObjectFieldMapper.Create;
 265end;
 266
 267{ TJSONArrayFieldMapper }
 268
 269procedure TJSONArrayFieldMapper.SetJSONDataForField(const FieldName: String;
 270  FieldIndex: Integer; Row, Data: TJSONData);
 271begin
 272  (Row as TJSONArray).Items[FieldIndex]:=Data;
 273end;
 274
 275function TJSONArrayFieldMapper.GetJSONDataForField(Const FieldName: String;
 276  FieldIndex: Integer; Row: TJSONData): TJSONData;
 277begin
 278  Result:=(Row as TJSONArray).Items[FieldIndex];
 279end;
 280
 281function TJSONArrayFieldMapper.CreateRow: TJSONData;
 282begin
 283  Result:=TJSONArray.Create;
 284end;
 285
 286{ TJSONObjectFieldMapper }
 287
 288procedure TJSONObjectFieldMapper.SetJSONDataForField(const FieldName: String;
 289  FieldIndex: Integer; Row, Data: TJSONData);
 290begin
 291  (Row as TJSONObject).Elements[FieldName]:=Data;
 292end;
 293
 294function TJSONObjectFieldMapper.GetJSONDataForField(const FieldName: String;
 295  FieldIndex: Integer; Row: TJSONData): TJSONData;
 296begin
 297  Result:=(Row as TJSONObject).Elements[FieldName];
 298end;
 299
 300function TJSONObjectFieldMapper.CreateRow: TJSONData;
 301begin
 302  Result:=TJSONObject.Create;
 303end;
 304
 305procedure TBaseJSONDataSet.SetMetaData(AValue: TJSONObject);
 306begin
 307  CheckInActive;
 308  if FMetaData=AValue then
 309    Exit;
 310  If OwnsData then
 311    FreeAndNil(FMetaData);
 312  FMetaData:=AValue;
 313end;
 314
 315procedure TBaseJSONDataSet.SetRows(AValue: TJSONArray);
 316begin
 317  CheckInActive;
 318  if FRows=AValue then Exit;
 319  If OwnsData then
 320    FreeAndNil(FRows);
 321  FRows:=AValue;
 322end;
 323
 324function TBaseJSONDataSet.AllocRecordBuffer: TRecordBuffer;
 325begin
 326  Result := TRecordBuffer(StrAlloc(fRecordSize));
 327end;
 328
 329// the next two are particularly ugly.
 330procedure TBaseJSONDataSet.InternalInitRecord(Buffer: TRecordBuffer);
 331begin
 332  FillChar(Buffer^, FRecordSize, 0);
 333end;
 334
 335procedure TBaseJSONDataSet.FreeRecordBuffer (var Buffer: TRecordBuffer);
 336begin
 337  StrDispose(pansichar(Buffer));
 338end;
 339
 340procedure TBaseJSONDataSet.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
 341begin
 342  PInteger(Data)^ := PRecInfo(Buffer)^.Bookmark;
 343end;
 344
 345function TBaseJSONDataSet.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
 346begin
 347  Result := PRecInfo(Buffer)^.BookmarkFlag;
 348end;
 349
 350function TBaseJSONDataSet.GetRecNo: Integer;
 351begin
 352  Result := FCurrent + 1;
 353end;
 354
 355procedure TBaseJSONDataSet.InternalInitFieldDefs;
 356begin
 357  If Assigned(FMetaData) then
 358    MetaDataToFieldDefs;
 359  if (FieldDefs.Count=0) then
 360    Raise EJSONDataset.Create('No fields found');
 361end;
 362
 363procedure TBaseJSONDataSet.FreeData;
 364begin
 365  If FOwnsData then
 366    begin
 367    FreeAndNil(FRows);
 368    FreeAndNil(FMetaData);
 369    end;
 370  if (FCurrentList<>FDefaultList) then
 371    FreeAndNil(FCurrentList)
 372  else
 373    FCurrentList:=Nil;
 374  FreeAndNil(FDefaultList);
 375  FreeAndNil(FFieldMapper);
 376  FCurrentList:=Nil;
 377end;
 378
 379procedure TBaseJSONDataSet.FillList;
 380
 381Var
 382  I : Integer;
 383
 384begin
 385  FDefaultList:=TFPList.Create;
 386  For I:=0 to FRows.Count-1 do
 387    FDefaultList.Add(FRows[i]);
 388  FCurrentList:=FDefaultList;
 389end;
 390
 391Function  TExtJSJSONDataSet.StringToFieldType(S : String) : TFieldType;
 392
 393begin
 394  if (s='int') then
 395    Result:=ftLargeInt
 396  else if (s='float') then
 397    Result:=ftFloat
 398  else if (s='boolean') then
 399    Result:=ftBoolean
 400  else if (s='date') then
 401    Result:=ftDateTime
 402  else if (s='string') or (s='auto') or (s='') then
 403    Result:=ftString
 404  else
 405    if MapUnknownToStringType then
 406      Result:=ftString
 407    else
 408      Raise EJSONDataset.CreateFmt('Unknown JSON data type : %s',[s]);
 409end;
 410
 411Function  TExtJSJSONDataSet.GetStringFieldLength(F : TJSONObject; AName : String; AIndex : Integer) : integer;
 412
 413Var
 414  I,L : Integer;
 415  D : TJSONData;
 416
 417begin
 418  Result:=0;
 419  I:=F.IndexOfName('maxlen');
 420  if (I<>-1) and (F.Items[I].jsonType=jtNumber) then
 421    begin
 422    Result:=StrToIntDef(trim(F.Items[i].AsString),-1);
 423    if (Result=-1) then
 424      Raise EJSONDataset.CreateFmt('Invalid maximum length specifier for field %s : %s',[AName,F.Items[i].AsString])
 425    end
 426  else
 427    begin
 428    For I:=0 to FRows.Count-1 do
 429      begin
 430      D:=FFieldMapper.GetJSONDataForField(Aname,AIndex,FRows[i]);
 431      if (D<>Nil) and (D.JsonType<>jtNull) then
 432        begin
 433        l:=Length(D.AsString);
 434        if L>Result then
 435          Result:=L;
 436        end;
 437      end;
 438    end;
 439  if (Result=0) then
 440    Result:=20;
 441end;
 442
 443procedure TExtJSJSONDataSet.LoadFromStream(S: TStream);
 444
 445Var
 446  P : TJSONParser;
 447  D : TJSONData;
 448  O : TJSONObject;
 449  N : String;
 450  I : Integer;
 451
 452begin
 453  P:=TJSONParser.Create(S);
 454  try
 455    D:=P.Parse;
 456    try
 457      if (D.JSONType=jtObject) then
 458        O:=D as TJSONObject
 459      else
 460        begin
 461        FreeAndNil(D);
 462        Raise EJSONDataset.Create('Not a valid ExtJS JSON data packet');
 463        end;
 464      N:='rows';
 465      // Check metadata
 466      I:=O.IndexOfName('metaData');
 467      if (I<>-1) then
 468        begin
 469        If (O.Items[i].JSONType<>jtObject) then
 470          Raise EJSONDataset.Create('Invalid ExtJS JSON metaData in data packet.');
 471        Metadata:=O.Objects['metaData'];
 472        O.Extract(I);
 473        I:=Metadata.IndexOfName('root');
 474        If (I<>-1) then
 475          begin
 476          if (MetaData.Items[i].JSONType<>jtString) then
 477            Raise EJSONDataset.Create('Invalid ExtJS JSON root element in metaData.');
 478          N:=MetaData.Strings['root'];
 479          end;
 480        end;
 481      // Check rows
 482      I:=O.IndexOfName(N);
 483      if (I=-1) then
 484        Raise EJSONDataset.Create('Missing rows in data packet');
 485      if (O.Items[i].JSONType<>jtArray) then
 486        Raise EJSONDataset.Create('Rows element must be an array');
 487      Rows:=O.Items[i] as TJSONArray;
 488      O.Extract(I);
 489      OwnsData:=True;
 490    finally
 491      D.Free;
 492    end;
 493  finally
 494    P.Free;
 495  end;
 496end;
 497
 498procedure TExtJSJSONDataSet.LoadFromFile(const AFileName: string);
 499
 500Var
 501  F : TFileStream;
 502
 503begin
 504  F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
 505  try
 506    LoadFromStream(F);
 507  finally
 508    F.Free;
 509  end;
 510end;
 511
 512procedure TExtJSJSONDataSet.SaveToStream(S: TStream; SaveMetaData: Boolean);
 513
 514Var
 515  O : TJSONObject;
 516  SS : TStringStream;
 517  N : String;
 518  I : Integer;
 519  M : TJSONobject;
 520
 521begin
 522  O:=TJSONObject.Create;
 523  try
 524    N:='rows';
 525    If SaveMetaData then
 526      begin
 527      M:=MetaData;
 528      if M=Nil then
 529        M:=GenerateMetaData;
 530      O.Add('metaData',M);
 531      if M.IndexOfName('root')<>-1 then
 532        N:=M.Strings['root'];
 533      end;
 534    O.Add(N,Rows);
 535    SS:=TStringStream.Create(O.FormatJSON());
 536    try
 537      S.CopyFrom(SS,0);
 538    finally
 539      SS.Free;
 540    end;
 541  finally
 542    If (MetaData<>Nil) and SaveMetaData then
 543      begin
 544      I:=O.IndexOfName('metaData');
 545      if (I<>-1) then
 546        O.Extract(i);
 547      end;
 548    O.Extract(O.IndexOfName(N));
 549    O.Free;
 550  end;
 551end;
 552
 553procedure TExtJSJSONDataSet.SaveToFile(const AFileName: String;
 554  SaveMetaData: Boolean);
 555
 556Var
 557  F : TFileStream;
 558
 559begin
 560  F:=TFileStream.Create(AFileName,fmCreate);
 561  try
 562    SaveToStream(F,SaveMetaData);
 563  finally
 564    F.Free;
 565  end;
 566end;
 567
 568procedure TExtJSJSONDataSet.MetaDataToFieldDefs;
 569
 570Var
 571  A : TJSONArray;
 572  F : TJSONObject;
 573  I,J,FS : Integer;
 574  N,idf : String;
 575  ft: TFieldType;
 576  D : TJSONData;
 577
 578begin
 579  FieldDefs.Clear;
 580  I:=FMetadata.IndexOfName('fields');
 581  if (I=-1) or (FMetaData.Items[i].JSONType<>jtArray) then
 582    Raise EJSONDataset.Create('Invalid metadata object');
 583  A:=FMetadata.Arrays['fields'];
 584  For I:=0 to A.Count-1 do
 585    begin
 586    If (A.Types[i]<>jtObject) then
 587      Raise EJSONDataset.CreateFmt('Field definition %d in metadata (%s) is not an object',[i,A[i].AsJSON]);
 588    F:=A.Objects[i];
 589    J:=F.IndexOfName('name');
 590    If (J=-1) or (F.Items[J].JSONType<>jtString) then
 591      Raise EJSONDataset.CreateFmt('Field definition %d in has no or invalid name property',[i]);
 592    N:=F.Items[J].AsString;
 593    J:=F.IndexOfName('type');
 594    If (J=-1) then
 595      ft:=ftstring
 596    else If (F.Items[J].JSONType<>jtString) then
 597      Raise EJSONDataset.CreateFmt('Field definition %d in has invalid type property',[i])
 598    else
 599      ft:=StringToFieldType(F.Items[J].asString);
 600    if (ft=ftString) then
 601      fs:=GetStringFieldLength(F,N,I)
 602    else
 603      fs:=0;
 604    FieldDefs.Add(N,ft,fs);
 605    end;
 606  FFields:=A;
 607end;
 608
 609function TExtJSJSONDataSet.GenerateMetaData: TJSONObject;
 610
 611Var
 612  F : TJSONArray;
 613  O : TJSONObject;
 614  I,M : Integer;
 615  T : STring;
 616
 617begin
 618  Result:=TJSONObject.Create;
 619  F:=TJSONArray.Create;
 620  Result.Add('fields',F);
 621  For I:=0 to FieldDefs.Count -1 do
 622    begin
 623    O:=TJSONObject.Create(['name',FieldDefs[i].name]);
 624    F.Add(O);
 625    M:=0;
 626    case FieldDefs[i].DataType of
 627      ftfixedwidechar,
 628      ftwideString,
 629      ftfixedchar,
 630      ftString:
 631        begin
 632        T:='string';
 633        M:=FieldDefs[i].Size;
 634        end;
 635      ftBoolean: T:='boolean';
 636      ftDate,
 637      ftTime,
 638      ftDateTime: T:='date';
 639      ftFloat: t:='float';
 640      ftSmallint,
 641      ftInteger,
 642      ftAutoInc,
 643      ftLargeInt,
 644      ftword: t:='int';
 645    else
 646      Raise EJSONDataset.CreateFmt('Unsupported field type : %s',[GetEnumName(TypeInfo(TFieldType),Ord(FieldDefs[i].DataType))]);
 647    end; // case
 648    O.Strings['type']:=t;
 649    if M<>0 then
 650      O.Integers['maxlen']:=M;
 651    end;
 652  Result.strings['root']:='rows';
 653end;
 654
 655Function TExtJSJSONDataSet.ConvertDateFormat(S : String) : String;
 656
 657{ Not handled: N S w z W t L o O P T Z c U MS }
 658
 659begin
 660  Result:=StringReplace(S,'y','yy',[rfReplaceall]);
 661  Result:=StringReplace(Result,'Y','yyyy',[rfReplaceall]);
 662  Result:=StringReplace(Result,'g','h',[rfReplaceall]);
 663  Result:=StringReplace(Result,'G','hh',[rfReplaceall]);
 664  Result:=StringReplace(Result,'F','mmmm',[rfReplaceall]);
 665  Result:=StringReplace(Result,'M','mmm',[rfReplaceall]);
 666  Result:=StringReplace(Result,'n','m',[rfReplaceall]);
 667  Result:=StringReplace(Result,'D','ddd',[rfReplaceall]);
 668  Result:=StringReplace(Result,'j','d',[rfReplaceall]);
 669  Result:=StringReplace(Result,'l','dddd',[rfReplaceall]);
 670  Result:=StringReplace(Result,'i','nn',[rfReplaceall]);
 671  Result:=StringReplace(Result,'u','zzz',[rfReplaceall]);
 672  Result:=StringReplace(Result,'a','am/pm',[rfReplaceall,rfIgnoreCase]);
 673  Result:=LowerCase(Result);
 674end;
 675
 676procedure TExtJSJSONDataSet.InitDateTimeFields;
 677
 678Var
 679  F : TJSONObject;
 680  FF : TField;
 681  I,J : Integer;
 682  Fmt : String;
 683
 684begin
 685  If (FFields=Nil) then
 686    Exit;
 687  For I:=0 to FFields.Count-1 do
 688    begin
 689    F:=FFields.Objects[i];
 690    J:=F.IndexOfName('type');
 691    if (J<>-1) and (F.Items[J].JSONType=jtString) and (F.items[J].AsString='date') then
 692      begin
 693      J:=F.IndexOfName('dateFormat');
 694      if (J<>-1) and (F.Items[J].JSONType=jtString) then
 695         begin
 696         FMT:=ConvertDateFormat(F.Items[J].AsString);
 697         FF:=FindField(F.Strings['name']);
 698         if (FF<>Nil) and (FF.DataType in [ftDate,ftTime,ftDateTime]) and (FF.FieldKind=fkData) then
 699           begin
 700
 701           if FF is TJSONDateField then
 702             TJSONDateField(FF).DateFormat:=Fmt
 703           else if FF is TJSONTimeField then
 704             TJSONTimeField(FF).TimeFormat:=Fmt
 705           else if FF is TJSONDateTimeField then
 706             TJSONDateTimeField(FF).DateTimeFormat:=Fmt;
 707           end;
 708         end;
 709      end;
 710    end;
 711end;
 712
 713function TBaseJSONDataSet.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode;
 714  DoCheck: Boolean): TGetResult;
 715begin
 716  Result := grOK; // default
 717  case GetMode of
 718    gmNext: // move on
 719      if fCurrent < fCurrentList.Count - 1 then
 720        Inc (fCurrent)
 721      else
 722        Result := grEOF; // end of file
 723    gmPrior: // move back
 724      if fCurrent > 0 then
 725        Dec (fCurrent)
 726      else
 727        Result := grBOF; // begin of file
 728    gmCurrent: // check if empty
 729      if fCurrent >= fCurrentList.Count then
 730        Result := grEOF;
 731  end;
 732  if Result = grOK then // read the data
 733    with PRecInfo(Buffer)^ do
 734    begin
 735      Index := fCurrent;
 736      BookmarkFlag := bfCurrent;
 737      Bookmark := fCurrent;
 738    end;
 739end;
 740
 741function TBaseJSONDataSet.GetRecordCount: Integer;
 742begin
 743  Result := FCurrentList.Count;
 744end;
 745
 746function TBaseJSONDataSet.GetRecordSize: Word;
 747begin
 748  Result := SizeOf(Integer); // actual data without house-keeping
 749end;
 750
 751
 752procedure TBaseJSONDataSet.InternalClose;
 753begin
 754  // disconnet and destroy field objects
 755  BindFields (False);
 756  if DefaultFields then
 757    DestroyFields;
 758  FreeData;
 759end;
 760
 761procedure TBaseJSONDataSet.InternalDelete;
 762
 763Var
 764  R : TJSONData;
 765
 766begin
 767  R:=TJSONData(FCurrentList[FCurrent]);
 768  FCurrentList.Delete(FCurrent);
 769  if (FCurrent>=FCurrentList.Count) then
 770    Dec(FCurrent);
 771  FRows.Remove(R);
 772end;
 773
 774procedure TBaseJSONDataSet.InternalFirst;
 775begin
 776  FCurrent := -1;
 777end;
 778
 779procedure TBaseJSONDataSet.InternalGotoBookmark(ABookmark: Pointer);
 780begin
 781  if (ABookmark <> nil) then
 782    FCurrent := Integer (ABookmark);
 783end;
 784
 785procedure TBaseJSONDataSet.InternalInsert;
 786
 787Var
 788  I : Integer;
 789  D : TFieldDef;
 790
 791begin
 792  FEditRow:=FFieldMapper.CreateRow;
 793  For I:=0 to FieldDefs.Count-1 do
 794    begin
 795    D:=FieldDefs[i];
 796    FFieldMapper.SetJSONDataForField(D.Name,D.Index,FEditRow,TJSONNull.Create);
 797    end;
 798end;
 799
 800procedure TBaseJSONDataSet.InternalEdit;
 801begin
 802  FEditRow:=TJSONData(FCurrentList[FCurrent]).Clone;
 803end;
 804
 805procedure TBaseJSONDataSet.InternalCancel;
 806begin
 807  FreeAndNil(FEditRow);
 808end;
 809
 810procedure TBaseJSONDataSet.InternalLast;
 811begin
 812  FCurrent:=FCurrentList.Count-1;
 813end;
 814
 815procedure TBaseJSONDataSet.InitDateTimeFields;
 816
 817begin
 818  // Do nothing
 819end;
 820
 821procedure TBaseJSONDataSet.InternalOpen;
 822begin
 823  FreeAndNil(FFieldMapper);
 824  FFieldMapper:=CreateFieldMapper;
 825  IF (FRows=Nil) then // opening from fielddefs ?
 826    begin
 827    FRows:=TJSONArray.Create;
 828    OwnsData:=True;
 829    end;
 830  FillList;
 831  InternalInitFieldDefs;
 832  if DefaultFields then
 833    CreateFields;
 834  BindFields (True);
 835  InitDateTimeFields;
 836  FRecordSize := sizeof (TRecInfo);
 837  FCurrent := -1;
 838  BookmarkSize := sizeOf (Integer);
 839end;
 840
 841procedure TBaseJSONDataSet.InternalPost;
 842
 843Var
 844  RI,I : integer;
 845begin
 846  GetBookMarkData(ActiveBuffer,@I);
 847  if (State=dsInsert) then
 848    begin // Insert or Append
 849    FRows.Add(FEditRow);
 850    if GetBookMarkFlag(ActiveBuffer)=bfEOF then
 851      begin // Append
 852      FDefaultList.Add(FEditRow);
 853      if (FCurrentList<>FDefaultList) then
 854        FCurrentList.Add(FEditRow);
 855      end
 856    else  // insert
 857      begin
 858      FCurrentList.Insert(FCurrent,FEditRow);
 859      if (FCurrentList<>FDefaultList) then
 860        FDefaultList.Add(FEditRow);
 861      end;
 862    end
 863  else
 864    begin // Edit
 865    RI:=FRows.IndexOf(TJSONData(FCurrentList[FCurrent]));
 866    if (RI<>-1) then
 867      FRows[RI]:=FEditRow
 868    else
 869      FRows.Add(FEditRow);
 870    FCurrentList[FCurrent]:=FEditRow;
 871    if (FCurrentList<>FDefaultList) then
 872      FDefaultList[FCurrent]:=FEditRow;
 873    end;
 874  FEditRow:=Nil;
 875end;
 876
 877procedure TBaseJSONDataSet.InternalSetToRecord(Buffer: TRecordBuffer);
 878begin
 879  FCurrent := PRecInfo(Buffer)^.Index;
 880end;
 881
 882function TBaseJSONDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
 883begin
 884  case FieldType of
 885    ftDate : Result:=TJSONDateField;
 886    ftDateTime : Result:=TJSONDateTimeField;
 887    ftTime : Result:=TJSONTimeField;
 888  else
 889    Result:=inherited GetFieldClass(FieldType);
 890  end;
 891end;
 892
 893function TBaseJSONDataSet.IsCursorOpen: Boolean;
 894begin
 895  Result := Assigned(FDefaultList);
 896end;
 897
 898procedure TBaseJSONDataSet.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
 899begin
 900  PRecInfo(Buffer)^.Bookmark := PInteger(Data)^;
 901end;
 902
 903function TBaseJSONDataSet.ConvertDateTimeField(S : String; F : TField) : TDateTime;
 904
 905Var
 906  Ptrn : string;
 907
 908begin
 909  Result:=0;
 910  Case F.DataType of
 911    ftDate : Ptrn:=TJSONDateField(F).DateFormat;
 912    ftTime : Ptrn:=TJSONTimeField(F).TimeFormat;
 913    ftDateTime : Ptrn:=TJSONDateTimeField(F).DateTimeFormat;
 914  end;
 915  If (Ptrn='') then
 916    Case F.DataType of
 917      ftDate : Result:=StrToDate(S);
 918      ftTime : Result:=StrToTime(S);
 919      ftDateTime : Result:=StrToDateTime(S);
 920    end
 921  else
 922    begin
 923    Result:=ScanDateTime(ptrn,S,1);
 924    end;
 925end;
 926
 927function TBaseJSONDataSet.FormatDateTimeField(DT: TDateTime; F: TField
 928  ): String;
 929
 930Var
 931  Ptrn : string;
 932begin
 933  Result:='';
 934  Case F.DataType of
 935    ftDate : Ptrn:=TJSONDateField(F).DateFormat;
 936    ftTime : Ptrn:=TJSONTimeField(F).TimeFormat;
 937    ftDateTime : Ptrn:=TJSONDateTimeField(F).DateTimeFormat;
 938  end;
 939  If (Ptrn='') then
 940    Case F.DataType of
 941      ftDate : Result:=DateToStr(DT);
 942      ftTime : Result:=TimeToStr(DT);
 943      ftDateTime : Result:=DateTimeToStr(DT);
 944    end
 945  else
 946    Result:=FormatDateTime(ptrn,DT);
 947end;
 948
 949function TBaseJSONDataSet.GetFieldData(Field: TField; Buffer: Pointer
 950  ; NativeFormat : Boolean): Boolean;
 951var
 952  R,F : TJSONData;
 953  B : WordBool;
 954  s: string;
 955  w : widestring;
 956  D : TDateTime;
 957  FV : Double;
 958  I : Longint;
 959  li : int64;
 960
 961begin
 962  I:=PRecInfo(ActiveBuffer)^.Index;
 963  // Writeln('Index : ',I,'<',FCurrentList.Count,' ?');
 964  if (I<>-1) then
 965    R:=TJSONData(FCurrentList[i])
 966  else
 967    R:=FEditRow;
 968  F:=FFieldMapper.GetJSONDataForField(Field,R);
 969  Result:=(F<>Nil) and not (F.JSONType in [jtUnknown,jtNull]);
 970  if not Result then
 971    exit;
 972  case Field.DataType of
 973    ftfixedwidechar,
 974    ftwideString:
 975    begin
 976    W:=F.AsString;
 977    if (length(W)>0) then
 978      Move(W[1],Buffer^,Length(W)*SizeOf(Widechar)+1)
 979    else
 980      PChar(Buffer)^:=#0;
 981    end;
 982    ftfixedchar,
 983    ftString:
 984      begin
 985      S:=F.AsString;
 986      if (length(s)>0) then
 987        Move(S[1],Buffer^,Length(S)+1)
 988      else
 989        PChar(Buffer)^:=#0;
 990      end;
 991    ftBoolean:
 992      begin
 993      B:=F.AsBoolean;
 994      Move(B,Buffer^,sizeof(WordBool));
 995      end;
 996    ftDate,
 997    ftTime,
 998    ftDateTime:
 999      begin
1000      D:=ConvertDateTimeField(F.AsString,Field);
1001      Move(D,Buffer^,sizeof(TDateTime));
1002      end;
1003    ftFloat:
1004      begin
1005      Fv:=F.asFloat;
1006      Move(FV,Buffer^,sizeof(Double));
1007      end;
1008    ftSmallint,
1009    ftInteger,
1010    ftAutoInc,
1011    ftword:
1012      begin
1013      I:=F.AsInteger;
1014      Move(I,Buffer^,SizeOf(I));
1015      end;
1016    ftLargeint:
1017      begin
1018      LI:=F.AsInt64;
1019      Move(LI,Buffer^,SizeOf(LI));
1020      end;
1021  else
1022    Raise EJSONDataset.CreateFmt('Unsupported field type : %s',[GetEnumName(TypeInfo(TFieldType),Ord(Field.DataType))]);
1023  end; // case
1024end;
1025
1026procedure TBaseJSONDataSet.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat : Boolean);
1027var
1028  R,F : TJSONData;
1029  B : PWordBool;
1030  s: string;
1031  w : widestring;
1032  D : TDateTime;
1033  FV : Double;
1034  I : Longint;
1035  li : int64;
1036
1037begin
1038  F:=Nil;
1039  if (Buffer<>nil) then
1040  case Field.DataType of
1041    ftfixedwidechar,
1042    ftwideString:
1043    begin
1044    SetLength(W,Field.Size);
1045    if (length(W)>0) then
1046      Move(Buffer^,W[1],Field.Size*SizeOf(Widechar));
1047    F:=TJSONString.Create(W);
1048    end;
1049    ftfixedchar,
1050    ftString:
1051      F:=TJSONString.Create(StrPas(Buffer));
1052    ftBoolean:
1053      F:=TJSONBoolean.Create(PWordBool(Buffer)^);
1054    ftDate,
1055    ftTime,
1056    ftDateTime:
1057      begin
1058      S:=FormatDateTimeField(PDateTime(Buffer)^,Field);
1059      F:=TJSONString.Create(S);
1060      end;
1061    ftFloat:
1062      F:=TJSONFloatNumber.Create(PDouble(Buffer)^);
1063    ftSmallint,
1064    ftInteger,
1065    ftAutoInc,
1066    ftword:
1067      F:=TJSONIntegerNumber.Create(PLongint(Buffer)^);
1068    ftLargeint:
1069      begin
1070      F:=TJSONInt64Number.Create(PInt64(Buffer)^);
1071      end;
1072  else
1073    Raise EJSONDataset.CreateFmt('Unsupported field type : %s',[GetEnumName(TypeInfo(TFieldType),Ord(Field.DataType))]);
1074  end; // case
1075  if (F=Nil) then
1076    F:=TJSONNull.Create;
1077//  Writeln('Set field data : ',F.AsJSON);
1078  FFieldMapper.SetJSONDataForField(Field,FEditRow,F);
1079//  Writeln('Field data is set : ',FEditRow.AsJSON);
1080end;
1081
1082procedure TBaseJSONDataSet.SetBookmarkFlag(Buffer: TRecordBuffer;
1083  Value: TBookmarkFlag);
1084begin
1085  PRecInfo(Buffer)^.BookmarkFlag := Value;
1086end;
1087
1088procedure TBaseJSONDataSet.SetRecNo(Value: Integer);
1089begin
1090  if (Value < 0) or (Value > FCurrentList.Count) then
1091    raise EJSONDataset.CreateFmt('SetRecNo: index %d out of range',[Value]);
1092  FCurrent := Value - 1;
1093  Resync([]); 
1094  DoAfterScroll;
1095end;
1096
1097constructor TBaseJSONDataSet.Create(AOwner: TComponent);
1098begin
1099  inherited;
1100  FownsData:=True;
1101end;
1102
1103destructor TBaseJSONDataSet.Destroy;
1104begin
1105  FreeData;
1106  inherited;
1107end;
1108
1109end.