Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
840 lines (740 sloc) 20.3 KB
{ *************************************************************************** }
{ }
{ }
{ Copyright (C) Amarildo Lacerda }
{ }
{ https://github.com/amarildolacerda }
{ }
{ }
{ *************************************************************************** }
{ }
{ Licensed under the Apache License, Version 2.0 (the "License"); }
{ you may not use this file except in compliance with the License. }
{ You may obtain a copy of the License at }
{ }
{ http://www.apache.org/licenses/LICENSE-2.0 }
{ }
{ Unless required by applicable law or agreed to in writing, software }
{ distributed under the License is distributed on an "AS IS" BASIS, }
{ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. }
{ See the License for the specific language governing permissions and }
{ limitations under the License. }
{ }
{ *************************************************************************** }
unit System.uJson;
interface
{$I Delphi.inc }
{$IFDEF UNICODE}
{$DEFINE XE}
{$ENDIF}
uses System.Classes, System.Types, System.SysUtils, System.JSON,
System.Generics.collections,
RegularExpressions {RTTI, TypInfo, DBXJson,} , DBXJsonReflect;
type
TJsonType = (jtUnknown, jtObject, jtArray, jtString, jtTrue, jtFalse,
jtNumber, jtDate, jtDateTime, jtBytes);
TObjectHelper = class Helper for TObject
private
public
class function FromJson(AJson: String): System.TObject; static;
function Clone: System.TObject;
function AsJson: string;
end;
TJSONObjectHelper = class helper for TJSONObject
private
function GetValueBase(chave: string): string;
procedure SetValueBase(chave: string; const Value: string);
public
{$IFDEF VER270}
function ToJSON: string;
{$ENDIF}
class function GetTypeAsString(AType: TJsonType): string; static;
class function GetJsonType(AJsonValue: TJsonValue): TJsonType; static;
class function Stringify(so: TJSONObject): string;
class function Parse(const dados: string): TJSONObject;
function V(chave: String): variant;
function S(chave: string): string;
function I(chave: string): integer;
function O(chave: string): TJSONObject; overload;
function O(index: integer): TJSONObject; overload;
function F(chave: string): Extended;
function B(chave: string): boolean;
function A(chave: string): TJSONArray;
function AsArray: TJSONArray;
function Contains(chave: string): boolean;
function Find(chave: string): TJsonValue; virtual;
function asObject: System.TObject;
class function FromObject<T>(AObject: T): TJSONObject; overload;
class function FromRecord<T>(rec: T): TJSONObject;
function addPair(chave: string; Value: integer): TJSONObject; overload;
function addPair(chave: string; Value: Double): TJSONObject; overload;
function addPair(chave: string; Value: TDatetime): TJSONObject; overload;
property Value[chave: string]: string read GetValueBase write SetValueBase;
function Coalesce(chave: string; Value: string): TJsonPair;
// procedure FromRecord<T :record>(rec:T);
end;
TJSONArrayHelper = class helper for TJSONArray
public
function Length: integer;
end;
TJsonValuesList = class(TObjectList<TJsonPair>)
private
function GetNames(AName: string): TJsonPair;
procedure SetNames(AName: string; const Value: TJsonPair);
public
property Names[AName: string]: TJsonPair read GetNames write SetNames;
end;
TJSONValueHelper = class helper for TJsonValue
private
public
{$IFDEF VER270}
function ToJSON: string;
{$ENDIF}
function ToRecord<T>: T; overload;
class function ToRecord<T: record >(AJson: string): T; overload; static;
class procedure GetRecordList<T: record >(AList: TJsonValuesList; ARec: T);
function AsArray: TJSONArray;
function AsPair: TJsonPair;
function Datatype: TJsonType;
function asObject: TJSONObject;
function AsInteger:Integer;
end;
TJSONPairHelper = class helper for TJsonPair
public
function asObject: TJSONObject;
end;
IJson = TJSONObject;
IJSONArray = TJSONArray;
TJson = TJSONObject;
function ReadJsonString(const dados: string; chave: string): string;
function ReadJsonInteger(const dados: string; chave: string): integer;
function ReadJsonFloat(const dados: string; chave: string): Extended;
// function ReadJsonObject(const dados: string): IJson;
function JSONstringify(so: IJson): string;
function JSONParse(const dados: string): IJson;
function ISODateTimeToString(ADateTime: TDatetime): string;
function ISODateToString(ADate: TDatetime): string;
function ISOTimeToString(ATime: TTime): string;
function ISOStrToDateTime(DateTimeAsString: string): TDatetime;
function ISOStrToDate(DateAsString: string): TDate;
function ISOStrToTime(TimeAsString: string): TTime;
function JSONStoreError(msg: string): TJsonValue;
implementation
uses db, System.Rtti, System.TypInfo, System.DateUtils, Rest.JSON;
var
LJson: TJson;
type
TValueHelper = record helper for TValue
private
function IsNumeric: boolean;
function IsFloat: boolean;
function IsBoolean: boolean;
function IsDate: boolean;
function IsDateTime: boolean;
function IsDouble: boolean;
function IsInteger: boolean;
end;
function TValueHelper.IsNumeric: boolean;
begin
result := Kind in [tkInteger, tkChar, tkEnumeration, tkFloat,
tkWChar, tkInt64];
end;
function TValueHelper.IsFloat: boolean;
begin
result := Kind = tkFloat;
end;
function TValueHelper.IsBoolean: boolean;
begin
result := TypeInfo = System.TypeInfo(boolean);
end;
function TValueHelper.IsDate: boolean;
begin
result := TypeInfo = System.TypeInfo(TDate);
end;
function TValueHelper.IsDateTime: boolean;
begin
result := TypeInfo = System.TypeInfo(TDatetime);
end;
function TValueHelper.IsDouble: boolean;
begin
result := TypeInfo = System.TypeInfo(Double);
end;
function TValueHelper.IsInteger: boolean;
begin
result := TypeInfo = System.TypeInfo(integer);
end;
class function TJSONObjectHelper.GetTypeAsString(AType: TJsonType): string;
begin
case AType of
jtUnknown:
result := 'Unknown';
jtString:
result := 'String';
jtTrue, jtFalse:
result := 'Boolean';
jtNumber:
result := 'Extended';
jtDate:
result := 'TDate';
jtDateTime:
result := 'TDateTime';
jtBytes:
result := 'Byte';
end;
end;
function TJSONObjectHelper.GetValueBase(chave: string): string;
begin
result := S(chave);
end;
class function TJSONObjectHelper.GetJsonType(AJsonValue: TJsonValue): TJsonType;
var
LJsonString: TJSONString;
begin
if AJsonValue is TJSONObject then
result := jtObject
else if AJsonValue is TJSONArray then
result := jtArray
else if (AJsonValue is TJSONNumber) then
result := jtNumber
else if AJsonValue is TJSONTrue then
result := jtTrue
else if AJsonValue is TJSONFalse then
result := jtFalse
else if AJsonValue is TJSONString then
begin
LJsonString := (AJsonValue as TJSONString);
if TRegEx.IsMatch(LJsonString.Value,
'^([0-9]{4})-?(1[0-2]|0[1-9])-?(3[01]|0[1-9]|[12][0-9])(T| )(2[0-3]|[01][0-9]):?([0-5][0-9]):?([0-5][0-9])$')
then
result := jtDateTime
else if TRegEx.IsMatch(LJsonString.Value,
'^([0-9]{4})(-?)(1[0-2]|0[1-9])\2(3[01]|0[1-9]|[12][0-9])$') then
result := jtDate
else
result := jtString
end
else
result := jtUnknown;
end;
function JSONParse(const dados: string): IJson;
begin
result := TJSONObject.ParseJSONValue(dados) as IJson;
end;
function JSONstringify(so: IJson): string;
begin
result := so.ToJSON;
end;
function ReadJsonFloat(const dados: string; chave: string): Extended;
var
I: IJson;
begin
I := JSONParse(dados);
try
I.TryGetValue<Extended>(chave, result);
finally
I.Free;
end;
end;
function ReadJsonString(const dados: string; chave: string): string;
var
j: TJson;
I: IJson;
V: string;
begin
j := JSONParse(dados);
// usar variavel local para não gerar conflito com Multi_threaded application
try
j.TryGetValue<string>(chave, V);
result := V;
{ case VarTypeToDataType of
varString: Result := I.S[chave];
varInt64: Result := IntToStr(I.I[chave]);
varDouble,varCurrency: Result := FloatToStr(I.F[chave]);
varBoolean: Result := BoolToStr( I.B[chave] );
varDate: Result := DateToStr(I.D[chave]);
else
result := I.V[chave];
end; }
finally
j.Free;
end;
end;
(* function ReadJsonObject(const dados: string; chave: string): IJson;
var
j: TJson;
begin
result := JSONParse(dados);
{ // usar variavel local para não gerar conflito com Multi_threaded application
try
result := j.parse(dados);
finally
j.Free;
end;}
end;
*)
function ReadJsonInteger(const dados: string; chave: string): integer;
var
j: TJson;
I: IJson;
begin
j := JSONParse(dados);
// usar variavel local para não gerar conflito com Multi_threaded application
try
j.TryGetValue<integer>(chave, result);
finally
j.Free;
end;
end;
{$IFNDEF MULTI_THREADED}
function JSON: TJson;
begin
if not assigned(LJson) then
LJson := TJson.Create;
result := LJson;
end;
procedure JSONFree;
begin
if assigned(LJson) then
FreeAndNil(LJson);
end;
{$ENDIF}
{ TJSONObjectHelper }
function TJSONObjectHelper.A(chave: string): TJSONArray;
begin
TryGetValue<TJSONArray>(chave, result);
end;
function TJSONObjectHelper.addPair(chave: string; Value: integer): TJSONObject;
begin
result := addPair(chave, TJSONNumber.Create(Value));
end;
function TJSONObjectHelper.addPair(chave: string; Value: Double): TJSONObject;
begin
result := addPair(chave, TJSONNumber.Create(Value));
end;
function TJSONObjectHelper.addPair(chave: string; Value: TDatetime)
: TJSONObject;
var
S: string;
begin
if trunc(Value) <> Value then
S := ISODateTimeToString(Value)
else
S := ISODateToString(Value);
result := addPair(chave, S);
end;
function TJSONObjectHelper.AsArray: TJSONArray;
begin
result := TJSONObject.ParseJSONValue(self.ToJSON) as TJSONArray;
end;
function TJSONObjectHelper.B(chave: string): boolean;
begin
TryGetValue<boolean>(chave, result);
end;
function TJSONObjectHelper.Coalesce(chave, Value: string): TJsonPair;
begin
if not Contains(chave) then
addPair(chave, Value); // se nao existe, adiciona;
result := Get(chave);
end;
function TJSONObjectHelper.Contains(chave: string): boolean;
var
LJSONValue: TJsonValue;
begin
LJSONValue := FindValue(chave);
result := LJSONValue <> nil;
end;
function TJSONObjectHelper.F(chave: string): Extended;
begin
result := 0;
if FindValue(chave) <> nil then
TryGetValue<Extended>(chave, result);
end;
function TJSONObjectHelper.Find(chave: string): TJsonValue;
begin
result := inherited FindValue(chave);
end;
function TJSONObjectHelper.I(chave: string): integer;
begin
result := 0;
if FindValue(chave) <> nil then
TryGetValue<integer>(chave, result);
end;
function TJSONObjectHelper.O(index: integer): TJSONObject;
var
pair: TJsonPair;
begin
result := TJSONObject(Get(index));
end;
function TJSONObjectHelper.O(chave: string): TJSONObject;
var
V: TJsonValue;
begin
V := GetValue(chave);
result := V as TJSONObject;
// TryGetValue<TJSONObject>(chave, result);
end;
class function TJSONObjectHelper.Parse(const dados: string): TJSONObject;
begin
result := TJSONObject.ParseJSONValue(dados) as TJSONObject;
end;
class function TJSONObjectHelper.FromRecord<T>(rec: T): TJSONObject;
var
m: TJSONMarshal;
js: TJsonValue;
begin
{ m := TJSONMarshal.Create;
try
js := m.Marshal(AObject);
result := js as TJSONObject;
finally
m.Free;
end;
}
result := TJSONObject.FromObject<T>(rec);
end;
class function TJSONObjectHelper.FromObject<T>(AObject: T): TJSONObject;
var
typ: TRttiType;
ctx: TRttiContext;
field: TRttiField;
tk: TTypeKind;
P: Pointer;
key: String;
FRecord: TRttiRecordType;
FMethod: TRttiMethod;
begin
result := TJSONObject.Create;
ctx := TRttiContext.Create;
typ := ctx.GetType(TypeInfo(T));
P := @AObject;
for field in typ.GetFields do
begin
try
key := field.Name.ToLower;
if not(field.Visibility in [mvPublic, mvPublished]) then
continue;
tk := field.FieldType.TypeKind;
case tk of
tkRecord:
begin
(* FRecord := ctx.GetType(field.GetValue(P).TypeInfo).AsRecord ;
FMethod := FRecord.GetMethod('asJson');
if assigned(FMethod) then
begin
result.AddPair(key,fMethod.asJson );
end; *)
end;
tkInteger:
result.addPair(key, TJSONNumber.Create(field.GetValue(P).AsInteger));
tkFloat:
begin // System.Classes.Helper
if sametext(field.FieldType.Name, 'TDateTime') then
result.addPair(TJsonPair.Create(key,
ISODateTimeToString(field.GetValue(P).asExtended)))
else if sametext(field.FieldType.Name, 'TDate') then
result.addPair(TJsonPair.Create(key,
ISODateToString(field.GetValue(P).asExtended)))
else if sametext(field.FieldType.Name, 'TTime') then
result.addPair(TJsonPair.Create(key,
ISOTimeToString(field.GetValue(P).asExtended)))
else if sametext(field.FieldType.Name, 'TTimeStamp') then
result.addPair(TJsonPair.Create(key,
ISODateTimeToString(field.GetValue(P).asExtended)))
else
result.addPair(key,
TJSONNumber.Create(field.GetValue(P).asExtended));
end
else
result.addPair(TJsonPair.Create(key, field.GetValue(P).ToString));
end;
except
end;
end;
end;
function TJSONObjectHelper.S(chave: string): string;
begin
TryGetValue<string>(chave, result);
end;
procedure TJSONObjectHelper.SetValueBase(chave: string; const Value: string);
var
V: TJsonPair;
begin
V := Get(chave);
if not assigned(V) then
addPair(chave, Value)
else
begin
V.JsonValue := TJSONString.Create(Value);
end;
end;
class function TJSONObjectHelper.Stringify(so: TJSONObject): string;
begin
result := so.ToJSON;
end;
class function TJSONValueHelper.ToRecord<T>(AJson: string): T;
var
j: TJsonValue;
begin
j := TJSONObject.ParseJSONValue(AJson);
try
result := (j).ToRecord<T>;
finally
j.Free;
end;
end;
function TJSONValueHelper.ToRecord<T>(): T;
var
AContext: TRttiContext;
ARecord: TRttiRecordType;
AField: TRttiField;
AJsonValue: TJsonPair;
AValue: TValue;
AFieldName: String;
j: TJSONObject;
begin
AContext := TRttiContext.Create;
ARecord := AContext.GetType(TypeInfo(T)).AsRecord;
j := self as TJSONObject;
for AField in ARecord.GetFields do
begin
try
AFieldName := lowercase(AField.Name);
if FindValue(AFieldName) = nil then
continue;
AJsonValue := j.Get(AFieldName);
case AField.FieldType.TypeKind of
tkFloat: // Also for TDateTime !
begin
if sametext(AField.FieldType.Name, 'TDateTime') then
AValue := ISOStrToDateTime(AJsonValue.JsonValue.Value)
else if sametext(AField.FieldType.Name, 'TTime') then
AValue := ISOStrToTime(AJsonValue.JsonValue.Value)
else
AValue := StrToFloatDef(AJsonValue.JsonValue.Value, 0);
AField.SetValue(@result, AValue);
end;
tkInteger:
begin
AValue := AJsonValue.JsonValue.Value;
AField.SetValue(@result, AValue);
end;
tkUString, tkLString:
begin
AValue := AJsonValue.JsonValue.Value;
AField.SetValue(@result, AValue);
end;
else
if sametext(AField.FieldType.Name, 'Boolean') then
begin
AValue := sametext(AJsonValue.JsonValue.Value, 'true');
AField.SetValue(@result, AValue);
end;
// You should add other types as well
end;
except
end;
end;
end;
function TJSONObjectHelper.V(chave: String): variant;
var
V: string;
begin
TryGetValue<string>(chave, V);
result := V;
end;
function TJSONObjectHelper.asObject: System.TObject;
var
m: TJSONunMarshal;
begin
m := TJSONunMarshal.Create;
try
result := m.Unmarshal(self);
finally
m.Free;
end;
end;
{$IFDEF VER270}
function TJSONObjectHelper.ToJSON: string;
begin
result := ToString;
end;
{$ENDIF}
{ TJSONArrayHelper }
function TJSONArrayHelper.Length: integer;
begin
result := Count;
end;
{ TJSONValueHelper }
{$IFDEF VER270}
function TJSONValueHelper.ToJSON: string;
begin
result := ToString;
end;
{$ENDIF}
{ TJSONValueHelper }
function TJSONValueHelper.AsArray: TJSONArray;
begin
result := self as TJSONArray;
end;
function TJSONValueHelper.AsInteger: Integer;
begin
TryGetValue<integer>(result);
end;
function TJSONValueHelper.asObject: TJSONObject;
begin
result := self as TJSONObject;
end;
function TJSONValueHelper.AsPair: TJsonPair;
begin
result := TJsonPair(self);
end;
function TJSONValueHelper.Datatype: TJsonType;
begin
result := TJSONObject.GetJsonType(self);
end;
class procedure TJSONValueHelper.GetRecordList<T>
(AList: TJsonValuesList; ARec: T);
var
AContext: TRttiContext;
ARecord: TRttiRecordType;
AField: TRttiField;
AJsonValue: TJsonPair;
AValue: TValue;
AFieldName: String;
j: TJSONObject;
APair: TJsonPair;
begin
AContext := TRttiContext.Create;
ARecord := AContext.GetType(TypeInfo(T)).AsRecord;
for AField in ARecord.GetFields do
begin
AFieldName := lowercase(AField.Name);
AValue := AField.GetValue(@ARec);
APair := nil;
case AField.FieldType.TypeKind of
tkInteger, tkFloat, tkInt64:
APair := TJsonPair.Create(AFieldName,
TJSONNumber.Create(AValue.asExtended));
tkString, tkWString, tkLString, tkChar, tkWChar, tkUString:
APair := TJsonPair.Create(AFieldName, AValue.AsString);
else
if sametext(AField.FieldType.Name, 'Boolean') then
begin
APair := TJsonPair.Create(AFieldName,
TJSONBool.Create(AValue.AsBoolean));
end;
end;
if assigned(APair) then
AList.Add(APair);
end;
end;
{ TJSONPairHelper }
function TJSONPairHelper.asObject: TJSONObject;
begin
result := (self.JsonValue) as TJSONObject;
end;
{ TObjectHelper }
function TObjectHelper.AsJson: string;
var
j: TJsonValue;
m: TJSONMarshal;
begin
m := TJSONMarshal.Create;
try
j := m.Marshal(self);
result := j.ToJSON;
finally
m.Free;
end;
end;
function TObjectHelper.Clone: System.TObject;
begin
result := TObject.FromJson(AsJson);
end;
class function TObjectHelper.FromJson(AJson: String): System.TObject;
var
m: TJSONunMarshal;
V: TJSONObject;
begin
m := TJSONunMarshal.Create;
try
V := TJSONObject.Parse(AJson);
result := m.Unmarshal(V);
finally
m.Free;
end;
end;
function ISOTimeToString(ATime: TTime): string;
var
fs: TFormatSettings;
begin
fs.TimeSeparator := ':';
result := FormatDateTime('hh:nn:ss', ATime, fs);
end;
function ISODateToString(ADate: TDatetime): string;
begin
result := FormatDateTime('YYYY-MM-DD', ADate);
end;
function ISODateTimeToString(ADateTime: TDatetime): string;
begin
result := System.DateUtils.DateToISO8601(ADateTime, false);
end;
function ISOStrToDateTime(DateTimeAsString: string): TDatetime;
begin
if pos('T', DateTimeAsString) > 0 then
result := System.DateUtils.ISO8601ToDate(DateTimeAsString)
else
result := StrToDateTime(DateTimeAsString);
end;
function ISOStrToTime(TimeAsString: string): TTime;
begin
result := EncodeTime(StrToInt(Copy(TimeAsString, 1, 2)),
StrToInt(Copy(TimeAsString, 4, 2)), StrToInt(Copy(TimeAsString, 7, 2)), 0);
end;
function ISOStrToDate(DateAsString: string): TDate;
begin
result := System.DateUtils.ISO8601ToDate(DateAsString);
end;
function JSONStoreError(msg: string): TJsonValue;
var
js: TJSONObject;
begin
js := TJSONObject.Create;
js.addPair('error', msg);
js.addPair('ok', 'false');
result := js;
end;
{ TJsonValuesList }
function TJsonValuesList.GetNames(AName: string): TJsonPair;
var
I: integer;
fld: string;
begin
result := nil;
fld := lowercase(AName);
for I := 0 to Count - 1 do
if sametext(Items[I].JsonString.Value, fld) then
begin
result := Items[I];
exit;
end;
end;
procedure TJsonValuesList.SetNames(AName: string; const Value: TJsonPair);
var
I: integer;
fld: string;
begin
fld := lowercase(AName);
for I := 0 to Count - 1 do
if sametext(Items[I].JsonString.Value, fld) then
begin
Items[I] := Value;
exit;
end;
end;
initialization
finalization
{$IFNDEF MULTI_THREADED}
JSONFree;
{$ENDIF}
end.