unit SimplyJSON;
{$MODE Delphi}
{$codepage UTF8}
{*************************************************************************************************************************************
                                                      SimplyJSON
                                    Модуль для парсинга JSON файлов (используется TJSONConfig).
                                        Авторские права (c) 2016 - 2019, Александр Бабаев.
История изменений:
1.3 (01.05.2019) Переработан алгоритм открытия / парсинга JSON файлов при чтении, изменена функция JSReadFont
1.2 (09.05.2017) Добавлены функции чтения/записи шрифтов.
*************************************************************************************************************************************}
interface
uses Classes, SysUtils, Graphics, GraphicsEx, LazFileUtils, fpjson, jsonparser, jsonConf, ANBFormatString;
//stdcalls
function JSReadString (const AKey, ADefault: UnicodeString; const AFileName: String): UnicodeString; STDCALL; OVERLOAD;
function JSReadString (const AKey, ADefault, AFileName: String): String; STDCALL; OVERLOAD;
function JSReadInteger (const AKey: UnicodeString; const ADefault: Int64; const AFileName: String): Int64; STDCALL; OVERLOAD;
function JSReadInteger (const AKey: String; const ADefault: Int64; const AFileName: String): Int64; STDCALL; OVERLOAD;
function JSReadBoolean (const AKey: UnicodeString; const ADefault: Boolean; const AFileName: String): Boolean; STDCALL; OVERLOAD;
function JSReadBoolean (const AKey: String; const ADefault: Boolean; const AFileName: String): Boolean; STDCALL; OVERLOAD;
function JSReadRGBColor (const AKey: UnicodeString; const ADefault: TRGBColor; const AFileName: String): TRGBColor; STDCALL; OVERLOAD;
function JSReadRGBColor (const AKey: String; const ADefault: TRGBColor; const AFileName: String): TRGBColor; STDCALL; OVERLOAD;
procedure JSReadFont (const AKey: UnicodeString; var Font: TFont; const AFileName: String); STDCALL; OVERLOAD;
procedure JSReadFont (const AKey: String; var Font: TFont; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteString (const AKey, AValue: UnicodeString; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteString (const AKey, AValue, AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteInteger (const AKey: UnicodeString; const AValue: Int64; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteInteger (const AKey: String; const AValue: Int64; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteBoolean (const AKey: UnicodeString; const AValue: Boolean; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteBoolean (const AKey: String; const AValue: Boolean; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteRGBColor (const AKey: UnicodeString; const AValue: TRGBColor; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteRGBColor (const AKey: String; const AValue: TRGBColor; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteFont (const AKey: UnicodeString; const AValue: TFont; const AFileName: String); STDCALL; OVERLOAD;
procedure JSWriteFont (const AKey: String; const AValue: TFont; const AFileName: String); STDCALL; OVERLOAD;
procedure JSDeleteKey (const AKey: UnicodeString; const AFileName: String); STDCALL; OVERLOAD;
procedure JSDeleteKey (const AKey, AFileName: String); STDCALL; OVERLOAD;
procedure JSReadSubKeys (const AKey: UnicodeString; SubkeyList: TStrings; const AFileName: String); STDCALL; OVERLOAD;
procedure JSReadSubKeys (const AKey: String; SubkeyList: TStrings; const AFileName: String); STDCALL; OVERLOAD;
implementation
//Support functions
procedure GetJSData (const AFileName: String; var JSData: TJSONData);
var FS: TFileStream;
    SL: TStringList;
begin
if not FileExistsUTF8(AFileName) then
 begin
 FS:= TFileStream.Create(AFileName, fmOpenWrite);
 SL:= TStringList.Create;
 SL.Text:= '{}';
 SL.SaveToStream(FS);
 SL.Free;
 FS.Free;
 end;
FS:= TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
JSData:= GetJSON(FS, True);
FS.Free;
end;
function FrmtKey (const AKey: UnicodeString): UnicodeString;
var KeyM: UnicodeString;
begin
Result:= AKey;
//Для совместимости с SimplyJSON 1.0 - 1.2 и операциями записи
KeyM:= AKey;
if KeyM[1] = '/' then
 Delete(KeyM, 1, 1);
Result:= UnicodeString(FormatStr(KeyM, ['/'], ['.']));
end;
//Read functions
function JSReadString (const AKey, ADefault: UnicodeString; const AFileName: String): UnicodeString; OVERLOAD;
var JD: TJSONData;
begin
GetJSData(AFileName, JD);
try
 Result:= JD.FindPath(FrmtKey(AKey)).AsUnicodeString;
 except
 Result:= ADefault;
 end;
JD.Free;
end;
function JSReadString (const AKey, ADefault, AFileName: String): String; OVERLOAD;
var Key, Def, Res: UnicodeString;
begin
Key:= UnicodeString(AKey);
Def:= UnicodeString(ADefault);
Res:= JSReadString(Key, Def, AFileName);
Result:= String(Res);
end;
function JSReadInteger (const AKey: UnicodeString; const ADefault: Int64; const AFileName: String): Int64; OVERLOAD;
var JD: TJSONData;
begin
GetJSData(AFileName, JD);
try
 Result:= JD.FindPath(FrmtKey(AKey)).AsInt64;
 except
 Result:= ADefault;
 end;
JD.Free;
end;
function JSReadInteger (const AKey: String; const ADefault: Int64; const AFileName: String): Int64; OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
Result:= JSReadInteger(Key, ADefault, AFileName);
end;
function JSReadBoolean (const AKey: UnicodeString; const ADefault: Boolean; const AFileName: String): Boolean; OVERLOAD;
var JD: TJSONData;
begin
GetJSData(AFileName, JD);
try
 Result:= JD.FindPath(FrmtKey(AKey)).AsBoolean;
 except
 Result:= ADefault;
 end;
JD.Free;
end;
function JSReadBoolean (const AKey: String; const ADefault: Boolean; const AFileName: String): Boolean; OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
Result:= JSReadBoolean(Key, ADefault, AFileName);
end;
function JSReadRGBColor (const AKey: UnicodeString; const ADefault: TRGBColor; const AFileName: String): TRGBColor; OVERLOAD;
var JD: TJSONData;
    KeyM: UnicodeString;
begin
GetJSData(AFileName, JD);
KeyM:= FrmtKey(AKey);
try
 Result.R:= JD.FindPath(KeyM + '.r').AsInteger;
 Result.G:= JD.FindPath(KeyM + '.g').AsInteger;
 Result.B:= JD.FindPath(KeyM + '.b').AsInteger;
 except
 Result:= ADefault;
 end;
JD.Free;
end;
function JSReadRGBColor (const AKey: String; const ADefault: TRGBColor; const AFileName: String): TRGBColor; OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
Result:= JSReadRGBColor(Key, ADefault, AFileName);
end;
procedure JSReadFont (const AKey: UnicodeString; var Font: TFont; const AFileName: String);
var JD: TJSONData;
    FStyle: TFontStyles;
    KeyM: UnicodeString;
begin
GetJSData(AFileName, JD);
KeyM:= FrmtKey(AKey);
try
 Font.CharSet:= TFontCharSet(JD.FindPath(KeyM + '.charset').AsInteger);
 Font.Color:= StringToColor(JD.FindPath(KeyM + '.color').AsString);
 Font.Height:= JD.FindPath(KeyM + '.height').AsInteger;
 Font.Name:= JD.FindPath(KeyM + '.name').AsString;
 Font.Orientation:= JD.FindPath(KeyM + '.orientation').AsInteger;
 Font.Pitch:= TFontPitch(JD.FindPath(KeyM + '.pitch').AsInteger);
 Font.Quality:= TFontQuality(JD.FindPath(KeyM + '.quality').AsInteger);
 Font.Size:= JD.FindPath(KeyM + '.size').AsInteger;
 FStyle:= [];
 if (JD.FindPath(KeyM + '.style.bold').AsBoolean) then
  FStyle:= FStyle + [fsBold];
 if (JD.FindPath(KeyM + '.style.italic').AsBoolean) then
  FStyle:= FStyle + [fsItalic];
 if (JD.FindPath(KeyM + '.style.underline').AsBoolean) then
  FStyle:= FStyle + [fsUnderline];
 if (JD.FindPath(KeyM + '.style.strikeout').AsBoolean) then
  FStyle:= FStyle + [fsStrikeOut];
 Font.Style:= FStyle;
 except
 end;
JD.Free;
end;
procedure JSReadFont (const AKey: String; var Font: TFont; const AFileName: String);
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSReadFont(Key, Font, AFileName);
end;
//Write procedures
procedure JSWriteString (const AKey, AValue: UnicodeString; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SetValue(AKey, AValue);
 Flush;
 Free;
 end;
end;
procedure JSWriteString (const AKey, AValue, AFileName: String); OVERLOAD;
var Key, Val: UnicodeString;
begin
Key:= UnicodeString(AKey);
Val:= UnicodeString(AValue);
JSWriteString(Key, Val, AFileName);
end;
procedure JSWriteInteger (const AKey: UnicodeString; const AValue: Int64; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SetValue(AKey, AValue);
 Free;
 end;
end;
procedure JSWriteInteger (const AKey: String; const AValue: Int64; const AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSWriteInteger(Key, AValue, AFileName);
end;
procedure JSWriteBoolean (const AKey: UnicodeString; const AValue: Boolean; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SetValue(AKey, AValue);
 Free;
 end;
end;
procedure JSWriteBoolean (const AKey: String; const AValue: Boolean; const AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSWriteBoolean(Key, AValue, AFileName);
end;
procedure JSWriteRGBColor (const AKey: UnicodeString; const AValue: TRGBColor; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SetValue(AKey + '/r', AValue.R);
 SetValue(AKey + '/g', AValue.G);
 SetValue(AKey + '/b', AValue.B);
 Free;
 end;
end;
procedure JSWriteRGBColor (const AKey: String; const AValue: TRGBColor; const AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSWriteRGBColor(Key, AValue, AFileName);
end;
procedure JSWriteFont (const AKey: UnicodeString; const AValue: TFont; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SetValue(AKey + '/charset', Integer(AValue.CharSet));
 SetValue(AKey + '/color', ColorToString(AValue.Color));
 SetValue(AKey + '/height', AValue.Height);
 SetValue(AKey + '/name', AValue.Name);
 SetValue(AKey + '/orientation', AValue.Orientation);
 SetValue(AKey + '/pitch', Integer(AValue.Pitch));
 SetValue(AKey + '/quality', Integer(AValue.Quality));
 SetValue(AKey + '/size', AValue.Size);
 SetValue(AKey + '/style/bold', (fsBold in AValue.Style));
 SetValue(AKey + '/style/italic', (fsItalic in AValue.Style));
 SetValue(AKey + '/style/underline', (fsUnderline in AValue.Style));
 SetValue(AKey + '/style/strikeout', (fsStrikeOut in AValue.Style));
 Free;
 end;
end;
procedure JSWriteFont (const AKey: String; const AValue: TFont; const AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSWriteFont(Key, AValue, AFileName);
end;
//Delete function
procedure JSDeleteKey (const AKey: UnicodeString; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 DeletePath(AKey);
 Free;
 end;
end;
procedure JSDeleteKey (const AKey, AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSDeleteKey(Key, AFileName);
end;
//Read subkeys
procedure JSReadSubKeys (const AKey: UnicodeString; SubkeyList: TStrings; const AFileName: String); OVERLOAD;
var JSConf: TJSONConfig;
begin
JSConf:= TJSONConfig.Create(Nil);
with JSConf do
 begin
 Filename:= AFileName;
 Formatted:= True;
 SubkeyList.Clear;
 EnumSubKeys(AKey, SubkeyList);
 Free;
 end;
end;
procedure JSReadSubKeys (const AKey: String; SubkeyList: TStrings; const AFileName: String); OVERLOAD;
var Key: UnicodeString;
begin
Key:= UnicodeString(AKey);
JSReadSubKeys(Key, SubkeyList, AFileName);
end;
end.