{ This file is part of the Free Pascal run time library. Copyright (c) 2019 by Michael Van Canneyt, member of the Free Pascal development team Simple JSON dataset component. See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {$mode objfpc} unit JSONDataset; interface uses Types, JS, DB, Classes, SysUtils, typinfo, fpexprpars; type TBaseJSONDataset = Class; TJSONIndexDef = class; // How are rows encoded in the JSON ? TJSONRowType = (rtJSONObject, // Each row is an object. rtJSONArray // Each row is an array. ); { TJSONFieldMapper } // This class is responsible for mapping the field objects of the records. TJSONFieldMapper = Class(TObject) Public Function CopyRow(aRow : JSValue) : JSValue; virtual; // Remove a field from the Procedure RemoveField(Const FieldName : String; FieldIndex : Integer; Row : JSValue); virtual; abstract; // Return row TJSONData instance with data for field 'FieldName' or 'FieldIndex'. Function GetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row : JSValue) : JSValue; virtual; abstract; // Same, but now based on TField. Function GetJSONDataForField(F : TField; Row : JSValue) : JSValue; virtual; // Set data for field 'FieldName' or 'FieldIndex' to supplied TJSONData instance in row procedure SetJSONDataForField(Const FieldName : String; FieldIndex : Integer; Row,Data : JSValue); virtual; abstract; // Set data for field TField to supplied TJSONData instance procedure SetJSONDataForField(F : TField; Row,Data : JSValue); virtual; // Create a new row. Function CreateRow : JSValue; virtual; abstract; end; // JSON has no date/time type, so we use a string field. // ExtJS provides the date/time format in it's field config: 'dateFormat' // The below field classes store this in the NNNFormat field. { TJSONDateField } TJSONDateField = Class(TDateField) private FDateFormat: String; Published Property DateFormat : String Read FDateFormat Write FDateFormat; end; { TJSONTimeField } TJSONTimeField = Class(TTimeField) private FTimeFormat: String; Published Property TimeFormat : String Read FTimeFormat Write FTimeFormat; end; { TJSONDateTimeField } TJSONDateTimeField = Class(TDateTimeField) private FDateTimeFormat: String; Published Property DateTimeFormat : String Read FDateTimeFormat Write FDateTimeFormat; end; { TFieldComparer } TFieldComparer = Class Private FDesc: Boolean; FValue : JSValue; FField : TField; FOptions : TLocateOptions; FDataset : TBaseJSONDataset; Public Constructor Create(aDataset : TBaseJSONDataset; aField : TField; aValue : JSValue; aOptions : TLocateOptions); Function GetFieldValue(RowIndex : integer) : JSValue; Function CompareRows (RowIndex1,RowIndex2 : Integer) : Integer; virtual; // First value is always dataset value. Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; virtual; abstract; Function Compare (RowIndex : Integer) : Integer; virtual; Property Value : JSValue read FValue Write FValue; Property Options : TLocateOptions Read FOptions Write FOptions; Property Dataset : TBaseJSONDataset Read FDataset; Property Field : TField Read FField; Property Desc : Boolean Read FDesc Write FDesc; end; TFieldComparerClass = Class of TFieldComparer; { TStringFieldComparer } TStringFieldComparer = Class (TFieldComparer) Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; override; end; { TNativeIntFieldComparer } TNativeIntFieldComparer = Class (TFieldComparer) Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; override; end; { TBooleanFieldComparer } TBooleanFieldComparer = Class (TFieldComparer) Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; override; end; { TDateTimeFieldComparer } TDateTimeFieldComparer = Class (TFieldComparer) Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; override; end; { TFloatFieldComparer } TFloatFieldComparer = Class (TFieldComparer) Function Compare (RowIndex : Integer; aValue : JSValue) : Integer; override; end; { TRecordComparer } TRecordComparer = class private FDataset: TBaseJSONDataset; FIndexBased: Boolean; FItems : Array of TFieldComparer; FOptions: TLocateOptions; FValues: TJSValueDynArray; function GetFieldComparer(Index : Integer): TFieldComparer; Protected procedure ConstructItems(aFields: String); virtual; function DataTypeToComparerClass(aFieldType: TFieldType): TFieldComparerClass; Function Compare(aRowindex : integer) : Integer; Function CompareRows(aRowindex1,aRowIndex2 : integer) : Integer; procedure updateFromIndex(aIndex : TJSONIndexDef); virtual; Public Constructor Create(aDataset : TBaseJSONDataset; aFields : String; aValues : JSValue; aOptions : TLocateOptions); Constructor Create(aDataset : TBaseJSONDataset; aIndex : TJSONIndexDef); Destructor Destroy; override; Property Dataset : TBaseJSONDataset Read FDataset; property Items [Index : Integer] : TFieldComparer Read GetFieldComparer; Property Options : TLocateOptions Read FOptions Write FOptions; Property Values : TJSValueDynArray Read FValues; Property IndexBased : Boolean Read FIndexBased; end; TRecordComparerClass = Class of TRecordComparer; { TBaseJSONDataSet } { TJSONIndex } TJSONIndex = Class FList : TJSArray; // Indexes of elements in FRows. FRows : TJSArray; FDataset : TBaseJSONDataset; private function GetRecordIndex(aListIndex : Integer): NativeInt; protected Function GetCount: Integer; virtual; Procedure CreateIndex; Virtual; abstract; Procedure ClearIndex; Property List : TJSArray Read FList; Property Rows : TJSArray Read FRows; Property Dataset : TBaseJSONDataset Read FDataset; Public Constructor Create(aDataset: TBaseJSONDataset; aRows : TJSArray); reintroduce; // Append remainder of FRows to FList. Procedure AppendToIndex; virtual; abstract; // Delete aListIndex from list, not from row. Return Recordindex of deleted record. Function Delete(aListIndex : Integer) : Integer; virtual; // Delete By rowIndex, Return list index of deleted record. Function DeleteByRowIndex(aRowIndex : Integer) : Integer; virtual; // Append aRecordIndex to list. Return ListIndex of appended record. Function Append(aRecordIndex : Integer) : Integer; virtual; abstract; // Insert record into list. By default, this does an append. Return ListIndex of inserted record Function Insert(aCurrentIndex{%H-}, aRecordIndex : Integer) : Integer; virtual; // Record at index aCurrentIndex has changed. Update index and return new listindex. Function Update(aRecordIndex : Integer) : Integer; virtual; abstract; // Find list index for Record at index aCurrentIndex. Return -1 if not found. Function FindRecord(aRecordIndex : Integer) : Integer; virtual; abstract; // index of record in index list, based on Row index. Function IndexOfRow(aRowIndex : Integer): NativeInt; // index of record in FRows based on aListIndex in List. Property RecordIndex[aListIndex : Integer] : NativeInt Read GetRecordIndex; // Number of records in index. This can differ from FRows, e.g. when filtering. Property Count : Integer Read GetCount; end; { TDefaultJSONIndex } TDefaultJSONIndex = Class(TJSONIndex) public Procedure CreateIndex; override; Procedure AppendToIndex; override; Function Append(aRecordIndex : Integer) : Integer; override; Function Insert(aCurrentIndex, aRecordIndex : Integer) : Integer; override; Function FindRecord(aRecordIndex : Integer) : Integer; override; Function Update(aRecordIndex : Integer) : Integer; override; end; { TSortedJSONIndex } TSortedJSONIndex = Class(TJSONIndex) Private FComparer : TRecordComparer; FUnique: Boolean; function FindPos(aRecordIndex: Integer): Integer; function MergeSort(aList: TJSArray): TJSArray; Protected Property Comparer : TRecordComparer Read FComparer Write FComparer; public Destructor Destroy; override; procedure CreateComparer(aIndex: TJSONIndexDef); Procedure CreateIndex; override; Procedure AppendToIndex; override; Function Append(aRecordIndex : Integer) : Integer; override; Function FindRecord(aRecordIndex : Integer) : Integer; override; Function Update(aRecordIndex : Integer) : Integer; override; Property Unique : Boolean Read FUnique Write FUnique; end; { TJSONIndexDef } TJSONIndexDef = class(TIndexDef) Private FIndex : TSortedJSONIndex; Protected Procedure ClearIndex; Property Index : TSortedJSONIndex Read FIndex Write FIndex; Public Procedure BuildIndex(aDataset : TBaseJSONDataset); end; { TJSONIndexDefs } TJSONIndexDefs = Class(TIndexDefs) private function GetD(aIndex : Integer): TJSONIndexDef; procedure SetD(aIndex : Integer; AValue: TJSONIndexDef); Public Function AddJSONIndexDef: TJSONIndexDef; Property Defs[aIndex : Integer] : TJSONIndexDef Read GetD Write SetD; default; end; TBlobFormat = (bfHex, bfBase64, bfBytes, bfCustom); TBlobFormats = Set of TBlobFormat; TOnDecodeBlobBytesEvent = Procedure (Sender : TDataset; aValue : JSValue; var aData : TBytes) of object; TOnEncodeBlobBytesEvent = Procedure (Sender : TDataset; aData : TBytes; var aValue : JSValue) of object; // basic JSON dataset. Does nothing ExtJS specific. TBaseJSONDataSet = class (TDataSet) private FActiveIndex: String; FBlobFormat: TBlobFormat; FIndexes: TJSONIndexDefs; FMUS: Boolean; FOnDecodeBlobValue: TOnDecodeBlobBytesEvent; FOnEncodeBlobValue: TOnEncodeBlobBytesEvent; FOwnsData : Boolean; FDefaultIndex : TJSONIndex; // Default index, built from array FCurrentIndex : TJSONIndex; // Currently active index. FCurrent: Integer; // Record Index in the current IndexList // Possible metadata to configure fields from. FMetaData : TJSObject; // This will contain the rows. FRows : TJSArray; // Deleted rows FDeletedRows : TJSArray; FFieldMapper : TJSONFieldMapper; // When editing, this object is edited. FEditIdx : Integer; FEditRow : JSValue; // When filtering, this is the current row; FFilterRow : JSValue; FUseDateTimeFormatFields: Boolean; FRowType: TJSONRowType; FFilterExpression : TFPExpressionParser; function GetFilterField(const AName: String): TFPExpressionResult; procedure SetActiveIndex(AValue: String); procedure SetIndexes(AValue: TJSONIndexDefs); procedure SetMetaData(AValue: TJSObject); procedure SetRows(AValue: TJSArray); procedure SetRowType(AValue: TJSONRowType); protected // Remove calculated fields from buffer procedure RemoveCalcFields(Buf: JSValue); procedure ActivateIndex(Build : Boolean); // Determine filter value type based on field type function FieldTypeToExpressionType(aDataType: TFieldType): TResultType; virtual; // Callback for IsNull filter function. function GetFilterIsNull(const Args: TExprParameterArray): TFPExpressionResult; virtual; // Expression parser class. Override this to create a customized version. function FilterExpressionClass: TFPExpressionParserClass; virtual; // Create filter expression. function CreateFilterExpression: TFPExpressionParser; virtual; // Function called to check if current buffer should be accepted. function DoFilterRecord: Boolean; virtual; // Override this to return customized version. function CreateIndexDefs: TJSONIndexDefs; virtual; // override this to return a customized version if you are so inclined function RecordComparerClass: TRecordComparerClass; virtual; // Return index of Row in FRows matching keyfields/values. If not found, -1 is returned. function LocateRecordIndex(const KeyFields: string; const KeyValues: JSValue; Options: TLocateOptions): Integer; virtual; // dataset virtual methods function AllocRecordBuffer: TDataRecord; override; procedure FreeRecordBuffer(var Buffer: TDataRecord); override; procedure InternalInitRecord(var Buffer: TDataRecord); override; function GetRecord(Var Buffer: TDataRecord; GetMode: TGetMode; DoCheck{%H-}: Boolean): TGetResult; override; function GetRecordSize: Word; override; procedure AddToRows(AValue: TJSArray); procedure InternalClose; override; procedure InternalDelete; override; procedure InternalFirst; override; procedure InternalLast; override; procedure InternalOpen; override; procedure InternalPost; override; procedure InternalInsert; override; procedure InternalEdit; override; procedure InternalCancel; override; procedure InternalInitFieldDefs; override; procedure InternalSetToRecord(Buffer: TDataRecord); override; procedure SetFilterText(const Value: string); override; procedure SetFiltered(Value: Boolean); override; function GetFieldClass(FieldType: TFieldType): TFieldClass; override; Function GetApplyUpdateData(Buffer : TDataRecord) : JSValue; override; function IsCursorOpen: Boolean; override; // Bookmark operations procedure GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark); override; function GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag; override; procedure InternalGotoBookmark(ABookmark: TBookmark); override; procedure SetBookmarkFlag(Var Buffer: TDataRecord; Value: TBookmarkFlag); override; procedure SetBookmarkData(Var Buffer: TDataRecord; Data: TBookmark); override; function GetRecordCount: Integer; override; procedure SetRecNo(Value: Integer); override; function GetRecNo: Integer; override; Protected // New methods. // Build all sorted indexes. Default index is not built. Procedure BuildIndexes; // Called when dataset is closed. If OwnsData is true, metadata and rows are freed. Procedure FreeData; virtual; // Fill default list. procedure AppendToIndexes; virtual; Procedure CreateIndexes; virtual; // Convert MetaData object to FieldDefs. Procedure MetaDataToFieldDefs; virtual; abstract; // Initialize Date/Time info in all date/time fields. Called during InternalOpen procedure InitDateTimeFields; virtual; // Convert JSON date S to DateTime for Field F function ConvertDateTimeField(S: String; F: TField): TDateTime; virtual; // Format JSON date to from DT for Field F function FormatDateTimeField(DT : TDateTime; F: TField): String; virtual; // Create fieldmapper. A descendent MUST implement this. Function CreateFieldMapper : TJSONFieldMapper; virtual; // If True, then the dataset will free MetaData and FRows when it is closed. Property OwnsData : Boolean Read FownsData Write FOwnsData; // set to true if unknown field types should be handled as string fields. Property MapUnknownToStringType : Boolean Read FMUS Write FMUS; // Metadata Property MetaData : TJSObject Read FMetaData Write SetMetaData; // Rows Property Rows : TJSArray Read FRows Write SetRows; // RowType Property RowType : TJSONRowType Read FRowType Write SetRowType; // Fieldmapper Property FieldMapper : TJSONFieldMapper Read FFieldMapper; // FieldClass Property UseDateTimeFormatFields : Boolean Read FUseDateTimeFormatFields Write FUseDateTimeFormatFields; // Indexes Property Indexes : TJSONIndexDefs Read FIndexes Write SetIndexes; // Active index name. Set to empty for default index. Property ActiveIndex : String Read FActiveIndex Write SetActiveIndex; // Blob format returned by server Property BlobFormat : TBlobFormat Read FBlobFormat Write FBlobFormat; // Called when BlobFormat is custom to decode incoming server data to TBytes Property OnDecodeBlobValue : TOnDecodeBlobBytesEvent Read FOnDecodeBlobValue Write FOnDecodeBlobValue; // Called when BlobFormat is custom to encode TBytes to server data. Property OnEncodeBlobValue : TOnEncodeBlobBytesEvent Read FOnEncodeBlobValue Write FOnEncodeBlobValue; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; Function BlobDataToBytes(aValue : JSValue) : TBytes; override; Function BytesToBlobData(aValue : TBytes) : JSValue ; override; function ConvertDateTimeToNative(aField : TField; aValue : TDateTime) : JSValue; override; function Locate(const KeyFields: string; const KeyValues: JSValue; Options: TLocateOptions): boolean; override; function Lookup(const KeyFields: string; const KeyValues: JSValue; const ResultFields: string): JSValue; override; function GetFieldData(Field: TField; Buffer: TDatarecord): JSValue; override; procedure SetFieldData(Field: TField; var Buffer{%H-}: TDatarecord; AValue : JSValue); override; function BookmarkValid(ABookmark: TBookmark): Boolean; override; function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override; end; TJSONDataset = Class(TBaseJSONDataset) published Property FieldDefs; Property RowType; Property UseDateTimeFormatFields; Property Indexes; Property ActiveIndex; 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; Property OnRecordResolved; property OnLoadFail; Property BlobFormat; Property OnDecodeBlobValue; Property OnEncodeBlobValue; end; { TJSONObjectFieldMapper } // Fieldmapper to be used when the data is in an object TJSONObjectFieldMapper = Class(TJSONFieldMapper) Public Procedure RemoveField(Const FieldName : String; FieldIndex{%H-} : Integer; Row : JSValue); override; procedure SetJSONDataForField(Const FieldName : String; FieldIndex{%H-} : Integer; Row,Data : JSValue); override; Function GetJSONDataForField(Const FieldName : String; FieldIndex{%H-} : Integer; Row : JSValue) : JSValue; override; Function CreateRow : JSValue; override; end; { TJSONArrayFieldMapper } // Fieldmapper to be used when the data is in an array TJSONArrayFieldMapper = Class(TJSONFieldMapper) Public Procedure RemoveField(Const FieldName{%H-} : String; FieldIndex : Integer; Row : JSValue); override; procedure SetJSONDataForField(Const FieldName{%H-} : String; FieldIndex : Integer; Row,Data : JSValue); override; Function GetJSONDataForField(Const FieldName{%H-} : String; FieldIndex : Integer; Row : JSValue) : JSValue; override; Function CreateRow : JSValue; override; end; EJSONDataset = Class(EDatabaseError); implementation uses DateUtils; Function atob (s : String) : string; external name 'atob'; Function btoa (s : String) : string; external name 'btoa'; { TJSONIndexDef } procedure TJSONIndexDef.ClearIndex; begin FreeAndNil(FIndex); end; procedure TJSONIndexDef.BuildIndex(aDataset : TBaseJSONDataset); begin if Findex=Nil then FIndex:=TSortedJSONIndex.Create(aDataset,aDataset.Rows) else FIndex.ClearIndex; FIndex.CreateComparer(Self); FIndex.CreateIndex; end; { TJSONIndexDefs } function TJSONIndexDefs.GetD(aIndex : Integer): TJSONIndexDef; begin Result:=Items[aIndex] as TJSONIndexDef; end; procedure TJSONIndexDefs.SetD(aIndex : Integer; AValue: TJSONIndexDef); begin Items[aIndex]:=aValue; end; function TJSONIndexDefs.AddJSONIndexDef: TJSONIndexDef; begin Result:=Add as TJSONIndexDef; end; { TSortedJSONIndex } Function TSortedJSONIndex.MergeSort(aList : TJSArray) : TJSArray; Var temp : TJSArray; l,p,q,e,tail : integer; insize, nmerges, psize, qsize : Integer; begin if aList=Nil then Exit(Nil); L:=aList.length; Result:=TJSArray.new(l); if L=0 then exit; insize:=1; Repeat p:=0; Tail:=0; nmerges := 0; // count number of merges we do in this pass while (p0) or ((qsize > 0) and (Q=L)) then begin // * q is empty; e must come from p. */ e := p; Inc(p); Dec(psize); end else if (FComparer.CompareRows(Integer(aList[p]),Integer(aList[q])) <= 0) then begin // * First element of p is lower (or same); * e must come from p. */ e:=p; inc(p); Dec(psize); end else begin // * First element of q is lower; e must come from q. */ e := q; Inc(q); Dec(qsize); end; Result[Tail]:=aList[e]; Inc(tail); end; p:=q; end; // * If we have done only one merge, we're finished. */ if (nmerges <= 1) then //* allow for nmerges==0, the empty list case */ exit; // * Otherwise repeat, merging lists twice the size */ InSize:=Insize * 2; // Swap lists for next round. Temp:=Result; Result:=aList; aList:=Temp; until false; end; destructor TSortedJSONIndex.Destroy; begin FreeAndNil(FComparer); Inherited; end; procedure TSortedJSONIndex.CreateComparer(aIndex: TJSONIndexDef); begin FreeAndNil(FComparer); FComparer:=TRecordComparer.Create(Dataset,aindex); end; procedure TSortedJSONIndex.CreateIndex; Var Lst : Array of Integer; I,SrcLen,Destlen : Integer; begin // CreateIndex is called during constructor. We cannot build index then, so we exit if FComparer=Nil then exit; SrcLen:=FRows.Length; // Temp list, mergsort destroys list SetLength(Lst,SrcLen); DestLen:=0; For I:=0 to SrcLen-1 do begin if not isUndefined(FRows[I]) then begin Lst[DestLen]:=I; Inc(DestLen); end; end; SetLength(Lst,DestLen); FList:=MergeSort(TJSArray(Lst)); end; procedure TSortedJSONIndex.AppendToIndex; begin // In theory, we could sort the rest of the list, and then merge the 2 sublists. CreateIndex; end; function TSortedJSONIndex.FindPos(aRecordIndex: Integer): Integer; Var L,R,I, CompareRes : Integer; begin if not Assigned(FComparer) then exit; L := 0; R := Count - 1; while (L<=R) do begin I := L + (R - L) div 2; CompareRes := FComparer.CompareRows(aRecordIndex, Integer(Flist[I])); if (CompareRes>0) then L := I+1 else begin R := I-1; if (CompareRes=0) then begin if Unique then L := I; // forces end of while loop end; end; end; Result:=L; end; function TSortedJSONIndex.Append(aRecordIndex: Integer): Integer; begin Result:=FindPos(aRecordIndex); // insert in list FList.Splice(Result,0,aRecordIndex); end; function TSortedJSONIndex.FindRecord(aRecordIndex: Integer): Integer; begin Result:=FList.indexOf(aRecordIndex); end; function TSortedJSONIndex.Update(aRecordIndex: Integer): Integer; Var aCurrentIndex : Integer; begin // Old pos aCurrentIndex:=FindRecord(aRecordIndex); // New pos Result:=FindPos(aRecordIndex); if Result<>aCurrentIndex then FList.Splice(Result,0,FList.Splice(aCurrentIndex,1)[0]) end; { TFloatFieldComparer } function TFloatFieldComparer.Compare(RowIndex: Integer; aValue: JSValue): Integer; var D1,D2 : Double; begin D1:=Double(GetFieldValue(Rowindex)); D2:=Double(aValue); Result:=Round(D1-D2); end; { TDateTimeFieldComparer } function TDateTimeFieldComparer.Compare(RowIndex: Integer; aValue: JSValue): Integer; var D1,D2 : TDateTime; Function ToDate(v: JSValue) : TDateTime; begin if IsDate(v) then Result:= JSDateToDateTime(TJSDate(v)) else Result:=Dataset.ConvertDateTimeField(String(v),Self.Field); end; begin D1:=ToDate(GetFieldValue(RowIndex)); D2:=ToDate(aValue); Result:=Round(D1-D2); end; { TBooleanFieldComparer } function TBooleanFieldComparer.Compare(RowIndex: Integer; aValue: JSValue): Integer; var B1,B2 : Boolean; begin B1:=Boolean(GetFieldValue(Rowindex)); B2:=Boolean(aValue); Result:=Ord(B1)-Ord(B2); end; { TNativeIntFieldComparer } function TNativeIntFieldComparer.Compare(RowIndex: Integer; aValue: JSValue): Integer; var I1,I2 : NativeInt; begin I1:=NativeInt(GetFieldValue(Rowindex)); I2:=NativeInt(aValue); Result:=I1-I2; end; { TStringFieldComparer } function TStringFieldComparer.Compare(RowIndex: Integer; aValue: JSValue): Integer; var S1,S2 : String; begin S1:=String(GetFieldValue(Rowindex)); S2:=String(aValue); if loPartialKey in Options then S1:=Copy(S1,1,Length(S2)); if loCaseInsensitive in options then Result := CompareText(S1,S2) else Result := CompareStr(S1,S2); end; { TFieldComparer } constructor TFieldComparer.Create(aDataset: TBaseJSONDataset; aField: TField; aValue: JSValue; aOptions: TLocateOptions); begin FField:=AField; FValue:=aValue; FOptions:=aOptions; FDataset:=aDataset; end; function TFieldComparer.GetFieldValue(RowIndex: integer): JSValue; begin Result:=FDataset.FieldMapper.GetJSONDataForField(FField,FDataset.FRows[Rowindex]); end; function TFieldComparer.CompareRows(RowIndex1, RowIndex2: Integer): Integer; begin Result:=Compare(RowIndex1,GetFieldValue(RowIndex2)); end; function TFieldComparer.Compare(RowIndex: Integer): Integer; begin Result:=Compare(RowIndex,FValue); end; { TRecordComparer } function TRecordComparer.GetFieldComparer(Index: Integer): TFieldComparer; begin if (Index<0) or (Index>=Length(Fitems)) then Raise EListError.CreateFmt('Index out of bounds: %d not in [%d,%d]',[Index,0,Length(Fitems)-1]); Result:=Items[Index]; end; procedure TRecordComparer.ConstructItems(aFields : String); Var L : TFPlist; FCC : TFieldComparerClass; F : TField; I : Integer; begin L:=TFPList.Create; try Dataset.GetFieldList(L,aFields); if Not Indexbased and (L.Count<>Length(FValues)) then Raise EDatabaseError.CreateFmt('Array of values has different length (%d) from array of fields (%d)',[Length(FValues), L.Count]); SetLength(FItems,L.Count); For I:=0 to L.Count-1 do begin F:=TField(L[i]); FCC:=DataTypeToComparerClass(F.DataType); If FCC=Nil then Raise EDatabaseError.CreateFmt('Cannot locate on field %s of type %s)',[F.FieldName,GetEnumName(TypeInfo(TFieldType),Ord(F.DataType))]); if IndexBased then Fitems[i]:=FCC.Create(FDataset,F,Null,FOptions) else Fitems[i]:=FCC.Create(FDataset,F,FValues[i],FOptions); end; finally L.Free; end; end; function TRecordComparer.DataTypeToComparerClass(aFieldType: TFieldType): TFieldComparerClass; begin Case aFieldType of ftMemo, ftFixedChar,ftString : Result:=TStringFieldComparer; ftAutoInc, ftInteger, ftLargeInt: Result:=TNativeIntFieldComparer; ftBoolean: Result:=TBooleanFieldComparer; ftFloat: Result:=TFloatFieldComparer; ftDate, ftTime, ftDateTime: Result:=TDateTimeFieldComparer; else result:=Nil; end; end; function TRecordComparer.Compare(aRowindex: integer): Integer; Var I,L : Integer; begin Result:=0; I:=0; L:=Length(FItems); While (Result=0) and (I0) and Fitems[i].Desc then Result:=-Result; Inc(I); end; end; procedure TRecordComparer.updateFromIndex(aIndex: TJSONIndexDef); Var L : TFPList; I : Integer; begin L:=TFPList.Create; try if (aIndex.CaseInsFields<>'') then begin Dataset.GetFieldList(L,aIndex.CaseInsFields); for I:=0 to Length(FItems)-1 do if L.IndexOf(FItems[i].Field)<>-1 then Fitems[i].Options:=Fitems[i].Options+[loCaseInsensitive]; end; L.Clear; Dataset.GetFieldList(L,aIndex.DescFields); for I:=0 to Length(FItems)-1 do Fitems[i].Desc:=(ixDescending in aIndex.Options) or (L.IndexOf(FItems[i].Field)<>-1); finally L.Free; end; end; constructor TRecordComparer.Create(aDataset: TBaseJSONDataset; aFields: String; aValues: JSValue; aOptions: TLocateOptions); begin FDataset:=aDataset; if isArray(aValues) then FValues:=TJSValueDynArray(aValues) else begin SetLength(FValues,1); FValues[0]:=Avalues; end; Foptions:=aOptions; ConstructItems(aFields); end; constructor TRecordComparer.Create(aDataset: TBaseJSONDataset; aIndex: TJSONIndexDef); begin FDataset:=aDataset; FIndexBased:=True; if ixCaseInsensitive in aIndex.Options then FOptions:=[loCaseInsensitive]; ConstructItems(aIndex.Fields); UpdateFromIndex(aIndex); end; destructor TRecordComparer.Destroy; Var I : Integer; begin For I:=0 to Length(FItems)-1 do FItems[i].Free; inherited Destroy; end; { TDefaultJSONIndex } procedure TDefaultJSONIndex.CreateIndex; Var I : Integer; begin For I:=0 to FRows.length-1 do FList[i]:=I; end; procedure TDefaultJSONIndex.AppendToIndex; Var I,L : Integer; begin L:=FList.Length; FList.Length:=FRows.Length; For I:=L to FRows.Length-1 do FList[i]:=I; end; function TDefaultJSONIndex.Append(aRecordIndex: Integer): Integer; begin Result:=FList.Push(aRecordIndex)-1; end; function TDefaultJSONIndex.Insert(aCurrentIndex, aRecordIndex: Integer ): Integer; begin FList.splice(aCurrentIndex, 0, aRecordIndex); Result:=aCurrentIndex; end; function TDefaultJSONIndex.FindRecord(aRecordIndex: Integer): Integer; begin Result:=FList.indexOf(aRecordIndex); end; function TDefaultJSONIndex.Update(aRecordIndex: Integer ): Integer; begin Result:=aRecordIndex; end; { TJSONIndex } constructor TJSONIndex.Create(aDataset: TBaseJSONDataset; aRows: TJSArray); begin FRows:=aRows; FList:=TJSArray.New(FRows.length); FDataset:=aDataset; CreateIndex; end; function TJSONIndex.Delete(aListIndex: Integer): Integer; Var a : TJSArray; begin A:=FList.Splice(aListIndex,1); If a.Length>0 then Result:=Integer(A[0]) else Result:=-1; end; function TJSONIndex.DeleteByRowIndex(aRowIndex: Integer): Integer; begin Result:=IndexOfRow(aRowIndex); if Result<>-1 then FList.Splice(Result,1); end; function TJSONIndex.Insert(aCurrentIndex, aRecordIndex: Integer): Integer; begin Result:=Append(aRecordIndex); end; function TJSONIndex.IndexOfRow(aRowIndex: Integer): NativeInt; begin Result:=FList.indexOf(aRowIndex); end; function TJSONIndex.GetCount: Integer; begin Result:=FList.Length; end; procedure TJSONIndex.ClearIndex; begin FList.Length:=0; end; function TJSONIndex.GetRecordIndex(aListIndex : Integer): NativeInt; begin if isUndefined(FList[aListIndex]) then Result:=-1 else Result:=NativeInt(FList[aListIndex]); end; { TJSONFieldMapper } function TJSONFieldMapper.CopyRow(aRow: JSValue): JSValue; begin Result:=TJSJSON.parse(TJSJSON.stringify(aRow)); end; function TJSONFieldMapper.GetJSONDataForField(F: TField; Row: JSValue ): JSValue; begin // This supposes that Index is correct, i.e. the field positions have not been changed. Result:=GetJSONDataForField(F.FieldName,F.Index,Row); end; procedure TJSONFieldMapper.SetJSONDataForField(F: TField; Row,Data: JSValue); begin SetJSONDataForField(F.FieldName,F.Index,Row,Data); end; { TJSONArrayFieldMapper } procedure TJSONArrayFieldMapper.RemoveField(const FieldName: String; FieldIndex: Integer; Row: JSValue); begin TJSArray(Row).Splice(FieldIndex,1); end; procedure TJSONArrayFieldMapper.SetJSONDataForField(const FieldName: String; FieldIndex: Integer; Row, Data: JSValue); begin TJSValueDynArray(Row)[FieldIndex]:=Data; end; function TJSONArrayFieldMapper.GetJSONDataForField(const FieldName: String; FieldIndex: Integer; Row: JSValue): JSValue; begin Result:=TJSValueDynArray(Row)[FieldIndex]; end; function TJSONArrayFieldMapper.CreateRow: JSValue; begin Result:=TJSArray.New; end; { TJSONObjectFieldMapper } procedure TJSONObjectFieldMapper.RemoveField(const FieldName: String; FieldIndex: Integer; Row: JSValue); begin jsDelete(Row,FieldName); end; procedure TJSONObjectFieldMapper.SetJSONDataForField(const FieldName: String; FieldIndex: Integer; Row, Data: JSValue); begin TJSObject(Row).Properties[FieldName]:=Data; end; function TJSONObjectFieldMapper.GetJSONDataForField(const FieldName: String; FieldIndex: Integer; Row: JSValue): JSValue; begin Result:=TJSObject(Row).Properties[FieldName]; end; function TJSONObjectFieldMapper.CreateRow: JSValue; begin Result:=TJSObject.New; end; procedure TBaseJSONDataSet.SetMetaData(AValue: TJSObject); begin CheckInActive; FMetaData:=AValue; end; procedure TBaseJSONDataSet.SetIndexes(AValue: TJSONIndexDefs); begin if FIndexes=AValue then Exit; FIndexes.Assign(aValue); if Active then BuildIndexes; end; procedure TBaseJSONDataSet.SetActiveIndex(AValue: String); begin if FActiveIndex=AValue then Exit; FActiveIndex:=AValue; if (csLoading in ComponentState) then exit; ActivateIndex(Active); end; procedure TBaseJSONDataSet.ActivateIndex(Build : Boolean); Var Idx : TJSONIndexDef; begin if (FActiveIndex<>'') then Idx:=FIndexes.Find(FActiveIndex) as TJSONIndexDef else Idx:=nil; if Idx=Nil then FCurrentIndex:=FDefaultIndex else begin if (Idx.Index=Nil) and Build then Idx.BuildIndex(Self); FCurrentIndex:=Idx.Index; end; if Active then Resync([rmCenter]); end; procedure TBaseJSONDataSet.AddToRows(AValue: TJSArray); begin if FRows=Nil then FRows:=AValue else begin FRows:=FRows.Concat(AValue); AppendToIndexes; end; end; procedure TBaseJSONDataSet.SetRows(AValue: TJSArray); begin if AValue=FRows then exit; CheckInActive; FRows:=Nil; AddToRows(AValue); end; procedure TBaseJSONDataSet.SetRowType(AValue: TJSONRowType); begin if FRowType=AValue then Exit; CheckInactive; FRowType:=AValue; end; function TBaseJSONDataSet.BlobDataToBytes(aValue: JSValue): TBytes; begin Result:=[]; Case BlobFormat of bfHex: Result:=DefaultBlobDataToBytes(aValue); bfBase64: Result:=BytesOf(atob(String(aValue))); bfBytes: Result:=TBytes(aValue); bfCustom: if Assigned(FOnDecodeBlobValue) then FOnDecodeBlobValue(Self,aValue,Result); end; end; function TBaseJSONDataSet.BytesToBlobData(aValue: TBytes): JSValue; begin Result:=''; Case BlobFormat of bfHex: Result:=DefaultBytesToBlobData(aValue); bfBase64: begin Result:=BtoA(StringOf(aValue)); end; bfBytes: Result:=TBytes(aValue); bfCustom: if Assigned(FOnEncodeBlobValue) then FOnEncodeBlobValue(Self,aValue,Result); end; end; function TBaseJSONDataSet.ConvertDateTimeToNative(aField : TField; aValue: TDateTime): JSValue; begin if jsISNan(aValue) then Result:=Null else Result:=FormatDateTimeField(aValue,aField) end; function TBaseJSONDataSet.AllocRecordBuffer: TDataRecord; begin Result.data:=TJSObject.New; Result.bookmark:=null; Result.state:=rsNew; end; // the next two are particularly ugly. procedure TBaseJSONDataSet.InternalInitRecord(var Buffer: TDataRecord); begin // Writeln('TBaseJSONDataSet.InternalInitRecord'); Buffer.Data:=FFieldMapper.CreateRow; Buffer.bookmark:=null; Buffer.state:=rsNew; end; procedure TBaseJSONDataSet.FreeRecordBuffer (var Buffer: TDataRecord); begin Buffer.Data:=Null; Buffer.bookmark:=null; Buffer.state:=rsNew; end; procedure TBaseJSONDataSet.GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark); begin Data.Data:=Buffer.bookmark; end; function TBaseJSONDataSet.GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag; begin Result :=Buffer.BookmarkFlag; end; function TBaseJSONDataSet.GetRecNo: Integer; Var bkmIdx : Integer; begin bkmIdx:=Integer(ActiveBuffer.bookmark); Result:=FCurrentIndex.FindRecord(bkmIdx)+1; end; procedure TBaseJSONDataSet.InternalInitFieldDefs; begin If Assigned(FMetaData) then MetaDataToFieldDefs; if (FieldDefs.Count=0) then Raise EJSONDataset.Create('No fields found'); end; procedure TBaseJSONDataSet.FreeData; Var I : integer; begin If FOwnsData then begin FRows:=Nil; FMetaData:=Nil; end; For I:=0 to FIndexes.Count-1 do FIndexes[i].ClearIndex; FCurrentIndex:=Nil; FreeAndNil(FDefaultindex); FreeAndNil(FFieldMapper); FCurrentIndex:=Nil; FDeletedRows:=Nil; end; procedure TBaseJSONDataSet.AppendToIndexes; begin FDefaultIndex.AppendToIndex; if Assigned(FCurrentIndex) and (FCurrentIndex<>FDefaultIndex) then FCurrentIndex.AppendToIndex; end; procedure TBaseJSONDataSet.CreateIndexes; begin FDefaultIndex:=TDefaultJSONIndex.Create(Self,FRows); AppendToIndexes; if FCurrentIndex=Nil then FCurrentIndex:=FDefaultIndex; end; function TBaseJSONDataSet.FilterExpressionClass : TFPExpressionParserClass; begin Result:=TFPExpressionParser; end; function TBaseJSONDataSet.GetFilterIsNull(const Args: TExprParameterArray): TFPExpressionResult; begin Result.ResultType:=rtBoolean; Result.ResValue:=FieldByName(String(Args[0].resValue)).IsNull; end; function TBaseJSONDataSet.FieldTypeToExpressionType(aDataType : TFieldType) : TResultType; begin Case aDataType of ftMemo, ftFixedChar, ftString : Result:=rtString; ftInteger, ftAutoInc, ftLargeInt : Result:=rtInteger; ftBoolean : Result:=rtBoolean; ftFloat : Result:=rtFloat; ftDate, ftTime, ftDateTime : Result:=rtDateTime; else DatabaseErrorFmt('Fields of type %s are not supported in filter expressions.',[Fieldtypenames[aDataType]],Self); end; end; function TBaseJSONDataSet.GetFilterField(const AName: String): TFPExpressionResult; Var F : TField; C : Currency; begin F:=FieldByName(aName); Result.resultType:=FieldTypeToExpressionType(F.DataType); case Result.resultType of rtBoolean : Result.resValue:=F.AsBoolean; rtInteger : Result.resValue:=F.AsLargeInt; rtFloat : Result.resValue:=F.AsFloat; rtDateTime : Result.resValue:=F.AsDateTime; rtString : Result.resValue:=F.AsString; rtCurrency : begin C:=Currency(F.AsFloat); Result.resValue:=C; end; end; // Writeln('Filtering field ',aName,'value: ',result.resValue); end; function TBaseJSONDataSet.CreateFilterExpression : TFPExpressionParser; Var I : Integer; begin Result:=FilterExpressionClass.Create(Self); for I:=0 to Fields.Count-1 do Result.Identifiers.AddVariable(Fields[i].FieldName,FieldTypeToExpressionType(Fields[i].DataType),@GetFilterField); Result.Identifiers.AddFunction('IsNull','B','S',@GetFilterIsNull); Result.Expression:=Filter; end; function TBaseJSONDataSet.DoFilterRecord : Boolean; Var DS : TDatasetState; begin // Writeln('Filtering'); Result:=True; DS:=SetTempState(dsFilter); try if Assigned(OnFilterRecord) then begin OnFilterRecord(Self,Result); if Not Result then Exit; end; if not Filtered or (Filter='') then Exit; if (FFilterExpression=Nil) then FFilterExpression:=CreateFilterExpression; Result:=FFilterExpression.AsBoolean; finally RestoreState(DS); end; end; function TBaseJSONDataSet.GetRecord(var Buffer: TDataRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult; Var BkmIdx : Integer; recordAccepted : Boolean; begin Result := grOK; // default Repeat recordAccepted:=True; case GetMode of gmNext: // move on if fCurrent < fCurrentIndex.Count - 1 then Inc (fCurrent) else Result := grEOF; // end of file gmPrior: // move back if fCurrent > 0 then Dec (fCurrent) else Result := grBOF; // begin of file gmCurrent: // check if empty if (FCurrent<0) or (fCurrent >= fCurrentIndex.Count) then Result := grEOF; end; if Result = grOK then // read the data begin BkmIdx:=FCurrentIndex.RecordIndex[FCurrent]; Buffer.Data:=FRows[bkmIdx]; Buffer.BookmarkFlag := bfCurrent; Buffer.Bookmark:=BkmIdx; GetCalcFields(Buffer); if Filtered then begin FFilterRow:=Buffer.Data; recordAccepted:=DoFilterRecord; if Not RecordAccepted and (GetMode=gmCurrent) then begin // Transform to EOF. RecordAccepted:=True; Result:=grEOF; end; end; end; until recordAccepted; end; function TBaseJSONDataSet.GetRecordCount: Integer; begin if Assigned(FCurrentIndex) then Result:=FCurrentIndex.Count else Result:=0; end; function TBaseJSONDataSet.GetRecordSize: Word; begin Result := 0; // actual data without house-keeping end; procedure TBaseJSONDataSet.InternalClose; begin // disconnect and destroy field objects BindFields (False); if DefaultFields then DestroyFields; FreeData; end; procedure TBaseJSONDataSet.InternalDelete; Var I,RowIdx : Integer; aIndex : TJSONIndex; begin RowIdx:=FCurrentIndex.Delete(FCurrent); if (RowIdx<>-1) then begin For I:=0 to FIndexes.Count-1 do begin aIndex:=FIndexes[i].Index; if aIndex<>FCurrentIndex then aIndex.DeleteByRowIndex(RowIdx); end; // ... // Add to array of deleted records. if Not Assigned(FDeletedRows) then FDeletedRows:=TJSArray.New(FRows[RowIdx]) else FDeletedRows.Push(FRows[RowIdx]); FRows[RowIdx]:=Undefined; end; end; procedure TBaseJSONDataSet.InternalFirst; begin FCurrent := -1; end; procedure TBaseJSONDataSet.InternalGotoBookmark(ABookmark: TBookmark); begin if isNumber(ABookmark.Data) then FCurrent:=FCurrentIndex.FindRecord(Integer(ABookmark.Data)); // Writeln('Fcurrent', FCurrent,' from ',ABookmark.Data); end; procedure TBaseJSONDataSet.InternalInsert; Var I : Integer; D : TFieldDef; begin // Writeln('TBaseJSONDataSet.InternalInsert'); FEditRow:=ActiveBuffer.Data; For I:=0 to FieldDefs.Count-1 do begin D:=FieldDefs[i]; FFieldMapper.SetJSONDataForField(D.Name,D.Index,FEditRow,Null); end; end; procedure TBaseJSONDataSet.RemoveCalcFields(Buf : JSValue); Var i : integer; begin For I:=0 to Fields.Count-1 do if Fields[i].FieldKind in [fkCalculated,fkInternalCalc,fkLookup] then FieldMapper.RemoveField(FIelds[i].FieldName,FIelds[i].Index,Buf); end; procedure TBaseJSONDataSet.InternalEdit; begin // Writeln('TBaseJSONDataSet.InternalEdit: '); FEditIdx:=FCurrentIndex.RecordIndex[FCurrent]; if not isUndefined(Rows[FEditIdx]) then begin FEditRow:=FieldMapper.CopyRow(Rows[FEditIdx]); end else FEditRow:=FFieldMapper.CreateRow; // Writeln('TBaseJSONDataSet.InternalEdit: ',FEditRow); end; procedure TBaseJSONDataSet.InternalCancel; begin FEditIdx:=-1; FEditRow:=Nil; end; procedure TBaseJSONDataSet.InternalLast; begin // The first thing that will happen is a GetPrior Record. FCurrent:=FCurrentIndex.Count; end; procedure TBaseJSONDataSet.InitDateTimeFields; begin // Do nothing end; procedure TBaseJSONDataSet.InternalOpen; begin FreeAndNil(FFieldMapper); FFieldMapper:=CreateFieldMapper; IF (FRows=Nil) then // opening from fielddefs ? begin FRows:=TJSArray.New; OwnsData:=True; end; CreateIndexes; InternalInitFieldDefs; if DefaultFields then CreateFields; BindFields (True); InitDateTimeFields; if FActiveIndex<>'' then ActivateIndex(True); FCurrent := -1; end; procedure TBaseJSONDataSet.InternalPost; Var I,NewIdx,NewCurrent,Idx : integer; B : TBookmark; begin NewCurrent:=-1; GetBookMarkData(ActiveBuffer,B); if (State=dsInsert) then begin // Insert or Append Idx:=FRows.push(FEditRow)-1; if GetBookMarkFlag(ActiveBuffer)=bfEOF then begin // Append FDefaultIndex.Append(Idx); for I:=0 to FIndexes.Count-1 do if Assigned(FIndexes[i].Findex) then begin NewIdx:=FIndexes[i].Findex.Append(Idx); if FIndexes[i].Findex=FCurrentIndex then NewCurrent:=NewIdx; end; end else // insert begin FCurrent:=FDefaultIndex.Insert(FCurrent,Idx); for I:=0 to FIndexes.Count-1 do if Assigned(FIndexes[i].Findex) then begin NewIdx:=FIndexes[i].Findex.Append(Idx); if FIndexes[i].Findex=FCurrentIndex then NewCurrent:=NewIdx; end; end; end else begin // Edit if (FEditIdx=-1) then DatabaseErrorFmt('Failed to retrieve record index for record %d',[FCurrent]); // Update source record Idx:=FEditIdx; FRows[Idx]:=FEditRow; FDefaultIndex.Update(Idx); // Must replace this by updating all indexes. // Note that this will change current index. for I:=0 to FIndexes.Count-1 do begin // Determine old index. NewIdx:=FCurrentIndex.Update(Idx); if Assigned(FIndexes[i].Findex) then if FIndexes[i].Findex=FCurrentIndex then NewCurrent:=NewIdx; end; end; // We have an active index, set current to that index. if NewCurrent<>-1 then FCurrent:=NewCurrent; FEditIdx:=-1; FEditRow:=Nil; end; procedure TBaseJSONDataSet.InternalSetToRecord(Buffer: TDataRecord); begin FCurrent:=FCurrentIndex.FindRecord(Integer(Buffer.Bookmark)); end; procedure TBaseJSONDataSet.SetFilterText(const Value: string); begin inherited SetFilterText(Value); FreeAndNil(FFilterExpression); if Active then Resync([rmCenter]); end; procedure TBaseJSONDataSet.SetFiltered(Value: Boolean); begin inherited SetFiltered(Value); FreeAndNil(FFilterExpression); if Active then Resync([rmCenter]); end; function TBaseJSONDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass; begin If UseDateTimeFormatFields and (FieldType in [ftDate,ftDateTime,ftTime]) then case FieldType of ftDate : Result:=TJSONDateField; ftDateTime : Result:=TJSONDateTimeField; ftTime : Result:=TJSONTimeField; end else Result:=inherited GetFieldClass(FieldType); end; function TBaseJSONDataSet.GetApplyUpdateData(Buffer: TDataRecord): JSValue; begin Result:=FieldMapper.CopyRow(Buffer.Data); RemoveCalcFields(Result); end; function TBaseJSONDataSet.IsCursorOpen: Boolean; begin Result := Assigned(FDefaultIndex); end; function TBaseJSONDataSet.BookmarkValid(ABookmark: TBookmark): Boolean; begin Result:=isNumber(ABookmark.Data); end; procedure TBaseJSONDataSet.SetBookmarkData(var Buffer: TDataRecord; Data: TBookmark); begin Buffer.Bookmark:=Data.Data; // Writeln('Set Bookmark from: ',Data.Data); end; function TBaseJSONDataSet.ConvertDateTimeField(S : String; F : TField) : TDateTime; Var Ptrn : string; begin Result:=0; Ptrn:=''; Case F.DataType of ftDate : if F is TJSONDateField then Ptrn:=(F as TJSONDateField).DateFormat; ftTime : if F is TJSONTimeField then Ptrn:=(F as TJSONTimeField).TimeFormat; ftDateTime : if F is TJSONDateTimeField then Ptrn:=(F as TJSONDateTimeField).DateTimeFormat; end; If (Ptrn='') then Result := DefaultConvertToDateTime(F,S,True) else Result:=ScanDateTime(ptrn,S,1); end; function TBaseJSONDataSet.FormatDateTimeField(DT: TDateTime; F: TField ): String; Var Ptrn : string; begin Result:=''; Ptrn:=''; Case F.DataType of ftDate : if F is TJSONDateField then Ptrn:=TJSONDateField(F).DateFormat; ftTime : if F is TJSONTimeField then Ptrn:=TJSONTimeField(F).TimeFormat; ftDateTime : if F is TJSONDateTimeField then Ptrn:=TJSONDateTimeField(F).DateTimeFormat; end; If (Ptrn='') then Result := DateTimeToRFC3339(DT) else Result:=FormatDateTime(ptrn,DT); end; function TBaseJSONDataSet.CreateFieldMapper: TJSONFieldMapper; begin if FRowType=rtJSONArray then Result:=TJSONArrayFieldMapper.Create else Result:=TJSONObjectFieldMapper.Create; end; function TBaseJSONDataSet.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue; var R : JSValue; begin if State in [dsCalcFields,dsInternalCalc] then R:=CalcBuffer.data else if (State=dsFilter) then R:=FFilterRow else if (FEditIdx=Buffer.Bookmark) then begin if State=dsOldValue then R:=Buffer.data else R:=FEditRow; end else begin if State=dsOldValue then Exit(Null) else R:=Buffer.data; end; Result:=FFieldMapper.GetJSONDataForField(Field,R); if isUndefined(Result) then Result:=Null; end; procedure TBaseJSONDataSet.SetFieldData(Field: TField; var Buffer: TDatarecord; AValue : JSValue); var R : JSValue; begin if State in [dsCalcFields,dsInternalCalc] then R:=CalcBuffer.Data else R:=FEditRow; FFieldMapper.SetJSONDataForField(Field,R,AValue); if not(State in [dsCalcFields, dsInternalCalc, dsFilter, dsNewValue]) then DataEvent(deFieldChange, Field); SetModified(True); // FFieldMapper.SetJSONDataForField(Field,Buffer.Data,AValue); end; procedure TBaseJSONDataSet.SetBookmarkFlag(var Buffer: TDataRecord; Value: TBookmarkFlag); begin Buffer.BookmarkFlag := Value; end; function TBaseJSONDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; begin if isNumber(Bookmark1.Data) and isNumber(Bookmark2.Data) then Result := Integer(Bookmark2.Data) - Integer(Bookmark1.Data) else begin if isNumber(Bookmark1.Data) then Result := -1 else if isNumber(Bookmark2.Data) then Result := 1 else Result := 0; end; end; procedure TBaseJSONDataSet.SetRecNo(Value: Integer); begin CheckBrowseMode; DoBeforeScroll; if (Value < 1) or (Value > FCurrentIndex.Count) then raise EJSONDataset.CreateFmt('%s: SetRecNo: index %d out of range',[Name,Value]); FCurrent := Value - 1; Resync([]); DoAfterScroll; end; constructor TBaseJSONDataSet.Create(AOwner: TComponent); begin inherited; FownsData:=True; UseDateTimeFormatFields:=False; FEditIdx:=-1; FIndexes:=CreateIndexDefs; end; destructor TBaseJSONDataSet.Destroy; begin Close; FreeAndNil(FFilterExpression); FreeAndNil(FIndexes); FEditIdx:=-1; inherited; end; function TBaseJSONDataSet.CreateIndexDefs: TJSONIndexDefs; begin Result:=TJSONIndexDefs.Create(Self,Self,TJSONIndexDef); end; procedure TBaseJSONDataSet.BuildIndexes; Var I : integer; begin For I:=0 to FIndexes.Count-1 do FIndexes[i].BuildIndex(Self); end; function TBaseJSONDataSet.RecordComparerClass : TRecordComparerClass; begin Result:=TRecordComparer; end; function TBaseJSONDataSet.LocateRecordIndex(const KeyFields: string; const KeyValues: JSValue; Options: TLocateOptions): Integer; Var Comp : TRecordComparer; RI,I : Integer; begin Result:=-1; Comp:=RecordComparerClass.Create(Self,KeyFields,KeyValues,Options); try if loFromCurrent in Options then I:=FCurrent else I:=0; RI:=FCurrentIndex.GetRecordIndex(I); While (Result=-1) and (RI<>-1) do begin if Comp.Compare(RI)=0 then Result:=RI; inc(I); RI:=FCurrentIndex.GetRecordIndex(I); end; finally Comp.Free; end; end; function TBaseJSONDataSet.Locate(const KeyFields: string; const KeyValues: JSValue; Options: TLocateOptions): boolean; Var I : Integer; BM : TBookMark; begin Result:=Inherited; I:=LocateRecordIndex(KeyFields,KeyValues,Options); Result:=I<>-1; if Result then begin // Construct bookmark. // Bookmark is always the index in the FRows array. BM.Data:=I; BM.Flag:=bfCurrent; GotoBookMark(BM); end; end; function TBaseJSONDataSet.Lookup(const KeyFields: string; const KeyValues: JSValue; const ResultFields: string): JSValue; Var RI,I : Integer; l : TFPList; Vals : TJSValueDynArray; begin Result:=Null; l:=TFPList.Create; try GetFieldList(L,ResultFields); Result:=inherited Lookup(KeyFields, KeyValues, ResultFields); RI:=LocateRecordIndex(KeyFields,KeyValues,[]); if RI<>-1 then begin SetLength(Vals,L.Count); For I:=0 to L.Count-1 do Vals[i]:=FFieldMapper.GetJSONDataForField(TField(L[I]),FRows[RI]); if L.Count=1 then Result:=Vals[i] else Result:=Vals; end; finally L.Free; end; end; end.