Related
Is it possible to call a function that called a function in a DLL that is written in Delphi? The calling program that loads the DLL just has access to my DLL's exported functions and can not export it's own functions (it's Easylanguge programming language and does not have a command to export or the ability to pass pointers). I do not need to pass any parameters when I call the from the DLL, just execute the code again after the return address point.
So if a function in Easylanguage calls a function from the DLL, can the return address from the Easylanguage function be used in the DLL to later call the Easylanguage function at the point of the return address? Even a hack will do.
I want to get this concept code I wrote working correctly before I try to apply it to the actual DLL & Easylanguage platform. I sometimes get access violations.
Delphi demo that simulates the interaction of the DLL & Easylanguage:
type
Tra_func = function: Integer;
var
Form9: TForm9;
ra: pointer;
ra_func: Tra_func;
implementation
{$R *.dfm}
function dll_func: integer;
begin
ra := System.ReturnAddress;
Form9.ListBox1.Items.Add(Format('RA to "easylanguage_func": %p', [ra]));
Form9.ListBox1.Items.Add('END of "dll" function');
result := 1;
end;
function easylanguage_func: integer; // temp stand-in function for Easylanguage
begin
Form9.ListBox1.Items.Add('Call "dll" to get return address...');
dll_func();
Form9.ListBox1.Items.Add('END of "easylanguage_func" function');
result := 1;
end;
procedure TForm9.Button1Click(Sender: TObject);
begin
easylanguage_func; // * this call would be from Easylanguage to the DLL
ListBox1.Items.Add('Calling RA address of "easylanguage_func"');
ra_func := Tra_func(ra);
ra_func; // * this call would be located in the DLL
end;
end.
What an Easylanguage routine that calls a DLL function could look like:
external: "ra_test_dll.dll", INT, "GetRAFunction";
method void ReturnFunction() // * can not export this *
begin
Print("GetRAFunction");
GetRAFunction(); // calls function in DLL
// *** returns here, start execution here when call from the DLL later
Print("*RA - next line*");
end;
String passing as parameters and returns in both directions..
Easylanguage:
external: "ts_dll_str_test.dll", String, "StringTest", String; // Delphi DLL function def
method void StrFunction(String ss)
variables:
String ss2;
begin
ss2 = StringTest(ss+"abc");
Print(ss2); // Output = ABCD5FGHIJKLM
end;
Call: StrFunction("0123456789")
Delphi DLL:
var
ss: AnsiString;
myCharPtr: PAnsiChar;
function StringTest(StrIn: PAnsiChar): PAnsiChar; stdcall; // called by EL
begin
ss := 'ABCDEFGHIJKLM';
myCharPtr := #ss[1];
myCharPtr[4] := StrIn[5];
result := myCharPtr;
end;
exports StringTest;
Thanks.
I designed a demo with Delphi used in both the calling application and the DLL. You'll have to apply the same "trick" in your EasyLanguage programming.
The idea is that when the DLL need to call a function in the executable - function which is not exported in anyway - it simply returns with a special value transporting all the information required to call whatever EasyLanguage (here Delphi) function.
This means that at both the caller and the DLL, the function are loops. The EXE calls the DLL passing the initial argument, the DLL get it and return a special value describing the function call it needs. The EXE recognize that, call the required function in his code and then call again the same function in the DLL, this time passing the result of the function call. And the process loops for a second, thirds and so on. Finally the DLL is able to produce the final result and return it without the mark indicating a function call.
Everything is handled using AnsiString since EasyLaguage do not support pointers.
The code below has been simplified at maximum so that it is more readable. In a real application it is much better to validate many things to avoid unexpected behaviour.
Here is the code for executable:
unit CallingCallerDemoMain;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
ParamParsing;
type
TCallingCallerForm = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
public
function CallDll(Value: Integer): String;
function DemoSquare(Arg1: Integer): Integer;
function DemoSum(Arg1: Integer): Integer;
end;
// Declaration for function in DLL
// In this demo, the function takes one integer argument and return a string
// looking like "Value=4 Square=16 Sum=8". The value is the argument, the
// square and the sum are computed by THIS executable: the DLL somehow call
// this executable.
// The use of AnsiChar is required for this demo because it is normally not
// written in Delphi but in EasyLanguage which has only ANSI strings.
function DllFunc(
StrIn : PAnsiChar
) : PAnsiChar; stdcall; external 'CallingCallerDemoDll.dll';
var
CallingCallerForm: TCallingCallerForm;
implementation
{$R *.dfm}
function TCallingCallerForm.DemoSquare(Arg1 : Integer) : Integer;
begin
Result := Arg1 * Arg1;
Memo1.Lines.Add('DemoSquare called');
end;
function TCallingCallerForm.DemoSum(Arg1 : Integer) : Integer;
begin
Result := Arg1 + Arg1;
Memo1.Lines.Add('DemoSum called');
end;
function TCallingCallerForm.CallDll(Value : Integer) : String;
var
S : String;
DllFctPrm : AnsiString;
Params : String;
FctName : String;
Arg1 : Integer;
Status : Boolean;
State : String;
Value1 : Integer;
Value2 : Integer;
begin
DllFctPrm := '4';
while TRUE do begin
S := String(DllFunc(PAnsiChar(DllFctPrm)));
if not ((S <> '') and (S[1] = '[') and (S[Length(S)] = ']')) then begin
Result := S;
Exit;
end
else begin
Params := Trim(Copy(S, 2, Length(S) - 2));
FctName := ParamByNameAsString(Params, 'FctName', Status, '');
State := ParamByNameAsString(Params, 'State', Status, '');
Memo1.Lines.Add('Callback="' + Params + '"');
if SameText(FctName, 'DemoSquare') then begin
Arg1 := ParamByNameAsInteger(Params, 'Arg1', Status, 0);
Value1 := DemoSquare(Arg1);
DllFctPrm := AnsiString('[' +
'State=' + State +';' +
'Value=' + IntToStr(Value1) +
']');
continue;
end
else if SameText(FctName, 'DemoSum') then begin
Arg1 := ParamByNameAsInteger(Params, 'Arg1', Status, 0);
Value2 := DemoSum(Arg1);
DllFctPrm := AnsiString('[' +
'State=' + State +';' +
'Value=' + IntToStr(Value2) +
']');
continue;
end
else
raise Exception.Create('Unexpected function name');
end;
end;
end;
procedure TCallingCallerForm.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add('Result: ' + CallDll(4));
end;
end.
Here is the code for the DLL:
library CallingCallerDemoDll;
uses
System.SysUtils,
System.Classes,
ParamParsing in '..\DirectCompute\Mandel\Delphi\ParamParsing.pas';
{$R *.res}
var
GBuffer : AnsiString;
Value : Integer;
Value1 : Integer;
Value2 : Integer;
function DllFunc(StrIn : PAnsiChar) : PAnsiChar; stdcall;
var
S : String;
Params : String;
State : Integer;
Status : Boolean;
begin
S := String(StrIn);
if not ((S <> '') and (S[1] = '[') and (S[Length(S)] = ']')) then begin
// Normal call
State := 1;
Value := StrToInt(S);
Value1 := 0;
Value2 := 0;
end;
while TRUE do begin
if not ((S <> '') and (S[1] = '[') and (S[Length(S)] = ']')) then begin
// Call caller
{$WARN USE_BEFORE_DEF OFF}
case State of
1: GBuffer := '[FctName=' + '"DemoSquare";' +
'Arg1=' + AnsiString(IntToStr(Value)) + ';' +
'State=' + AnsiString(IntToStr(State)) + ']';
2: GBuffer := '[FctName=' + '"DemoSum";' +
'Arg1=' + AnsiString(IntToStr(Value)) + ';' +
'State=' + AnsiString(IntToStr(State)) + ']';
end;
Result := PAnsiChar(GBuffer);
Exit;
end
else begin
// Return from function
Params := Trim(Copy(S, 2, Length(S) - 2));
State := StrToInt(ParamByNameAsString(Params, 'State', Status, ''));
case State of
1: begin
Value1 := ParamByNameAsInteger(Params, 'Value', Status, 0);
State := 2;
S := '';
continue;
end;
2: begin
Value2 := ParamByNameAsInteger(Params, 'Value', Status, 0);
GBuffer := AnsiString(Format('Value=%d Square=%d Sum=%d',
[Value, Value1, Value2]));
Result := PAnsiChar(GBuffer);
Exit;
end;
end;
end;
end;
end;
exports
DllFunc;
begin
end.
And finally a support unit to parse values:
unit ParamParsing;
interface
uses
SysUtils;
function ParamByNameAsString(
const Params : String;
const ParamName : String;
var Status : Boolean;
const DefValue : String) : String;
function ParamByNameAsInteger(
const Params : String;
const ParamName : String;
var Status : Boolean;
const DefValue : Integer) : Integer;
implementation
// Parameters format = 'name1="value";name2="value2";....;nameN="valueN"
function ParamByNameAsString(
const Params : String;
const ParamName : String;
var Status : Boolean;
const DefValue : String) : String;
var
I, J : Integer;
Ch : Char;
begin
Status := FALSE;
I := 1;
while I <= Length(Params) do begin
J := I;
while (I <= Length(Params)) and (Params[I] <> '=') do
Inc(I);
if I > Length(Params) then begin
Result := DefValue;
Exit; // Not found
end;
if SameText(ParamName, Trim(Copy(Params, J, I - J))) then begin
// Found parameter name, extract value
Inc(I); // Skip '='
// Skip spaces
J := I;
while (J < Length(Params)) and (Params[J] = ' ') do
Inc(J);
if (J <= Length(Params)) and (Params[J] = '"') then begin
// Value is between double quotes
// Embedded double quotes and backslashes are prefixed
// by backslash
I := J;
Status := TRUE;
Result := '';
Inc(I); // Skip starting delimiter
while I <= Length(Params) do begin
Ch := Params[I];
if Ch = '\' then begin
Inc(I); // Skip escape character
if I > Length(Params) then
break;
Ch := Params[I];
end
else if Ch = '"' then
break;
Result := Result + Ch;
Inc(I);
end;
end
else begin
// Value is up to semicolon or end of string
J := I;
while (I <= Length(Params)) and (Params[I] <> ';') do
Inc(I);
Result := Trim(Copy(Params, J, I - J));
Status := TRUE;
end;
Exit;
end;
// Not good parameter name, skip to next
Inc(I); // Skip '='
if (I <= Length(Params)) and (Params[I] = '"') then begin
Inc(I); // Skip starting delimiter
while I <= Length(Params) do begin
Ch := Params[I];
if Ch = '\' then begin
Inc(I); // Skip escape character
if I > Length(Params) then
break;
end
else if Ch = '"' then
break;
Inc(I);
end;
Inc(I); // Skip ending delimiter
end;
// Param ends with ';'
while (I <= Length(Params)) and (Params[I] <> ';') do
Inc(I);
Inc(I); // Skip semicolon
end;
Result := DefValue;
end;
function ParamByNameAsInteger(
const Params : String;
const ParamName : String;
var Status : Boolean;
const DefValue : Integer) : Integer;
begin
Result := StrToInt(ParamByNameAsString(Params, ParamName, Status, IntToStr(DefValue)));
end;
end.
Everything tested OK with Delphi 10.4.2 (Should work with any other recent Delphi).
i have a problem developing this function, i have this text..
Testing Function
ok
US.Cool
rwgehtrhjyw54 US_Cool
fhknehq is ryhetjuy6u24
gflekhtrhissfhejyw54i
my function :
function TForm5.FindWordInString(sWordToFind, sTheString : String): Integer;
var
i : Integer; x:String;
begin
Result := 0;
for i:= 1 to Length(sTheString) do
begin
x := Copy(sTheString,i,Length(sWordToFind));
if X = sWordToFind then
begin
if X.Length > sWordToFind.Length then
begin
Result := 100;
break;
end else
begin
Result := i;
break;
end;
end;
end;
end;
now, i want X to be US.Cool, but here its always = US, because i want to check the length of sWordToFind and X.
After clarification, this question is about getting length of a word searched by its starting substring within a string. For example when having string like this:
fhknehq is ryhetjuy6u24
When you execute a desired function for the above string with the following substrings, you should get results like:
hknehq → 0 → substring is not at the beginning of a word
fhknehq → 7 → length of the word because substring is at the beginning of a word
yhetjuy6u24 → 0 → substring is not at the beginning of a word
ryhetjuy6u24 → 12 → length of the word because substring is at the beginning of a word
If that is so, I would do this:
function GetFoundWordLength(const Text, Word: string): Integer;
const
Separators: TSysCharSet = [' '];
var
RetPos: PChar;
begin
Result := 0;
{ get the pointer to the char where the Word was found in Text }
RetPos := StrPos(PChar(Text), PChar(Word));
{ if the Word was found in Text, and it was at the beginning of Text, or the preceding
char is a defined word separator, we're at the beginning of the word; so let's count
this word's length by iterating chars till the end of Text or until we reach defined
separator }
if Assigned(RetPos) and ((RetPos = PChar(Text)) or CharInSet((RetPos - 1)^, Separators)) then
while not CharInSet(RetPos^, [#0] + Separators) do
begin
Inc(Result);
Inc(RetPos);
end;
end;
I spend a few times on your idea, so i wrote below codes, but it is not a good way for develop a Start With search. with some research you can find builtin functions, that provide better performance. you can try StrUtils.SearchBuf Function it will provide a full function string search.
anyway this code are working with SPACE separator, I hope it will be useful for you:
function TForm5.FindWordInString(sWordToFind, sTheString : String): Integer;
var
i : Integer; x:String;
flag : Boolean;
begin
Result := 0;
i := 1;
flag := False;
while True do
begin
if i > Length(sTheString) then Break;
if not flag then
x := Copy(sTheString,i,Length(sWordToFind))
else
begin
if sTheString[i] = ' ' then Break;
x := x + sTheString[i];
end;
if (X = sWordToFind) then
begin
flag := True;
if (X.Length >= sWordToFind.Length) and
(sTheString[i + Length(sWordToFind)] = ' ') then
break
else
i := i + Length(sWordToFind) -1;
end;
i := i + 1;
end;
Result := Length(x);
end;
procedure TGateScanForm.ebContainerKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
Found: Boolean;
begin
if Key = VK_RETURN then
begin
ebContainer.ValidateEdit(True);
if not BookingContainer.Active then BookingContainer.Open;
Found:= BookingContainer.Locate('no_container', ebContainer.Text, []);
if Found then
begin
no_booking:= BookingContainer.FieldByName('no_booking').Value;
no_bc11:= BookingContainer.FieldByName('no_bc11').Value;
no_container:= BookingContainer.FieldByName('no_container').Value;
statCont:= BookingContainer.FieldByName('status_container').Value;
statBooking:= BookingContainerstatus.Value;
bProses.Enabled:= True;
Key := VK_TAB;
end
else
begin
bProses.Enabled:= False;
BookingContainer.Close;
ShowMessage('Nomor Container tidak ditemukan');
end;
end;
end;
The qusetion is how i can convert the below line to query.
Found:= BookingContainer.Locate('no_container', ebContainer.Text, []);
If I have understood correctly, you may use :
function Found(S : string) : boolean;
begin
try
**Unsafe code:**
MyQuery.SQL := Format('SELECT NO_CONTAINER FROM TABLE_BookingContainer
WHERE NO_CONTAINER = ''%s''',[S]);
**Safe code:**
MyQuery.SQL := 'SELECT NO_CONTAINER FROM TABLE_BookingContainer
WHERE NO_CONTAINER = :p);
MyQuery.Params.ParamByName('p').AsString = s;
MyQuery.Open;
result := MyQuery.FieldByName('NO_CONTAINER').Value <> null;
finnaly
MyQuery.Close;
end;
end;
to execute function may use :
....
if Found(ebContainer.Text) then
.......
I don't know what for Dataset you use but something like this can search on the database.
BookingContainer.Close;
BookingContainer.SQL.Text := 'SELECT * FROM Table WHERE no_container= :no_container';
BookingContainer.Parameters.ParamByName('no_container').Value := ebContainer.Text;
BookingContainer.Open;
I m parsing and go threw a JSON structure, in Delphi XE8, and it gives me an error because of the JSON Structure. if i use the REST Debugger i can see the data in the grid but if i try to get it manually i get an error.
here is the JSON :
{
"S":1,
"U":"2898",
"F":[],
"D":[
{
"PRJCT_ID":"7",
"PRJCT_NAME":"Hotel La Rosiere",
"PRJCT_ADRESS":"le plateau"
},
{
"PRJCT_ID":"8",
"PRJCT_NAME":"Hotel Delux",
"PRJCT_ADRESS":"Centre Maison"
},
{
"PRJCT_ID":"9",
"PRJCT_NAME":"villedieu",
"PRJCT_ADRESS":""
}
]
}
I can get the Pair list from level 1 properly : S, F, D
But how can i test if the data is an anonymous record of data :
i tried :
if JSO.Pairs[i].JsonString.Value = '' then
I get an Exception EListError Message... which is normal because no JSON Key associated for the value "{"PRJCT_ID":"7","PRJCT_NAME":"Hotel La Rosiere","PRJCT_ADRESS":"le plateau"}"
My code is
procedure TAArray2.ExtractValues(JSO : TJsonObject);
var
i : integer;
begin
try
i := 0;
while (i < JSO.Count) do
begin
if JSO.Pairs[i].JsonValue is TJSONArray then // array of values "Key":[{"Key":"Value","Key":"Value"},{"Key":"Value","Key":"Value"}]
begin
AddItem(JSO.Pairs[i].JsonString.Value, '', TJSonObject(JSO.Pairs[i].JsonValue)); // recursive call ExtractValues(TJSonObject(JSO.Pairs[i].JsonValue))
end
else if JSO.Pairs[i].JsonString.Value = '' then // ERROR HERE : anonymous key : {"Key":"Value","Key":"Value"},{"Key":"Value","Key":"Value"}
begin
AddItem(i, JSO.Pairs[i].JsonValue.Value);
end
else // standard creation : "Key":"Value"
begin
AddItem(JSO.Pairs[i].JsonString.Value, JSO.Pairs[i].JsonValue.Value);
end;
inc(i);
end;
finally
end;
end;
How can i do it ? Does anyone get an idea ?
Nota : i call anonymous JSON Record Set the portion of JSON that don't
is member of Array "D" like we could say : "D[1]":{ "PRJCT_ID":"7",
"PRJCT_NAME":"Hotel La Rosiere", "PRJCT_ADRESS":"le plateau"} i call it anonymouse because this record set doesn't have his own Reference Key.
Here is the full code : about building a dictionnary of TREE - data accessing as well as Key string value or index : (Note i will only "Parse" the node if needed (Get), if not it will stay stored like a string)
unit Unit3;
interface
uses
Classes, System.SysUtils, System.Types, REST.Types, System.JSON, Data.Bind.Components,
System.RegularExpressions, System.Variants,
Generics.Collections;
type
TAArray2 = class;
PTRec=^TRec;
TRec = class
public
Key : Variant;
isRequired : boolean;
Value : Variant;
OldValue : Variant;
JSON : string;
JSO : TJSonObject;
Items : TAArray2;
procedure Add(Key : Variant ; Value: TRec);
end;
TAArray2 = class(TDictionary<Variant, TRec>)
private
function Get(Index: variant): TRec;
procedure ExtractValues(JSO : TJsonObject);
public
procedure AddItem(Key: Variant; Value: Variant ; JSOnObject : TJSOnObject = nil);
procedure ExtractFromJSON(JSonString: string ; RootElement : string = '');
property Items[Cle : Variant]: TRec read Get; default;
end;
implementation
procedure TRec.Add(Key : Variant ; Value: TRec);
begin
if not(assigned(items)) then
self.Items := TAArray2.Create;
Items.Add( Key, Value);
end;
procedure TAArray2.AddItem(Key : Variant ; Value: Variant ; JSOnObject : TJSOnObject = nil);
var
LocalRec : TRec;
begin
LocalRec := Get(Key);
if assigned(LocalRec) then
begin
LocalRec.Key := Key;
LocalRec.Value := Value;
LocalRec.JSO := JSOnObject;
end
else
begin
LocalRec := TRec.Create;
LocalRec.Value := Value;
LocalRec.Key := Key;
LocalRec.JSO := JSOnObject;
inherited Add( Key, LocalRec);
end;
end;
function TAArray2.Get(Index: Variant): TRec;
var
LocalRec : TRec;
begin
if self.ContainsKey(Index) then
begin
LocalRec := inherited items[Index];
if (LocalRec.JSON <> '') or (LocalRec.JSO <> nil) then
begin
LocalRec.Items := TAArray2.Create;
// ExtractValues(JSO);
end;
Result := LocalRec;
end
else
begin
result := nil;
end;
end;
// *****************************************************************************
//
// *****************************************************************************
procedure TAArray2.ExtractFromJSON(JSonString: string ; RootElement : string = '');
var
JSO : TJsonObject;
JSP : TJSonPair;
begin
try
JSO := TJSOnObject.ParseJSONValue(JSonString) as TJSONObject;
try
if (RootElement <> '') then
begin
JSP := JSO.Get(RootElement);
if not(JSP.Null) then
begin
ExtractValues(TJSonObject(JSP.JsonValue));
end;
end
else if Not(JSO.Null) then
begin
ExtractValues(JSO);
end;
finally
JSO.Free();
end;
except
on E:Exception do showmessage('Data Structure Error');
end;
end;
I view the content with this code :
procedure TForm1.ShowAssocArray2(AAA : TAArray2 ; Level : integer);
var
i : Integer;
s : string;
MyRec : TRec;
begin
s := DupeString(' ',Level * 4);
for MyRec in AAA.Values Do
begin
memo2.Lines.Add(s + string(MyRec.Key) + ' = ' + string(MyRec.Value) + ' (' + string(MyRec.JSON) + ')'); // Error Here
AAA[MyRec.Key];
if assigned(MyRec.Items) then
begin
if MyRec.Items.Count > 0 then
ShowAssocArray2(MyRec.items, Level + 1); // recursive for childrens
end;
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
var
MyList: TAArray2;
MyRec, MyRec2 : TRec;
i: Integer;
begin
MyList := TAArray2.Create;
MyList.ExtractFromJSON(Memo1.Lines.Text);
ShowAssocArray2(MyList, 0);
end;
You are not accessing the array correctly. When you find a TJSONArray, you are type-casting it to TJSONObject, but an array is not an object. You would have gotten a runtime error had you used the as operator for the type-cast, but you did not.
You need to do something more like this instead:
procedure TAArray2.ExtractValues(JSO : TJSONObject);
var
i, j: integer;
pair: TJSONPair;
arr: TJSONArray;
value: TJSONvalue;
begin
for i := 0 to JSO.Count-1 do
begin
pair := JSO.Pairs[i];
value := pair.JsonValue;
if value is TJSONArray then
begin
arr := TJSONArray(value);
for j := 0 to arr.Count-1 do
begin
value := arr[j];
if value is TJSONObject then
begin
ExtractValues(TJSONObject(value));
end
else
begin
// value is not an object, do something else...
end;
end;
end
else
begin
AddItem(pair.JsonString.Value, value.Value);
end;
end;
end;
Update: the JSON document is already in a tree structure. If you are trying to display that tree to the user, such as in a TTreeView, then you can use something like this:
function TAArray2.AddJSONValueToTreeView(const Name: String; Value: TJSONValue; ParentNode: TTreeNode = nil): TTreeNode;
var
i: integer;
obj: TJSONObject;
pair: TJSONPair;
arr: TJSONArray;
begin
if ParentNode <> nil then
Result := TreeView1.Items.AddChild(ParentNode, Name);
else
Result := TreeView1.Items.Add(nil, Name);
if Value is TJSONObject then
begin
obj := TJSONObject(Value);
for i := 0 to obj.Count-1 do
begin
pair := obj.Pairs[i];
AddJSONValueToTreeView(pair.JsonString.Value, pair.JsonValue, Result);
end;
end
else if Value is TJSONArray then
begin
arr := TJSONArray(Value);
for i := 0 to arr.Count-1 do
begin
AddJSONValueToTreeView('['+IntToStr(i)+']', arr.Items[i], Result);
end;
end
else
begin
TreeView1.Items.AddChild(Result, Value.Value);
end;
end;
In Delphi XE2, I need to make a function that receives a JSONValue and returns an indented String, much like JSONLint. This JSONValue could be any type of JSON, could be an array, an object, even just a string, so I have to make sure to cover all types with this function. I have no idea where to start.
You'll have to do it recursively. Something like this:
const INDENT_SIZE = 2;
procedure PrettyPrintJSON(value: TJSONValue; output: TStrings; indent: integer = 0); forward;
procedure PrettyPrintPair(value: TJSONPair; output: TStrings; last: boolean; indent: integer);
const TEMPLATE = '%s : %s';
var
line: string;
newList: TStringList;
begin
newList := TStringList.Create;
try
PrettyPrintJSON(value.JsonValue, newList, indent);
line := format(TEMPLATE, [value.JsonString.ToString, Trim(newList.Text)]);
finally
newList.Free;
end;
line := StringOfChar(' ', indent * INDENT_SIZE) + line;
if not last then
line := line + ','
output.add(line);
end;
procedure PrettyPrintJSON(value: TJSONValue; output: TStrings; indent: integer);
var
i: integer;
begin
if value is TJSONObject then
begin
output.add(StringOfChar(' ', indent * INDENT_SIZE) + '{');
for i := 0 to TJSONObject(value).size - 1 do
PrettyPrintPair(TJSONObject(value).Get(i), output, i = TJSONObject(value).size - 1, indent + 1);
output.add(StringOfChar(' ', indent * INDENT_SIZE) + '}');
end
else if value is TJSONArray then
//left as an exercise to the reader
else output.add(StringOfChar(' ', indent * INDENT_SIZE) + value.ToString);
end;
This covers the basic principle. WARNING: I wrote this up off the top of my head. It may not be correct or even compile, but it's the general idea. Also, you'll have to come up with your own implementation of printing a JSON array. But this should get you started.
I have adopted the code from Mason, did the reader exercise, and put it in a separate unit:
unit uJSONTools;
interface
Uses
Classes, SysUtils, DBXJSON;
procedure PrettyPrintJSON(JSONValue: TJSONValue; OutputStrings: TStrings; indent: integer = 0);
// Formats JSONValue to an indented structure and adds it to OutputStrings
implementation
const INDENT_SIZE = 2;
procedure PrettyPrintPair(JSONValue: TJSONPair; OutputStrings: TStrings; last: boolean; indent: integer);
const TEMPLATE = '%s : %s';
var
line: string;
newList: TStringList;
begin
newList := TStringList.Create;
try
PrettyPrintJSON(JSONValue.JsonValue, newList, indent);
line := format(TEMPLATE, [JSONValue.JsonString.ToString, Trim(newList.Text)]);
finally
newList.Free;
end;
line := StringOfChar(' ', indent * INDENT_SIZE) + line;
if not last then
line := line + ',';
OutputStrings.add(line);
end;
procedure PrettyPrintArray(JSONValue: TJSONArray; OutputStrings: TStrings; last: boolean; indent: integer);
var i: integer;
begin
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + '[');
for i := 0 to JSONValue.size - 1 do
PrettyPrintJSON(JSONValue.Get(i), OutputStrings, indent + 1);
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + ']');
end;
procedure PrettyPrintJSON(JSONValue: TJSONValue; OutputStrings: TStrings; indent: integer = 0);
var
i: integer;
begin
if JSONValue is TJSONObject then
begin
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + '{');
for i := 0 to TJSONObject(JSONValue).size - 1 do
PrettyPrintPair(TJSONObject(JSONValue).Get(i), OutputStrings, i = TJSONObject(JSONValue).size - 1, indent + 1);
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + '}');
end
else if JSONValue is TJSONArray then
PrettyPrintArray(TJSONArray(JSONValue), OutputStrings, i = TJSONObject(JSONValue).size - 1, indent + 1)
else OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + JSONValue.ToString);
end;
end.
To augment the answer by Doggen and Wheeler, I replaced the PrettyPrintArray routine with the following replacement in order to make sure that array objects are separated by commas otherwise the prettyprint output is invalid json.
procedure PrettyPrintArray(JSONValue: TJSONArray; OutputStrings: TStrings; last: boolean; indent: integer);
var i: integer;
begin
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + '[');
for i := 0 to JSONValue.size - 1 do
begin
PrettyPrintJSON(JSONValue.Get(i), OutputStrings, indent + 1);
if i < JSONValue.size - 1 then
OutputStrings[OutputStrings.Count-1] := OutputStrings[OutputStrings.Count-1] + ',';
end;
OutputStrings.add(StringOfChar(' ', indent * INDENT_SIZE) + ']');
end;