json.pas

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

unit json;

{$IFDEF FPC}
  {$MODE OBJFPC}{$H+}
{$ENDIF}

interface

uses
  Classes;

{$DEFINE JSON_LARGE_INT}
{$DEFINE JSON_EXTENDED_SYNTAX}

type
{$IFNDEF FPC}
  PtrInt  = longint;
  PtrUInt = longword;
{$ENDIF}
{$IFDEF JSON_LARGE_INT}
  JsonInt = int64;
{$ELSE}
  JsonInt = Integer;
{$ENDIF}

const
  JSON_ARRAY_LIST_DEFAULT_SIZE = 32;
  JSON_TOKENER_MAX_DEPTH       = 32;

  JSON_AVL_MAX_DEPTH     = sizeof(longint) * 8;
  JSON_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1);

type
  // forward declarations
  TJsonObject = class;

(* AVL Tree
 *  This is a "special" autobalanced AVL tree
 *  It use a hash value for fast compare
 *)

  TJsonAvlSize = longword;

  TJsonAvlBitArray = set of 0..JSON_AVL_MAX_DEPTH - 1;

  TJsonAvlSearchType  = (stEQual, stLess, stGreater);
  TJsonAvlSearchTypes = set of TJsonAvlSearchType;

  TJsonAvlEntry = class
  private
    FGt, FLt: TJsonAvlEntry;
    FBf:      integer;
    FHash:    cardinal;
    FName:    PChar;
    FObj:     Pointer;
  public
    class function Hash(k: PChar): cardinal; virtual;
    constructor Create(AName: PChar; Obj: Pointer); virtual;
    destructor Destroy; override;
    property Name: PChar Read FName;
    property Obj: Pointer Read FObj;
  end;

  TJsonAvlTree = class
  private
    FRoot:  TJsonAvlEntry;
    FCount: integer;
    function balance(bal: TJsonAvlEntry): TJsonAvlEntry;
  protected
    procedure doDeleteEntry(Entry: TJsonAvlEntry); virtual;
    function CompareNodeNode(node1, node2: TJsonAvlEntry): integer; virtual;
    function CompareKeyNode(k: PChar; h: TJsonAvlEntry): integer; virtual;
    function Insert(h: TJsonAvlEntry): TJsonAvlEntry; virtual;
    function Search(k: PChar; st: TJsonAvlSearchTypes = [stEqual]): TJsonAvlEntry;
      virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function IsEmpty: boolean;
    procedure Clear; virtual;
    procedure Delete(k: PChar);
    property Count: integer Read FCount;
  end;

  TJsonTableString = class(TJsonAvlTree)
  protected
    procedure doDeleteEntry(Entry: TJsonAvlEntry); override;
  public
    function Put(k: PChar; Obj: TJsonObject): TJsonObject;
    function Get(k: PChar): TJsonObject;
  end;


  TJsonAvlIterator = class
  private
    FTree:   TJsonAvlTree;
    FBranch: TJsonAvlBitArray;
    FDepth:  longint;
    FPath:   array[0..JSON_AVL_MAX_DEPTH - 2] of TJsonAvlEntry;
  public
    constructor Create(tree: TJsonAvlTree); virtual;
    procedure Search(k: PChar; st: TJsonAvlSearchTypes = [stEQual]);
    procedure First;
    procedure Last;
    function GetIter: TJsonAvlEntry;
    procedure Next;
    procedure Prior;
  end;

  TJsonObjectArray = array[0..(high(PtrInt) div sizeof(TJsonObject)) - 1] of TJsonObject;
  PJsonObjectArray = ^TJsonObjectArray;


  TJsonRpcMethod = procedure(Params: TJsonObject; out Result: TJsonObject) of object;
  PJsonRpcMethod = ^TJsonRpcMethod;

  TJsonRpcService = class(TJsonAvlTree)
  protected
    procedure doDeleteEntry(Entry: TJsonAvlEntry); override;
  public
    procedure RegisterMethod(Aname: PChar; Sender: TObject; Method: Pointer);
    procedure Invoke(Obj: TJsonTableString; out Result: TJsonObject; out error: string);
  end;

  TJsonRpcClass = class of TJsonRpcService;

  TJsonRpcServiceList = class(TJsonAvlTree)
  protected
    procedure doDeleteEntry(Entry: TJsonAvlEntry); override;
  public
    procedure RegisterService(AName: PChar; obj: TJsonRpcService);
    function Invoke(service: TJsonRpcService; Obj: TJsonObject;
      var error: string): TJsonObject; overload;
    function Invoke(service: PChar; s: PChar): TJsonObject; overload;
  end;

  TJsonArray = class
  private
    FArray:  PJsonObjectArray;
    FLength: integer;
    FSize:   integer;
    function Expand(max: integer): integer;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function Add(Data: TJsonObject): integer;
    function Get(i: integer): TJsonObject;
    procedure Put(i: integer; Data: TJsonObject);
    property Length: integer Read FLength;
    property Items[i: integer]: TJsonObject Read Get Write Put; default;
  end;

  TJsonWriter = class
  protected
    // abstact methods to overide
    function Append(buf: PChar; Size: integer): integer; overload; virtual; abstract;
    function Append(buf: PChar): integer; overload; virtual; abstract;
    procedure Reset; virtual; abstract;
  public

    function Write(obj: TJsonObject; format: boolean; level: integer): integer; virtual;
  end;

  TJsonWriterString = class(TJsonWriter)
  private
    FBuf:  PChar;
    FBPos: integer;
    FSize: integer;
  protected
    function Append(buf: PChar; Size: integer): integer; overload; override;
    function Append(buf: PChar): integer; overload; override;
    procedure Reset; override;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    property Data: PChar Read FBuf;
    property Size: integer Read FSize;
    property Position: integer Read FBPos;
  end;

  TJsonWriterStream = class(TJsonWriter)
  private
    FStream: TStream;
  protected
    function Append(buf: PChar; Size: integer): integer; override;
    function Append(buf: PChar): integer; override;
    procedure Reset; override;
  public
    constructor Create(AStream: TStream); reintroduce; virtual;
  end;

  TJsonWriterFake = class(TJsonWriter)
  private
    FSize: integer;
  protected
    function Append(buf: PChar; Size: integer): integer; override;
    function Append(buf: PChar): integer; override;
    procedure Reset; override;
  public
    constructor Create; reintroduce; virtual;
    property size: integer Read FSize;
  end;

  TJsonWriterSock = class(TJsonWriter)
  private
    FSocket: longint;
    FSize:   integer;
  protected
    function Append(buf: PChar; Size: integer): integer; override;
    function Append(buf: PChar): integer; override;
    procedure Reset; override;
  public
    constructor Create(ASocket: longint); reintroduce; virtual;
    property Socket: longint Read FSocket;
    property Size: integer Read FSize;
  end;


  TJsonTokenerError = (
    json_tokener_success,
    json_tokener_continue,
    json_tokener_error_depth,
    json_tokener_error_parse_eof,
    json_tokener_error_parse_unexpected,
    json_tokener_error_parse_null,
    json_tokener_error_parse_boolean,
    json_tokener_error_parse_number,
    json_tokener_error_parse_array,
    json_tokener_error_parse_object_key_name,
    json_tokener_error_parse_object_key_sep,
    json_tokener_error_parse_object_value_sep,
    json_tokener_error_parse_string,
    json_tokener_error_parse_comment
    );

  TJsonTokenerState = (
    json_tokener_state_eatws,
    json_tokener_state_start,
    json_tokener_state_finish,
    json_tokener_state_null,
    json_tokener_state_comment_start,
    json_tokener_state_comment,
    json_tokener_state_comment_eol,
    json_tokener_state_comment_end,
    json_tokener_state_string,
    json_tokener_state_string_escape,
{$IFDEF JSON_EXTENDED_SYNTAX}
    json_tokener_state_unquoted_string,
{$ENDIF}
    json_tokener_state_escape_unicode,
    json_tokener_state_boolean,
    json_tokener_state_number,
    json_tokener_state_array,
    json_tokener_state_array_add,
    json_tokener_state_array_sep,
    json_tokener_state_object_field_start,
    json_tokener_state_object_field,
{$IFDEF JSON_EXTENDED_SYNTAX}
    json_tokener_state_object_unquoted_field,
{$ENDIF}
    json_tokener_state_object_field_end,
    json_tokener_state_object_value,
    json_tokener_state_object_value_add,
    json_tokener_state_object_sep
    );

  PJsonTokenerSrec = ^TJsonTokenerSrec;

  TJsonTokenerSrec = record
    state, saved_state: TJsonTokenerState;
    obj:                TJsonObject;
    current:            TJsonObject;
    obj_field_name:     PChar;
  end;

  TJsonTokener = class
  public
    str:        PChar;
    pb:         TJsonWriterString;
    depth, is_double, st_pos, char_offset: integer;
    err:        TJsonTokenerError;
    ucs_char:   cardinal;
    quote_char: char;
    stack:      array[0..JSON_TOKENER_MAX_DEPTH - 1] of TJsonTokenerSrec;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure ResetLevel(adepth: integer);
    procedure Reset;
  end;

  // supported object types
  TJsonType = (
    json_type_null,
    json_type_boolean,
    json_type_double,
    json_type_int,
    json_type_object,
    json_type_array,
    json_type_string
    );

  TJsonValidateError = (
    veRuleMalformated,
    veFieldIsRequired,
    veInvalidDataType,
    veFieldNotFound,
    veUnexpectedField,
    veInvalidDate,
    veInvalidTime,
    veInvalidTimeStamp,
    veDuplicateEntry,
    veValueNotInEnum,
    veInvalidLength,
    veInvalidRange
    );

  TJsonCompareResult = (cpLess, cpEqu, cpGreat, cpError);

  TJsonOnValidateError = procedure(Sender: Pointer; error: TJsonValidateError;
    const objpath: string);

  TJsonObject = class
  private

    FJsonType: TJsonType;
    Fpb:       TJsonWriterString;
    FRefCount: integer;
    FDataPtr:  Pointer;
    o: record
                          case TJsonType of
        json_type_boolean: (c_boolean: boolean);
        json_type_double: (c_double: double);
        json_type_int:    (c_int: JsonInt);
        json_type_object: (c_object: TJsonTableString);
        json_type_array:  (c_array: TJsonArray);
        json_type_string: (c_string: PChar);
    end;
    function GetJsonType: TJsonType;
  public
    // refcount
    function AddRef: integer;
    function Release: integer;

    // Writers
    function SaveTo(stream: TStream; format: boolean = False): integer; overload;
    function SaveTo(const FileName: string; format: boolean = False): integer; overload;
    function SaveTo(socket: longint; format: boolean = False): integer; overload;
    function CalcSize(format: boolean = False): integer;
    function AsJSon(format: boolean = False): PChar;

    // parser
    class function Parse(s: PChar): TJsonObject;
    class function ParseEx(tok: TJsonTokener; str: PChar; len: integer): TJsonObject;

    // constructors / destructor
    constructor Create(jt: TJsonType = json_type_object); overload; virtual;
    constructor Create(b: boolean); overload; virtual;
    constructor Create(i: JsonInt); overload; virtual;
    constructor Create(d: double); overload; virtual;
    constructor Create(p: PChar); overload; virtual;
    constructor Create(const s: string); overload; virtual;
    destructor Destroy; override;
    procedure Free; reintroduce; // objects are refcounted

    function AsBoolean: boolean;
    function AsInteger: JsonInt;
    function AsDouble: double;
    function AsString: PChar;
    function AsArray: TJsonArray;
    function AsObject: TJsonTableString;

    // clone a node
    function Clone: TJsonObject;

    // validate methods
    function Validate(const rules, defs: string; callback: TJsonOnValidateError = nil;
      Sender: Pointer = nil): boolean; overload;
    function Validate(rules, defs: TJsonObject; callback: TJsonOnValidateError = nil;
      Sender: Pointer = nil): boolean; overload;

    // compare
    function Compare(obj: TJsonObject): TJsonCompareResult;

    // the json data type
    function IsType(AType: TJsonType): boolean;
    property JsonType: TJsonType Read GetJsonType;
    // a data pointer to link to something ele, a treeview for example
    property DataPtr: Pointer Read FDataPtr Write FDataPtr;
  end;

  TJsonObjectIter = record
    key: PChar;
    val: TJsonObject;
    Ite: TJsonAvlIterator;
  end;

function JsonIsError(obj: TJsonObject): boolean;
function JsonIsValid(obj: TJsonObject): boolean;

function JsonFindFirst(obj: TJsonObject; var F: TJsonObjectIter): boolean;
function JsonFindNext(var F: TJsonObjectIter): boolean;
procedure JsonFindClose(var F: TJsonObjectIter);

function JavaToDelphiDateTime(const dt: int64): TDateTime;
function DelphiToJavaDateTime(const dt: TDateTime): int64;

implementation

uses SysUtils
{$IFDEF UNIX}
  ,libc, baseunix, unix
{$ELSE}
  , Windows
{$ENDIF}
{$IFDEF FPC}
  ,sockets
{$ELSE}
  , WinSock
{$ENDIF};

const
  json_number_chars     = '0123456789.+-e';
  json_number_chars_set = ['0'..'9', '.', '+', '-', 'e'];
  json_hex_chars        = '0123456789abcdef';
  json_hex_chars_set    = ['0'..'9', 'a'..'f'];

{$ifdef MSWINDOWS}
function sprintf(buffer, format: PChar): longint;
  varargs; cdecl; external 'msvcrt.dll';
{$endif}

{$IFDEF UNIX}
function GetTimeBias: integer;
var
  TimeVal: TTimeVal;
  TimeZone: TTimeZone;
begin
  fpGetTimeOfDay(@TimeVal, @TimeZone);
  Result := TimeZone.tz_minuteswest;
end;
{$ELSE}

function GetTimeBias: integer;
var
  tzi: TTimeZoneInformation;
begin
  if GetTimeZoneInformation(tzi) = TIME_ZONE_ID_DAYLIGHT then
    Result := tzi.Bias + tzi.DaylightBias
  else
    Result := tzi.Bias;
end;

{$ENDIF}

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