DFM->JSON 格式转换

应群友的要求，编写了一个解析 DFM 文件格式，将其转换为 JSON 格式的函数，需要引用 QJSON 和 QString 单元。代码分享给大家，供大家参考：

function DFM2Json(AFileName: String): TQJson;
var
  ADFMStream, ATemp: TMemoryStream;
  I: Integer;
  AObjNode: TQJson;
const
  SSpace: PWideChar = ' '#9;
  SColon: PWideChar = ':';
  SNull: WideChar = #0;
  function IsTextDFM(S: PAnsiChar): Boolean;
  begin
    Result := (AnsiStrLComp(S, 'object', 6) = 0) or
      (AnsiStrLComp(S, 'inherited', 9) = 0);
  end;
  procedure DecodeObject(ALine: PWideChar; var AObjName, AObjClass: QStringW);
  begin
    SkipUntilW(ALine, SSpace);
    AObjName := Trim(DecodeTokenW(ALine, SColon, SNull, True));
    AObjClass := Trim(ALine);
  end;
  function DecodeDFMString(S: QStringW): QStringW;
  var
    ps, pd: PWideChar;
    V: Int64;
  begin
    if Length(S) > 0 then
    begin
      ps := PWideChar(S);
      SetLength(Result, Length(S));
      pd := PWideChar(Result);
      while ps^ <> #0 do
      begin
        if ps^ = '#' then
        begin
          Inc(ps);
          if ParseInt(ps, V) > 0 then
          begin
            pd^ := WideChar(V);
            Inc(pd);
          end;
        end
        else if ps^ = '''' then
        begin
          Inc(ps);
          while ps^ <> '''' do
          begin
            pd^ := ps^;
            Inc(pd);
            Inc(ps);
          end;
          Inc(ps);
        end
        else
        begin
          break;
        end;
      end;
      SetLength(Result, pd - PWideChar(Result));
    end
    else
      Result := '';
  end;

  procedure DecodePropAndChildren(AParent: TQJson; var ps: PWideChar;
    AIsCollection: Boolean);
  var
    ALine, AName, AValue: QStringW;
    pl, pv: PWideChar;
    ATemp: TQJson;
    ACharset: Longint;
    AProps: TQJson;
    AChildren: TQJson;
  const
    SObject: PWideChar = 'object';
    SInline: PWideChar = 'inline';
    SEnd: PWideChar = 'end';
    SEqual: PWideChar = '=';
    SNull: WideChar = #0;
    SItem: PWideChar = 'item';
    SBracket: PWideChar = ')';
  begin
    AProps := AParent;
    AChildren := nil;
    repeat
      ALine := DecodeLineW(ps);
      pl := PWideChar(ALine);
      SkipSpaceW(pl);
      SkipSpaceW(ps);
      if StartWithW(pl, SObject, True) or StartWithW(pl, SInline, True) then
      begin
        DecodeObject(pl, AName, AValue);
        DecodePropAndChildren(AParent.Add(AName, jdtObject), ps, False);
      end
      else if StartWithW(pl, SEnd, True) then
        Exit
      else // Property line
      begin
        AName := Trim(DecodeTokenW(pl, SEqual, SNull, True));
        AValue := Trim(pl);
        pv := PWideChar(AValue);
        if (pv^ = '''') or (pv^ = '#') then
        begin
          AProps.ForcePath(AName).AsString := DecodeDFMString(AValue);
        end
        else if pv^ = '<' then
        begin
          Inc(pv);
          SkipSpaceW(pv);
          if pv^ <> '>' then
          begin
            ATemp := TQJson.Create;
            ATemp.DataType := jdtArray;
            try
              SkipSpaceW(ps);
              while StartWithW(ps, SItem, True) do
              begin
                SkipLineW(ps);
                DecodePropAndChildren(ATemp.Add, ps, True);
              end;
              SkipSpaceW(ps);
              if ps^ = '>' then
                SkipLineW(ps);
            finally
              if ATemp.Count > 0 then
                AProps.Add(AName).Assign(ATemp);
              FreeObject(ATemp);
            end;
          end;
        end
        else if pv^ = '(' then // Strings
        begin
          AValue := '';
          while ps^ <> #0 do
          begin
            ALine := Trim(DecodeLineW(ps));
            if Length(AValue) > 0 then
              AValue := AValue + SLineBreak + DecodeDFMString(ALine)
            else
              AValue := DecodeDFMString(ALine);
            if (ps^ = ')') or EndWithW(ALine, SBracket, True) then
              break;
          end;
          SkipSpaceW(ps);
          if ps^ = ')' then
            SkipLineW(ps);
          SkipSpaceW(ps);
          if Length(AValue) > 0 then
            AProps.ForcePath(AName).AsString := AValue;
        end
        else
          AProps.ForcePath(AName).Value := AValue;
      end;
    until Length(ALine) = 0;
  end;

  procedure DoConvert(AText: QStringW);
  var
    p: PWideChar;
    AObjectName, ARootClass: QStringW;
  const
    SObject: PWideChar = 'object ';
    SInherited: PWideChar = 'inherited ';
  begin
    if Length(AText) > 0 then
    begin
      p := PWideChar(AText);
      if StartWithW(p, SObject, True) or StartWithW(p, SInherited, True) then
      begin
        Result := TQJson.Create;
        try
          DecodeObject(PWideChar(DecodeLineW(p)), AObjectName, ARootClass);
          DecodePropAndChildren(Result.Add(ARootClass, jdtObject), p, False);
        finally
          if Result.Count = 0 then
            FreeAndNil(Result);
        end;
      end;
    end;
  end;

begin
  ADFMStream := TMemoryStream.Create;
  try
    ADFMStream.LoadFromFile(AFileName);
    if PCardinal(ADFMStream.Memory)^ = $30465054 then
    begin
      ATemp := TMemoryStream.Create;
      ATemp.CopyFrom(ADFMStream, 0);
      ATemp.Position := 0;
      ADFMStream.Size := 0;
      ObjectBinaryToText(ATemp, ADFMStream);
      FreeAndNil(ATemp);
      ADFMStream.Position := 0;
      DoConvert(LoadTextW(ADFMStream));
    end
    else if IsTextDFM(ADFMStream.Memory) then
      DoConvert(LoadTextW(ADFMStream));
  finally
    FreeObject(ADFMStream);
  end;
end;

用法：

procedure TForm1.Button1Click(Sender: TObject);
var
  AJson: TQJson;
begin
  if OpenDialog1.Execute then
  begin
    AJson := DFM2Json(OpenDialog1.FileName);
    if AJson <> nil then
    begin
      Memo1.Lines.Text := AJson.AsString;
      FreeAndNil(AJson);
    end;
  end;
end;

一个转换结果示例：

{
  "TForm1":{
    "Left":446,
    "Top":185,
    "Caption":"Form1",
    "ClientHeight":394,
    "ClientWidth":545,
    "Color":"clBtnFace",
    "Font":{
      "Charset":"DEFAULT_CHARSET",
      "Color":"clWindowText",
      "Height":-11,
      "Name":"Tahoma",
      "Style":[]
    },
    "OldCreateOrder":false,
    "PixelsPerInch":96,
    "TextHeight":13,
    "Label1":{
      "Left":288,
      "Top":64,
      "Width":75,
      "Height":20,
      "Caption":"测试LAB",
      "Font":{
        "Charset":"GB2312_CHARSET",
        "Color":"clBlue",
        "Height":-20,
        "Name":"宋体",
        "Style":"[fsBold]"
      },
      "ParentFont":false
    },
    "Edit1":{
      "Left":16,
      "Top":56,
      "Width":169,
      "Height":29,
      "Font":{
        "Charset":"GB2312_CHARSET",
        "Color":"clWindowText",
        "Height":-21,
        "Name":"宋体",
        "Style":"[fsBold]"
      },
      "ParentFont":false,
      "TabOrder":0,
      "Text":"Edit1"
    }
  }
}