fpc和delphi共用的数据集和json相互转换

fpc和delphi共用的数据集和json相互转换

unit core.dbjson;

// cxg 2025-4-22 json<-->TDataSet fit delphi + FPC
interface

{ .$define base64 }
uses
  core.json, core.encode,
{$IFNDEF fpc}
  DBClient, FireDAC.comp.Client, system.JSON,
{$ELSE}
  fpjson, jsonparser, BufDataset,
{$ENDIF}
  SysUtils, DB, Classes;

type
  TDbJson = class helper for TDataSet
    // marshal dataset's fields to TJSONArray
    function FieldsToJsonArray: TJSONArray;
    // marshal dataset's current record to TJSONObject
    function RecordToJsonObject: TJSONObject;
    // marshal dataset(fields+data) to TJSONObject
    function DatasetToJsonObject: TJSONObject;
    // marshal dataset's data to TJSONArray
    function DataToJsonArray: TJSONArray;
    // unmarshal dataset's fields from TJSONArray
    procedure JsonArrayToFields(const AJsonArray: TJSONArray);
    // unmarshal dataset's data from TJSONArray
    procedure JsonArrayToData(const AJsonArray: TJSONArray);
    // unmarshal dataset(fields+data) from TJSONObject
    procedure JsonObjectToDataset(const AJsonObject: TJSONObject);
  end;

implementation

function DataTypeToStr(const ADataType: TFieldType): string;
begin
  case ADataType of
    ftString, ftWideString, ftMemo, ftWideMemo, ftUnknown, ftVariant:
      Result := 'string';
    ftBoolean:
      Result := 'bool';
    ftInteger:
      Result := 'int32';
    ftLargeint:
      Result := 'int64';
    ftWord:
      Result := 'word';
    ftSmallint:
      Result := 'smallint';
    ftFloat:
      Result := 'float';
    ftDateTime:
      Result := 'datetime';
    ftDate:
      Result := 'date';
    ftTime:
      Result := 'time';
    ftCurrency, ftBCD:
      Result := 'currency';
    ftGuid:
      Result := 'guid';
    ftBlob, ftBytes, ftVarBytes:
      Result := 'bin.hex';
  end;
end;

function StrToDataType(const AValue: string): TFieldType;
begin
  if AValue = 'string' then
    Result := ftWideString
  else if AValue = 'boolean' then
    Result := ftBoolean
  else if AValue = 'int32' then
    Result := ftInteger
  else if AValue = 'int64' then
    Result := ftLargeint
  else if AValue = 'word' then
    Result := ftWord
  else if AValue = 'smallint' then
    Result := ftSmallint
  else if AValue = 'float' then
    Result := ftFloat
  else if AValue = 'datetime' then
    Result := ftDateTime
  else if AValue = 'date' then
    Result := ftDate
  else if AValue = 'time' then
    Result := ftTime
  else if AValue = 'currency' then
    Result := ftCurrency
  else if AValue = 'guid' then
    Result := ftGuid
  else if AValue = 'bin.hex' then
    Result := ftBlob;
end;

function TDbJson.DatasetToJsonObject: TJSONObject;
begin
  if not Self.Active then
    Exit;
  Result := TJSONObject.Create;
  Result.A['fields'] := FieldsToJsonArray;
  Result.A['data'] := DataToJsonArray;
end;

procedure TDbJson.JsonArrayToData(const AJsonArray: TJSONArray);
var
  LJsonObject: TJSONObject;
  i: integer;
  LField: TField;
  LBase64: TBase64;
  LBinHex: TBinHex;
begin
  if not Self.Active then
    Exit;
  Self.DisableControls;
  try
    for i := 0 to AJsonArray.Count - 1 do
    begin
      Self.Append;
      LJsonObject := AJsonArray.Items[i] as TJSONObject;
      for LField in Self.Fields do
      begin
        case LField.DataType of
          ftString, ftWideString, ftMemo, ftWideMemo, ftUnknown, ftVariant:
            LField.AsWideString := LJsonObject.S[LField.FieldName];
          ftBoolean:
            LField.AsBoolean := LJsonObject.B[LField.FieldName];
          ftInteger, ftWord, ftSmallint:
            LField.AsInteger := LJsonObject.i[LField.FieldName];
          ftLargeint:
            LField.AsLargeInt := LJsonObject.I64[LField.FieldName];
          ftFloat:
            LField.AsFloat := LJsonObject.D[LField.FieldName];
          ftDateTime, ftDate, ftTime:
            LField.AsWideString := LJsonObject.S[LField.FieldName];
          ftCurrency, ftBCD:
            LField.AsCurrency := LJsonObject.D[LField.FieldName];
          ftBlob, ftBytes, ftVarBytes:
{$IFNDEF base64}
            LBinHex.Decode(LJsonObject.S[LField.FieldName], LField);
{$ELSE}
            LBase64.Decode(LJsonObject.S[LField.FieldName], LField);
{$ENDIF}
        end;
      end;
      Self.Post;
    end;
  finally
    Self.EnableControls;
  end;
end;

function TDbJson.DataToJsonArray: TJSONArray;
var
  LField: TField;
  LBase64: TBase64;
begin
  if not Self.Active then
    Exit;
  Self.DisableControls;
  try
    Result := TJSONArray.Create;
    Self.First;
    while not Self.EOF do
    begin
      Result.Add(RecordToJsonObject);
      Self.Next;
    end;
  finally
    Self.EnableControls;
  end;
end;

function TDbJson.RecordToJsonObject: TJSONObject;
var
  LField: TField;
  LBase64: TBase64;
  LBinHex: TBinHex;
{$IFNDEF base}
  LStr: String;
{$ENDIF}
begin
  if not Self.Active then
    Exit;
  Result := TJSONObject.Create;
  for LField in Self.Fields do
  begin
    case LField.DataType of
      ftString, ftWideString, ftMemo, ftWideMemo, ftUnknown, ftVariant:
        Result.S[LField.FieldName] := LField.AsWideString;
      ftBoolean:
        Result.B[LField.FieldName] := LField.AsBoolean;
      ftInteger, ftWord, ftSmallint:
        Result.i[LField.FieldName] := LField.AsInteger;
      ftLargeint:
        Result.I64[LField.FieldName] := LField.AsLargeInt;
      ftFloat:
        Result.D[LField.FieldName] := LField.AsFloat;
      ftDateTime, ftDate, ftTime:
        Result.D[LField.FieldName] := LField.AsDateTime;
      ftCurrency, ftBCD:
        Result.D[LField.FieldName] := LField.AsCurrency;
      ftBlob, ftBytes, ftVarBytes:
{$IFNDEF base64}
        begin
          LBinHex.encode(LField, LStr);
          Result.S[LField.FieldName] := LStr;
        end;
{$ELSE}
        Result.S[LField.FieldName] := LBase64.encode(LField);
{$ENDIF}
    end;
  end;
end;

function TDbJson.FieldsToJsonArray: TJSONArray;
var
  LFieldDef: TFieldDef;
  i: integer;
  LJsonObject: TJSONObject;
begin
  Result := TJSONArray.Create;
  for i := 0 to Self.FieldDefs.Count - 1 do
  begin
    LJsonObject := TJSONObject.Create;
    LFieldDef := Self.FieldDefs.Items[i];
    LJsonObject.S['name'] := LFieldDef.Name;
    LJsonObject.S['datatype'] := DataTypeToStr(LFieldDef.DataType);
    LJsonObject.i['size'] := LFieldDef.Size;
    LJsonObject.B['required'] := LFieldDef.Required;
    Result.Add(LJsonObject);
  end;
end;

procedure TDbJson.JsonArrayToFields(const AJsonArray: TJSONArray);
var
  LFieldDef: TFieldDef;
  LJsonObject: TJSONObject;
  i: integer;
begin
  if AJsonArray = nil then
    Exit;
  Self.Close;
  Self.FieldDefs.Clear;
  for i := 0 to AJsonArray.Count - 1 do
  begin
    LJsonObject := AJsonArray.Items[i] as TJSONObject;
    LFieldDef := Self.FieldDefs.AddFieldDef;
    LFieldDef.Name := LJsonObject.S['name'];
    LFieldDef.DataType := StrToDataType(LJsonObject.S['datatype']);
    LFieldDef.Size := LJsonObject.i['size'];
    LFieldDef.Required := LJsonObject.B['required'];
  end;
{$IFNDEF fpc}
  if Self is TFDMemTable then
    TFDMemTable(Self).CreateDataSet
  else if Self is TClientDataSet then
    TClientDataSet(Self).CreateDataSet;
{$ELSE}
  if Self is TBufDataset then
  begin
    TBufDataset(Self).CreateDataSet;
    TBufDataset(Self).Active := true;
  end;
{$ENDIF}
end;

procedure TDbJson.JsonObjectToDataset(const AJsonObject: TJSONObject);
begin
  if AJsonObject = nil then
    Exit;
  JsonArrayToFields(AJsonObject.A['fields']);
  JsonArrayToData(AJsonObject.A['data']);
end;

end.