source upload
This commit is contained in:
Razor12911
@@ -0,0 +1,30 @@
|
||||
TSynJSONTreeView
|
||||
================
|
||||
|
||||
By *EMartin* (Esteban Martin).
|
||||
|
||||
|
||||
# Presentation
|
||||
|
||||
`TSynJSONTreeView` is a treeview supporting mORMot's JSON document, the allowed tasks are:
|
||||
|
||||
- edit a node
|
||||
- delete a node
|
||||
- add a node
|
||||
- save to file
|
||||
- load from file
|
||||
- generate JSON to string variable
|
||||
- implement a custom input for edit/insert node
|
||||
|
||||
# Forum Thread
|
||||
|
||||
See http://synopse.info/forum/viewtopic.php?id=3451
|
||||
|
||||
# TODO
|
||||
|
||||
- FPC support (I just use Windows)
|
||||
- Developed with Delphi 7, not tested with any other Delphi version.
|
||||
|
||||
# License
|
||||
|
||||
Feel free to use and/or append to Lib and extend if needed.
|
||||
@@ -0,0 +1 @@
|
||||
{"HandleUserAuthentication":true,"HTTPServer":{"HttpQueueLength":1000,"MaxBandWidth":0,"MaxConnections":0,"BindPort":"8888","Authentication":"adDefault","EnableCORS":false,"ThreadCount":32,"Https":false,"HttpSysQueueName":"ARISQueue","WebSocketPassword":""},"HTTPServerWS":{"HttpQueueLength":0,"MaxBandWidth":0,"MaxConnections":0,"BindPort":"8889","Authentication":"adDefault","EnableCORS":false,"ThreadCount":0,"Https":false,"HttpSysQueueName":"ARISWSQueue","WebSocketPassword":"Bsyv1NapccWDNwPVgcQ+fU+pKhed5PGUVUT4h0Im+E07aA=="},"Log":{"Ident":0,"Level":["sllNone","sllInfo","sllDebug","sllTrace","sllWarning","sllError","sllEnter","sllLeave","sllLastError","sllException","sllExceptionOS","sllMemory","sllStackTrace","sllFail","sllSQL","sllCache","sllResult","sllDB","sllHTTP","sllClient","sllServer","sllServiceCall","sllServiceReturn","sllUserAuth","sllCustom1","sllCustom2","sllCustom3","sllCustom4","sllNewRun","sllDDDError","sllDDDInfo","sllMonitoring"],"LevelStackTrace":["sllError","sllLastError","sllException","sllExceptionOS","sllStackTrace","sllFail","sllDDDError"],"DestinationPath":"D:\\TecnoVoz\\Log\\","DefaultExtension":".synlog","IncludeComputerNameInFileName":false,"CustomFileName":"ARIS","ArchivePath":"D:\\TecnoVoz\\Log\\Archive","ArchiveAfterDays":1,"BufferSize":4096,"PerThreadLog":"ptIdentifiedInOnFile","HighResolutionTimeStamp":false,"LocalTimeStamp":true,"WithUnitName":true,"AutoFlushTimeOut":0,"NoEnvironmentVariable":false,"NoFile":false,"RotateFileCount":10,"RotateFileSizeKB":262144,"RotateFileDailyAtHour":-1,"StackTraceLevel":30,"StackTraceUse":"stOnlyAPI","FileExistsAction":"acAppend","EndOfLineCRLF":false},"SMTP":{"Authentication":"","Port":"25","Server":"tvzserver","SSLVersion":"sslvNone","UserName":"emartin","Password":"GaZZ0opaJqvttSQ="},"SQLDBConnections":{"ConnectionTimeoutMinutes":10,"Count":9,"ConnectionDefinitions":[{"DatabaseName":"DRIVER={ODBC Driver 11 for SQL Server};UID=USER;PWD=D3rNfXg2ug==;Server=DBEngines;DataBase=TEST;","DBMS":"dMSSQL","Kind":"TODBCConnectionProperties","Name":"TEST_MSSQL","ServerName":"","AllowGetObjects":false,"Description":"Conexi<78>n a la m<>quina virtual de bases de datos.","Properties":"","UserName":"TEST_USER","Password":""},{"DatabaseName":"FirebirdTest1","DBMS":"dFirebird","Kind":"TSQLDBZEOSConnectionProperties","Name":"APPROACH","ServerName":"firebird-2.5://DBEngines","AllowGetObjects":false,"Description":"","Properties":"hard_commit=true","UserName":"SYSDBA","Password":"D3rNfXg2ug=="},{"DatabaseName":"FirebirdTest2","DBMS":"dFirebird","Kind":"TSQLDBZEOSConnectionProperties","Name":"SCHEDULER","ServerName":"firebird-2.5://DBEngines","AllowGetObjects":false,"Description":"Any description with accented characters <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>","Properties":"hard_commit=true","UserName":"SYSDBA","Password":"D3rNfXg2ug=="}]},"LastElement":true}
|
||||
@@ -0,0 +1,15 @@
|
||||
program SynJSONTVEditor;
|
||||
|
||||
uses
|
||||
Forms,
|
||||
fMain in 'fMain.pas' {frmJSONEditor},
|
||||
SynJSONTreeView in 'SynJSONTreeView.pas',
|
||||
fLevel in 'fLevel.pas' {frmLevel};
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TfrmJSONEditor, frmJSONEditor);
|
||||
Application.Run;
|
||||
end.
|
||||
Binary file not shown.
@@ -0,0 +1,903 @@
|
||||
/// JSON tree view bases on Synopse JSON parser
|
||||
// - based on JSON TreeView VCL Component from pawel.glowacki@embarcadero.com
|
||||
// - this unit is a part of the freeware Synopse mORMot framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynJSONTreeView;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 Arnaud Bouchez
|
||||
Synopse Informatique - https://synopse.info
|
||||
|
||||
*** BEGIN LICENSE BLOCK *****
|
||||
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
||||
|
||||
The contents of this file are subject to the Mozilla Public License Version
|
||||
1.1 (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.mozilla.org/MPL
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
||||
for the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is Synopse mORMot framework.
|
||||
|
||||
The Initial Developer of the Original Code is Arnaud Bouchez.
|
||||
|
||||
Portions created by the Initial Developer are Copyright (C) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- Esteban Martin (EMartin)
|
||||
|
||||
Alternatively, the contents of this file may be used under the terms of
|
||||
either the GNU General Public License Version 2 or later (the "GPL"), or
|
||||
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
||||
in which case the provisions of the GPL or the LGPL are applicable instead
|
||||
of those above. If you wish to allow use of your version of this file only
|
||||
under the terms of either the GPL or the LGPL, and not to allow others to
|
||||
use your version of this file under the terms of the MPL, indicate your
|
||||
decision by deleting the provisions above and replace them with the notice
|
||||
and other provisions required by the GPL or the LGPL. If you do not delete
|
||||
the provisions above, a recipient may use your version of this file under
|
||||
the terms of any one of the MPL, the GPL or the LGPL.
|
||||
|
||||
***** END LICENSE BLOCK *****
|
||||
|
||||
Version 1.18
|
||||
- first public release, corresponding to Synopse mORMot Framework 1.18
|
||||
|
||||
TODO:
|
||||
- FPC support (I just use Windows)
|
||||
- Developed with Delphi 7, not tested with other Delphi versions
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
Classes,
|
||||
ComCtrls,
|
||||
Controls,
|
||||
SynCommons,
|
||||
SynTable;
|
||||
|
||||
type
|
||||
ESynJSONTreeView = class(ESynException);
|
||||
TSynJSONTreeNode = class;
|
||||
|
||||
/// Tree node types
|
||||
// - jtnObject: JSON object, i.e: {"fieldNumber":123,"fieldText":"text","fieldNull":null}
|
||||
// - jtnObjectContent: conten of jtnObject, i.e: "fieldNumber":123
|
||||
// - jtnArray: JSON array, i.e: [123,"text",{"fieldNumber":123,"fieldText":"text","fieldNull":null},null]
|
||||
// - jtnArrayContent: content of jtnArray, i.e: 123 or {"fieldNumber":123,"fieldText":"text","fieldNull":null}
|
||||
TSynJSONTreeNodeType = (jtnObject, jtnObjectContent, jtnArray, jtnArrayContent);
|
||||
|
||||
/// Event type for fire event when editing
|
||||
TSynJSONTreeViewCustomInputEvent = procedure(Sender: TObject; Node: TSynJSONTreeNode;
|
||||
var Prompt: RawUTF8; var Value: Variant;
|
||||
var Handled: Boolean) of object;
|
||||
/// Node extension for handling JSON value in the treeview
|
||||
TSynJSONTreeNode = class(TTreeNode)
|
||||
protected
|
||||
fName: RawUTF8;
|
||||
fJSONType: TSynJSONTreeNodeType;
|
||||
fValue: Variant;
|
||||
public
|
||||
/// Clone the node
|
||||
function Clone: TSynJSONTreeNode;
|
||||
/// JSON type in the node
|
||||
property JSONType: TSynJSONTreeNodeType read fJSONType write fJSONType;
|
||||
/// Name of the JSON value
|
||||
property Name: RawUTF8 read FName write fName;
|
||||
/// JSON value
|
||||
property Value: Variant read fValue write fValue;
|
||||
end;
|
||||
|
||||
/// Allowed edition states of treeview
|
||||
// - estEdit: allow edit a node
|
||||
// - estDelete: allow delete a node
|
||||
// - estInsert: allow insert a node
|
||||
TSynJSONTreeViewEditionStateType = (estEdit , estDelete, estInsert);
|
||||
TSynJSONTreeViewEditionStateSet = set of TSynJSONTreeViewEditionStateType;
|
||||
|
||||
/// TSynJSONTreeView is a treeview supporting mORMOn JSON document (TDocVariantData), the allowed tasks are:
|
||||
// - edit a node
|
||||
// - delete a node
|
||||
// - add a node
|
||||
// - save to file
|
||||
// - load from file
|
||||
// - generate JSON to string variable
|
||||
// - implement a custom input for edit/insert node
|
||||
TSynJSONTreeView = class(TTreeView)
|
||||
private
|
||||
fAllowedEditionStates: TSynJSONTreeViewEditionStateSet;
|
||||
protected
|
||||
fFirsttime: Boolean;
|
||||
fJSONDocument: Variant;
|
||||
fJSONText: RawUTF8;
|
||||
fKey: Integer;
|
||||
fOnDblClickBak: TNotifyEvent;
|
||||
fOnEditingBak: TTVEditingEvent;
|
||||
fOnKeyDownBak: TKeyEvent;
|
||||
fOnCustomInput: TSynJSONTreeViewCustomInputEvent;
|
||||
fVisibleChildrenCounts: boolean;
|
||||
fVisibleByteSizes: boolean;
|
||||
/// Add child node from JSON value
|
||||
// - aNode: node from which add the child
|
||||
// - aJSON: JSON value single or object/array
|
||||
// - aNameOrIndex: if it is numeric, then is the index into the object/array, otherwise the name of the container node
|
||||
function AddChildFromJSON(const aNode: TSynJSONTreeNode; const aJSON: Variant; const aNameOrIndex: Variant): TSynJSONTreeNode;
|
||||
procedure BackupEvents;
|
||||
procedure DeleteNode(Node: TSynJSONTreeNode; const aAsk: Boolean = True);
|
||||
procedure DoOnCreateNodeClass(Sender: TCustomTreeView; var NodeClass: TTreeNodeClass);
|
||||
procedure DoOnDblClick(Sender: TObject);
|
||||
procedure DoOnEditing(Sender: TObject; Node: TTreeNode; var AllowEdit: Boolean);
|
||||
procedure DoOnKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
||||
procedure EditNode(Node: TSynJSONTreeNode);
|
||||
procedure InsertNode(Node: TSynJSONTreeNode; const aJSON: Variant);
|
||||
function IsActive: Boolean;
|
||||
function IsSimpleJsonValue(v: Variant): boolean;{$ifdef HASINLINE}inline;{$endif}
|
||||
procedure ProcessArray(const aCurrNode: TSynJSONTreeNode; const aValue: Variant; const aNameOrIndex: Variant);
|
||||
procedure ProcessElement(currNode: TSynJSONTreeNode; arr: Variant; aIndex: integer);
|
||||
function ProcessJSONText: boolean;
|
||||
procedure ProcessObject(const aCurrNode: TSynJSONTreeNode; const aValue: Variant; const aNameOrIndex: Variant);
|
||||
function ProcessPair(currNode: TSynJSONTreeNode; obj: Variant; aIndex: integer): TSynJSONTreeNode;
|
||||
/// Assign and process the JSON text
|
||||
// - if Value is null then clear the JSON text and the treeview content
|
||||
procedure SetJSONText(const Value: RawUTF8);
|
||||
/// Assign mORMot JSON Document
|
||||
// - if Value is not equal to the previous value then load the JSON into the treeview
|
||||
procedure SetSynJSONDocument(const Value: Variant);
|
||||
/// Show how many children has a container node
|
||||
procedure SetVisibleChildrenCounts(const Value: boolean);
|
||||
/// Show byte size of a container node
|
||||
procedure SetVisibleByteSizes(const Value: boolean);
|
||||
/// Update info of a container node
|
||||
procedure UpdateNodeInfo(aNode: TSynJSONTreeNode);
|
||||
/// Get the original value from variant value
|
||||
function VariantToRaw(const aVarData: Variant): Variant;
|
||||
/// Assign source variant to dest variant but considering the dest data type
|
||||
procedure VariantToVariant(aSource: Variant; var aDest: Variant);
|
||||
/// Convert variant to UTF8 but checking the boolean type and convert it to true/false string
|
||||
function VarToUTF8(const aVarData: Variant): RawUTF8;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
|
||||
/// Remove items and JSON text
|
||||
procedure ClearAll;
|
||||
/// Load from file
|
||||
procedure LoadFromFile(const aFileName: TFileName);
|
||||
/// Load the JSONText in the treeview, clear if empty
|
||||
procedure LoadJSON;
|
||||
/// Save to file
|
||||
procedure SaveToFile(const aFileName: TFileName);
|
||||
/// Generate JSON from the treeview
|
||||
function ToJSON: RawUTF8;
|
||||
|
||||
/// JSON DocVariantData
|
||||
property JSONDocument: Variant read FJSONDocument write SeTSynJSONDocument;
|
||||
published
|
||||
/// Allowed state editions
|
||||
property AllowedEditionStates: TSynJSONTreeViewEditionStateSet read fAllowedEditionStates write fAllowedEditionStates;
|
||||
/// Content the JSON text, when assigned parse the the JSON and load in the treeview
|
||||
property JSONText: RawUTF8 read fJSONText write SetJSONText;
|
||||
/// Display info over how many children has each node
|
||||
property VisibleChildrenCounts: boolean read FVisibleChildrenCounts write SetVisibleChildrenCounts;
|
||||
/// Display info over the size of node
|
||||
property VisibleByteSizes: boolean read FVisibleByteSizes write SetVisibleByteSizes;
|
||||
/// Event fired when editing for custom input
|
||||
property OnCustomInput: TSynJSONTreeViewCustomInputEvent read fOnCustomInput write fOnCustomInput;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Windows,
|
||||
Variants,
|
||||
mORMotUILogin;
|
||||
|
||||
resourcestring
|
||||
SInvalidJSONValue = 'Invalid JSON value';
|
||||
SInvalidJSON = 'Invalid JSON: %';
|
||||
SEnterValue = 'Enter Value';
|
||||
SInsertNewItem = 'Insert new item';
|
||||
SInsertNewItemPrompt = 'Enter JSON:\n\n object: <name>:<value>\n array: [<index>]:<value>\n\n ' +
|
||||
'In array the brackets are required.';
|
||||
SRemoveChildren = 'This node has children, are you sure to remove them';
|
||||
SDeleteNode = 'Delete node\n\n% ?';
|
||||
|
||||
{ TSynJSONTreeView }
|
||||
|
||||
procedure TSynJSONTreeView.ClearAll;
|
||||
begin
|
||||
SetJSONText('');
|
||||
Items.Clear;
|
||||
end;
|
||||
|
||||
constructor TSynJSONTreeView.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
OnCreateNodeClass := DoOnCreateNodeClass;
|
||||
fAllowedEditionStates := [estEdit, estDelete, estInsert];
|
||||
fFirstTime := True;
|
||||
FVisibleChildrenCounts := true;
|
||||
FVisibleByteSizes := false;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.LoadJson;
|
||||
var
|
||||
v: Variant;
|
||||
begin
|
||||
BackupEvents;
|
||||
Items.Clear;
|
||||
|
||||
if IsActive then
|
||||
begin
|
||||
v := fJSONDocument;
|
||||
Items.Clear;
|
||||
|
||||
if (v._Kind = dvObject) then
|
||||
ProcessObject(nil, v, Unassigned)
|
||||
else if (v._Kind = dvArray) then
|
||||
ProcessArray(nil, v, Unassigned)
|
||||
else
|
||||
raise ESynJSONTreeView.Create(SInvalidJSONValue);
|
||||
|
||||
FullExpand;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.ProcessPair(currNode: TSynJSONTreeNode; obj: Variant; aIndex: integer): TSynJSONTreeNode;
|
||||
var
|
||||
p: Variant;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
p := obj._(aIndex);
|
||||
|
||||
if IsSimpleJsonValue(p) then
|
||||
begin
|
||||
AddChildFromJSON(currNode, obj, aIndex);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if (p._Kind = dvObject) then
|
||||
ProcessObject(currNode, _CopyFast(p), obj.Name(aIndex))
|
||||
else if (p._Kind = dvArray) then
|
||||
ProcessArray(currNode, _CopyFast(p), obj.Name(aIndex))
|
||||
else
|
||||
raise ESynJSONTreeView.Create(SInvalidJSONValue);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.ProcessElement(currNode: TSynJSONTreeNode; arr: Variant; aIndex: integer);
|
||||
var
|
||||
v: Variant;
|
||||
begin
|
||||
v := arr._(aIndex);
|
||||
|
||||
if IsSimpleJsonValue(v) then
|
||||
begin
|
||||
AddChildFromJSON(currNode, arr, aIndex);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if (v._Kind = dvObject) then
|
||||
ProcessObject(currNode, _CopyFast(v), IntToStr(aIndex))
|
||||
else if (v._Kind = dvArray) then
|
||||
ProcessArray(currNode, _CopyFast(v), aIndex)
|
||||
else
|
||||
raise ESynJSONTreeView.Create(SInvalidJSONValue);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.SetSynJSONDocument(const Value: Variant);
|
||||
begin
|
||||
if fJSONDocument <> Value then
|
||||
begin
|
||||
fJSONDocument := Value;
|
||||
ClearAll;
|
||||
if IsActive then
|
||||
LoadJson;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.SetVisibleByteSizes(const Value: boolean);
|
||||
begin
|
||||
if FVisibleByteSizes <> Value then
|
||||
begin
|
||||
FVisibleByteSizes := Value;
|
||||
LoadJson;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.SetVisibleChildrenCounts(const Value: boolean);
|
||||
begin
|
||||
if FVisibleChildrenCounts <> Value then
|
||||
begin
|
||||
FVisibleChildrenCounts := Value;
|
||||
LoadJson;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.VarToUTF8(const aVarData: Variant): RawUTF8;
|
||||
begin
|
||||
if (TVarData(aVarData).VType = varBoolean) then
|
||||
begin
|
||||
if TVarData(aVarData).VBoolean then
|
||||
Result := 'true'
|
||||
else
|
||||
Result := 'false';
|
||||
end else
|
||||
Result := VariantToUTF8(aVarData);
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.ToJSON: RawUTF8;
|
||||
var
|
||||
lW: TTextWriter;
|
||||
|
||||
procedure ProcessNode(aNode: TSynJSONTreeNode);
|
||||
|
||||
procedure CheckLastComma(aW: TTextWriter);
|
||||
begin
|
||||
if (aW.TextLength > 0) and (not (aW.LastChar in [',','[','{'])) then
|
||||
aW.Add(',');
|
||||
end;
|
||||
|
||||
var
|
||||
lNode: TSynJSONTreeNode;
|
||||
begin
|
||||
lNode := aNode;
|
||||
repeat
|
||||
if Assigned(lNode) then begin
|
||||
case lNode.JSONType of
|
||||
jtnObject:
|
||||
begin
|
||||
CheckLastComma(lW);
|
||||
// numeric name is excluded
|
||||
if (lNode.Name <> '') and (StrToIntDef(lNode.Name, MaxInt) = MaxInt) then
|
||||
lW.AddFieldName(lNode.Name);
|
||||
lW.Add('{');
|
||||
end;
|
||||
jtnArray:
|
||||
begin
|
||||
CheckLastComma(lW);
|
||||
if (lNode.Name <> '') then
|
||||
lW.AddFieldName(lNode.Name);
|
||||
lW.Add('[');
|
||||
end;
|
||||
jtnObjectContent:
|
||||
begin
|
||||
CheckLastComma(lW);
|
||||
lW.AddFieldName(lNode.Name);
|
||||
lW.AddVariant(lNode.Value);
|
||||
lW.Add(',');
|
||||
end;
|
||||
jtnArrayContent:
|
||||
begin
|
||||
CheckLastComma(lW);
|
||||
lW.AddVariant(lNode.Value);
|
||||
lW.Add(',');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if lNode.HasChildren then begin
|
||||
ProcessNode(TSynJSONTreeNode(lNode.GetFirstChild));
|
||||
lW.CancelLastComma;
|
||||
case lNode.JSONType of
|
||||
jtnObject: lW.Add('}');
|
||||
jtnArray: lW.Add(']');
|
||||
end;
|
||||
end;
|
||||
lNode := TSynJSONTreeNode(lNode.GetNextSibling);
|
||||
until not Assigned(lNode);
|
||||
end;
|
||||
|
||||
begin
|
||||
lW := TTextWriter.CreateOwnedStream;
|
||||
try
|
||||
ProcessNode(TSynJSONTreeNode(Items.GetFirstNode));
|
||||
lW.CancelLastComma;
|
||||
lW.SetText(Result);
|
||||
finally
|
||||
lW.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.DoOnCreateNodeClass(Sender: TCustomTreeView; var NodeClass: TTreeNodeClass);
|
||||
begin
|
||||
NodeClass := TSynJSONTreeNode;
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.VariantToRaw(const aVarData: Variant): Variant;
|
||||
var
|
||||
lVar: TSQLVar;
|
||||
lTmp: RawByteString;
|
||||
begin
|
||||
if VarIs(aVarData, [varBoolean]) then
|
||||
begin
|
||||
Result := aVarData;
|
||||
Exit;
|
||||
end;
|
||||
VariantToSQLVar(aVarData, lTmp, lVar);
|
||||
with lVar do
|
||||
case VType of
|
||||
ftNull: Result := null;
|
||||
ftCurrency: Result := VInt64;
|
||||
ftUTF8:
|
||||
if Assigned(VText) then
|
||||
Result := RawUTF8(PUTF8Char(VText))
|
||||
else
|
||||
Result := '';
|
||||
ftInt64: Result := VInt64;
|
||||
ftDouble: Result := VDouble;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.DoOnDblClick(Sender: TObject);
|
||||
begin
|
||||
if ReadOnly or (Selected.Count > 0) or (not (estEdit in fAllowedEditionStates)) then
|
||||
Exit;
|
||||
|
||||
EditNode(TSynJSONTreeNode(Selected));
|
||||
if Assigned(fOnDblClickBak) then
|
||||
fOnDblClickBak(Sender);
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.IsActive: Boolean;
|
||||
begin
|
||||
Result := (fJSONDocument <> Unassigned) and (not VarIsEmptyOrNull(fJSONDocument)) and (fJSONDocument._Kind <> dvUndefined);
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.IsSimpleJsonValue(v: Variant): boolean;
|
||||
begin
|
||||
Result := VarIsEmptyOrNull(v) or VarIsNumeric(v) or VarIsStr(v) or VarIsStr(v);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.SetJSONText(const Value: RawUTF8);
|
||||
begin
|
||||
if fJSONText <> Value then
|
||||
begin
|
||||
fJSONText := Value;
|
||||
if fJSONText <> '' then
|
||||
ProcessJSONText
|
||||
else
|
||||
begin
|
||||
TDocVariantData(fJSONDocument).Clear;
|
||||
fJSONDocument := Unassigned;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.ProcessJSONText: boolean;
|
||||
begin
|
||||
if IsActive then
|
||||
fJSONDocument.Clear;
|
||||
TDocVariantData(fJSONDocument).InitJSON(fJSONText);
|
||||
if (TDocVariantData(fJSONDocument).Kind = dvUndefined) then
|
||||
raise ESynJSONTreeView.CreateUTF8(SInvalidJSON, [fJSONText]);
|
||||
Result := IsActive;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.BackupEvents;
|
||||
begin
|
||||
if not fFirstTime then
|
||||
Exit;
|
||||
|
||||
if not Assigned(fOnDblClickBak) and Assigned(OnDblClick) then
|
||||
fOnDblClickBak := OnDblClick;
|
||||
OnDblClick := DoOnDblClick;
|
||||
|
||||
if not Assigned(fOnEditingBak) and Assigned(OnEditing) then
|
||||
fOnEditingBak := OnEditing;
|
||||
OnEditing := DoOnEditing;
|
||||
|
||||
if not Assigned(fOnKeyDownBak) and Assigned(OnKeyDown) then
|
||||
fOnKeyDownBak := OnKeyDown;
|
||||
OnKeyDown := DoOnKeyDown;
|
||||
|
||||
fFirstTime := False;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.DoOnKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
if ReadOnly or (not (Key in [VK_DELETE, VK_INSERT, VK_RETURN])) or
|
||||
((Key = VK_DELETE) and (not (estDelete in fAllowedEditionStates))) or
|
||||
((Key = VK_RETURN) and (not (estEdit in fAllowedEditionStates))) or
|
||||
((Key = VK_INSERT) and (not (estInsert in fAllowedEditionStates))) then
|
||||
Exit;
|
||||
|
||||
case Key of
|
||||
VK_DELETE: DeleteNode(TSynJSONTreeNode(Selected));
|
||||
VK_INSERT: InsertNode(TSynJSONTreeNode(Selected), Unassigned);
|
||||
VK_RETURN: EditNode(TSynJSONTreeNode(Selected));
|
||||
end;
|
||||
|
||||
if Assigned(fOnKeyDownBak) then
|
||||
fOnKeyDownBak(Sender, Key, Shift);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.UpdateNodeInfo(aNode: TSynJSONTreeNode);
|
||||
|
||||
procedure UpdateNodeText(aNode: TSynJSONTreeNode; const aText: RawUTF8);
|
||||
begin
|
||||
if not VarIsNull(aNode.Value) then
|
||||
aNode.Text := aText
|
||||
else
|
||||
aNode.Text := aNode.Name + ': null';
|
||||
end;
|
||||
|
||||
begin
|
||||
case aNode.JSONType of
|
||||
jtnObject: begin
|
||||
if (not Assigned(aNode.Parent)) or (TSynJSONTreeNode(aNode.Parent).JSONType <> jtnArray) then
|
||||
UpdateNodeText(aNode, aNode.Name + ' {}')
|
||||
else
|
||||
UpdateNodeText(aNode, FormatUTF8('[%] {}', [aNode.Name]));
|
||||
end;
|
||||
jtnArray:
|
||||
if not VarIsNull(aNode.Value) then
|
||||
UpdateNodeText(aNode, aNode.Name + ' []');
|
||||
end;
|
||||
|
||||
case aNode.JSONType of
|
||||
jtnObject, jtnArray: begin
|
||||
if VisibleChildrenCounts then
|
||||
if not VarIsNull(aNode.Value) then
|
||||
UpdateNodeText(aNode, aNode.Text + ' (' + IntToStr(aNode.Value._Count) + ')')
|
||||
else
|
||||
UpdateNodeText(aNode, '');
|
||||
|
||||
if VisibleByteSizes then
|
||||
if not VarIsNull(aNode.Value) then
|
||||
UpdateNodeText(aNode, aNode.Text + ' (size: ' + IntToStr(Length(aNode.Value._JSON)) + ' bytes)')
|
||||
else
|
||||
UpdateNodeText(aNode, '');
|
||||
end;
|
||||
jtnObjectContent, jtnArrayContent: begin
|
||||
UpdateNodeText(aNode, '');
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.DeleteNode(Node: TSynJSONTreeNode; const aAsk: Boolean);
|
||||
|
||||
procedure RecalculateChildNames(aNode: TSynJSONTreeNode);
|
||||
var
|
||||
lNode: TSynJSONTreeNode;
|
||||
I: Integer;
|
||||
begin
|
||||
lNode := TSynJSONTreeNode(aNode.GetFirstChild);
|
||||
if not Assigned(lNode) then
|
||||
Exit;
|
||||
I := 0;
|
||||
case lNode.JSONType of
|
||||
jtnObject: begin
|
||||
repeat
|
||||
if Assigned(lNode) then begin
|
||||
if (StrToIntDef(lNode.Name, MaxInt) <> MaxInt) then
|
||||
lNode.Name := IntToStr(I);
|
||||
UpdateNodeInfo(lNode);
|
||||
Inc(I);
|
||||
end;
|
||||
lNode := TSynJSONTreeNode(lNode.getNextSibling);
|
||||
until not Assigned(lNode);
|
||||
end;
|
||||
jtnArrayContent: begin
|
||||
repeat
|
||||
if Assigned(lNode) then begin
|
||||
lNode.Name := IntToStr(I);
|
||||
lNode.Text := UTF8ToString(FormatUTF8('[%]: %', [lNode.Name, lNode.Value]));
|
||||
Inc(I);
|
||||
end;
|
||||
lNode := TSynJSONTreeNode(lNode.getNextSibling);
|
||||
until not Assigned(lNode);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure UpdateEmptyParent(aParent: TSynJSONTreeNode);
|
||||
begin
|
||||
if (aParent.Count = 0) then begin
|
||||
aParent.Value := NULL;
|
||||
case TSynJSONTreeNode(aParent.Parent).JSONType of
|
||||
jtnObject: aParent.JSONType := jtnObjectContent;
|
||||
jtnArray: aParent.JSONType := jtnArrayContent;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
lParent, lDeletedNode: TSynJSONTreeNode;
|
||||
begin
|
||||
if aAsk then
|
||||
if (YesNo(UTF8ToString(FormatUTF8(SDeleteNode, [Node.Text])), '', False) <> mrYes) then
|
||||
Exit;
|
||||
lDeletedNode := Node.Clone;
|
||||
lParent := TSynJSONTreeNode(Node.Parent);
|
||||
Items.BeginUpdate;
|
||||
try
|
||||
Node.Delete;
|
||||
Node := lDeletedNode;
|
||||
// if node name is empty it means that the JSON object is empty
|
||||
if (Node.Name = '') then begin
|
||||
ClearAll;
|
||||
Exit;
|
||||
end;
|
||||
case Node.JSONType of
|
||||
jtnArray, jtnObject: begin
|
||||
if (StrToIntDef(Node.Name, MaxInt) <> MaxInt) then
|
||||
TDocVariantData(lParent.Value).Delete(StrToInt(Node.Name))
|
||||
else
|
||||
TDocVariantData(lParent.Value).Delete(Node.Name);
|
||||
if (lParent.Count = 0) then
|
||||
UpdateEmptyParent(lParent)
|
||||
else
|
||||
RecalculateChildNames(lParent);
|
||||
UpdateNodeInfo(lParent);
|
||||
end;
|
||||
jtnArrayContent: begin
|
||||
TDocVariantData(lParent.Value).Delete(StrToInt(Node.Name));
|
||||
if (lParent.Count = 0) then
|
||||
UpdateEmptyParent(lParent)
|
||||
else
|
||||
RecalculateChildNames(lParent);
|
||||
UpdateNodeInfo(lParent);
|
||||
end;
|
||||
jtnObjectContent: begin
|
||||
TDocVariantData(lParent.Value).Delete(Node.Name);
|
||||
if (lParent.Count = 0) then
|
||||
UpdateEmptyParent(lParent);
|
||||
UpdateNodeInfo(lParent);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Items.EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.InsertNode(Node: TSynJSONTreeNode; const aJSON: Variant);
|
||||
var
|
||||
lJSON: Variant;
|
||||
lPrompt: RawUTF8;
|
||||
lValue: Variant;
|
||||
I: Integer;
|
||||
lCount: Integer;
|
||||
lHandled: Boolean;
|
||||
begin
|
||||
if (aJSON = Unassigned) then begin
|
||||
lPrompt := SInsertNewItemPrompt;
|
||||
|
||||
if Assigned(fOnCustomInput) then
|
||||
fOnCustomInput(Self, Node, lPrompt, lValue, lHandled);
|
||||
|
||||
if not lHandled then
|
||||
lValue := InputBox(SInsertNewItem, lPrompt, '');
|
||||
|
||||
|
||||
if (lValue = '') then
|
||||
Exit;
|
||||
|
||||
if (lValue[1] <> '[') then
|
||||
if (lValue[1] <> '{') then
|
||||
lValue := '{' + lValue + '}';
|
||||
TDocVariantData(lJSON).InitJSON(lValue);
|
||||
if (TDocVariantData(lJSON).Kind = dvUndefined) then
|
||||
raise ESynJSONTreeView.CreateUTF8(SInvalidJSON, [lValue]);
|
||||
end else
|
||||
lJSON := aJSON;
|
||||
// always will be an object the inserted node
|
||||
lCount := lJSON._Count;
|
||||
TDocVariantData(TSynJSONTreeNode(Node).Value).AddOrUpdateObject(lJSON);
|
||||
for I := 0 to lCount-1 do begin
|
||||
lValue := lJSON._(I);
|
||||
if IsSimpleJsonValue(lValue) then begin
|
||||
AddChildFromJSON(Node, lJSON, I);
|
||||
end else
|
||||
ProcessObject(Node, _CopyFast(lValue), lJSON.Name(I));
|
||||
end;
|
||||
UpdateNodeInfo(Node);
|
||||
end;
|
||||
|
||||
function TSynJSONTreeView.AddChildFromJSON(const aNode: TSynJSONTreeNode; const aJSON: Variant; const aNameOrIndex: Variant): TSynJSONTreeNode;
|
||||
var
|
||||
lValue: Variant;
|
||||
begin
|
||||
Result := TSynJSONTreeNode(Items.AddChild(aNode, ''));
|
||||
if not VarIsEmpty(aNameOrIndex) and (VariantToIntegerDef(aNameOrIndex, -1) <> -1) then
|
||||
lValue := VariantToRaw(aJSON._(aNameOrIndex))
|
||||
else
|
||||
lValue := aJSON;
|
||||
|
||||
if (TDocVariantData(lValue).Kind <> dvUndefined) then
|
||||
Result.Value := _CopyFast(lValue)
|
||||
else
|
||||
Result.Value := lValue;
|
||||
|
||||
case TDocVariantData(aJSON).Kind of
|
||||
dvObject:
|
||||
if not VarIsEmpty(aNameOrIndex) then begin
|
||||
// is name or index is numeric, the text property is assigned showing the name and value, otherwise is a
|
||||
// container node
|
||||
if (VariantToIntegerDef(aNameOrIndex, -1) <> -1) then begin
|
||||
Result.Name := aJSON.Name(aNameOrIndex);
|
||||
Result.JSONType := jtnObjectContent;
|
||||
Result.Text := Result.Name + ': ' + VarToUTF8(lValue);
|
||||
end else begin
|
||||
Result.Name := aNameOrIndex;
|
||||
Result.JSONType := jtnObject;
|
||||
end;
|
||||
end;
|
||||
dvArray:
|
||||
if not VarIsEmpty(aNameOrIndex) then begin
|
||||
// is name or index is numeric, the text property is assigned showing the name and value, otherwise is a
|
||||
// container node
|
||||
if (VariantToIntegerDef(aNameOrIndex, -1) <> -1) then begin
|
||||
Result.Name := aNameOrIndex;
|
||||
Result.JSONType := jtnArrayContent;
|
||||
Result.Text := IntToStr(aNameOrIndex) + ': ' + VarToUTF8(lValue);
|
||||
end else begin
|
||||
Result.Name := aNameOrIndex;
|
||||
Result.JSONType := jtnArray;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.ProcessObject(const aCurrNode: TSynJSONTreeNode; const aValue: Variant; const aNameOrIndex: Variant);
|
||||
var
|
||||
lCount: Integer;
|
||||
I: Integer;
|
||||
lCurrNode: TSynJSONTreeNode;
|
||||
begin
|
||||
lCurrNode := AddChildFromJSON(aCurrNode, aValue, aNameOrIndex);
|
||||
UpdateNodeInfo(lCurrNode);
|
||||
lCount := aValue._Count;
|
||||
for I := 0 to lCount - 1 do
|
||||
ProcessPair(lCurrNode, _CopyFast(aValue), I);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.ProcessArray(const aCurrNode: TSynJSONTreeNode; const aValue: Variant; const aNameOrIndex: Variant);
|
||||
var
|
||||
lCount: Integer;
|
||||
I: Integer;
|
||||
lCurrNode: TSynJSONTreeNode;
|
||||
begin
|
||||
lCurrNode := AddChildFromJSON(aCurrNode, aValue, aNameOrIndex);
|
||||
UpdateNodeInfo(lCurrNode);
|
||||
lCount := aValue._Count;
|
||||
for I := 0 to lCount - 1 do
|
||||
ProcessElement(lCurrNode, aValue, I);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.EditNode(Node: TSynJSONTreeNode);
|
||||
var
|
||||
lPrompt: RawUTF8;
|
||||
lJSON, lValue, lDestValue: Variant;
|
||||
lHandled: Boolean;
|
||||
begin
|
||||
lPrompt := UTF8ToString(TSynJSONTreeNode(Selected).Name);
|
||||
if (Selected.Text[1] = '[') then
|
||||
lPrompt := FormatUTF8('[%]', [lPrompt]);
|
||||
lValue := '';
|
||||
if not VarIsNull(TSynJSONTreeNode(Selected).Value) then
|
||||
lValue := TSynJSONTreeNode(Selected).Value;
|
||||
if Assigned(fOnCustomInput) then
|
||||
fOnCustomInput(Self, Node, lPrompt, lValue, lHandled);
|
||||
if not lHandled then
|
||||
lValue := InputBox(SEnterValue, lPrompt, lValue);
|
||||
|
||||
// if not modification, exit
|
||||
if (lValue = TSynJSONTreeNode(Selected).Value) then
|
||||
Exit;
|
||||
|
||||
// remove children if input data was null
|
||||
if (TDocVariantData(lValue).Kind = dvUndefined) and
|
||||
((lValue = '') or IdemPChar(pointer(VariantToUTF8(lValue)), 'NULL')) and
|
||||
Selected.HasChildren then begin
|
||||
if (YesNo(SRemoveChildren, '', False) = mrYes) then begin
|
||||
Selected.DeleteChildren;
|
||||
TSynJSONTreeNode(Selected).Value := NULL;
|
||||
UpdateNodeInfo(TSynJSONTreeNode(Selected));
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
TDocVariantData(lJSON).InitJSON(lValue);
|
||||
case TDocVariantData(lJSON).Kind of
|
||||
dvUndefined: begin
|
||||
Selected.Text := FormatUTF8('%: %', [lPrompt, lValue]);
|
||||
lDestValue := TSynJSONTreeNode(Selected).Value;
|
||||
VariantToVariant(lValue, lDestValue);
|
||||
TSynJSONTreeNode(Selected).Value := lDestValue;
|
||||
if Assigned(Selected.Parent) then begin
|
||||
case TSynJSONTreeNode(Selected.Parent).JSONType of
|
||||
jtnObject: TSynJSONTreeNode(Selected).JSONType := jtnObjectContent;
|
||||
jtnArray: begin
|
||||
TSynJSONTreeNode(Selected).JSONType := jtnArrayContent;
|
||||
TDocVariantData(TSynJSONTreeNode(Selected.Parent).Value).Values[StrToInt(TSynJSONTreeNode(Selected).Name)] :=
|
||||
TSynJSONTreeNode(Selected).Value;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
case TDocVariantData(lJSON).Kind of
|
||||
dvObject: TSynJSONTreeNode(Selected).JSONType := jtnObject;
|
||||
dvArray: TSynJSONTreeNode(Selected).JSONType := jtnArray;
|
||||
end;
|
||||
Node.Value := _CopyFast(lJSON);
|
||||
if Node.HasChildren then
|
||||
Node.DeleteChildren;
|
||||
InsertNode(Node, lJSON);
|
||||
UpdateNodeInfo(Node);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.LoadFromFile(const aFileName: TFileName);
|
||||
begin
|
||||
if (aFileName = '') then
|
||||
Exit;
|
||||
SetJSONText(StringFromFile(aFileName));
|
||||
LoadJSON;
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.SaveToFile(const aFileName: TFileName);
|
||||
var
|
||||
lJSON: RawUTF8;
|
||||
begin
|
||||
if (aFileName = '') then
|
||||
Exit;
|
||||
lJSON := ToJSON;
|
||||
FileFromString(lJSON, aFileName);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.DoOnEditing(Sender: TObject; Node: TTreeNode; var AllowEdit: Boolean);
|
||||
begin
|
||||
AllowEdit := (estEdit in fAllowedEditionStates);
|
||||
if AllowEdit and Assigned(fOnEditingBak) then
|
||||
fOnEditingBak(Sender, Node, AllowEdit);
|
||||
end;
|
||||
|
||||
procedure TSynJSONTreeView.VariantToVariant(aSource: Variant; var aDest: Variant);
|
||||
var
|
||||
lVar: TSQLVar;
|
||||
lTmp: RawByteString;
|
||||
begin
|
||||
VariantToSQLVar(aDest, lTmp, lVar);
|
||||
with lVar do
|
||||
case VType of
|
||||
ftNull: aDest := aSource;
|
||||
ftCurrency: aDest := aSource.VInt64;
|
||||
ftUTF8: aDest := VariantToUTF8(aSource);
|
||||
ftInt64: begin
|
||||
if (aSource <> '') then
|
||||
if (UpperCaseU(aSource) <> 'TRUE') and (UpperCaseU(aSource) <> 'FALSE') then begin
|
||||
aDest := StrToInt64Def(aSource, MaxInt);
|
||||
if (aDest = MaxInt) then
|
||||
raise ESynJSONTreeView.CreateUTF8('Invalid input data type: %', [aSource]);
|
||||
end else
|
||||
if (UpperCaseU(aSource) = 'TRUE') then
|
||||
aDest := True
|
||||
else
|
||||
aDest := False;
|
||||
end;
|
||||
ftDouble: aDest := aSource.VDouble;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TSynJSONTreeNode }
|
||||
|
||||
function TSynJSONTreeNode.Clone: TSynJSONTreeNode;
|
||||
begin
|
||||
Result := TSynJSONTreeNode.Create(nil);
|
||||
Result.Name := fName;
|
||||
Result.JSONType := fJSONType;
|
||||
Result.Value := fValue;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Binary file not shown.
@@ -0,0 +1,48 @@
|
||||
object frmLevel: TfrmLevel
|
||||
Left = 746
|
||||
Top = 164
|
||||
Width = 346
|
||||
Height = 490
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object chklstLevel: TCheckListBox
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 338
|
||||
Height = 423
|
||||
Align = alClient
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
end
|
||||
object pnlBottom: TPanel
|
||||
Left = 0
|
||||
Top = 423
|
||||
Width = 338
|
||||
Height = 36
|
||||
Align = alBottom
|
||||
TabOrder = 1
|
||||
object btnOK: TBitBtn
|
||||
Left = 84
|
||||
Top = 6
|
||||
Width = 75
|
||||
Height = 25
|
||||
TabOrder = 0
|
||||
Kind = bkOK
|
||||
end
|
||||
object btnCancel: TBitBtn
|
||||
Left = 180
|
||||
Top = 6
|
||||
Width = 75
|
||||
Height = 25
|
||||
TabOrder = 1
|
||||
Kind = bkCancel
|
||||
end
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,73 @@
|
||||
unit fLevel;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls, Buttons, ExtCtrls, CheckLst,
|
||||
SynCommons;
|
||||
|
||||
type
|
||||
TfrmLevel = class(TForm)
|
||||
chklstLevel: TCheckListBox;
|
||||
pnlBottom: TPanel;
|
||||
btnOK: TBitBtn;
|
||||
btnCancel: TBitBtn;
|
||||
private
|
||||
{ Private declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
procedure FillListBox(const aJSON: Variant);
|
||||
function ToJSON: RawUTF8;
|
||||
end;
|
||||
|
||||
var
|
||||
frmLevel: TfrmLevel;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
{ TfrmLevel }
|
||||
|
||||
procedure TfrmLevel.FillListBox(const aJSON: Variant);
|
||||
var
|
||||
I, J, lCount: Integer;
|
||||
begin
|
||||
lCount := TDocVariantData(aJSON).Count;
|
||||
chklstLevel.Items.BeginUpdate;
|
||||
try
|
||||
for I := 0 to lCount-1 do
|
||||
begin
|
||||
J := chklstLevel.Items.Add(TDocVariantData(aJSON).Values[I]);
|
||||
chklstLevel.Checked[J] := True;
|
||||
end;
|
||||
finally
|
||||
chklstLevel.Items.EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TfrmLevel.ToJSON: RawUTF8;
|
||||
var
|
||||
lW: TTextWriter;
|
||||
I: Integer;
|
||||
begin
|
||||
lW := TTextWriter.CreateOwnedStream;
|
||||
try
|
||||
lW.Add('[');
|
||||
for I := 0 to chklstLevel.Items.Count-1 do
|
||||
if chklstLevel.Checked[I] then
|
||||
begin
|
||||
lW.Add('"');
|
||||
lW.AddString(chklstLevel.Items[I]);
|
||||
lW.Add('"', ',');
|
||||
end;
|
||||
lW.CancelLastComma;
|
||||
lW.Add(']');
|
||||
lW.SetText(Result);
|
||||
finally
|
||||
lW.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,430 @@
|
||||
object frmJSONEditor: TfrmJSONEditor
|
||||
Left = 600
|
||||
Top = 213
|
||||
Width = 466
|
||||
Height = 643
|
||||
Caption = 'Delphi JSON Editor'
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
OnCreate = FormCreate
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object Panel1: TPanel
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 458
|
||||
Height = 33
|
||||
Align = alTop
|
||||
TabOrder = 0
|
||||
object BitBtn1: TBitBtn
|
||||
Left = 5
|
||||
Top = 4
|
||||
Width = 75
|
||||
Height = 25
|
||||
Action = EditPaste1
|
||||
Caption = '&Paste'
|
||||
TabOrder = 0
|
||||
Glyph.Data = {
|
||||
36040000424D3604000000000000360000002800000010000000100000000100
|
||||
2000000000000004000000000000000000000000000000000000FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF008000000080000000800000008000
|
||||
0000800000008000000080000000800000008000000080000000FF00FF000000
|
||||
00000000000000000000000000000000000080000000FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0080000000000000008686
|
||||
86000080800086868600008080008686860080000000FFFFFF00000000000000
|
||||
000000000000000000000000000000000000FFFFFF0080000000000000000080
|
||||
80008686860000808000868686000080800080000000FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0080000000000000008686
|
||||
86000080800086868600008080008686860080000000FFFFFF00000000000000
|
||||
000000000000FFFFFF0080000000800000008000000080000000000000000080
|
||||
80008686860000808000868686000080800080000000FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF0080000000FFFFFF0080000000FF00FF00000000008686
|
||||
86000080800086868600008080008686860080000000FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF008000000080000000FF00FF00FF00FF00000000000080
|
||||
8000868686000080800086868600008080008000000080000000800000008000
|
||||
000080000000800000008000000000000000FF00FF00FF00FF00000000008686
|
||||
8600008080008686860000808000868686000080800086868600008080008686
|
||||
860000808000868686000080800000000000FF00FF00FF00FF00000000000080
|
||||
8000868686000000000000000000000000000000000000000000000000000000
|
||||
000000000000868686008686860000000000FF00FF00FF00FF00000000008686
|
||||
86008686860000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF0000000000868686000080800000000000FF00FF00FF00FF00000000000080
|
||||
800086868600008080000000000000FFFF00000000000000000000FFFF000000
|
||||
000086868600008080008686860000000000FF00FF00FF00FF00FF00FF000000
|
||||
00000000000000000000000000000000000000FFFF0000FFFF00000000000000
|
||||
0000000000000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF0000000000000000000000000000000000FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00}
|
||||
end
|
||||
object btnClear: TBitBtn
|
||||
Left = 91
|
||||
Top = 4
|
||||
Width = 75
|
||||
Height = 25
|
||||
Action = EditClear1
|
||||
Caption = '&Clear'
|
||||
TabOrder = 1
|
||||
Glyph.Data = {
|
||||
36040000424D3604000000000000360000002800000010000000100000000100
|
||||
2000000000000004000000000000000000000000000000000000FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF0000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF0000000000FF00FF00FF00FF00FF00
|
||||
FF00000000000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF0000000000000000000000000000000000FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF0000000000FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00000000000000000000000000FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF0000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00000000000000000000000000FF00FF00FF00FF00FF00
|
||||
FF00FF00FF000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00000000000000000000000000FF00FF00FF00
|
||||
FF000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF000000000000000000000000000000
|
||||
000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF0000000000000000000000
|
||||
0000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF000000000000000000000000000000
|
||||
000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00000000000000000000000000FF00FF00FF00
|
||||
FF000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF0000000000000000000000000000000000FF00FF00FF00FF00FF00
|
||||
FF00FF00FF000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF0000000000000000000000000000000000FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF000000000000000000FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00000000000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF0000000000FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00}
|
||||
end
|
||||
object btnSaveJSON: TBitBtn
|
||||
Left = 178
|
||||
Top = 4
|
||||
Width = 75
|
||||
Height = 25
|
||||
Action = EditSave1
|
||||
Caption = '&Save'
|
||||
TabOrder = 2
|
||||
Glyph.Data = {
|
||||
36040000424D3604000000000000360000002800000010000000100000000100
|
||||
2000000000000004000000000000000000000000000000000000C8C8C8008F8D
|
||||
8D008B8787008784840087848400878484008784840087848400878484008784
|
||||
8400878484008784840087848400908E8E008F8D8D00DADADA008E8E8E008181
|
||||
80006E6C6C00A6A2A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2
|
||||
A200A6A2A200A6A2A200A6A2A200272424007C7B7B009C9A9A008E8C8C001F1C
|
||||
1B008E8A8900EAE5E400E8E4E300E8E4E300E8E4E300E8E4E300E8E4E300E8E4
|
||||
E300E8E4E300E8E4E300EBE7E600353130001F1C1B009C9B9B008F8D8D00211E
|
||||
1E008D8A8900EFEAE900EFEAE900EFEAE900EFEAE900EFEAE900EFEAE900EFEA
|
||||
E900EFEAE900EFEAE900EFEAE90036333300211E1E009C9C9C00908F8F002421
|
||||
21008C898900E7E2E100E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0
|
||||
DF00E5E0DF00E5E0DF00E8E2E10039363600242121009F9C9C00929090002724
|
||||
23008C878700E4DEDE00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DD
|
||||
DD00E3DDDD00E3DDDD00E6E0E0003B383800272423009F9C9C00939191002926
|
||||
26008A878700E3DCDC00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DB
|
||||
DA00E1DBDA00E1DBDA00E4DEDD003D3A3A00292626009F9C9C00949392002C29
|
||||
280075727000CDC7C600CEC7C700CEC7C700CEC7C700CEC7C700CEC7C700CEC7
|
||||
C700CEC7C700CEC7C700CAC4C400383433002C2928009F9F9F00969494002F2C
|
||||
2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C
|
||||
2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B009F9F9F0097959500312E
|
||||
2D00312E2D0043403F00423F3F00434040004340400043404000434040004340
|
||||
4000434040003F3C3C003C3B3A0038343300312E2D00A09F9F009A9898003734
|
||||
330037343300807E7E00B5B3B30095939300B5B3B300B7B5B500B7B5B500B7B5
|
||||
B500B7B5B50098969600201C1C00423F3E0037343300A2A0A0009E9C9B003F3B
|
||||
3A003F3B3A0089868600ABAAAA0027232300B1B1B100B5B4B400B5B4B400B5B4
|
||||
B400B5B4B4009E9A9A0027232300484545003F3B3A00A5A3A300A2A09F004743
|
||||
4100474341008C898900ABAAAA002F2A2A00B1B1B100B5B4B400B5B4B400B5B4
|
||||
B400B5B4B400A09C9C002F2A2A00504C4B0047434100A6A5A500A6A4A2004F4B
|
||||
48004F4B48009A989800BFBEBE0037313100C8C7C700D1D0D000D1D0D000D1D0
|
||||
D000D1D0D000AFABAB0037313100585352004F4B4800A8A6A600D6D6D5005E5B
|
||||
5A0057535000A9A7A600E5E4E400C5C2C200EAE9E900EEEDED00EEEDED00EEED
|
||||
ED00EEEDED00BDBBBB003F3838005F5B590057535000ABA9A800FF00FF00D9D8
|
||||
D800AFADAC00A9A9A9009A9797009A9797009A9797009A9797009A9997009A99
|
||||
97009A999700A6A5A500B7B7B700B5B5B300B0AFAE00D4D4D400}
|
||||
end
|
||||
object btnLoad: TBitBtn
|
||||
Left = 264
|
||||
Top = 4
|
||||
Width = 75
|
||||
Height = 25
|
||||
Action = actEditLoad1
|
||||
Caption = 'Load'
|
||||
TabOrder = 3
|
||||
Glyph.Data = {
|
||||
36040000424D3604000000000000360000002800000010000000100000000100
|
||||
2000000000000004000000000000000000000000000000000000FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00D2CE
|
||||
CD00C4B09F00A4917E00A4917E00A4917E00A4917E00A4917E00A4917E00A491
|
||||
7E00A4917E00A18C7B00C5B29F00CFC8BF00FF00FF00FF00FF00FF00FF008D89
|
||||
8500A87B5500C7905D00C7905D00C7905D00C7905D00C78F5D00C78F5C00C78F
|
||||
5C00C78F5C00C78F5C00C78F5C00BA895C00E4DCD600FF00FF00FF00FF00A2A2
|
||||
A20087756500CA986A00CE9B6C00CE9B6C00CE9B6C00CE9B6C00CD9B6B00CD9B
|
||||
6B00CD9A6B00CD9A6B00CD9A6B00CA976700DDC2AC00FF00FF00FF00FF009393
|
||||
93009A928C00C59B7500D2A57B00D1A37800D0A17500D0A07400CFA07300CFA0
|
||||
7300CF9F7200CF9F7200CF9F7200D0A17400CDA48500FF00FF00FF00FF009393
|
||||
9300BAB8B600C6A28300D5A98200D3A87F00D3A77E00D3A77E00D3A77D00D3A6
|
||||
7D00D2A57B00D1A37800CFA07300CF9F7200CAA07900FF00FF00E9E9E9009292
|
||||
9200B8B8B800C1A08500D6AD8600D4AA8100D4A98100D4A98000D4A88000D4A8
|
||||
7F00D3A87F00D3A77E00D3A67D00D0A17500CFA27900E2CEBC00E3E3E3009797
|
||||
9700B0B0B000BCA48D00D5AD8800D5AD8600D5AC8500D5AC8400D5AB8400D4AB
|
||||
8300D4AB8200D4AA8200D4AA8100D4A98000D4A87F00D4B29600DADADA00ABAB
|
||||
AB00A4A4A400B2A29400CAA58300CDA98900CDA98900CDA98900CDA98900CDA9
|
||||
8900CDA98900CDA98900C6A18400CEAA8800D3AD8C00D0AB8D00CFCFCF00B5B5
|
||||
B50099999900B8B7B700A8A5A100A7A4A100A7A4A100A8A5A100A8A5A100A9A5
|
||||
A200ADA8A400AEA9A400B0ABA600A8A29C00FF00FF00FF00FF00C7C7C700B4B4
|
||||
B400A1A1A100BBBBBB00BDBDBD00B5B5B500B6B6B600B6B6B600B6B6B600B6B6
|
||||
B600B7B7B700B8B8B800BEBEBE00B5B5B500E4E4E400FF00FF00C1C1C100B1B1
|
||||
B100A8A8A800ADADAD00D2D2D200BEBEBE00BCBCBC00BDBDBD00BDBDBD00BDBD
|
||||
BD00BEBEBE00C0C0C000C4C4C400CCCCCC00D7D7D700FF00FF00BEBEBE00B6B6
|
||||
B600B1B1B100A2A2A200E3E3E300D0D0D000CDCDCD00CECECE00CFCFCF00CFCF
|
||||
CF00CFCFCF00D3D3D300DDDDDD00E5E5E500D5D5D500FF00FF00FF00FF00D1D1
|
||||
D100D4D4D400B4B4B400E8E8E800E5E5E500E4E4E400E3E3E300E3E3E300E3E3
|
||||
E300E3E3E300E4E4E400E4E4E400E7E7E700CFCFCF00FF00FF00FF00FF00FF00
|
||||
FF00FF00FF00FF00FF00D5D5D500D7D7D700D7D7D700D8D8D800D9D9D900DADA
|
||||
DA00DCDCDC00DDDDDD00DDDDDD00DFDFDF00EAEAEA00FF00FF00}
|
||||
end
|
||||
end
|
||||
object pnlJSONTreeView: TPanel
|
||||
Left = 0
|
||||
Top = 33
|
||||
Width = 458
|
||||
Height = 579
|
||||
Align = alClient
|
||||
Caption = 'JSON TreeView'
|
||||
TabOrder = 1
|
||||
end
|
||||
object ActionList1: TActionList
|
||||
Images = ImageList1
|
||||
Left = 327
|
||||
Top = 150
|
||||
object EditPaste1: TEditPaste
|
||||
Category = 'Edit'
|
||||
Caption = '&Paste'
|
||||
Hint = 'Paste|Inserts Clipboard contents'
|
||||
ImageIndex = 0
|
||||
ShortCut = 16470
|
||||
OnExecute = EditPaste1Execute
|
||||
end
|
||||
object EditClear1: TEditDelete
|
||||
Category = 'Edit'
|
||||
Caption = '&Clear'
|
||||
Enabled = False
|
||||
Hint = 'Clear|Clears the selection'
|
||||
ImageIndex = 1
|
||||
ShortCut = 16430
|
||||
OnExecute = EditClear1Execute
|
||||
end
|
||||
object ActionToggleVisibleChildrenCounts: TAction
|
||||
AutoCheck = True
|
||||
Caption = 'Visible Children Counts'
|
||||
OnExecute = ActionToggleVisibleChildrenCountsExecute
|
||||
end
|
||||
object ActionToggleVisibleByteSizes: TAction
|
||||
AutoCheck = True
|
||||
Caption = 'Visible Byte Sizes'
|
||||
OnExecute = ActionToggleVisibleByteSizesExecute
|
||||
end
|
||||
object EditSave1: TAction
|
||||
Category = 'Edit'
|
||||
Caption = '&Save'
|
||||
Enabled = False
|
||||
Hint = 'Save|Save to JSON file'
|
||||
ImageIndex = 2
|
||||
ShortCut = 16467
|
||||
OnExecute = EditSave1Execute
|
||||
end
|
||||
object actEditLoad1: TAction
|
||||
Category = 'Edit'
|
||||
Caption = 'Load'
|
||||
Hint = 'Load|Load JSON from file'
|
||||
ImageIndex = 3
|
||||
ShortCut = 16463
|
||||
OnExecute = actEditLoad1Execute
|
||||
end
|
||||
end
|
||||
object ImageList1: TImageList
|
||||
Left = 335
|
||||
Top = 238
|
||||
Bitmap = {
|
||||
494C0101040008000C0010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
|
||||
0000000000003600000028000000400000001000000001002000000000000010
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000C8C8C8008F8D8D008B8787008784
|
||||
8400878484008784840087848400878484008784840087848400878484008784
|
||||
840087848400908E8E008F8D8D00DADADA000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000080000000800000008000000080000000800000008000
|
||||
0000800000008000000080000000800000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000008E8E8E00818180006E6C6C00A6A2
|
||||
A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2A200A6A2
|
||||
A200A6A2A200272424007C7B7B009C9A9A000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF00FFFFFF00800000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000008E8C8C001F1C1B008E8A8900EAE5
|
||||
E400E8E4E300E8E4E300E8E4E300E8E4E300E8E4E300E8E4E300E8E4E300E8E4
|
||||
E300EBE7E600353130001F1C1B009C9B9B0000000000D2CECD00C4B09F00A491
|
||||
7E00A4917E00A4917E00A4917E00A4917E00A4917E00A4917E00A4917E00A18C
|
||||
7B00C5B29F00CFC8BF0000000000000000000000000086868600008080008686
|
||||
8600008080008686860080000000FFFFFF000000000000000000000000000000
|
||||
00000000000000000000FFFFFF00800000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000008F8D8D00211E1E008D8A8900EFEA
|
||||
E900EFEAE900EFEAE900EFEAE900EFEAE900EFEAE900EFEAE900EFEAE900EFEA
|
||||
E900EFEAE90036333300211E1E009C9C9C00000000008D898500A87B5500C790
|
||||
5D00C7905D00C7905D00C7905D00C78F5D00C78F5C00C78F5C00C78F5C00C78F
|
||||
5C00C78F5C00BA895C00E4DCD600000000000000000000808000868686000080
|
||||
8000868686000080800080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
|
||||
FF00FFFFFF00FFFFFF00FFFFFF00800000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000908F8F00242121008C898900E7E2
|
||||
E100E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0DF00E5E0
|
||||
DF00E8E2E10039363600242121009F9C9C0000000000A2A2A20087756500CA98
|
||||
6A00CE9B6C00CE9B6C00CE9B6C00CE9B6C00CD9B6B00CD9B6B00CD9A6B00CD9A
|
||||
6B00CD9A6B00CA976700DDC2AC00000000000000000086868600008080008686
|
||||
8600008080008686860080000000FFFFFF00000000000000000000000000FFFF
|
||||
FF00800000008000000080000000800000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
00000000000000000000000000000000000092909000272423008C878700E4DE
|
||||
DE00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DDDD00E3DD
|
||||
DD00E6E0E0003B383800272423009F9C9C0000000000939393009A928C00C59B
|
||||
7500D2A57B00D1A37800D0A17500D0A07400CFA07300CFA07300CF9F7200CF9F
|
||||
7200CF9F7200D0A17400CDA48500000000000000000000808000868686000080
|
||||
8000868686000080800080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
|
||||
FF0080000000FFFFFF0080000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
00000000000000000000000000000000000093919100292626008A878700E3DC
|
||||
DC00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DBDA00E1DB
|
||||
DA00E4DEDD003D3A3A00292626009F9C9C000000000093939300BAB8B600C6A2
|
||||
8300D5A98200D3A87F00D3A77E00D3A77E00D3A77D00D3A67D00D2A57B00D1A3
|
||||
7800CFA07300CF9F7200CAA07900000000000000000086868600008080008686
|
||||
8600008080008686860080000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
|
||||
FF00800000008000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000949392002C29280075727000CDC7
|
||||
C600CEC7C700CEC7C700CEC7C700CEC7C700CEC7C700CEC7C700CEC7C700CEC7
|
||||
C700CAC4C400383433002C2928009F9F9F00E9E9E90092929200B8B8B800C1A0
|
||||
8500D6AD8600D4AA8100D4A98100D4A98000D4A88000D4A87F00D3A87F00D3A7
|
||||
7E00D3A67D00D0A17500CFA27900E2CEBC000000000000808000868686000080
|
||||
8000868686000080800080000000800000008000000080000000800000008000
|
||||
0000800000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000969494002F2C2B002F2C2B002F2C
|
||||
2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C2B002F2C
|
||||
2B002F2C2B002F2C2B002F2C2B009F9F9F00E3E3E30097979700B0B0B000BCA4
|
||||
8D00D5AD8800D5AD8600D5AC8500D5AC8400D5AB8400D4AB8300D4AB8200D4AA
|
||||
8200D4AA8100D4A98000D4A87F00D4B296000000000086868600008080008686
|
||||
8600008080008686860000808000868686000080800086868600008080008686
|
||||
8600008080000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
00000000000000000000000000000000000097959500312E2D00312E2D004340
|
||||
3F00423F3F004340400043404000434040004340400043404000434040003F3C
|
||||
3C003C3B3A0038343300312E2D00A09F9F00DADADA00ABABAB00A4A4A400B2A2
|
||||
9400CAA58300CDA98900CDA98900CDA98900CDA98900CDA98900CDA98900CDA9
|
||||
8900C6A18400CEAA8800D3AD8C00D0AB8D000000000000808000868686000000
|
||||
0000000000000000000000000000000000000000000000000000000000008686
|
||||
8600868686000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000009A9898003734330037343300807E
|
||||
7E00B5B3B30095939300B5B3B300B7B5B500B7B5B500B7B5B500B7B5B5009896
|
||||
9600201C1C00423F3E0037343300A2A0A000CFCFCF00B5B5B50099999900B8B7
|
||||
B700A8A5A100A7A4A100A7A4A100A8A5A100A8A5A100A9A5A200ADA8A400AEA9
|
||||
A400B0ABA600A8A29C0000000000000000000000000086868600868686000000
|
||||
0000000000000000000000000000000000000000000000000000000000008686
|
||||
8600008080000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000009E9C9B003F3B3A003F3B3A008986
|
||||
8600ABAAAA0027232300B1B1B100B5B4B400B5B4B400B5B4B400B5B4B4009E9A
|
||||
9A0027232300484545003F3B3A00A5A3A300C7C7C700B4B4B400A1A1A100BBBB
|
||||
BB00BDBDBD00B5B5B500B6B6B600B6B6B600B6B6B600B6B6B600B7B7B700B8B8
|
||||
B800BEBEBE00B5B5B500E4E4E400000000000000000000808000868686000080
|
||||
80000000000000FFFF00000000000000000000FFFF0000000000868686000080
|
||||
8000868686000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000A2A09F0047434100474341008C89
|
||||
8900ABAAAA002F2A2A00B1B1B100B5B4B400B5B4B400B5B4B400B5B4B400A09C
|
||||
9C002F2A2A00504C4B0047434100A6A5A500C1C1C100B1B1B100A8A8A800ADAD
|
||||
AD00D2D2D200BEBEBE00BCBCBC00BDBDBD00BDBDBD00BDBDBD00BEBEBE00C0C0
|
||||
C000C4C4C400CCCCCC00D7D7D700000000000000000000000000000000000000
|
||||
0000000000000000000000FFFF0000FFFF000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000A6A4A2004F4B48004F4B48009A98
|
||||
9800BFBEBE0037313100C8C7C700D1D0D000D1D0D000D1D0D000D1D0D000AFAB
|
||||
AB0037313100585352004F4B4800A8A6A600BEBEBE00B6B6B600B1B1B100A2A2
|
||||
A200E3E3E300D0D0D000CDCDCD00CECECE00CFCFCF00CFCFCF00CFCFCF00D3D3
|
||||
D300DDDDDD00E5E5E500D5D5D500000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
000000000000000000000000000000000000D6D6D5005E5B5A0057535000A9A7
|
||||
A600E5E4E400C5C2C200EAE9E900EEEDED00EEEDED00EEEDED00EEEDED00BDBB
|
||||
BB003F3838005F5B590057535000ABA9A80000000000D1D1D100D4D4D400B4B4
|
||||
B400E8E8E800E5E5E500E4E4E400E3E3E300E3E3E300E3E3E300E3E3E300E4E4
|
||||
E400E4E4E400E7E7E700CFCFCF00000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
0000000000000000000000000000000000000000000000000000000000000000
|
||||
00000000000000000000000000000000000000000000D9D8D800AFADAC00A9A9
|
||||
A9009A9797009A9797009A9797009A9797009A9997009A9997009A999700A6A5
|
||||
A500B7B7B700B5B5B300B0AFAE00D4D4D4000000000000000000000000000000
|
||||
0000D5D5D500D7D7D700D7D7D700D8D8D800D9D9D900DADADA00DCDCDC00DDDD
|
||||
DD00DDDDDD00DFDFDF00EAEAEA0000000000424D3E000000000000003E000000
|
||||
2800000040000000100000000100010000000000800000000000000000000000
|
||||
000000000000000000000000FFFFFF00FFFFFFFF0000FFFFFC00FFFF0000FFFF
|
||||
8000EFFD000080030000C7FF000080010000C3FB000080010000E3F700008001
|
||||
0001F1E7000080010003F8CF000000000003FC1F000000000003FE3F00000000
|
||||
0003FC1F000000030FC3F8CF000000010003E1E7000000018007C3F300000001
|
||||
F87FC7FD00008001FFFFFFFF8000F00100000000000000000000000000000000
|
||||
000000000000}
|
||||
end
|
||||
object PopupMenu1: TPopupMenu
|
||||
Left = 323
|
||||
Top = 92
|
||||
object VisibleChildrenCounts1: TMenuItem
|
||||
Action = ActionToggleVisibleChildrenCounts
|
||||
AutoCheck = True
|
||||
end
|
||||
object VisibleByteSizes1: TMenuItem
|
||||
Action = ActionToggleVisibleByteSizes
|
||||
AutoCheck = True
|
||||
end
|
||||
end
|
||||
object dlgSave: TSaveDialog
|
||||
DefaultExt = 'json'
|
||||
Filter = 'JSON file|*.json'
|
||||
Options = [ofOverwritePrompt, ofHideReadOnly, ofEnableSizing]
|
||||
Title = 'Save JSON file'
|
||||
Left = 184
|
||||
Top = 41
|
||||
end
|
||||
object dlgOpenJSONFile: TOpenDialog
|
||||
DefaultExt = 'json'
|
||||
Filter = 'JSON File|*.json'
|
||||
Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing]
|
||||
Title = 'Select a JSON file'
|
||||
Left = 272
|
||||
Top = 97
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,155 @@
|
||||
unit fMain;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, ExtCtrls, StdCtrls, Buttons, ActnList, StdActns, ImgList, Menus,
|
||||
ComCtrls,
|
||||
SynJSONTreeView,
|
||||
SynCommons;
|
||||
|
||||
type
|
||||
TfrmJSONEditor = class(TForm)
|
||||
Panel1: TPanel;
|
||||
ActionList1: TActionList;
|
||||
ImageList1: TImageList;
|
||||
EditPaste1: TEditPaste;
|
||||
EditClear1: TEditDelete;
|
||||
BitBtn1: TBitBtn;
|
||||
btnClear: TBitBtn;
|
||||
ActionToggleVisibleChildrenCounts: TAction;
|
||||
ActionToggleVisibleByteSizes: TAction;
|
||||
PopupMenu1: TPopupMenu;
|
||||
VisibleChildrenCounts1: TMenuItem;
|
||||
VisibleByteSizes1: TMenuItem;
|
||||
pnlJSONTreeView: TPanel;
|
||||
btnSaveJSON: TBitBtn;
|
||||
EditSave1: TAction;
|
||||
dlgSave: TSaveDialog;
|
||||
actEditLoad1: TAction;
|
||||
btnLoad: TBitBtn;
|
||||
dlgOpenJSONFile: TOpenDialog;
|
||||
procedure ActionToggleVisibleChildrenCountsExecute(Sender: TObject);
|
||||
procedure ActionToggleVisibleByteSizesExecute(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure EditPaste1Execute(Sender: TObject);
|
||||
procedure EditClear1Execute(Sender: TObject);
|
||||
procedure EditSave1Execute(Sender: TObject);
|
||||
procedure actEditLoad1Execute(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
JSONTreeView1: TSynJSONTreeView;
|
||||
procedure DoOnCustomInput(Sender: TObject; Node: TSynJSONTreeNode;
|
||||
var Prompt: RawUTF8; var Value: Variant; var Handled: Boolean);
|
||||
procedure SetJSON(const aJSON: RawUTF8);
|
||||
procedure ToogleButtons;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
frmJSONEditor: TfrmJSONEditor;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Clipbrd,
|
||||
fLevel;
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
procedure TfrmJSONEditor.FormCreate(Sender: TObject);
|
||||
begin
|
||||
JSONTreeView1 := TSynJSONTreeView.Create(pnlJSONTreeView);
|
||||
JSONTreeView1.PopupMenu := PopupMenu1;
|
||||
JSONTreeView1.Align := alClient;
|
||||
JSONTreeView1.Parent := pnlJSONTreeView;
|
||||
JSONTreeView1.OnCustomInput := DoOnCustomInput;
|
||||
ActionToggleVisibleByteSizes.Checked := JSONTreeView1.VisibleByteSizes;
|
||||
ActionToggleVisibleChildrenCounts.Checked := JSONTreeView1.VisibleChildrenCounts;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.ActionToggleVisibleByteSizesExecute(Sender: TObject);
|
||||
begin
|
||||
JSONTreeView1.VisibleByteSizes := not JSONTreeView1.VisibleByteSizes;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.ActionToggleVisibleChildrenCountsExecute(Sender: TObject);
|
||||
begin
|
||||
JSONTreeView1.VisibleChildrenCounts := not JSONTreeView1.VisibleChildrenCounts;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.EditClear1Execute(Sender: TObject);
|
||||
begin
|
||||
JSONTreeView1.ClearAll;
|
||||
ToogleButtons;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.EditPaste1Execute(Sender: TObject);
|
||||
begin
|
||||
SetJSON(Clipboard.AsText);
|
||||
ToogleButtons;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.EditSave1Execute(Sender: TObject);
|
||||
begin
|
||||
if dlgSave.Execute then
|
||||
JSONTreeView1.SaveToFile(dlgSave.FileName);
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.actEditLoad1Execute(Sender: TObject);
|
||||
begin
|
||||
if dlgOpenJSONFile.Execute then
|
||||
begin
|
||||
SetJSON(StringFromFile(dlgOpenJSONFile.FileName));
|
||||
ToogleButtons;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.SetJSON(const aJSON: RawUTF8);
|
||||
begin
|
||||
JSONTreeView1.JsonText := aJSON;
|
||||
|
||||
JSONTreeView1.Items.BeginUpdate;
|
||||
JSONTreeView1.LoadJSON;
|
||||
JSONTreeView1.Items.EndUpdate;
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.ToogleButtons;
|
||||
begin
|
||||
EditSave1.Enabled := (JSONTreeView1.Items.Count > 0);
|
||||
EditClear1.Enabled := (JSONTreeView1.Items.Count > 0);
|
||||
end;
|
||||
|
||||
procedure TfrmJSONEditor.DoOnCustomInput(Sender: TObject;
|
||||
Node: TSynJSONTreeNode; var Prompt: RawUTF8; var Value: Variant; var Handled: Boolean);
|
||||
|
||||
procedure ProcessLevel;
|
||||
begin
|
||||
if (TDocVariantData(Value).Kind <> dvArray) then
|
||||
begin
|
||||
MessageDlg('Level node is not an array', mtError, [mbOK], 0);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
with TFrmLevel.Create(nil) do
|
||||
begin
|
||||
Caption := Prompt;
|
||||
FillListBox(Value);
|
||||
ShowModal;
|
||||
if (ModalResult = mrOK) then
|
||||
begin
|
||||
TDocVariantData(Value).Clear;
|
||||
TDocVariantData(Value).InitJSON(ToJSON);
|
||||
end;
|
||||
Handled := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
if IdemPChar(pointer(Prompt), 'LEVEL') then
|
||||
ProcessLevel;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,23 @@
|
||||
#------------------------------------------------------------------------------
|
||||
VERSION = BWS.01
|
||||
#------------------------------------------------------------------------------
|
||||
!ifndef ROOT
|
||||
ROOT = $(MAKEDIR)\..
|
||||
!endif
|
||||
#------------------------------------------------------------------------------
|
||||
MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$**
|
||||
DCC = $(ROOT)\bin\dcc32.exe $**
|
||||
BRCC = $(ROOT)\bin\brcc32.exe $**
|
||||
#------------------------------------------------------------------------------
|
||||
PROJECTS = Server.exe FishFactSyn.exe
|
||||
#------------------------------------------------------------------------------
|
||||
default: $(PROJECTS)
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
Server.exe: Server.dpr
|
||||
$(DCC)
|
||||
|
||||
FishFactSyn.exe: FishFactSyn\FishFactSyn.dpr
|
||||
$(DCC)
|
||||
|
||||
|
||||
@@ -0,0 +1,186 @@
|
||||
object Form1: TForm1
|
||||
Left = 341
|
||||
Top = 83
|
||||
BorderIcons = [biSystemMenu, biMinimize]
|
||||
BorderStyle = bsSingle
|
||||
Caption = 'FISH FACTS'
|
||||
ClientHeight = 584
|
||||
ClientWidth = 542
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clBlack
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
OldCreateOrder = True
|
||||
ShowHint = True
|
||||
OnCreate = FormCreate
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object Panel1: TPanel
|
||||
Left = 6
|
||||
Top = 8
|
||||
Width = 299
|
||||
Height = 249
|
||||
Hint = 'Scroll grid below to see other fish'
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 0
|
||||
object DBLabel1: TDBText
|
||||
Left = 4
|
||||
Top = 220
|
||||
Width = 249
|
||||
Height = 24
|
||||
DataField = 'Common_Name'
|
||||
DataSource = DataSource1
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clRed
|
||||
Font.Height = -19
|
||||
Font.Name = 'MS Serif'
|
||||
Font.Style = [fsBold, fsItalic]
|
||||
ParentFont = False
|
||||
end
|
||||
object img: TImage
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 281
|
||||
Height = 201
|
||||
end
|
||||
object btnUpload: TButton
|
||||
Left = 212
|
||||
Top = 216
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Upload'
|
||||
Enabled = False
|
||||
TabOrder = 0
|
||||
OnClick = btnUploadClick
|
||||
end
|
||||
end
|
||||
object Panel2: TPanel
|
||||
Left = 310
|
||||
Top = 8
|
||||
Width = 225
|
||||
Height = 22
|
||||
TabOrder = 1
|
||||
object Label1: TLabel
|
||||
Left = 7
|
||||
Top = 4
|
||||
Width = 56
|
||||
Height = 13
|
||||
Caption = 'About the'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clBlue
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object DBLabel2: TDBText
|
||||
Left = 67
|
||||
Top = 4
|
||||
Width = 56
|
||||
Height = 13
|
||||
AutoSize = True
|
||||
DataField = 'Common_Name'
|
||||
DataSource = DataSource1
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clBlue
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
end
|
||||
object Panel3: TPanel
|
||||
Left = 312
|
||||
Top = 32
|
||||
Width = 223
|
||||
Height = 187
|
||||
BevelOuter = bvLowered
|
||||
TabOrder = 2
|
||||
object DBMemo1: TDBMemo
|
||||
Left = 3
|
||||
Top = 2
|
||||
Width = 217
|
||||
Height = 183
|
||||
BorderStyle = bsNone
|
||||
Color = clSilver
|
||||
Ctl3D = False
|
||||
DataField = 'Notes'
|
||||
DataSource = DataSource1
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clBlack
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
ParentCtl3D = False
|
||||
ParentFont = False
|
||||
ScrollBars = ssVertical
|
||||
TabOrder = 0
|
||||
end
|
||||
end
|
||||
object Panel4: TPanel
|
||||
Left = 0
|
||||
Top = 260
|
||||
Width = 542
|
||||
Height = 324
|
||||
Align = alBottom
|
||||
BevelInner = bvRaised
|
||||
BorderStyle = bsSingle
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 3
|
||||
object DBGrid1: TDBGrid
|
||||
Left = 2
|
||||
Top = 12
|
||||
Width = 534
|
||||
Height = 281
|
||||
Hint = 'Scroll up/down to see other fish!'
|
||||
Align = alBottom
|
||||
DataSource = DataSource1
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
TabOrder = 0
|
||||
TitleFont.Charset = DEFAULT_CHARSET
|
||||
TitleFont.Color = clBlack
|
||||
TitleFont.Height = -11
|
||||
TitleFont.Name = 'MS Sans Serif'
|
||||
TitleFont.Style = []
|
||||
end
|
||||
object dbnvgr1: TDBNavigator
|
||||
Left = 2
|
||||
Top = 293
|
||||
Width = 534
|
||||
Height = 25
|
||||
DataSource = DataSource1
|
||||
Align = alBottom
|
||||
TabOrder = 1
|
||||
OnClick = dbnvgr1Click
|
||||
end
|
||||
end
|
||||
object DataSource1: TDataSource
|
||||
Left = 19
|
||||
Top = 193
|
||||
end
|
||||
object dlgOpenPic1: TOpenPictureDialog
|
||||
Filter =
|
||||
'All (*.png;*.jpg;*.jpeg;*.gif;*.cur;*.pcx;*.ani;*.jpg;*.jpeg;*.b' +
|
||||
'mp;*.ico;*.emf;*.wmf)|*.png;*.jpg;*.jpeg;*.gif;*.cur;*.pcx;*.ani' +
|
||||
';*.jpg;*.jpeg;*.bmp;*.ico;*.emf;*.wmf|JPEG Image File (*.jpg)|*.' +
|
||||
'jpg|JPEG Image File (*.jpeg)|*.jpeg|CompuServe GIF Image (*.gif)' +
|
||||
'|*.gif|Cursor files (*.cur)|*.cur|PCX Image (*.pcx)|*.pcx|ANI Im' +
|
||||
'age (*.ani)|*.ani|JPEG Image File (*.jpg)|*.jpg|JPEG Image File ' +
|
||||
'(*.jpeg)|*.jpeg|Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanc' +
|
||||
'ed Metafiles (*.emf)|*.emf|Metafiles (*.wmf)|*.wmf|PNG Image Fil' +
|
||||
'e (*.png)|*.png'
|
||||
Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing]
|
||||
Title = 'Fish Image'
|
||||
Left = 174
|
||||
Top = 224
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,99 @@
|
||||
unit Ffactwin;
|
||||
|
||||
{ This application shows how to display TSynRestDataset style memo and graphic
|
||||
fields in a form.
|
||||
|
||||
- This application use TWebBrowser for display the image from Project19Server.db3.
|
||||
- Removed display of image because is need convert the Project19Server.db3 field image to base64 or any suggest.
|
||||
- fixed memory leak (by houdw2006)
|
||||
}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Windows, Messages, Classes, Graphics, Controls,
|
||||
Forms, StdCtrls, DBCtrls, DBGrids, DB, Buttons, Grids, ExtCtrls,
|
||||
SynRestMidasVCL, DBClient,
|
||||
SynCommons, mORMot, OleCtrls, Dialogs, ExtDlgs,
|
||||
SynGdiPlus;
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
Panel1: TPanel;
|
||||
Label1: TLabel;
|
||||
DBLabel1: TDBText;
|
||||
DBMemo1: TDBMemo;
|
||||
DataSource1: TDataSource;
|
||||
DBGrid1: TDBGrid;
|
||||
dbnvgr1: TDBNavigator;
|
||||
btnUpload: TButton;
|
||||
dlgOpenPic1: TOpenPictureDialog;
|
||||
img: TImage;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
procedure btnUploadClick(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
procedure DoOnAfterScroll(Dataset: TDataset);
|
||||
public
|
||||
{ Public declarations }
|
||||
SynRestDataset: TSynRestDataset;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
uses SampleData;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
SynRestDataset := TSynRestDataset.Create(Nil);
|
||||
SynRestDataset.DataSet.SQLModel := TSQLModel.Create([TSQLBioLife]);
|
||||
SynRestDataset.CommandText := 'http://LocalHost:8080/root/BioLife?select=Species_No,Category,Common_Name,Species_Name,Length_cm,Length_in,Graphic,Notes,Som&sort=Species_No';
|
||||
SynRestDataset.Open;
|
||||
SynRestDataset.AfterScroll := DoOnAfterScroll;
|
||||
DataSource1.DataSet := SynRestDataset;
|
||||
// show the first record image
|
||||
DoOnAfterScroll(Nil);
|
||||
// hide blob fields in the grid
|
||||
for I := 0 to DBGrid1.Columns.Count-1 do
|
||||
if (DBGrid1.Columns[I].Field.DataType = DB.ftBlob) then
|
||||
DBGrid1.Columns[I].Visible := False;
|
||||
end;
|
||||
|
||||
procedure TForm1.dbnvgr1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
case Button of
|
||||
nbDelete, nbPost: SynRestDataset.ApplyUpdates(0);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.btnUploadClick(Sender: TObject);
|
||||
begin
|
||||
// I don't know as encode this :(
|
||||
if not (SynRestDataset.State in [dsEdit, dsInsert]) then
|
||||
SynRestDataset.Edit;
|
||||
if dlgOpenPic1.Execute then
|
||||
TBlobField(SynRestDataset.FieldByName('Graphic')).LoadFromFile(dlgOpenPic1.FileName);
|
||||
end;
|
||||
|
||||
procedure TForm1.DoOnAfterScroll(Dataset: TDataset);
|
||||
begin
|
||||
//img.Picture :=
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
SynRestDataset.Dataset.SQLModel.Free;
|
||||
SynRestDataset.Dataset.SQLModel := nil;
|
||||
FreeAndNil(SynRestDataset);
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,17 @@
|
||||
program FishFactSyn;
|
||||
|
||||
uses
|
||||
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
|
||||
Forms,
|
||||
Ffactwin in 'Ffactwin.pas' {Form1},
|
||||
SynRestVCL in '..\SynRestVCL.pas',
|
||||
SynRestMidasVCL in '..\SynRestMidasVCL.pas',
|
||||
SampleData in '..\SampleData.pas';
|
||||
|
||||
{$R *.RES}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
@@ -0,0 +1,189 @@
|
||||
TSynRestDataset
|
||||
===============
|
||||
|
||||
By *EMartin* (Esteban Martin).
|
||||
|
||||
|
||||
# Presentation
|
||||
|
||||
Migrating from *RemObjects* to *mORMot* I had to implement a GUI functionality that *RemObjects* has, an editable dataset connected through URL (RO version 3 use SOAP and other components adapters, etc.).
|
||||
|
||||
My implementation is basic and the most probably is not the best, but works for me, the same use RESTful URL for get and update data, also get data from a *mORMot* interface based services returning a *mORMot* JSON array but cannot update because the table not exists.
|
||||
|
||||
In this folder there are two units: `SynRestVCL.pas` and `SynRestMidasVCL.pas`, both have some duplicated code from its counterpart (`SynDBVCL.pas` and `SynDBMidasVCL.pas`) and the others, but the rest are modifications with use of RESTful instead of the `TSQLDBConnection` (this require the database client installed in the client machine).
|
||||
|
||||
A `TSQLModel` is required because the `TSynRestDataset` get the fields definition column type and size from this. Also is used from the `TSQLRecord` the defined validations (I used `InternalDefineModel`) and the `ComputeFieldsBeforeWrite` (I used this for default values).
|
||||
|
||||
This was developed with Delphi 7 on Windows 7 and probably (almost sure) is not cross platform.
|
||||
|
||||
If this serves for others may be the best option will be that *ab* integrate this in the framework and make this code more *mORMot*. Meanwhile I will update on the google drive.
|
||||
I hope this is helpful to someone.
|
||||
|
||||
# Example 1: from a table
|
||||
|
||||
// defining the table
|
||||
TSQLRecordTest = class(TSQLRecord)
|
||||
private
|
||||
fDecimal: Double;
|
||||
fNumber: Double;
|
||||
fTestID: Integer;
|
||||
fText: RawUTF8;
|
||||
fDateTime: TDateTime;
|
||||
protected
|
||||
class procedure InternalDefineModel(Props: TSQLRecordProperties); override;
|
||||
public
|
||||
procedure ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent); override;
|
||||
published
|
||||
property Test_ID: Integer read fTestID write fTestID;
|
||||
property Text: RawUTF8 index 255 read fText write fText;
|
||||
property Date_Time: TDateTime read fDateTime write fDateTime;
|
||||
property Number: Double read fNumber write fNumber;
|
||||
property Decimal_: Double read fDecimal write fDecimal;
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
{ TSQLRecordTest }
|
||||
|
||||
procedure TSQLRecordTest.ComputeFieldsBeforeWrite(aRest: TSQLRest; aOccasion: TSQLEvent);
|
||||
begin
|
||||
inherited;
|
||||
fDateTime := Now;
|
||||
end;
|
||||
|
||||
class procedure TSQLRecordTest.InternalDefineModel(Props: TSQLRecordProperties);
|
||||
begin
|
||||
AddFilterNotVoidText(['Text']);
|
||||
AddFilterOrValidate('Text', TSynValidateNonNull.Create);
|
||||
end;
|
||||
|
||||
// client
|
||||
type
|
||||
TForm3 = class(TForm)
|
||||
DBGrid1: TDBGrid;
|
||||
DBNavigator1: TDBNavigator;
|
||||
btnOpen: TButton;
|
||||
edtURL: TEdit;
|
||||
dsRest: TDataSource;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnOpenClick(Sender: TObject);
|
||||
procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
private
|
||||
{ Private declarations }
|
||||
fRestDS: TSynRestDataset;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
procedure TForm3.FormCreate(Sender: TObject);
|
||||
begin
|
||||
fRestDS := TSynRestDataset.Create(Self);
|
||||
fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordTest], 'root');
|
||||
dsRest.Dataset := fRestDS;
|
||||
end;
|
||||
|
||||
procedure TForm3.btnOpenClick(Sender: TObject);
|
||||
begin
|
||||
fRestDS.Close;
|
||||
fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*
|
||||
fRestDS.Open;
|
||||
// you can filter by
|
||||
// where: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=CONDITION
|
||||
// fRestDS.Open;
|
||||
// named parameter: fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/Test/select=*&where=:PARAMNAME
|
||||
// fRestDS.Params.ParamByName('PARAMNAME').Value := XXX
|
||||
// fRestDS.Open;
|
||||
end;
|
||||
|
||||
procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
if (Button = nbPost) then
|
||||
fRestDS.ApplyUpdates(0);
|
||||
end;
|
||||
|
||||
# Example 2: from a service
|
||||
|
||||
// defining the table, the service name and operation name are required
|
||||
TSQLRecordServiceName_OperationName = class(TSQLRecord)
|
||||
private
|
||||
fText: RawUTF8;
|
||||
published
|
||||
property Text: RawUTF8 index 255 read fText write fText;
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
// server (the implementation)
|
||||
|
||||
TServiceName =class(TInterfacedObjectWithCustomCreate, IServiceName)
|
||||
public
|
||||
...
|
||||
// this function can also be function OperationName(const aParamName: RawUTF8): RawUTF8;
|
||||
function OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
|
||||
...
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
function TServiceName.OperationName(const aParamName: RawUTF8; out aData: RawUTF8): Integer;
|
||||
begin
|
||||
Result := OK;
|
||||
aData := '[{"text":"test"},{"text":"test1"}]';
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
// client
|
||||
type
|
||||
TForm3 = class(TForm)
|
||||
DBGrid1: TDBGrid;
|
||||
DBNavigator1: TDBNavigator;
|
||||
btnOpen: TButton;
|
||||
edtURL: TEdit;
|
||||
dsRest: TDataSource;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnOpenClick(Sender: TObject);
|
||||
procedure DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
private
|
||||
{ Private declarations }
|
||||
fRestDS: TSynRestDataset;
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
...
|
||||
|
||||
procedure TForm3.FormCreate(Sender: TObject);
|
||||
begin
|
||||
fRestDS := TSynRestDataset.Create(Self);
|
||||
fRestDS.Dataset.SQLModel := TSQLModel.Create([TSQLRecordServiceName_OperationName], 'root');
|
||||
dsRest.Dataset := fRestDS;
|
||||
end;
|
||||
|
||||
procedure TForm3.btnOpenClick(Sender: TObject);
|
||||
begin
|
||||
fRestDS.Close;
|
||||
fRestDS.CommandText := edtURL.Text; // edtURL.Text = 'http://localhost:8888/root/ServiceName.OperationName?aParamName=XXX
|
||||
fRestDS.Open;
|
||||
// you can filter by named parameter:
|
||||
// fRestDS.CommandText := edtURL.Text; // 'http://localhost:8888/root/ServiceName.OperationName?aParamName=:aParamName
|
||||
// fRestDS.Params.ParamByName('aParamName').Value := XXX
|
||||
// fRestDS.Open;
|
||||
end;
|
||||
|
||||
procedure TForm3.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
|
||||
begin
|
||||
if (Button = nbPost) then
|
||||
fRestDS.ApplyUpdates(0); // raise an error "Cannot update data from a service"
|
||||
end;
|
||||
|
||||
|
||||
# Forum Thread
|
||||
|
||||
See http://synopse.info/forum/viewtopic.php?id=2712
|
||||
|
||||
# License
|
||||
|
||||
Feel free to use and/or append to Lib and extend if needed.
|
||||
@@ -0,0 +1,51 @@
|
||||
/// it's a good practice to put all data definition into a stand-alone unit
|
||||
// - this unit will be shared between client and server
|
||||
unit SampleData;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SynCommons,
|
||||
mORMot;
|
||||
|
||||
type
|
||||
/// here we declare the class containing the data
|
||||
// - it just has to inherits from TSQLRecord, and the published
|
||||
// properties will be used for the ORM (and all SQL creation)
|
||||
// - the beginning of the class name must be 'TSQL' for proper table naming
|
||||
// in client/server environnment
|
||||
TSQLBiolife = class(TSQLRecord)
|
||||
private
|
||||
fSpecies_No: Integer;
|
||||
fCategory: RawUTF8;
|
||||
fCommon_Name: RawUTF8;
|
||||
fSpecies_Name: RawUTF8;
|
||||
fLength_cm: double;
|
||||
fLength_in: double;
|
||||
fNotes: TSQLRawBlob;
|
||||
fGraphic: TSQLRawBlob;
|
||||
fSom: TSQLRawBlob;
|
||||
published
|
||||
property Species_No: Integer read fSpecies_No write fSpecies_No;
|
||||
property Category: RawUTF8 index 15 read fCategory write fCategory;
|
||||
property Common_Name: RawUTF8 index 30 read fCommon_Name write fCommon_Name;
|
||||
property Species_Name: RawUTF8 index 40 read fSpecies_Name write fSpecies_Name;
|
||||
property Length_cm: Double read fLength_Cm write fLength_Cm;
|
||||
property Length_In: Double read fLength_In write fLength_In;
|
||||
property Notes: TSQLRawBlob read fNotes write fNotes;
|
||||
property Graphic: TSQLRawBlob read fGraphic write fGraphic;
|
||||
property Som: TSQLRawBlob read fSom write fSom;
|
||||
end;
|
||||
|
||||
/// an easy way to create a database model for client and server
|
||||
function CreateSampleModel: TSQLModel;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
function CreateSampleModel: TSQLModel;
|
||||
begin
|
||||
result := TSQLModel.Create([TSQLBioLife]);
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,59 @@
|
||||
{
|
||||
Synopse mORMot framework
|
||||
|
||||
Sample 04 - HTTP Client-Server
|
||||
purpose of this sample is to show HTTP Client/Server SQLite3 database usage:
|
||||
|
||||
- a TSQLSampleRecord class is defined in shared unit SampleData.pas
|
||||
- this sample uses two projects, Project04Client.dpr and Project04Server.dpr
|
||||
- a SQLite3 server is initialized in Project04Server
|
||||
- the CreateMissingTables method will create all necessary tables in the
|
||||
SQLite3 database
|
||||
- one or more client instances can be run in Project04Client
|
||||
- the purpose of the Client form in Unit1.pas is to add a record to the
|
||||
database; the Time field is filled with the current date and time
|
||||
- the 'Find a previous message' button show how to perform a basic query
|
||||
- since the framework use UTF-8 encoding, we use some basic functions for
|
||||
fast conversion to/from the User Interface; in real applications,
|
||||
you should better use our SQLite3i18n unit and the corresponding
|
||||
TLanguageFile.StringToUTF8() and TLanguageFile.UTF8ToString() methods
|
||||
- note that you didn't need to write any SQL statement, only define a
|
||||
class and call some methods; even the query was made very easy (just an
|
||||
obvious WHERE clause to write)
|
||||
- thanks to the true object oriented modelling of the framework, the same
|
||||
exact Unit1 is used for both static in-memory database engine, or
|
||||
with SQLite3 database storage, in local mode or in Client/Server mode:
|
||||
only the TForm1.Database object creation instance was modified
|
||||
- in order to register the URL for the http.sys server, you have to run
|
||||
this program once as administrator, or call Project04ServerRegister first
|
||||
- look at the tiny size of the EXE (even with SQLite3 engine embedded), less
|
||||
than 400KB for the server, and 80KB for the client, with LVCL :)
|
||||
|
||||
|
||||
Version 1.0 - February 07, 2010
|
||||
|
||||
Version 1.16
|
||||
- added authentication to the remote process
|
||||
|
||||
Version 1.18
|
||||
- added Project04ServerRegister.dpr program
|
||||
|
||||
}
|
||||
|
||||
program Server;
|
||||
|
||||
uses
|
||||
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
|
||||
Forms,
|
||||
SysUtils,
|
||||
fMain in 'fMain.pas' {frmMain},
|
||||
SampleData in 'SampleData.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
SetCurrentDir(ExtractFilePath(ParamStr(0)));
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TfrmMain, frmMain);
|
||||
Application.Run;
|
||||
end.
|
||||
@@ -0,0 +1,433 @@
|
||||
/// fill a VCL TClientDataset from SynRestVCL data access
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynRestMidasVCL;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 Arnaud Bouchez
|
||||
Synopse Informatique - https://synopse.info
|
||||
|
||||
*** BEGIN LICENSE BLOCK *****
|
||||
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
||||
|
||||
The contents of this file are subject to the Mozilla Public License Version
|
||||
1.1 (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.mozilla.org/MPL
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
||||
for the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is Synopse mORMot framework.
|
||||
|
||||
The Initial Developer of the Original Code is Arnaud Bouchez.
|
||||
|
||||
Portions created by the Initial Developer are Copyright (C) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- Esteban Martin
|
||||
- houdw2006
|
||||
|
||||
Alternatively, the contents of this file may be used under the terms of
|
||||
either the GNU General Public License Version 2 or later (the "GPL"), or
|
||||
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
||||
in which case the provisions of the GPL or the LGPL are applicable instead
|
||||
of those above. If you wish to allow use of your version of this file only
|
||||
under the terms of either the GPL or the LGPL, and not to allow others to
|
||||
use your version of this file under the terms of the MPL, indicate your
|
||||
decision by deleting the provisions above and replace them with the notice
|
||||
and other provisions required by the GPL or the LGPL. If you do not delete
|
||||
the provisions above, a recipient may use your version of this file under
|
||||
the terms of any one of the MPL, the GPL or the LGPL.
|
||||
|
||||
***** END LICENSE BLOCK *****
|
||||
|
||||
Version 1.18
|
||||
- first public release, corresponding to Synopse mORMot Framework 1.18,
|
||||
which is an extraction from former SynRestVCL.pas unit (which is faster
|
||||
but read/only)
|
||||
- introducing TSynRestDataSet (under Delphi), which allows to apply updates:
|
||||
will be used now for overloaded ToClientDataSet() functions result
|
||||
- fixed Delphi XE2 compilation issue with SetCommandText declaration
|
||||
- bug fix skipping first record
|
||||
- fix memory leak adding TSynRestDataset.destroy (by houdw2006)
|
||||
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
|
||||
Classes,
|
||||
{$ifndef DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ifndef FPC}
|
||||
MidasLib,
|
||||
{$endif}
|
||||
{$endif}
|
||||
mORMot,
|
||||
mORMotHttpClient,
|
||||
SynCommons,
|
||||
SynTable,
|
||||
SynDB,
|
||||
SynRestVCL,
|
||||
DB,
|
||||
{$ifdef FPC}
|
||||
BufDataset
|
||||
{$else}
|
||||
Contnrs,
|
||||
DBClient,
|
||||
Provider,
|
||||
SqlConst
|
||||
{$endif};
|
||||
|
||||
|
||||
{$ifdef FPC} { TODO: duplicated code from SynDBMidasVCL }
|
||||
type
|
||||
/// FPC's pure pascal in-memory buffer is used instead of TClientDataSet
|
||||
TClientDataSet = TBufDataset;
|
||||
|
||||
/// wrapper functions will use FPC's pure pascal in-memory buffer
|
||||
TSynRestDataSet = TBufDataset;
|
||||
|
||||
{$else FPC}
|
||||
type
|
||||
/// A TSynRestDataset, inherited from TCustomClientDataSet, which allows to apply updates on a TWinHTTP connection.
|
||||
// The TSQLModel is required for getting column datatype and size and if the TSQLRecord has defined
|
||||
// InternalDefineModel for validations they will be associated to a TField.OnValidate. Similary if the method
|
||||
// ComputeBeforeWriteFields is overridden this will be used.
|
||||
// - typical usage may be for instance:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! ds.CommandText := 'http://host:port/root/TableName?select=*&where=condition&sort=fieldname';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
// or using from a service returning a dataset:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! the TSQLRecord associated should be defined with the same structure of the returned array from the service
|
||||
// ! ds.CommandText := 'http://host:port/root/ServiceName.Operation?paramname=:paramvalue';
|
||||
// ! ds.Params.ParamByName('paramname').Value := 'xyz';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
TSynRestDataSet = class(TCustomClientDataSet)
|
||||
protected
|
||||
fDataSet: TSynRestSQLDataset;
|
||||
fProvider: TDataSetProvider;
|
||||
procedure DoOnFieldValidate(Sender: TField);
|
||||
procedure DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError; UpdateKind: TUpdateKind; var Response: TResolverResponse);
|
||||
// from TDataSet
|
||||
procedure OpenCursor(InfoQuery: Boolean); override;
|
||||
{$ifdef ISDELPHI2007ANDUP}
|
||||
// from IProviderSupport
|
||||
function PSGetCommandText: string; override;
|
||||
{$endif}
|
||||
{$IFNDEF NEXTGEN}
|
||||
{$ifdef ISDELPHIXE}
|
||||
procedure SetCommandText(Value: WideString); override;
|
||||
{$else ISDELPHIXE}
|
||||
procedure SetCommandText(Value: String); override;
|
||||
{$endif ISDELPHIXE}
|
||||
{$ELSE}
|
||||
procedure SetCommandText(Value: String); override;
|
||||
{$ENDIF !NEXTGEN}
|
||||
procedure SetFieldValidateFromSQLRecordSynValidate;
|
||||
public
|
||||
/// initialize the instance
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
/// destroy the instance
|
||||
destructor Destroy; override;
|
||||
/// initialize the internal TDataSet from a Rest statement result set
|
||||
// - Statement will have the form http://host:port/root/tablename or
|
||||
// http://host:port/root/servicename.operationname?paramname=:paramalias
|
||||
// examples:
|
||||
// http://host:port/root/tablename?select=XXX or
|
||||
// http://host:port/root/tablename?select=XXX&where=field1=XXX or field2=XXX
|
||||
// http://host:port/root/service.operation?param=:param
|
||||
procedure From(Statement: RawUTF8; MaxRowCount: cardinal=0);
|
||||
procedure FetchParams;
|
||||
published
|
||||
property CommandText;
|
||||
property Active;
|
||||
property Aggregates;
|
||||
property AggregatesActive;
|
||||
property AutoCalcFields;
|
||||
property Constraints;
|
||||
property DisableStringTrim;
|
||||
property FileName;
|
||||
property Filter;
|
||||
property Filtered;
|
||||
property FilterOptions;
|
||||
property FieldDefs;
|
||||
property IndexDefs;
|
||||
property IndexFieldNames;
|
||||
property IndexName;
|
||||
property FetchOnDemand;
|
||||
property MasterFields;
|
||||
property MasterSource;
|
||||
property ObjectView;
|
||||
property PacketRecords;
|
||||
property Params;
|
||||
property ReadOnly;
|
||||
property StoreDefs;
|
||||
property BeforeOpen;
|
||||
property AfterOpen;
|
||||
property BeforeClose;
|
||||
property AfterClose;
|
||||
property BeforeInsert;
|
||||
property AfterInsert;
|
||||
property BeforeEdit;
|
||||
property AfterEdit;
|
||||
property BeforePost;
|
||||
property AfterPost;
|
||||
property BeforeCancel;
|
||||
property AfterCancel;
|
||||
property BeforeDelete;
|
||||
property AfterDelete;
|
||||
property BeforeScroll;
|
||||
property AfterScroll;
|
||||
property BeforeRefresh;
|
||||
property AfterRefresh;
|
||||
property OnCalcFields;
|
||||
property OnDeleteError;
|
||||
property OnEditError;
|
||||
property OnFilterRecord;
|
||||
property OnNewRecord;
|
||||
property OnPostError;
|
||||
property OnReconcileError;
|
||||
property BeforeApplyUpdates;
|
||||
property AfterApplyUpdates;
|
||||
property BeforeGetRecords;
|
||||
property AfterGetRecords;
|
||||
property BeforeRowRequest;
|
||||
property AfterRowRequest;
|
||||
property BeforeExecute;
|
||||
property AfterExecute;
|
||||
property BeforeGetParams;
|
||||
property AfterGetParams;
|
||||
/// the associated SynRestVCL TDataSet, used to retrieve and update data
|
||||
property DataSet: TSynRestSQLDataSet read fDataSet;
|
||||
end;
|
||||
|
||||
{$endif FPC}
|
||||
|
||||
/// Convert JSON array to REST TClientDataset
|
||||
// - the dataset is created inside this function
|
||||
function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Dialogs;
|
||||
|
||||
type
|
||||
TSynRestSQLDatasetHack = class(TSynRestSQLDataset);
|
||||
TSynValidateRestHack = class(TSynValidateRest);
|
||||
|
||||
{$ifndef FPC}
|
||||
|
||||
function JSONToSynRestDataset(const aJSON: RawUTF8; const aSQLModel: TSQLModel): TSynRestDataset;
|
||||
var
|
||||
lSQLTableJSON: TSQLTableJSON;
|
||||
lData: TRawByteStringStream;
|
||||
begin
|
||||
Result := Nil;
|
||||
if (aJSON = '') then
|
||||
Exit;
|
||||
lSQLTableJSON := TSQLTableJSON.Create('', aJSON);
|
||||
lData := TRawByteStringStream.Create('');
|
||||
try
|
||||
JSONToBinary(lSQLTableJSON, lData);
|
||||
Result := TSynRestDataset.Create(Nil);
|
||||
Result.Dataset.SQLModel := aSQLModel;
|
||||
Result.DataSet.From(lData.DataString);
|
||||
finally
|
||||
FreeAndNil(lData);
|
||||
FreeAndNil(lSQLTableJSON);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TSynRestDataSet }
|
||||
|
||||
constructor TSynRestDataSet.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
fProvider := TDataSetProvider.Create(Self);
|
||||
fProvider.Name := 'InternalProvider'; { Do not localize }
|
||||
fProvider.SetSubComponent(True);
|
||||
fProvider.Options := fProvider.Options+[poAllowCommandText];
|
||||
fProvider.OnUpdateError := DoOnUpdateError;
|
||||
SetProvider(fProvider);
|
||||
fDataSet := TSynRestSQLDataSet.Create(Self);
|
||||
fDataSet.Name := 'InternalDataSet'; { Do not localize }
|
||||
fDataSet.SetSubComponent(True);
|
||||
fProvider.DataSet := fDataSet;
|
||||
end;
|
||||
|
||||
destructor TSynRestDataSet.Destroy;
|
||||
begin
|
||||
fProvider.DataSet := nil;
|
||||
FreeAndNil(fDataSet);
|
||||
FreeAndNil(fProvider);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.DoOnFieldValidate(Sender: TField);
|
||||
var
|
||||
lRec: TSQLRecord;
|
||||
F: Integer; // fields
|
||||
V: Integer; // validations
|
||||
Validate: TSynValidate;
|
||||
Value: RawUTF8;
|
||||
lErrMsg: string;
|
||||
lFields: TSQLPropInfoList;
|
||||
lwasTSynValidateRest: boolean;
|
||||
ValidateRest: TSynValidateRest absolute Validate;
|
||||
begin
|
||||
lRec := TSynRestSQLDatasetHack(fDataset).GetSQLRecordClass.Create;
|
||||
try
|
||||
lFields := lRec.RecordProps.Fields;
|
||||
F := lFields.IndexByName(Sender.FieldName);
|
||||
// the field has not validation
|
||||
if (Length(lRec.RecordProps.Filters[F]) = 0) then
|
||||
Exit;
|
||||
|
||||
if not (lFields.List[F].SQLFieldType in COPIABLE_FIELDS) then
|
||||
Exit;
|
||||
|
||||
lRec.SetFieldValue(Sender.FieldName, PUTF8Char(VariantToUTF8(Sender.Value)));
|
||||
for V := 0 to Length(lRec.RecordProps.Filters[F])-1 do begin
|
||||
Validate := TSynValidate(lRec.RecordProps.Filters[F,V]);
|
||||
if Validate.InheritsFrom(TSynValidate) then begin
|
||||
Value := Sender.Value;
|
||||
lwasTSynValidateRest := Validate.InheritsFrom(TSynValidateRest);
|
||||
if lwasTSynValidateRest then begin // set additional parameters
|
||||
TSynValidateRestHack(ValidateRest).fProcessRec := lRec;
|
||||
TSynValidateRestHack(ValidateRest).fProcessRest := Nil; // no Rest for the moment
|
||||
end;
|
||||
try
|
||||
if not Validate.Process(F,Value,lErrMsg) then begin
|
||||
if lErrMsg='' then
|
||||
// no custom message -> show a default message
|
||||
lErrMsg := format(sValidationFailed,[GetCaptionFromClass(Validate.ClassType)])
|
||||
else
|
||||
raise ESQLRestException.CreateUTF8('Error % on field "%"', [lErrMsg, Sender.DisplayName]);
|
||||
end;
|
||||
finally
|
||||
if lwasTSynValidateRest then begin // reset additional parameters
|
||||
TSynValidateRestHack(ValidateRest).fProcessRec := nil;
|
||||
TSynValidateRestHack(ValidateRest).fProcessRest := nil;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
lRec.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.DoOnUpdateError(Sender: TObject; DataSet: TCustomClientDataSet; E: EUpdateError;
|
||||
UpdateKind: TUpdateKind; var Response: TResolverResponse);
|
||||
begin
|
||||
Response := rrAbort;
|
||||
MessageDlg(E.OriginalException.Message, mtError, [mbOK], 0);
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.From(Statement: RawUTF8; MaxRowCount: cardinal);
|
||||
begin
|
||||
fDataSet.From(Statement);
|
||||
fDataSet.CommandText := ''; // ensure no SQL execution
|
||||
Open;
|
||||
fDataSet.CommandText := UTF8ToString(Statement); // assign it AFTER Open
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.FetchParams;
|
||||
begin
|
||||
if not HasAppServer and Assigned(FProvider) then
|
||||
SetProvider(FProvider);
|
||||
inherited FetchParams;
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.OpenCursor(InfoQuery: Boolean);
|
||||
begin
|
||||
if Assigned(fProvider) then
|
||||
SetProvider(fProvider);
|
||||
if fProvider.DataSet=self then
|
||||
raise ESQLDBException.Create(SCircularProvider);
|
||||
inherited OpenCursor(InfoQuery);
|
||||
SetFieldValidateFromSQLRecordSynValidate;
|
||||
end;
|
||||
|
||||
{$ifdef ISDELPHI2007ANDUP}
|
||||
function TSynRestDataSet.PSGetCommandText: string;
|
||||
{$ifdef ISDELPHIXE3}
|
||||
var IP: IProviderSupportNG;
|
||||
begin
|
||||
if Supports(fDataSet, IProviderSupportNG, IP) then
|
||||
{$else}
|
||||
var IP: IProviderSupport;
|
||||
begin
|
||||
if Supports(fDataSet, IProviderSupport, IP) then
|
||||
{$endif}
|
||||
result := IP.PSGetCommandText else
|
||||
result := CommandText;
|
||||
end;
|
||||
{$endif ISDELPHI2007ANDUP}
|
||||
|
||||
{$IFNDEF NEXTGEN}
|
||||
{$ifdef ISDELPHIXE}
|
||||
procedure TSynRestDataSet.SetCommandText(Value: WideString);
|
||||
{$else ISDELPHIXE}
|
||||
procedure TSynRestDataSet.SetCommandText(Value: String);
|
||||
{$endif ISDELPHIXE}
|
||||
{$ELSE}
|
||||
procedure TSynRestDataSet.SetCommandText(Value: String);
|
||||
{$ENDIF !NEXTGEN}
|
||||
begin
|
||||
TSynRestSQLDatasetHack(fDataset).SetCommandText(Value);
|
||||
inherited SetCommandText(fDataset.CommandText);
|
||||
// with this TSynRestSQLDataset can bind param values
|
||||
TSynRestSQLDatasetHack(fDataset).fParams := Params;
|
||||
if (Name = '') then
|
||||
Name := 'rds' + StringReplaceChars(TSynRestSQLDatasetHack(fDataset).fTableName, '.', '_');
|
||||
end;
|
||||
|
||||
procedure TSynRestDataSet.SetFieldValidateFromSQLRecordSynValidate;
|
||||
var
|
||||
F: Integer; // dataset fields
|
||||
V: Integer; // validation fields
|
||||
lProps: TSQLRecordProperties;
|
||||
begin
|
||||
// if not TSQLRecord associated, nothing to do
|
||||
if (TSynRestSQLDatasetHack(fDataset).GetTableName = '') then
|
||||
Exit;
|
||||
lProps := TSynRestSQLDatasetHack(fDataset).GetSQLRecordClass.RecordProps;
|
||||
// if there isn't filters, bye
|
||||
if (Length(lProps.Filters) = 0) then
|
||||
Exit;
|
||||
for F := 0 to Fields.Count-1 do
|
||||
begin
|
||||
V := lProps.Fields.IndexByName(Fields[F].FieldName);
|
||||
if (V > -1) then
|
||||
begin
|
||||
if (Length(lProps.Filters[V]) > 0) then
|
||||
Fields[F].OnValidate := DoOnFieldValidate;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif FPC}
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@@ -0,0 +1,845 @@
|
||||
/// fill a VCL TClientDataset from SynVirtualDataset data access
|
||||
// - this unit is a part of the freeware Synopse framework,
|
||||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||||
unit SynRestVCL;
|
||||
|
||||
{
|
||||
This file is part of Synopse framework.
|
||||
|
||||
Synopse framework. Copyright (C) 2020 Arnaud Bouchez
|
||||
Synopse Informatique - https://synopse.info
|
||||
|
||||
*** BEGIN LICENSE BLOCK *****
|
||||
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
||||
|
||||
The contents of this file are subject to the Mozilla Public License Version
|
||||
1.1 (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.mozilla.org/MPL
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
||||
for the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is Synopse mORMot framework.
|
||||
|
||||
The Initial Developer of the Original Code is Arnaud Bouchez.
|
||||
|
||||
Portions created by the Initial Developer are Copyright (C) 2020
|
||||
the Initial Developer. All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
- Esteban Martin (EMartin)
|
||||
- houdw2006
|
||||
|
||||
Alternatively, the contents of this file may be used under the terms of
|
||||
either the GNU General Public License Version 2 or later (the "GPL"), or
|
||||
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
||||
in which case the provisions of the GPL or the LGPL are applicable instead
|
||||
of those above. If you wish to allow use of your version of this file only
|
||||
under the terms of either the GPL or the LGPL, and not to allow others to
|
||||
use your version of this file under the terms of the MPL, indicate your
|
||||
decision by deleting the provisions above and replace them with the notice
|
||||
and other provisions required by the GPL or the LGPL. If you do not delete
|
||||
the provisions above, a recipient may use your version of this file under
|
||||
the terms of any one of the MPL, the GPL or the LGPL.
|
||||
|
||||
***** END LICENSE BLOCK *****
|
||||
|
||||
Version 1.18
|
||||
- first public release, corresponding to Synopse mORMot Framework 1.18,
|
||||
which is an extraction from former SynDBVCL.pas unit.
|
||||
- Added that blob field updates they are made with AddJSONEscapeString.
|
||||
- bug fix when updating accentuated string fields.
|
||||
- bug fix with datetime fields
|
||||
- bug fix with length string fields
|
||||
- fixed Delphi XE3 compilation issue with PSExecuteStatement declaration (by houdw2006)
|
||||
- added sftSessionUserID to SQLFIELDTYPETODBFIELDTYPE and SQLFieldTypeToVCLDB
|
||||
|
||||
}
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
|
||||
Classes,
|
||||
{$ifndef DELPHI5OROLDER}
|
||||
Variants,
|
||||
{$ifndef FPC}
|
||||
MidasLib,
|
||||
{$endif}
|
||||
{$endif}
|
||||
mORMot,
|
||||
mORMotHttpClient,
|
||||
SynCrtSock, // remover una vez implementado TSQLHttpClient
|
||||
SynCommons,
|
||||
SynTable,
|
||||
SynDB,
|
||||
SynDBVCL,
|
||||
DB,
|
||||
{$ifdef FPC}
|
||||
BufDataset
|
||||
{$else}
|
||||
Contnrs,
|
||||
DBClient,
|
||||
Provider,
|
||||
SqlConst
|
||||
{$endif};
|
||||
|
||||
|
||||
type
|
||||
/// generic Exception type
|
||||
ESQLRestException = class(ESynException);
|
||||
|
||||
/// URI signature event
|
||||
TOnGetURISignature = procedure(Sender: TObject; var aURI: string) of object;
|
||||
|
||||
/// a TDataSet which allows to apply updates on a Restful connection
|
||||
// - typical usage may be for instance:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! ds.CommandText := 'http://host:port/root/TableName?select=*&where=condition&sort=fieldname';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
// or using from a service returning a dataset:
|
||||
// ! ds := TSynRestDataSet.Create(MainForm);
|
||||
// ! ds.Dataset.SQLModel := CreateModel; // The SQLModel is required
|
||||
// ! the TSQLRecord associated should be defined with the same structure of the returned array from the service
|
||||
// ! ds.CommandText := 'http://host:port/root/ServiceName.Operation?paramname=:paramvalue';
|
||||
// ! ds.Params.ParamByName('paramname').Value := 'xyz';
|
||||
// ! ds1.Dataset := ds; // assigning the rest dataset to TDatasource that can be associated a TDBGrid for example.
|
||||
// ! ds.Open;
|
||||
// ! // ... use ds as usual, including modifications
|
||||
// ! ds.ApplyUpdates(0);
|
||||
TSynRestSQLDataSet = class(TSynBinaryDataSet)
|
||||
protected
|
||||
fBaseURL: RawUTF8;
|
||||
fCommandText: string;
|
||||
fDataSet: TSynBinaryDataSet;
|
||||
fOnGetURISignature: TOnGetURISignature;
|
||||
fParams: TParams;
|
||||
fProvider: TDataSetProvider;
|
||||
fRoot: RawUTF8;
|
||||
fSQLModel: TSQLModel;
|
||||
fTableName: RawUTF8;
|
||||
fURI: TURI;
|
||||
function BindParams(const aStatement: RawUTF8): RawUTF8;
|
||||
function BuildURI(const aURI: SockString): SockString;
|
||||
function GetSQLRecordClass: TSQLRecordClass;
|
||||
function GetTableName: string;
|
||||
// get the data
|
||||
procedure InternalInitFieldDefs; override;
|
||||
function InternalFrom(const aStatement: RawUTF8): RawByteString;
|
||||
procedure InternalOpen; override;
|
||||
procedure InternalClose; override;
|
||||
function IsTableFromService: Boolean;
|
||||
procedure ParseCommandText;
|
||||
// IProvider implementation
|
||||
procedure PSSetCommandText(const ACommandText: string); override;
|
||||
function PSGetTableName: string; override;
|
||||
function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
|
||||
function PSIsSQLBased: Boolean; override;
|
||||
function PSIsSQLSupported: Boolean; override;
|
||||
{$ifdef ISDELPHIXE3}
|
||||
function PSExecuteStatement(const ASQL: string; AParams: TParams): Integer; overload; override;
|
||||
function PSExecuteStatement(const ASQL: string; AParams: TParams; var ResultSet: TDataSet): Integer; overload; override;
|
||||
{$else}
|
||||
function PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer=nil): Integer; overload; override;
|
||||
{$endif}
|
||||
procedure SetCommandText(const Value: string);
|
||||
public
|
||||
/// the associated Model, if not defined an exception is raised.
|
||||
property SQLModel: TSQLModel read fSQLModel write fSQLModel;
|
||||
published
|
||||
/// the GET RESTful URI
|
||||
// - Statement will have the form http://host:port/root/tablename or
|
||||
// http://host:port/root/servicename.operationname?paramname=:paramalias
|
||||
// examples:
|
||||
// http://host:port/root/tablename?select=XXX or
|
||||
// http://host:port/root/tablename?select=XXX&where=field1=XXX or field2=XXX
|
||||
// http://host:port/root/service.operation?param=:param
|
||||
// if :param is used then before open assign the value: ds.Params.ParamByName('param').value := XXX
|
||||
property CommandText: string read fCommandText write fCommandText;
|
||||
/// the associated SynDB TDataSet, used to retrieve and update data
|
||||
property DataSet: TSynBinaryDataSet read fDataSet;
|
||||
/// event to get URI signature
|
||||
property OnGetURISignature: TOnGetURISignature write fOnGetURISignature;
|
||||
end;
|
||||
|
||||
// JSON columns to binary from a TSQLTableJSON, is not ideal because this code is a almost repeated code.
|
||||
procedure JSONColumnsToBinary(const aTable: TSQLTableJSON; W: TFileBufferWriter;
|
||||
Null: pointer; const ColTypes: TSQLDBFieldTypeDynArray);
|
||||
// convert to binary from a TSQLTableJSON, is not ideal because this code is a almost repeated code.
|
||||
function JSONToBinary(const aTable: TSQLTableJSON; Dest: TStream; MaxRowCount: cardinal=0; DataRowPosition: PCardinalDynArray=nil;
|
||||
const DefaultDataType: TSQLDBFieldType = SynTable.ftUTF8; const DefaultFieldSize: Integer = 255): cardinal;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
DBCommon,
|
||||
SynVirtualDataset;
|
||||
|
||||
const
|
||||
FETCHALLTOBINARY_MAGIC = 1;
|
||||
|
||||
SQLFIELDTYPETODBFIELDTYPE: array[TSQLFieldType] of TSQLDBFieldType =
|
||||
(SynTable.ftUnknown, // sftUnknown
|
||||
SynTable.ftUTF8, // sftAnsiText
|
||||
SynTable.ftUTF8, // sftUTF8Text
|
||||
SynTable.ftInt64, // sftEnumerate
|
||||
SynTable.ftInt64, // sftSet
|
||||
SynTable.ftInt64, // sftInteger
|
||||
SynTable.ftInt64, // sftID = TSQLRecord(aID)
|
||||
SynTable.ftInt64, // sftRecord = TRecordReference
|
||||
SynTable.ftInt64, // sftBoolean
|
||||
SynTable.ftDouble, // sftFloat
|
||||
SynTable.ftDate, // sftDateTime
|
||||
SynTable.ftInt64, // sftTimeLog
|
||||
SynTable.ftCurrency, // sftCurrency
|
||||
SynTable.ftUTF8, // sftObject
|
||||
{$ifndef NOVARIANTS}
|
||||
SynTable.ftUTF8, // sftVariant
|
||||
SynTable.ftUTF8, // sftNullable
|
||||
{$endif}
|
||||
SynTable.ftBlob, // sftBlob
|
||||
SynTable.ftBlob, // sftBlobDynArray
|
||||
SynTable.ftBlob, // sftBlobCustom
|
||||
SynTable.ftUTF8, // sftUTF8Custom
|
||||
SynTable.ftUnknown, // sftMany
|
||||
SynTable.ftInt64, // sftModTime
|
||||
SynTable.ftInt64, // sftCreateTime
|
||||
SynTable.ftInt64, // sftTID
|
||||
SynTable.ftInt64, // sftRecordVersion = TRecordVersion
|
||||
SynTable.ftInt64, // sftSessionUserID
|
||||
SynTable.ftDate, // sftDateTimeMS
|
||||
SynTable.ftInt64, // sftUnixTime
|
||||
SynTable.ftInt64); // sftUnixMSTime
|
||||
|
||||
SQLFieldTypeToVCLDB: array[TSQLFieldType] of TFieldType =
|
||||
(DB.ftUnknown, // sftUnknown
|
||||
DB.ftString, // sftAnsiText
|
||||
DB.ftString, // sftUTF8Text
|
||||
DB.ftLargeInt, // sftEnumerate
|
||||
DB.ftLargeInt, // sftSet
|
||||
DB.ftLargeInt, // sftInteger
|
||||
DB.ftLargeInt, // sftID = TSQLRecord(aID)
|
||||
DB.ftLargeInt, // sftRecord = TRecordReference
|
||||
DB.ftLargeInt, // sftBoolean
|
||||
DB.ftFloat, // sftFloat
|
||||
DB.ftDateTime, // sftDateTime
|
||||
DB.ftLargeInt, // sftTimeLog
|
||||
DB.ftCurrency, // sftCurrency
|
||||
DB.ftString, // sftObject
|
||||
{$ifndef NOVARIANTS}
|
||||
DB.ftString, // sftVariant
|
||||
DB.ftString, // sftNullable
|
||||
{$endif}
|
||||
DB.ftBlob, // sftBlob
|
||||
DB.ftBlob, // sftBlobDynArray
|
||||
DB.ftBlob, // sftBlobCustom
|
||||
DB.ftString, // sftUTF8Custom
|
||||
DB.ftUnknown, // sftMany
|
||||
DB.ftLargeInt, // sftModTime
|
||||
DB.ftLargeInt, // sftCreateTime
|
||||
DB.ftLargeInt, // sftTID
|
||||
DB.ftLargeInt, // sftRecordVersion = TRecordVersion
|
||||
DB.ftLargeInt, // sftSessionUserID
|
||||
DB.ftDateTime, // sftDateTime
|
||||
DB.ftLargeInt, // sftUnixTime
|
||||
DB.ftLargeInt); // sftUnixMSTime
|
||||
|
||||
VCLDBFieldTypeSQLDB: array[0..23] of TSQLFieldType =
|
||||
(sftUnknown, // ftUnknown
|
||||
sftAnsiText, // ftString
|
||||
sftUTF8Text, // ftString
|
||||
sftEnumerate, // ftInteger
|
||||
sftSet, // ftInteger
|
||||
sftInteger, // ftInteger
|
||||
sftID, // ftLargeInt = TSQLRecord(aID)
|
||||
sftRecord, // ftLargeInt
|
||||
sftBoolean, // ftBoolean
|
||||
sftFloat, // ftFloat
|
||||
sftDateTime, // ftDate
|
||||
sftTimeLog, // ftLargeInt
|
||||
sftCurrency, // ftCurrency
|
||||
sftObject, // ftString
|
||||
{$ifndef NOVARIANTS}
|
||||
sftVariant, // ftString
|
||||
{$endif}
|
||||
sftBlob, // ftBlob
|
||||
sftBlob, // ftBlob
|
||||
sftBlob, // ftBlob
|
||||
sftUTF8Custom, // ftString
|
||||
sftMany, // ftUnknown
|
||||
sftModTime, // ftLargeInt
|
||||
sftCreateTime, // ftLargeInt
|
||||
sftID, // ftLargeInt
|
||||
sftRecordVersion); // ftLargeInt = TRecordVersion
|
||||
|
||||
{$ifndef FPC}
|
||||
|
||||
|
||||
procedure JSONColumnsToBinary(const aTable: TSQLTableJSON; W: TFileBufferWriter;
|
||||
Null: pointer; const ColTypes: TSQLDBFieldTypeDynArray);
|
||||
var F: integer;
|
||||
VDouble: double;
|
||||
VCurrency: currency absolute VDouble;
|
||||
VDateTime: TDateTime absolute VDouble;
|
||||
colType: TSQLDBFieldType;
|
||||
begin
|
||||
for F := 0 to length(ColTypes)-1 do
|
||||
if not GetBitPtr(Null,F) then begin
|
||||
colType := ColTypes[F];
|
||||
if colType<ftInt64 then begin // ftUnknown,ftNull
|
||||
colType := SQLFIELDTYPETODBFIELDTYPE[aTable.FieldType(F)]; // per-row column type (SQLite3 only)
|
||||
W.Write1(ord(colType));
|
||||
end;
|
||||
case colType of
|
||||
ftInt64:
|
||||
begin
|
||||
W.WriteVarInt64(aTable.FieldAsInteger(F));
|
||||
end;
|
||||
ftDouble: begin
|
||||
VDouble := aTable.FieldAsFloat(F);
|
||||
W.Write(@VDouble,sizeof(VDouble));
|
||||
end;
|
||||
SynTable.ftCurrency: begin
|
||||
VCurrency := aTable.Field(F);
|
||||
W.Write(@VCurrency,sizeof(VCurrency));
|
||||
end;
|
||||
SynTable.ftDate: begin
|
||||
VDateTime := aTable.Field(F);
|
||||
W.Write(@VDateTime,sizeof(VDateTime));
|
||||
end;
|
||||
SynTable.ftUTF8:
|
||||
begin
|
||||
W.Write(aTable.FieldBuffer(F));
|
||||
end;
|
||||
SynTable.ftBlob:
|
||||
begin
|
||||
W.Write(aTable.FieldBuffer(F));
|
||||
end;
|
||||
else
|
||||
raise ESQLDBException.CreateUTF8('JSONColumnsToBinary: Invalid ColumnType(%)=%',
|
||||
[aTable.Get(0, F),ord(colType)]);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function JSONToBinary(const aTable: TSQLTableJSON; Dest: TStream; MaxRowCount: cardinal=0; DataRowPosition: PCardinalDynArray=nil;
|
||||
const DefaultDataType: TSQLDBFieldType = SynTable.ftUTF8; const DefaultFieldSize: Integer = 255): cardinal;
|
||||
var F, FMax, FieldSize, NullRowSize: integer;
|
||||
StartPos: cardinal;
|
||||
Null: TByteDynArray;
|
||||
W: TFileBufferWriter;
|
||||
ColTypes: TSQLDBFieldTypeDynArray;
|
||||
FieldType: TSQLDBFieldType;
|
||||
begin
|
||||
result := 0;
|
||||
W := TFileBufferWriter.Create(Dest);
|
||||
try
|
||||
W.WriteVarUInt32(FETCHALLTOBINARY_MAGIC);
|
||||
FMax := aTable.FieldCount;
|
||||
W.WriteVarUInt32(FMax);
|
||||
if FMax>0 then begin
|
||||
// write column description
|
||||
SetLength(ColTypes,FMax);
|
||||
dec(FMax);
|
||||
for F := 0 to FMax do begin
|
||||
W.Write(aTable.Get(0, F));
|
||||
FieldType := SQLFIELDTYPETODBFIELDTYPE[aTable.FieldType(F)];
|
||||
if (FieldType = SynTable.ftUnknown) and (DefaultDataType <> SynTable.ftUnknown) then
|
||||
FieldType := DefaultDataType;
|
||||
ColTypes[F] := FieldType;
|
||||
FieldSize := aTable.FieldLengthMax(F);
|
||||
if (FieldSize = 0) and (FieldType = DefaultDataType) and (DefaultFieldSize <> 0) then
|
||||
FieldSize := DefaultFieldSize;
|
||||
W.Write1(ord(ColTypes[F]));
|
||||
W.WriteVarUInt32(FieldSize);
|
||||
end;
|
||||
// initialize null handling
|
||||
SetLength(Null,(FMax shr 3)+1);
|
||||
NullRowSize := 0;
|
||||
// save all data rows
|
||||
StartPos := W.TotalWritten;
|
||||
if aTable.Step or (aTable.RowCount=1) then // Need step first or error is raised in Table.Field function.
|
||||
repeat
|
||||
// save row position in DataRowPosition[] (if any)
|
||||
if DataRowPosition<>nil then begin
|
||||
if Length(DataRowPosition^)<=integer(result) then
|
||||
SetLength(DataRowPosition^,result+result shr 3+256);
|
||||
DataRowPosition^[result] := W.TotalWritten-StartPos;
|
||||
end;
|
||||
// first write null columns flags
|
||||
if NullRowSize>0 then begin
|
||||
FillChar(Null[0],NullRowSize,0);
|
||||
NullRowSize := 0;
|
||||
end;
|
||||
for F := 0 to FMax do
|
||||
begin
|
||||
if VarIsNull(aTable.Field(F)) then begin
|
||||
SetBitPtr(pointer(Null),F);
|
||||
NullRowSize := (F shr 3)+1;
|
||||
end;
|
||||
end;
|
||||
W.WriteVarUInt32(NullRowSize);
|
||||
if NullRowSize>0 then
|
||||
W.Write(Null,NullRowSize);
|
||||
// then write data values
|
||||
JSONColumnsToBinary(aTable, W,Null,ColTypes);
|
||||
inc(result);
|
||||
if (MaxRowCount>0) and (result>=MaxRowCount) then
|
||||
break;
|
||||
until not aTable.Step;
|
||||
end;
|
||||
W.Write(@result,SizeOf(result)); // fixed size at the end for row count
|
||||
W.Flush;
|
||||
finally
|
||||
W.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TSynRestSQLDataSet }
|
||||
|
||||
function TSynRestSQLDataSet.BindParams(const aStatement: RawUTF8): RawUTF8;
|
||||
var
|
||||
I: Integer;
|
||||
lParamName: string;
|
||||
begin
|
||||
Result := aStatement;
|
||||
if (Pos(':', aStatement) = 0) and (fParams.Count = 0) then
|
||||
Exit;
|
||||
if ((Pos(':', aStatement) = 0) and (fParams.Count > 0)) or ((Pos(':', aStatement) > 0) and (fParams.Count = 0)) then
|
||||
raise ESQLRestException.CreateUTF8('Statement parameters (%) not match with Params (Count=%) property',
|
||||
[aStatement, fParams.Count]);
|
||||
for I := 0 to fParams.Count-1 do
|
||||
begin
|
||||
lParamName := ':' + fParams[I].Name;
|
||||
Result := StringReplace(Result, lParamName, fParams[I].AsString, [rfIgnoreCase]);
|
||||
end;
|
||||
// remove space before and after &
|
||||
Result := StringReplaceAll(Result, ' & ', '&');
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.BuildURI(const aURI: SockString): SockString;
|
||||
var
|
||||
lTmpURI: string;
|
||||
begin
|
||||
lTmpURI := aURI;
|
||||
if Assigned(fOnGetURISignature) then
|
||||
fOnGetURISignature(Self, lTmpURI);
|
||||
Result := FormatUTF8('%%' , [fBaseURL, lTmpURI]);
|
||||
if fURI.Https and (Result[5] <> 's') then
|
||||
System.Insert('s', Result, 5);
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.GetSQLRecordClass: TSQLRecordClass;
|
||||
begin
|
||||
Result := fSQLModel.Table[GetTableName];
|
||||
if not Assigned(Result) then
|
||||
raise ESQLRestException.CreateUTF8('Table % not registered in SQL Model', [GetTableName]);
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.GetTableName: string;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if not IsTableFromService then
|
||||
Result := PSGetTableName
|
||||
else
|
||||
begin
|
||||
Result := fTableName;
|
||||
for I := 1 to Length(Result) do
|
||||
if (Result[I] = '.') then
|
||||
begin
|
||||
Result[I] := '_'; // change only the firs found
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.InternalClose;
|
||||
begin
|
||||
inherited InternalClose;
|
||||
FreeAndNil(fDataAccess);
|
||||
fData := '';
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.InternalFrom(const aStatement: RawUTF8): RawByteString;
|
||||
|
||||
procedure UpdateFields(aSQLTableJSON: TSQLTableJSON);
|
||||
var
|
||||
I, J: Integer;
|
||||
lFields: TSQLPropInfoList;
|
||||
begin
|
||||
lFields := GetSQLRecordClass.RecordProps.Fields;
|
||||
for I := 0 to aSQLTableJSON.FieldCount-1 do
|
||||
begin
|
||||
J := lFields.IndexByName(aSQLTableJSON.Get(0, I));
|
||||
if (J > -1) then
|
||||
aSQLTableJSON.SetFieldType(I, lFields.Items[J].SQLFieldType, Nil, lFields.Items[J].FieldWidth);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
lData: TRawByteStringStream;
|
||||
lSQLTableJSON: TSQLTableJSON;
|
||||
lStatement: RawUTF8;
|
||||
lDocVar: TDocVariantData;
|
||||
lTmp: RawUTF8;
|
||||
lResp: TDocVariantData;
|
||||
lErrMsg: RawUTF8;
|
||||
lURI: RawUTF8;
|
||||
begin
|
||||
Result := '';
|
||||
lStatement := BindParams(aStatement);
|
||||
if (lStatement <> '') then
|
||||
lStatement := '?' + lStatement;
|
||||
lURI := BuildURI(fRoot + fTableName + lStatement);
|
||||
Result := TWinHTTP.Get(lURI);
|
||||
if (Result = '') then
|
||||
raise ESynException.CreateUTF8('Cannot get response (timeout?) from %', [lURI]);
|
||||
if (Result <> '') then
|
||||
begin
|
||||
lResp.InitJSON(Result);
|
||||
if (lResp.Kind = dvUndefined) then
|
||||
raise ESynException.CreateUTF8('Invalid JSON response' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
|
||||
[Result, lURI]);
|
||||
if (lResp.Kind = dvObject) then
|
||||
if (lResp.GetValueIndex('errorCode') > -1) then
|
||||
if (lResp.GetValueIndex('errorText') > -1) then
|
||||
begin
|
||||
lErrMsg := AnyAnsiToUTF8(lResp.Value['errorText']);
|
||||
raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%',
|
||||
[lResp.Value['errorText'], lURI]);
|
||||
end
|
||||
else if (lResp.GetValueIndex('error') > -1) then
|
||||
begin
|
||||
lErrMsg := AnyAnsiToUTF8(lResp.Value['error']);
|
||||
raise ESynException.CreateUTF8('Error' + sLineBreak + '%' + sLineBreak + 'from' + sLineBreak + '%', [lErrMsg, lURI]);
|
||||
end;
|
||||
|
||||
if IsTableFromService then // is the source dataset from a service ?
|
||||
begin
|
||||
lDocVar.InitJSON(Result);
|
||||
lTmp := lDocVar.Values[0];
|
||||
lDocVar.Clear;
|
||||
lDocVar.InitJSON(lTmp);
|
||||
if (lDocVar.Kind <> dvArray) then
|
||||
raise ESQLRestException.CreateUTF8('The service % not return an array: <%>', [fTableName, Result]);
|
||||
// if the array is empty, nothing to return
|
||||
Result := lDocVar.Values[0];
|
||||
if (Result = '') or (Result = '[]') or (Result = '{}') then
|
||||
raise ESQLRestException.CreateUTF8('Service % not return a valid array: <%>', [fTableName, Result]);
|
||||
end;
|
||||
lSQLTableJSON := TSQLTableJSON.CreateFromTables([GetSQLRecordClass], '', Result);
|
||||
// update info fields for avoid error conversion in JSONToBinary
|
||||
UpdateFields(lSQLTableJSON);
|
||||
lData := TRawByteStringStream.Create('');
|
||||
try
|
||||
JSONToBinary(lSQLTableJSON, lData);
|
||||
Result := lData.DataString
|
||||
finally
|
||||
FreeAndNil(lData);
|
||||
FreeAndNil(lSQLTableJSON);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.InternalInitFieldDefs;
|
||||
var F: integer;
|
||||
lFields: TSQLPropInfoList;
|
||||
lFieldDef: TFieldDef;
|
||||
lOldSize: Int64;
|
||||
begin
|
||||
inherited;
|
||||
if (GetTableName = '') then // JSON conversion to dataset ?
|
||||
Exit;
|
||||
// update field definitions from associated TSQLRecordClass of the table
|
||||
lFields := GetSQLRecordClass.RecordProps.Fields;
|
||||
for F := 0 to lFields.Count-1 do
|
||||
begin
|
||||
lFieldDef := TFieldDef(TDefCollection(FieldDefs).Find(lFields.Items[F].Name));
|
||||
if Assigned(lFieldDef) then
|
||||
begin
|
||||
if (lFieldDef.DataType <> SQLFieldTypeToVCLDB[lFields.Items[F].SQLFieldType]) then
|
||||
begin
|
||||
lOldSize := lFieldDef.Size; // DB.pas.TFieldDef.SetDataType change the size
|
||||
lFieldDef.DataType := SQLFieldTypeToVCLDB[lFields.Items[F].SQLFieldType];
|
||||
end;
|
||||
if (lFields.Items[F].FieldWidth > 0) and (lFieldDef.Size < lFields.Items[F].FieldWidth) then
|
||||
lFieldDef.Size := lFields.Items[F].FieldWidth
|
||||
else if (lOldSize > 0) and (lFieldDef.Size > 0) and (lOldSize <> lFieldDef.Size) then
|
||||
lFieldDef.Size := lOldSize;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.IsTableFromService: Boolean;
|
||||
begin
|
||||
Result := (Pos('.', fTableName) > 0);
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.InternalOpen;
|
||||
var
|
||||
lData: RawByteString;
|
||||
begin
|
||||
if (fCommandText='') and (not IsTableFromService) then begin
|
||||
if fData<>'' then // called e.g. after From() method
|
||||
inherited InternalOpen;
|
||||
exit;
|
||||
end;
|
||||
lData := InternalFrom(fCommandText);
|
||||
if (lData <> '') then
|
||||
begin
|
||||
From(lData);
|
||||
inherited InternalOpen;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.ParseCommandText;
|
||||
var
|
||||
lSQL: RawUTF8;
|
||||
begin
|
||||
// it is assumed http://host:port/root/tablename, the rest is optional: ?select=&where=&sort= etc.
|
||||
if not fURI.From(fCommandText) then
|
||||
raise ESynException.CreateUTF8('Invalid % command text. Must have the format protocol://host:port', [fCommandText]);
|
||||
if not fURI.Https then
|
||||
fBaseURL := FormatUTF8('http://%:%/', [fURI.Server, fURI.Port])
|
||||
else
|
||||
fBaseURL := FormatUTF8('https://%:%/', [fURI.Server, fURI.Port]);
|
||||
Split(fURI.Address, '/', fRoot, fTableName);
|
||||
if (fRoot = '') or (fTableName = '') then
|
||||
raise ESynException.CreateUTF8('Invalid % root. Must have the format protocol://host:port/root/tablename', [fCommandText]);
|
||||
fRoot := fRoot + '/';
|
||||
if (Pos('?', fTableName) > 0) then
|
||||
Split(fTableName, '?', fTableName, lSQL);
|
||||
if not Assigned(fSQLModel) then
|
||||
raise ESQLRestException.CreateUTF8('Error parsing command text. Empty Model.', []);
|
||||
fCommandText := lSQL
|
||||
end;
|
||||
|
||||
{$ifdef ISDELPHIXE3}
|
||||
function TSynRestSQLDataSet.PSExecuteStatement(const ASQL: string;
|
||||
AParams: TParams): Integer;
|
||||
var DS: TDataSet;
|
||||
begin
|
||||
DS := nil;
|
||||
result := PSExecuteStatement(ASQL,AParams,DS);
|
||||
DS.Free;
|
||||
end;
|
||||
function TSynRestSQLDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; var ResultSet: TDataSet): Integer;
|
||||
{$else}
|
||||
function TSynRestSQLDataSet.PSExecuteStatement(const ASQL: string; AParams: TParams; ResultSet: Pointer): Integer;
|
||||
{$endif}
|
||||
|
||||
function Compute(const aJSON: SockString; const aOccasion: TSQLOccasion): SockString;
|
||||
var
|
||||
lRec: TSQLRecord;
|
||||
lRecBak: TSQLRecord; // backup for get modifications
|
||||
lJSON: TDocVariantData;
|
||||
I: Integer;
|
||||
lCount: Integer;
|
||||
lOccasion: TSQLEvent;
|
||||
lVarValue: Variant;
|
||||
lVarValueBak: Variant;
|
||||
begin
|
||||
lRec := GetSQLRecordClass.Create;
|
||||
lRecBak := GetSQLRecordClass.Create;
|
||||
try
|
||||
lJSON.InitJSON(aJSON);
|
||||
lCount := lJSON.Count;
|
||||
// update record fields
|
||||
for I := 0 to lCount-1 do
|
||||
lRec.SetFieldVariant(lJSON.Names[I], lJSON.Values[I]);
|
||||
lOccasion := seUpdate;
|
||||
if (aOccasion = soInsert) then
|
||||
lOccasion := seAdd;
|
||||
lRec.ComputeFieldsBeforeWrite(Nil, lOccasion);
|
||||
// get modified fields
|
||||
for I := 0 to lRec.RecordProps.Fields.Count-1 do
|
||||
begin
|
||||
lRec.RecordProps.Fields.Items[I].GetVariant(lRec, lVarValue);
|
||||
lRecBak.RecordProps.Fields.Items[I].GetVariant(lRecBak, lVarValueBak);
|
||||
if (lVarValue <> lVarValueBak) then
|
||||
lJSON.AddOrUpdateValue(lRec.RecordProps.Fields.Items[I].Name, lVarValue);
|
||||
end;
|
||||
Result := lJSON.ToJSON;
|
||||
finally
|
||||
lRec.Free;
|
||||
lRecBak.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ExtractFields(const aSQL, aAfterStr, aBeforeStr: string): string;
|
||||
var
|
||||
lPosStart: Integer;
|
||||
lPosEnd: Integer;
|
||||
lSQL: string;
|
||||
begin
|
||||
lSQL := StringReplace(aSQL, sLineBreak, ' ', [rfReplaceAll]);
|
||||
lPosStart := Pos(aAfterStr, lSQL)+Length(aAfterStr);
|
||||
lPosEnd := Pos(aBeforeStr, lSQL);
|
||||
Result := Trim(Copy(lSQL, lPosStart, lPosEnd-lPosStart));
|
||||
end;
|
||||
|
||||
function SQLFieldsToJSON(const aSQLOccasion: TSQLOccasion; const aSQL, aAfterStr, aBeforeStr: string; aParams: TParams): SockString;
|
||||
var
|
||||
I: Integer;
|
||||
lLastPos: Integer;
|
||||
lFieldValues: TStrings;
|
||||
lBlob: TSQLRawBlob;
|
||||
begin
|
||||
lFieldValues := TStringList.Create;
|
||||
try
|
||||
ExtractStrings([','], [], PChar(ExtractFields(aSQL, aAfterStr, aBeforeStr)), lFieldValues);
|
||||
lLastPos := 0;
|
||||
with TTextWriter.CreateOwnedStream do
|
||||
begin
|
||||
Add('{');
|
||||
for I := 0 to lFieldValues.Count-1 do
|
||||
begin
|
||||
if (Pos('=', lFieldValues[I]) = 0) then
|
||||
lFieldValues[I] := lFieldValues[I] + '=';
|
||||
AddFieldName(Trim(lFieldValues.Names[I]));
|
||||
if (aParams[I].DataType <> ftBlob) then
|
||||
begin
|
||||
if (TVarData(aParams[I].Value).VType = varString) then
|
||||
AddVariant(StringToUTF8(aParams[I].Value))
|
||||
else
|
||||
AddVariant(aParams[I].Value);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Add('"');
|
||||
lBlob := BlobToTSQLRawBlob(PUTF8Char(aParams[I].AsBlob));
|
||||
AddJSONEscapeString(lBlob);
|
||||
Add('"');
|
||||
end;
|
||||
Add(',');
|
||||
lLastPos := I;
|
||||
end;
|
||||
CancelLastComma;
|
||||
Add('}');
|
||||
Result := Text;
|
||||
Free;
|
||||
end;
|
||||
lFieldValues.Clear;
|
||||
// the first field after the where clause is the ID
|
||||
if (aSQLOccasion <> soInsert) then
|
||||
aParams[lLastPos+1].Name := 'ID';
|
||||
finally
|
||||
lFieldValues.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetSQLOccasion(const aSQL: string): TSQLOccasion;
|
||||
begin
|
||||
if IdemPChar(PUTF8Char(UpperCase(aSQL)), 'DELETE') then
|
||||
Result := soDelete
|
||||
else if IdemPChar(PUTF8Char(UpperCase(aSQL)), 'INSERT') then
|
||||
Result := soInsert
|
||||
else
|
||||
Result := soUpdate;
|
||||
end;
|
||||
|
||||
var
|
||||
lJSON: SockString;
|
||||
lOccasion: TSQLOccasion;
|
||||
lResult: SockString;
|
||||
lURI: SockString;
|
||||
lID: string;
|
||||
begin // only execute writes in current implementation
|
||||
Result := -1;
|
||||
if IsTableFromService then
|
||||
DatabaseError('Cannot apply updates from a service');
|
||||
// build the RESTful URL
|
||||
lURI := FormatUTF8('%/%', [fSQLModel.Root, StringToUTF8(PSGetTableName)]);
|
||||
lOccasion := GetSQLOccasion(aSQL);
|
||||
case lOccasion of
|
||||
soDelete:
|
||||
begin
|
||||
lID := aParams[0].Value;
|
||||
lURI := lURI + '/' + lID;
|
||||
lResult := TWinHTTP.Delete(BuildURI(lURI), '');
|
||||
if (lResult = '') then
|
||||
Result := 1;
|
||||
end;
|
||||
soInsert:
|
||||
begin
|
||||
lJSON := SQLFieldsToJSON(soInsert, aSQL, '(', ') ', aParams);
|
||||
try
|
||||
lJSON := Compute(lJSON, soInsert);
|
||||
except
|
||||
Result := -1;
|
||||
lResult := Exception(ExceptObject).Message;
|
||||
end;
|
||||
lResult := TWinHTTP.Post(BuildURI(lURI), lJSON);
|
||||
if (lResult = '') then
|
||||
Result := 1;
|
||||
end;
|
||||
soUpdate:
|
||||
begin
|
||||
lJSON := SQLFieldsToJSON(soUpdate, aSQL, 'set ', 'where ', aParams);
|
||||
try
|
||||
lJSON := Compute(lJSON, soUpdate);
|
||||
except
|
||||
Result := -1;
|
||||
lResult := Exception(ExceptObject).Message;
|
||||
end;
|
||||
lID := aParams.ParamByName('ID').Value;
|
||||
lURI := lURI + '/' + lID;
|
||||
lResult := TWinHTTP.Put(BuildURI(lURI), lJSON);
|
||||
if (lResult = '') then
|
||||
Result := 1;
|
||||
end
|
||||
end;
|
||||
if (Result = -1) and (lResult <> '') then
|
||||
DatabaseError(lResult);
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.PSGetTableName: string;
|
||||
begin
|
||||
Result := fTableName;
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.PSIsSQLBased: Boolean;
|
||||
begin
|
||||
result := true;
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.PSIsSQLSupported: Boolean;
|
||||
begin
|
||||
result := true;
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.PSSetCommandText(const ACommandText: string);
|
||||
begin
|
||||
if (fCommandText <> ACommandText) then
|
||||
SetCommandText(ACommandText);
|
||||
end;
|
||||
|
||||
function TSynRestSQLDataSet.PSUpdateRecord(UpdateKind: TUpdateKind;
|
||||
Delta: TDataSet): Boolean;
|
||||
begin
|
||||
result := false;
|
||||
end;
|
||||
|
||||
procedure TSynRestSQLDataSet.SetCommandText(const Value: string);
|
||||
begin
|
||||
if (Value <> fCommandtext) then
|
||||
begin
|
||||
fCommandText := Value;
|
||||
ParseCommandText;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$endif FPC}
|
||||
|
||||
end.
|
||||
|
||||
|
||||
@@ -0,0 +1,48 @@
|
||||
object frmMain: TfrmMain
|
||||
Left = 198
|
||||
Top = 124
|
||||
Width = 418
|
||||
Height = 240
|
||||
Caption = 'SynRestDataset Demo'
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -13
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
OnShow = FormShow
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 16
|
||||
object Label1: TLabel
|
||||
Left = 40
|
||||
Top = 16
|
||||
Width = 297
|
||||
Height = 33
|
||||
AutoSize = False
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clTeal
|
||||
Font.Height = -16
|
||||
Font.Name = 'Tahoma'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 56
|
||||
Top = 72
|
||||
Width = 145
|
||||
Height = 16
|
||||
Caption = 'HTTP Server is running...'
|
||||
end
|
||||
object Button1: TButton
|
||||
Left = 88
|
||||
Top = 120
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Quit'
|
||||
TabOrder = 0
|
||||
OnClick = Button1Click
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,67 @@
|
||||
unit fMain;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$ifdef MSWINDOWS}
|
||||
Windows,
|
||||
Messages,
|
||||
{$endif}
|
||||
SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls,
|
||||
SynCommons, mORMot, mORMotSQLite3, SynSQLite3Static,
|
||||
mORMotHttpServer, SampleData;
|
||||
|
||||
type
|
||||
TfrmMain = class(TForm)
|
||||
Label1: TLabel;
|
||||
Button1: TButton;
|
||||
Label2: TLabel;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure FormShow(Sender: TObject);
|
||||
private
|
||||
public
|
||||
Model: TSQLModel;
|
||||
DB: TSQLRestServerDB;
|
||||
Server: TSQLHttpServer;
|
||||
end;
|
||||
|
||||
var
|
||||
frmMain: TfrmMain;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
mORMotDB;
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
procedure TfrmMain.Button1Click(Sender: TObject);
|
||||
begin
|
||||
Close;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormCreate(Sender: TObject);
|
||||
begin
|
||||
Model := CreateSampleModel;
|
||||
DB := TSQLRestServerDB.Create(Model, 'Project19Server.db3', False);
|
||||
DB.CreateMissingTables;
|
||||
Server := TSQLHttpServer.Create('8080',[DB],'+',HTTP_DEFAULT_MODE);
|
||||
Server.AccessControlAllowOrigin := '*'; // allow cross-site AJAX queries
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
Server.Free;
|
||||
DB.Free;
|
||||
Model.Free;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.FormShow(Sender: TObject);
|
||||
begin
|
||||
Label1.Caption := Caption;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user