json.pas

delphi2009 json 单元,了解delphi2009 json 的实现过程

function DelphiToJavaDateTime(const dt: TDateTime): int64;
begin
  Result := Round((dt - 25569) * 86400000) + (GetTimeBias * 60000);
end;

function FloatToStr(d: double): string;
var
  buffer: array[0..255] of char;
begin
{$IFDEF UNIX}
  sprintf(buffer, '%lf', [d]);
{$ELSE}
  sprintf(buffer, '%lf', d);
{$ENDIF}
  Result := buffer;
end;

function strdup(s: PChar): PChar;
var
  l: integer;
begin
  if s <> nil then
  begin
    l := StrLen(s);
    GetMem(Result, l + 1);
    move(s^, Result^, l);
    Result[l] := #0;
  end else
    Result := nil;
end;

function JsonIsError(obj: TJsonObject): boolean;
begin
  Result := PtrUInt(obj) > PtrUInt(-4000);
end;

function JsonIsValid(obj: TJsonObject): boolean;
begin
  Result := not ((obj = nil) or (PtrUInt(obj) > PtrUInt(-4000)));
end;

function JsonFindFirst(obj: TJsonObject; var F: TJsonObjectIter): boolean;
var
  i: TJsonAvlEntry;
begin
  F.Ite := TJsonAvlIterator.Create(obj.o.c_object);
  F.Ite.First;
  i := F.Ite.GetIter;
  if i <> nil then
  begin
    f.key  := i.FName;
    f.val  := TJsonObject(i.FObj);
    Result := True;
  end else
    Result := False;
end;

function JsonFindNext(var F: TJsonObjectIter): boolean;
var
  i: TJsonAvlEntry;
begin
  F.Ite.Next;
  i := F.Ite.GetIter;
  if i <> nil then
  begin
    f.key  := i.FName;
    f.val  := TJsonObject(i.FObj);
    Result := True;
  end else
    Result := False;
end;

procedure JsonFindClose(var F: TJsonObjectIter);
begin
  F.Ite.Free;
end;

{ TJsonObject }

constructor TJsonObject.Create(jt: TJsonType);
begin
  inherited Create;
  FRefCount := 1;
  FDataPtr  := nil;
  FJsonType := jt;
  case FJsonType of
    json_type_object: o.c_object := TJsonTableString.Create;
    json_type_array: o.c_array   := TJsonArray.Create;
    else
      o.c_object := nil;
  end;
  Fpb := nil;
end;

constructor TJsonObject.Create(b: boolean);
begin
  Create(json_type_boolean);
  o.c_boolean := b;
end;

constructor TJsonObject.Create(i: JsonInt);
begin
  Create(json_type_int);
  o.c_int := i;
end;

constructor TJsonObject.Create(d: double);
begin
  Create(json_type_double);
  o.c_double := d;
end;

function TJsonObject.AddRef: integer;
begin
  if JsonIsValid(Self) then
  begin
    Inc(FRefCount);
    Result := FRefCount;
  end else
    Result := 0;
end;

constructor TJsonObject.Create(p: PChar);
begin
  Create(json_type_string);
  o.c_string := strdup(p);
end;

destructor TJsonObject.Destroy;
begin
  Assert(FRefCount = 0, '');
  case FJsonType of
    json_type_object: o.c_object.Free;
    json_type_string: FreeMem(o.c_string);
    json_type_array: o.c_array.Free;
  end;
  if Fpb <> nil then
    Fpb.Free;
  inherited;
end;

function TJsonObject.Release: integer;
begin
  if JsonIsValid(Self) then
  begin
    Dec(FRefCount);
    Result := FRefCount;
    if FRefCount = 0 then
      Destroy;
  end else
    Result := 0;
end;

function TJsonObject.IsType(AType: TJsonType): boolean;
begin
  if JsonIsValid(Self) then
    Result := AType = FJsonType
  else
    Result := False;
end;

function TJsonObject.AsBoolean: boolean;
begin
  if JsonIsValid(Self) then
    case FJsonType of
      json_type_boolean: Result := o.c_boolean;
      json_type_int: Result     := (o.c_int <> 0);
      json_type_double: Result  := (o.c_double <> 0);
      json_type_string: Result  := (strlen(o.c_string) <> 0);
      else
        Result := True;
    end else
    Result := False;
end;

function TJsonObject.AsInteger: JsonInt;
var
  code: integer;
  cint: JsonInt;
begin
  if JsonIsValid(Self) then
    case FJsonType of
      json_type_int: Result     := o.c_int;
      json_type_double: Result  := round(o.c_double);
      json_type_boolean: Result := Ord(o.c_boolean);
      json_type_string:
      begin
        Val(o.c_string, cint, code);
        if code = 0 then
          Result := cint
        else
          Result := 0;
      end;
      else
        Result := 0;
    end else
    Result := 0;
end;

function TJsonObject.AsDouble: double;
var
  code:    integer;
  cdouble: double;
begin
  if JsonIsValid(Self) then
    case FJsonType of
      json_type_double: Result  := o.c_double;
      json_type_int: Result     := o.c_int;
      json_type_boolean: Result := Ord(o.c_boolean);
      json_type_string:
      begin
        Val(o.c_string, cdouble, code);
        if code = 0 then
          Result := cdouble
        else
          Result := 0.0;
      end;
      else
        Result := 0.0;
    end else
    Result := 0.0;
end;

function TJsonObject.AsString: PChar;
begin
  if JsonIsValid(Self) then
  begin
    if FJsonType = json_type_string then
      Result := o.c_string
    else
      Result := AsJSon(False);
  end else
    Result := '';
end;

function TJsonObject.AsArray: TJsonArray;
begin
  if JsonIsValid(Self) then
  begin
    if FJsonType = json_type_array then
      Result := o.c_array
    else
      Result := nil;
  end else
    Result := nil;
end;

function TJsonObject.AsObject: TJsonTableString;
begin
  if JsonIsValid(Self) then
  begin
    if FJsonType = json_type_object then
      Result := o.c_object
    else
      Result := nil;
  end else
    Result := nil;
end;

function TJsonObject.AsJSon(format: boolean): PChar;
begin
  if not JsonIsValid(Self) then
    Result := 'null'
  else
  begin
    if (Fpb = nil) then
      Fpb := TJsonWriterString.Create
    else
      Fpb.Reset;

    if (Fpb.Write(self, format, 0) < 0) then
    begin
      Result := '';
      Exit;
    end;
    Result := Fpb.FBuf;
  end;
end;

class function TJsonObject.Parse(s: PChar): TJsonObject;
var
  tok: TJsonTokener;
  obj: TJsonObject;
begin
  tok := TJsonTokener.Create;
  obj := ParseEx(tok, s, -1);
  if (tok.err <> json_tokener_success) then
    obj := TJsonObject(-Ord(tok.err));
  tok.Free;
  Result := obj;
end;

class function TJsonObject.ParseEx(tok: TJsonTokener; str: PChar;
  len: integer): TJsonObject;

  function hexdigit(x: char): byte;
  begin
    if x <= '9' then
      Result := byte(x) - byte('0')
    else
      Result := (byte(x) and 7) + 9;
  end;

  function min(v1, v2: integer): integer;
  begin
    if v1 < v2 then
      Result := v1
    else
      Result := v2;
  end;

var
  obj:     TJsonObject;
  c:       char;
  utf_out: array[0..2] of byte;

  numi:   JsonInt;
  numd:   double;
  code:   integer;
  TokRec: PJsonTokenerSrec;
const
  spaces   = [' ', #8, #10, #13, #9];
  alpha    = ['_', 'a'..'z', 'A'..'Z'];
  alphanum = ['_', 'a'..'z', 'A'..'Z', '0'..'9'];
label
  out, redo_char;
begin
  obj    := nil;
  TokRec := @tok.stack[tok.depth];

  tok.char_offset := 0;
  tok.err         := json_tokener_success;

  repeat
    if (tok.char_offset = len) then
    begin
      if (tok.depth = 0) and (TokRec^.state = json_tokener_state_eatws) and
        (TokRec^.saved_state = json_tokener_state_finish) then
        tok.err := json_tokener_success
      else
        tok.err := json_tokener_continue;
      goto out;
    end;

    c := str^;
    redo_char:
      case TokRec^.state of
        json_tokener_state_eatws:
        begin
          if c in spaces then {nop}
          else
          if (c = '/') then
          begin
            tok.pb.Reset;
            tok.pb.Append(@c, 1);
            TokRec^.state := json_tokener_state_comment_start;
          end else
          begin
            TokRec^.state := TokRec^.saved_state;
            goto redo_char;
          end;
        end;

        json_tokener_state_start:
          case c of
            '"',
            '''':
            begin
              TokRec^.state := json_tokener_state_string;
              tok.pb.Reset;
              tok.quote_char := c;
            end;
            '0'..'9',
            '-':
            begin
              TokRec^.state := json_tokener_state_number;
              tok.pb.Reset;
              tok.is_double := 0;
              goto redo_char;
            end;
            '{':
            begin
              TokRec^.state       := json_tokener_state_eatws;
              TokRec^.saved_state := json_tokener_state_object_field_start;
              TokRec^.current     := TJsonObject.Create(json_type_object);
            end;
            '[':
            begin
              TokRec^.state       := json_tokener_state_eatws;
              TokRec^.saved_state := json_tokener_state_array;
              TokRec^.current     := TJsonObject.Create(json_type_array);
            end;
            'N',
            'n':
            begin
              TokRec^.state := json_tokener_state_null;
              tok.pb.Reset;
              tok.st_pos := 0;
              goto redo_char;
            end;
            'T',
            't',
            'F',
            'f':
            begin
              TokRec^.state := json_tokener_state_boolean;
              tok.pb.Reset;
              tok.st_pos := 0;
              goto redo_char;
            end;
            else
      {$IFDEF JSON_EXTENDED_SYNTAX}
              TokRec^.state := json_tokener_state_unquoted_string;
              tok.pb.Reset;
              goto redo_char;
      {$ELSE}
        tok.err := json_tokener_error_parse_unexpected;
        goto out;
      {$ENDIF}
          end;

        json_tokener_state_finish:
        begin
          if (tok.depth = 0) then
            goto out;
          TokRec^.current.AddRef;
          obj := TokRec^.current;
          tok.ResetLevel(tok.depth);
          Dec(tok.depth);
          TokRec := @tok.stack[tok.depth];
          goto redo_char;
        end;
        json_tokener_state_null:
        begin
          tok.pb.Append(@c, 1);
          if (StrLComp('null', tok.pb.FBuf, min(tok.st_pos + 1, 4)) = 0) then
          begin
            if (tok.st_pos = 4) then
{$IFDEF JSON_EXTENDED_SYNTAX}
              if (c in alphanum) then
                TokRec^.state := json_tokener_state_unquoted_string
              else
{$ENDIF}
              begin
                TokRec^.current     := nil;
                TokRec^.saved_state := json_tokener_state_finish;
                TokRec^.state       := json_tokener_state_eatws;
                goto redo_char;
              end;
          end else
          begin
{$IFDEF JSON_EXTENDED_SYNTAX}
            TokRec^.state           := json_tokener_state_unquoted_string;
            tok.pb.FBuf[tok.st_pos] := #0;
            Dec(tok.pb.FBPos);
            goto redo_char;
{$ELSE}
          tok.err := json_tokener_error_parse_null;
          goto out;
{$ENDIF}