Delphi实现数据库对象的Json化(1)

来源：http://qburro.bbs.pepo.cn/page/bbs/default.aspx单元名为QBDBJson.pas，提供字段属性、字段属性列表、记录、记录列表、数据表等数据对象的Json化功能，实现的效果如下：1、字段属性描述类TFieldAttrJson:{ "FieldName": "CustomerID", "FieldType": "WideString", "JsonType": "String", "FieldSize": 5}2、字段属性列表描述类TFieldAttrListJson：（其中省略号为后续字段描述）{ "FieldAttrCount": 11, "FieldAttrList": [ { "FieldName": "CustomerID", "FieldType": "WideString", "JsonType": "String", "FieldSize": 5 }, ...... ]}3、数据库记录内容描述类TRecordJson：{ "CustomerID": "ALFKI", "CompanyName": "Alfreds Futterkiste", "ContactName": "Maria Anders", "ContactTitle": "Sales Representative", "Address": "Obere Str. 57", "City": "Berlin", "Region": "", "PostalCode": "12209", "Country": "Germany", "Phone": "030-0074321", "Fax": "030-0076545"}4、数据库记录列表描述类TRecordListJson：（省略号为后续字段描述）{ "RecordCount": 92, "RecordList": [ { "CustomerID": "ALFKI", "CompanyName": "Alfreds Futterkiste", "ContactName": "Maria Anders", "ContactTitle": "Sales Representative", "Address": "Obere Str. 57", "City": "Berlin", "Region": "", "PostalCode": "12209", "Country": "Germany", "Phone": "030-0074321", "Fax": "030-0076545" }, ...... ]}5、数据表完整描述类：TTableJson：（省略号为后续字段属性或后续记录描述）{ "TableName": "Customers", "TableHead": { "FieldAttrCount": 11, "FieldAttrList": [ { "FieldName": "CustomerID", "FieldType": "WideString", "JsonType": "String", "FieldSize": 5 }, ...... ] }, "TableBody": { "RecordCount": 92, "RecordList": [ { "CustomerID": "ALFKI", "CompanyName": "Alfreds Futterkiste", "ContactName": "Maria Anders", "ContactTitle": "Sales Representative", "Address": "Obere Str. 57", "City": "Berlin", "Region": "", "PostalCode": "12209", "Country": "Germany", "Phone": "030-0074321", "Fax": "030-0076545" }, ...... ] }}

下面是该单元的声明：//// QBDBJson.pas -- 数据库应用Json类扩展单元（For QuickBurro中间件）// Copyright (C) 2009 Jopher Software Studio// Autor : Jopher（W.G.Z）// Date : 7/31/2009// Email: Jopher@189.cn// WebSite: http://www.quickburro.net///unit QBDBJson;interfaceuses Windows, SysUtils, Classes, QBJson, DbClient, AdoDB, QBParcel, db;type TStructureRecord=Record FieldName: string; FieldType: string; JsonType: string; FieldSize: integer;end;Type//// 字段属性Json类：描述一个数据表字段的属性... TFieldAttrJson=class(TQBJson) class function CreateIt(aFieldName: string; aFieldType: string; aJsonType: string; aFieldSize: integer): TFieldAttrJson; Overload; class function CreateIt(aCds: TClientDataset; Index: integer): TFieldAttrJson; Overload; class function CreateIt(aDs: TAdoDataset; Index: integer): TFieldAttrJson; Overload; procedure ResolveTo(var aFieldName: string; var aFieldType: string; var aJsonType: string; var aFieldSize: integer); end;//// 字段属性表Json类：描述一个数据表的所有字段的属性... TFieldAttrListJson=class(TQBJson) class function CreateIt(aCds: TClientDataset): TFieldAttrListJson; Overload; class function CreateIt(aDs: TAdoDataset): TFieldAttrListJson; Overload; function ResolveTo: TQBJsonArray; function ConvertToCds(aCds: TClientDataset): boolean; end;//// 记录数据Json类：用于储存一个数据库记录的值... TRecordJson=class(TQBJson) class function CreateIt(aFAListJson: TFieldAttrListJson): TRecordJson; Overload; class function CreateIt(aCds: TClientDataset): TRecordJson; Overload; class function CreateIt(aDs: TAdoDataset): TRecordJson; Overload; function ResolveTo(aDs: TAdoDataset): boolean; Overload; function ResolveTo(aCds: TClientDataset): boolean; Overload; end;//// 记录集Json类：用于储存一批记录（不含表结构信息，记录可能异构）的值... TRecordListJson=class(TQBJson) class function CreateIt(aCds: TClientDataset): TRecordListJson; Overload; class function CreateIt(aDs: TAdoDataset): TRecordListJson; Overload; procedure PutRecordJson(aRecordJson: TRecordJson); Overload; function GetRecordJson(index: integer): TRecordJson; function ResolveTo(aDs: TAdoDataset): boolean; Overload; function ResolveTo(aCds: TClientDataset): boolean; Overload; end;//// 数据集Json类：用于描述某数据表对应的数据集的完整信息（含表头及记录集，记录同构）... TTableJson=class(TQBJson) class function CreateIt(TableName: string; aCds: TClientDataset): TTableJson; Overload; class function CreateIt(TableName: string; aDs: TAdoDataset): TTableJson; Overload; function ResolveTo(aDs: TAdoDataset): boolean; Overload; function ResolveTo(aCds: TClientDataset): boolean; Overload; end;implementation

牛啊！！！

这样提交数据的意义在于哪里呢？

Json化的意义：1、降低持久化时的系统开销（相对XML）2、便于持久化复杂的构造类对象（如主从关系实体、关联关系实体等等，因为Json支持嵌套）3、直接为客户端JavaScript提供对象数据4、让Delphi设计的系统与Java系统软件之间更方便地交换数据。。。

上面这个扩展类从TQBJson基类继承，因此，下述属性、方法也直接继承下来：TQBJson类的声明： TQBJSon = class (TQBJSonAbstractObject) private myHashMap : TStringList; function GetPropValues(const Key: String): String; procedure SetPropValues(const Key: String; const Value: String); procedure SetAsString(const Value: String); function GetKeyByIndex(index: Integer): String; procedure SetCascadeValueEx(const Value: String; const Keys: array of String; StartIdx: Integer); function GetValByIndex(index: Integer): String; procedure UpdateByTokener(x: TQBJSonTokener); public constructor Create; overload; constructor Create (jo : TQBJSon; sa : array of string); overload; constructor Create (x : TQBJSonTokener); overload; constructor Create (map : TStringList); overload; constructor Create (s : string); overload; constructor Create (aStream: TStream; Bytes: integer); overLoad; constructor Create (aFilename: string; FailIfNof ile: boolean); overload; constructor create (aQBParcel: TQBParcel; GoodsName: string); overload; procedure Clean; function Clone : TQBJSonAbstractObject; override; function Accumulate (key : string; value : TQBJSonAbstractObject): TQBJSon; function Get (key : string) : TQBJSonAbstractObject; function GetBoolean (key : string): boolean; function GetDouble (key : string): double; function GetInt (key : string): integer; function GetJSonArray (key : string) : TQBJSonArray; function GetJSon (key : string) : TQBJSon; function GetString (key : string): string; function Has (key : string) : boolean; function IsNull (key : string) : boolean; function Keys : TStringList ; function Length : integer; function Names : TQBJSonArray; class function NumberToString (n: _Number): string; class function ValueToString(value : TQBJSonAbstractObject) : string; overload; class function ValueToString(value : TQBJSonAbstractObject; indentFactor, indent : integer) : string; overload; function Opt (key : string) : TQBJSonAbstractObject; function OptBoolean (key : string): boolean; overload; function OptBoolean (key : string; defaultValue : boolean): boolean; overload; function OptDouble (key : string): double; overload; function OptDouble (key : string; defaultValue : double): double; overload; function OptInt (key : string): integer; overload; function OptInt (key : string; defaultValue : integer): integer; overload; function OptString (key : string): string; overload; function OptString (key : string; defaultValue : string): string; overload; function OptJSonArray (key : string): TQBJSonArray; overload; function OptJSon (key : string): TQBJSon; overload; procedure Put (key : string; value : boolean); overload; procedure Put (key : string; value : double); overload; procedure Put (key : string; value : integer); overload; procedure Put (key : string; value : string); overload; procedure Put (key : string; value : TQBJSonAbstractObject); overload; procedure PutOpt (key : string; value : TQBJSonAbstractObject); class function quote (s : string): string; function Remove (key : string): TQBJSonAbstractObject; procedure AssignTo(JSon: TQBJSon); function ToJSonArray (names : TQBJSonArray) : TQBJSonArray; function ToString (): string ; overload; override; function ToString2 (indentFactor : integer): string; overload; function ToString3 (indentFactor, indent : integer): string; overload; property PropValues[const Key: String]:String read GetPropValues write SetPropValues; default; property KeyByIndex[index: Integer]:String read GetKeyByIndex; property ValByIndex[index: Integer]:String read GetValByIndex; property AsString:String read ToString write SetAsString; procedure Assign(Source: TQBJSon); function GetCascadeValue(const Keys: array of String): String; procedure SetCascadeValue(const Value: String; const Keys: array of String); function GetDiffFrom(Source: TQBJSon): TQBJSon; procedure RemoveByKeyHeader(const Header: String='~'); procedure CleanKey(const Key: String); function PropCount:Integer; function KeyByVal(const Value: String):String; destructor Destroy;override; class function NULL : _NULL; function SaveToSteam(aStream: TStream; OutFormat: integer): boolean; function SaveToFile(aFilename: string; OutFormat: integer): boolean; function SaveToParcel(aQBParcel: TQBParcel; GoodsName: string; OutFormat: integer): boolean; end;

还有一个Json数组类，也可以直接与TQBJson基类及TQBDBJson子类配合使用，下面是其声明：TQBJsonArray类的声明： TQBJSonArray = class (TQBJSonAbstractObject) public destructor destroy ; override; constructor create ; overload; constructor create (collection : TList); overload; constructor create (x : TQBJSonTokener); overload; constructor create (s : string); overload; constructor Create (aStream: TStream; Bytes: integer); overLoad; constructor Create (aFilename: string; FailIfNof ile: boolean); overload; constructor create (aQBParcel: TQBParcel; GoodsName: string); overload; function Clone : TQBJSonAbstractObject; override; function get (index : integer) : TQBJSonAbstractObject; function getBoolean (index : integer) : boolean; function getDouble (index : integer) : double; function getInt (index : integer): integer; function getJSonArray (index : integer) : TQBJSonArray; function getJSon (index : integer) : TQBJSon; function getString (index : integer) : string; function isNull (index : integer): boolean; function join (separator : string) : string; function length : integer; function opt (index : integer) : TQBJSonAbstractObject; function optBoolean ( index : integer) : boolean; overload; function optBoolean ( index : integer; defaultValue : boolean) : boolean; overload; function optDouble (index : integer) : double; overload; function optDouble (index : integer; defaultValue :double ) : double ; overload; function optInt (index : integer) : integer; overload; function optInt (index : integer; defaultValue : integer) : integer; overload; function optJSonArray (index : integer) : TQBJSonArray ; overload; function optJSon (index : integer) : TQBJSon ; overload; function optString (index : integer) : string; overload; function optString (index : integer; defaultValue : string) : string; overload; procedure put ( value : boolean); overload ; procedure put ( value : double ); overload ; procedure put ( value : integer); overload ; procedure put ( value : TQBJSonAbstractObject); overload ; procedure put ( value: string); overload; procedure put ( index : integer ; value : boolean); overload ; procedure put ( index : integer ; value : double); overload ; procedure put ( index : integer ; value : integer); overload ; procedure put ( index : integer ; value : TQBJSonAbstractObject); overload ; procedure put ( index: integer; value: string); overload; function toJSon (names : TQBJSonArray ) : TQBJSon ; overload ; function toString : string; overload; override; function toString2 (indentFactor : integer) : string; overload; function toString3 (indentFactor, indent : integer) : string; overload; function toList () : TList; function appendJSonArray( value : TQBJSonArray): Integer ; function SaveToSteam(aStream: TStream; OutFormat: integer): boolean; function SaveToFile(aFilename: string; OutFormat: integer): boolean; function SaveToParcel(aQBParcel: TQBParcel; GoodsName: string; OutFormat: integer): boolean; private myArrayList : TList; end;

快驴V3.08已经发布，已经全面支持Json数据类。请下载试用： http://www.quickburro.net/