Measure/Units/CslJson.pas

//------------------------------------------------------------------------------
//  类名:   TCslJson
//
//  描述:   简单的Json字符串解析。
//          为简化操作，该类对Json字符串的格式有一定的要求：
//          ①键名字不能重复；②键值全部是字符串。格式如下：
//          {"status":"true","msg":{"curr":"1","status2":"\u5ba1\u6838\u4e2d",
//          "name":"珠海纵横"}}
//
//          网上找过几个三方Json控件，基本不能用，有个叫lkJson的刚开始还不错，但
//          随着需求的深入，发现问题越来越多：不能嵌套数组、不能用索引的方式遍历
//          子结点（始终返回Null）、Delphi处理转义字符困难等问题。另外有些三方
//          Json控件(如superobject1.24)只支持Delphi XE等高版本, 表现为有些语法在
//          Delphi7中不支持、“Integer overflow”报错等。太多问题，无奈，自己写
//          个简单的解析。有点山寨，但能解决问题。有空再写个专业的。
//
//  作者:   Chenshilong, 2014-07-03
//------------------------------------------------------------------------------


unit CslJson;

interface

uses
  SysUtils, Classes, Dialogs;

type
  TOVArr = array of array of string;   // ObjectValuesArray
  TStrArr = array of string;

  TCslJson = class
  private
    FText: string;
    FOVArr: TOVArr;

    procedure SetText(const Value: string);
    function GetValue(const AField: string): string;
    // 处理转义字符的问题
    function Transfer(AStr: string): string;

  public
    property Text: string read FText write SetText;
    // 取指定键名字的键值。如果键值是个对象则返回{Object}
    // 键值带不带"号都能正确解析，一律返回字符串类型。键值为空不影响结果，
    // 没有类型转换、溢出等问题。
    property Value[const AField: string]: string read GetValue;
    // 如果指定键名字的键值是个对象，则把对象的每个属性值依次填入数组AArray中。
    // AArray数组下标任意，数组元素个数任意（不会溢出）
    procedure ChildValues(AField: string; var AArray: array of string);

    function ArrayText(AField: string): string;               // Json二维数组对象序列化后的字符串值
    function ArrayElementCount(AField: string): Integer;     // Json二维数组对象中元素个数
    function ArrayElementText(AField: string; AIndex: Integer): string;  //  Json二维数组的第AIndex个元素的字符串值
    function ArrayElementPropertyCount(AElementText: string): Integer;   //  Json二维数组的元素的键值对个数
    function ArrayValues(AField: string): TOVArr;

    procedure ValueStrings(AField: string; var AValue: TStrings);
  end;

implementation


{ TcslJson }

procedure TCslJson.SetText(const Value: string);
begin
  FText := Value;
end;

function TCslJson.GetValue(const AField: string): string;
var sF: string;
  iPos, iCur: Integer;
begin
  Result := '';
  if AField = '' then Exit;
  sF := Format('"%s":', [AField]);
  iPos := POS(sF, FText);
  if iPos = 0 then Exit;

  iCur := iPos + Length(sF);
  iPos := iCur;
  while (FText[iCur] <> ',') and (FText[iCur] <> '}') do
    Inc(iCur);
  Result := Copy(FText, iPos, iCur - iPos);
  if Pos('{', Result) > 0 then
  begin
    Result := '{Object}';
    Exit;
  end;
  Result := StringReplace(Result, '"', '', [rfReplaceAll]);
  Result := Transfer(Result);
end;

procedure TCslJson.ChildValues(AField: string; var AArray: array of string);
var sField, sText, sValue: string;
  iPos, iCur, i, j: Integer;
  vSL: TStringList;
begin
  if AField = '' then Exit;
  sField := Format('"%s":', [AField]);
  iPos := POS(sField, FText);
  if iPos = 0 then Exit;

  iCur := iPos + Length(sField);
  iPos := iCur;
  while (FText[iCur] <> '}') do
    Inc(iCur);
  sText := Copy(FText, iPos, iCur - iPos);
  sText := StringReplace(sText, '{', '', []);      // 去掉第一个"{"
  if Pos('{', sText) > 0 then                      // 证明还嵌套有子对象，不支持
  begin
      AArray[Low(AArray)] := '{Contain Sub Object}';
      Exit;
  end;

  // "curr":"1","status2":"\u5ba1\u6838\u4e2d","total":"1","name":"珠海纵横"
  vSL := TStringList.Create;
  try
    while Length(sText) > 0 do
    begin
      iPos := POS(':"', sText);
      iCur := iPos + 2;
      iPos := iCur;
      while (sText[iCur] <> '"') do
        Inc(iCur);

      sValue := Copy(sText, iPos, iCur - iPos);
      sValue := Transfer(sValue);
      vSL.Add(sValue);

      iCur := iCur + 2;
      sText := Copy(sText, iCur, Length(sText) - iCur + 1);
    end;

    // 这种方式保证数组下标任意，数组元素个数任意，不受限制
    j := 1;
    for i := Low(AArray) to High(AArray) do
    begin
      if J > vSL.Count then Break;
      AArray[i] := vSL[j - 1];
      Inc(j);
    end;

  finally
    vSL.Free;
  end;
end;

function TCslJson.Transfer(AStr: string): string;
begin
  AStr := StringReplace(AStr, '\/', '\', [rfReplaceAll]);   // 路径中的“\/”
  Result := AStr;
end;

function TCslJson.ArrayText(AField: string): string;
var sField: string;
  iPos, iCur: Integer;
begin
  Result := '';

  if AField = '' then Exit;
  sField := Format('"%s":[', [AField]);
  iPos := POS(sField, FText);
  if iPos = 0 then Exit;

  iCur := iPos + Length(sField);
  iPos := iCur;
  while (FText[iCur] <> ']') do
    Inc(iCur);
  Result := Copy(FText, iPos, iCur - iPos);
end;

function TCslJson.ArrayElementText(AField: string; AIndex: Integer): string;
var sAT: string;
  iLen, i, iCount, iPos1, iPos2: Integer;
begin
  Result := '';
  iCount := 0;
  iPos1 := 0;
  iPos2 := 0;

  sAT := ArrayText(AField);
  iLen := Length(sAT);

  for i := 1 to iLen do
  begin
    if sAT[i] = '{' then
    begin
      Inc(iCount);
      if iCount = AIndex then
      begin
        iPos1 := i;
        Break;
      end;
    end;
  end;

  for i := iPos1 to iLen do
  begin
    if sAT[i] = '}' then
    begin
      iPos2 := i;
      Break;
    end;
  end;
  Result := Copy(sAT, iPos1, iPos2 - iPos1 + 1);

end;  

function TCslJson.ArrayElementCount(AField: string): Integer;
var i, iLen: Integer;
  sAText: string;
begin
  Result := 0;
  sAText := ArrayText(AField);
  iLen := Length(sAText);
  for i := 1 to iLen do
  begin
    if sAText[i] = '}' then
      Inc(Result);
  end;
end;

function TCslJson.ArrayElementPropertyCount(AElementText: string): Integer;
var i, iLen: Integer;
begin
  Result := 1;

  iLen := Length(AElementText);
  for i := 1 to iLen do
  begin
    if AElementText[i] = ',' then
      if (i < iLen) and (AElementText[i + 1] = '"') then
        Inc(Result);
  end;
end;

function TCslJson.ArrayValues(AField: string): TOVArr;
var sText: string;
  iPos, iCur, i, j, iECount, iPCount: Integer;
  vSL: TStringList;
begin
  Result := nil;
  if AField = '' then Exit;
  iECount := ArrayElementCount(AField);
  if iECount = 0 then Exit;
  iPCount := ArrayElementPropertyCount(ArrayElementText(AField, 1));

  SetLength(FOVArr, iECount, iPCount);

  vSL := TStringList.Create;
  try
    for i := 1 to iECount do
    begin
      sText := ArrayElementText(AField, i);
      vSL.Clear;
      while Length(sText) > 0 do
      begin
        iPos := POS(':"', sText);
        iCur := iPos + 2;
        iPos := iCur;
        while (sText[iCur] <> '"') do
          Inc(iCur);

        vSL.Add(Transfer(Copy(sText, iPos, iCur - iPos)));

        iCur := iCur + 2;
        sText := Copy(sText, iCur, Length(sText) - iCur + 1);
      end;

      for j := 0 to vSL.Count - 1 do
      begin
        FOVArr[i - 1, j] := vSL[j];
      end;
    end;
  finally
    vSL.Free;
  end;
  Result := FOVArr;
end;

procedure TCslJson.ValueStrings(AField: string; var AValue: TStrings);
var
  sText: string;
  i, iECount: Integer;
  vSL: TStringList;
begin
  AValue.Clear;
  if AField = '' then Exit;

  iECount := ArrayElementCount(AField);
  if iECount = 0 then Exit;

  for i := 1 to iECount do
    AValue.Add(ArrayElementText(AField, i));
end;

end.