Disappearing SubDetail TObjectList when JSonToObject - json

this is my first question. Sorry my english.
I have a classes like this:
TSFis_S = class(TPersistent)
private
_SFis_MID : Integer;
public
property SFis_MID : Integer read _SFis_MID write _SFis_MID;
end;
TSFis_D = class(TPersistent)
private
_SFis_MID : Integer;
_SFis_S : TObjectList<TSFis_S>;
public
property SFis_MID : Integer read _SFis_MID write _SFis_MID;
property SFis_S : TObjectList<TSFis_S> read _SFis_S write _SFis_S;
end;
TSFis_M = class(TPersistent)
private
_SFis_MID : Integer;
_SFis_D : TObjectList<TSFis_D>;
public
property SFis_MID : Integer read _SFis_MID write _SFis_MID;
property SFis_D : TObjectList<TSFis_D> read _SFis_D write _SFis_D;
function ToJSON:TJSONValue;
destructor Destroy;
end;
I trying convert TSFis_M Object to JSon and Revert to Object for my datasnap application. I use converts and reverters for my datatypes (TObjectList and TObjectList)
{ TSFis_M }
function JSonToSFis_M(json: TJSONValue): TSFis_M;
var
UnMarshaller: TJSONUnMarshal;
begin
if json is TJSONNull then
exit(nil);
UnMarshaller := TJSONUnMarshal.Create;
try
UnMarshaller.RegisterReverter(TSFis_M, '_FisTar',
procedure(Data: TObject; Field: string; Arg: string)
var
ctx: TRttiContext;
datetime :
TDateTime;
begin
datetime := EncodeDateTime(StrToInt(Copy(Arg, 7, 4)), StrToInt(Copy(Arg, 4, 2)), StrToInt(Copy(Arg, 1, 2)), StrToInt
(Copy(Arg, 12, 2)), StrToInt(Copy(Arg, 15, 2)), StrToInt(Copy(Arg, 18, 2)), 0);
ctx.GetType(Data.ClassType).GetField(Field).SetValue(Data, datetime);
end
);
UnMarshaller.RegisterReverter(TSFis_D, '_SFis_S',
procedure(Data: TObject; Field: String; Args: TListOfObjects)
var
obj: TObject;
SFisS: TObjectList<TSFis_S>;
SFis, SFisNew: TSFis_S;
begin
if TSFis_D(Data)._SFis_S=Nil
then TSFis_D(Data)._SFis_S := TObjectList<TSFis_S>.Create(True);
SFisS := TSFis_D(Data)._SFis_S;
SFisS.Clear;
for obj in Args do
begin
SFis := obj as TSFis_S;
SFisNew := TSFis_S.Create;
SFisS.Add(SFisNew);
SFisNew._SFis_MID := SFis._SFis_MID;
end;
end
);
UnMarshaller.RegisterReverter(TSFis_M, '_SFis_D',
procedure(Data: TObject; Field: String; Args: TListOfObjects)
var
obj: TObject;
SFisD: TObjectList<TSFis_D>;
SFis, SFisNew: TSFis_D;
i: integer;
begin
if TSFis_M(Data)._SFis_D=Nil then
TSFis_M(Data)._SFis_D := TObjectList<TSFis_D>.Create(True);
SFisD := TSFis_M(Data)._SFis_D;
SFisD.Clear;
for obj in Args do
begin
SFis := obj as TSFis_D;
SFisNew := TSFis_D.Create;
SFisD.Add(SFisNew);
SFisNew._SFis_MID := SFis._SFis_MID;
end;
end
);
exit(Unmarshaller.Unmarshal(json) as TSFis_M)
finally
UnMarshaller.Free;
end;
end;
function TSFis_M.ToJSON: TJSONValue;
var
Marshaller: TJSONMarshal;
begin
if Assigned(Self) then
begin
Marshaller := TJSONMarshal.Create(TJSONConverter.Create);
try
Marshaller.RegisterConverter(TSFis_M, '_SFis_D',
function(Data: TObject; Field: String): TListOfObjects
var
FisD: TObjectList<TSFis_D>;
i: integer;
begin
FisD := TSFis_M(Data)._SFis_D;
SetLength(Result, FisD.Count);
if FisD.Count > 0 then
for I := 0 to FisD.Count - 1 do
Result[I] := FisD[i];
end);
Marshaller.RegisterConverter(TSFis_M, '_FisTar',
function(Data: TObject; Field: string): string
var
ctx: TRttiContext; date : TDateTime;
begin
date := ctx.GetType(Data.ClassType).GetField(Field).GetValue(Data).AsType<TDateTime>;
Result := FormatDateTime('dd.mm.yyyy hh:nn:ss', date);
end);
Marshaller.RegisterConverter(TSFis_D, '_SFis_S',
function(Data: TObject; Field: String): TListOfObjects
var
FisD: TObjectList<TSFis_S>;
i: integer;
begin
FisD := TSFis_D(Data)._SFis_S;
SetLength(Result, FisD.Count);
if FisD.Count > 0 then
for I := 0 to FisD.Count - 1 do
Result[I] := FisD[i];
end);
exit(Marshaller.Marshal(Self))
finally
Marshaller.Free;
end;
end
else
exit(TJSONNull.Create);
end;
And finally
for example i put 1 Button and 2 Memo on the form. And i try My created Object convert to Json, Json.ToString to Memo1. And Convert that JSonValue to Object.
procedure TForm1.Button1Click(Sender: TObject);
var
MainFis : TSFis_M;
MainFis2 : TSFis_M;
DFis : TSFis_D;
SFis : TSFis_S;
begin
MainFis := TSFis_M.Create;
MainFis.SFis_D := TObjectList<TSFis_D>.Create(True);
DFis := TSFis_D.Create;
DFis._SFis_MID := 1;
MainFis.SFis_D.Add(DFis);
SFis := TSFis_S.Create;
SFis._SFis_MID := 1;
DFis.SFis_S := TObjectList<TSFis_S>.Create(True);
DFis.SFis_S.Add(SFis);
Memo1.Text := MainFis.ToJSON.ToString;
Edit1.Text := IntToStr(MainFis.SFis_D[0].SFis_S.Count);
MainFis2 := JSonToSFis_M(MainFis.ToJSON);
Edit2.Text := IntToStr(MainFis2.SFis_D[0].SFis_S.Count); // Access violation. Because MainFis2.SFis_D[0].SFis_S = Nil Now (That's the my problem. Why?)
Memo2.Text := MainFis2.ToJSon.ToString;
end;
But when i do this. TSFis_S is disappearing. In first step (ObjectToJSon) no problem.
{"type":"Unit1.TSFis_M","id":1,"fields":
{"_SFis_MID":0,"_SFis_D":
[ {"type":"Unit1‌​.TSFis_D","id":2,"fields":
{"_SFis_MID":1,"_SFis_S":
[ {"type":"Unit1.TSFis_S","id":‌​3,"fields":{"_SFis_MID":1} } ]
}
} ]
}
}
But when i trying revert to Object reverter goes wrong.
I can't found problem. What's my fault.
Thanks
PS: If i didn't explain, sample code here: http://goo.gl/3QnSw

Related

Chisel compiled successfully but can't generate correctly verilog

I use Chisel write an RISC-V CPU, Chisel code compiled successfully and Firrtl code generate successfully too, but the verilog code just has a module statement.The Verilog files are basically empty.
It generates all module's Firrtl code.When I use Verilator to simulation it, under the test_run_dir fold it is just a 1kb verilog file and an empty VCD file.
Here is the code
package CPUModule
import chisel3._
import chisel3.util._
import chisel3.iotesters.{ChiselFlatSpec, Driver, PeekPokeTester}
import IFUModule._
import IDUModule._
import MemModel._
import EXUModule._
import WBUModule._
class SingleCycleCPU extends Module {
val io = IO(new Bundle {
val in_enable = Input(Bool())
})
val MM = Module(new MemoryModel) // L1D and L1I
val PC = Module(new PromgrameCounter) // pc
val PD = Module(new PlexDecoder) // decoder
val RF = Module(new RegisterFile) // regfile
val ALU = Module(new ALU) // ALU
val AGU = Module(new LSU) // AGU
val WB = Module(new WriteBackUnit) // write back
// L1I
val MM_in_L1I_readen = Wire(Bool())
val MM_in_L1I_readdr = Wire(UInt(32.W))
val MM_out_L1I_readdata = Wire(UInt(32.W))
// L1D
val MM_in_L1D_readen = Wire(Bool())
val MM_in_L1D_readaddr = Wire(UInt(32.W))
val MM_out_L1D_readdata = Wire(UInt(32.W))
val MM_in_L1D_writeen = Wire(Bool())
val MM_in_L1D_writeaddr = Wire(UInt(32.W))
val MM_in_L1D_writedata = Wire(UInt(32.W))
// not use
MM_in_L1I_readen := false.B
MM_in_L1I_readdr := DontCare
MM_in_L1D_readen := false.B
MM_in_L1D_readaddr := DontCare
// MM_out_L1D_readdata := DontCare
MM_in_L1D_writeen := false.B
MM_in_L1D_writeaddr := DontCare
MM_in_L1D_writedata := DontCare
val MM_L1D_FLAG = Wire(Bool()) // L1D enable
MM.io.in_L1I_readenable := MM_in_L1I_readen
MM.io.in_L1I_readaddr := MM_in_L1I_readdr
MM_out_L1I_readdata := MM.io.out_L1I_readdata
MM.io.in_L1D_readenable := MM_in_L1D_readen
MM.io.in_L1D_readaddr := MM_in_L1D_readaddr
MM_out_L1D_readdata := MM.io.out_L1D_readdata
MM.io.in_L1D_writeenable := MM_in_L1D_writeen
MM.io.in_L1D_writeaddr := MM_in_L1D_writeaddr
MM.io.in_L1D_writedata := MM_in_L1D_writedata
// PC
val PC_out_data = Wire(UInt(32.W))
PC.io.in_enable := io.in_enable // 启动PC
PC.io.in_immpcenable := false.B
PC.io.in_immpcnumber := 0.U(32.W)
PC_out_data := PC.io.out_pcnumber
// get inst
when(!MM_in_L1D_readen && !MM_in_L1D_writeen) {
MM_in_L1I_readen := true.B
MM_in_L1I_readdr := PC_out_data
} .otherwise {
MM_in_L1I_readen := false.B
MM_in_L1I_readdr := DontCare
}
// decoder
val PD_out_mircocode = Wire(UInt(32.W))
val PD_out_rs1 = Wire(UInt(5.W))
val PD_out_rs2 = Wire(UInt(5.W))
val PD_out_rd = Wire(UInt(5.W))
val PD_out_immItype = Wire(UInt(12.W))
val PD_out_immStype5 = Wire(UInt(5.W))
val PD_out_immStype7 = Wire(UInt(7.W))
val PD_out_shamt = Wire(UInt(5.W))
val reg_mircocode = RegInit(0.U(32.W))
val reg_rs1 = RegInit(0.U(5.W))
val reg_rs2 = RegInit(0.U(5.W))
val reg_rd = RegInit(0.U(5.W))
val reg_immItype = RegInit(0.U(12.W))
val reg_immStype5 = RegInit(0.U(5.W))
val reg_immStype7 = RegInit(0.U(7.W))
val reg_shamt = RegInit(0.U(5.W))
PD.io.in_instruction := MM_out_L1I_readdata
PD_out_mircocode := PD.io.out_mircocode
PD_out_rs1 := PD.io.out_rs1
PD_out_rs2 := PD.io.out_rs2
PD_out_rd := PD.io.out_rd
PD_out_immItype := PD.io.out_immItype
PD_out_immStype5 := PD.io.out_immStype5
PD_out_immStype7 := PD.io.out_immStype7
PD_out_shamt := PD.io.out_shamt
reg_mircocode := PD_out_mircocode
reg_rs1 := PD_out_rs1
reg_rs2 := PD_out_rs2
reg_rd := PD_out_rd
reg_immItype := PD_out_immItype
reg_immStype5 := PD_out_immStype5
reg_immStype7 := PD_out_immStype7
reg_shamt := PD_out_shamt
// reg file
val RF_in_readen = Wire(Bool())
val RF_out_readdata_1 = Wire(UInt(32.W))
val RF_out_readdata_2 = Wire(UInt(32.W))
val RF_in_writeen = Wire(Bool())
val RF_in_writeaddr = Wire(UInt(32.W))
val RF_in_writedata = Wire(UInt(32.W))
RF_in_readen := true.B
RF_in_writeen := false.B
RF.io.in_read := RF_in_readen
RF.io.in_readaddress_1 := reg_rs1
RF.io.in_readaddress_2 := reg_rs2
RF_out_readdata_1 := RF.io.out_readdata_1
RF_out_readdata_2 := RF.io.out_readdata_2
RF.io.in_write := RF_in_writeen
RF.io.in_writeaddress_1 := RF_in_writeaddr
RF.io.in_writedata_1 := RF_in_writedata
val reg_rf_data_1 = RegInit(0.U(32.W))
val reg_rf_data_2 = RegInit(0.U(32.W))
reg_rf_data_1 := RF_out_readdata_1
reg_rf_data_2 := RF_out_readdata_2
// ALU AGU
// ALU
val ALU_out_rd = Wire(UInt(32.W))
ALU.io.in_mircocode := reg_mircocode
ALU.io.in_rs1data := reg_rf_data_1
ALU.io.in_rs2data := reg_rf_data_2
ALU.io.in_immItype := reg_immItype
ALU.io.in_shamt := reg_shamt
ALU_out_rd := ALU.io.out_rddata
// AGU
val AGU_out_L1D_readen = Wire(Bool())
val AGU_out_L1D_readaddr = Wire(UInt(32.W))
val AGU_out_L1D_writeen = Wire(Bool())
val AGU_out_L1D_writeaddr = Wire(UInt(32.W))
val AGU_out_L1D_writedata = Wire(UInt(32.W))
val AGU_out_rdaddr = Wire(UInt(5.W))
AGU.io.in_mircocode := reg_mircocode
AGU.io.in_rs1data := reg_rf_data_1
AGU.io.in_rs2data := reg_rf_data_2
AGU.io.in_immItype := reg_immItype
AGU.io.in_immStype5 := reg_immStype5
AGU.io.in_immStype7 := reg_immStype7
AGU.io.in_rdaddress := reg_rd
AGU_out_L1D_readen := AGU.io.out_read_enable
AGU_out_L1D_writeen := AGU.io.out_write_enable
AGU_out_L1D_writeaddr := AGU.io.out_writeaddress
AGU_out_L1D_writedata := AGU.io.out_writedata
AGU_out_L1D_readaddr := AGU.io.out_readaddress
AGU_out_rdaddr := AGU.io.out_rdaddress
// connect AGU output to L1D input
when(AGU_out_L1D_readen) {
// connect
MM_in_L1D_readen := AGU_out_L1D_readen
MM_in_L1D_readaddr := AGU_out_L1D_readaddr
// not use
MM_in_L1D_writeen := false.B
MM_in_L1D_writeaddr := DontCare
MM_in_L1D_writedata := DontCare
MM_L1D_FLAG := true.B
} .elsewhen(AGU_out_L1D_writeen) {
// connect
MM_in_L1D_writeen := AGU_out_L1D_writeen
MM_in_L1D_writeaddr := AGU_out_L1D_writeaddr
MM_in_L1D_writedata := AGU_out_L1D_writedata
// not use
MM_in_L1D_readen := false.B
MM_in_L1D_readaddr := DontCare
MM_L1D_FLAG := false.B
} .otherwise {
// not use
MM_in_L1D_readen := false.B
MM_in_L1D_readaddr := DontCare
MM_in_L1D_writeen := false.B
MM_in_L1D_writeaddr := DontCare
MM_in_L1D_writedata := DontCare
MM_L1D_FLAG := true.B
}
val reg_L1D_readdata = RegInit(0.U(32.W))
reg_L1D_readdata := MM_out_L1D_readdata
val reg_ALU_rddata = RegInit(0.U(32.W))
reg_ALU_rddata := ALU_out_rd
val reg_AGU_rdaddr = RegInit(0.U(4.W))
reg_AGU_rdaddr := AGU_out_rdaddr
// write back
val WB_in_enable = Wire(Bool())
val WB_out_rdaddr = Wire(UInt(32.W))
val WB_out_rddata = Wire(UInt(32.W))
WB_in_enable := true.B
WB.io.in_enable := WB_in_enable
WB.io.in_address_1 := reg_AGU_rdaddr
WB.io.in_needwritedata_1 := reg_L1D_readdata
WB.io.in_mircocode := reg_mircocode
WB.io.in_address_2 := reg_rd
WB.io.in_needwritedata_2 := reg_ALU_rddata
WB_out_rdaddr := WB.io.out_address
WB_out_rddata := WB.io.out_data
val reg_wb_addr = RegInit(0.U(5.W))
val reg_wb_data = RegInit(0.U(32.W))
reg_wb_addr := WB_out_rdaddr
reg_wb_data := WB_out_rddata
// close read com
RF_in_readen := false.B
// open write com
RF_in_writeen := true.B
RF_in_writeaddr := reg_wb_addr
RF_in_writedata := reg_wb_data
}
// Tester
class TestSingleCycleCPU(c: SingleCycleCPU) extends PeekPokeTester(c) {
// poke
poke(c.io.in_enable, true.B)
// wait
step(1)
}
object SingleCycleCPU {
def main(args: Array[String]): Unit = {
val args = Array("--backend-name", "verilator")
chisel3.iotesters.Driver.execute(args, () => new SingleCycleCPU) { c => new TestSingleCycleCPU(c) }
// chisel3.Driver.execute(args, () => new SingleCycleCPU)
}
}
The FIRRTL compiler does a fair amount of optimizations between the output of Chisel and emitting Verilog. In this case, your code is getting removed by Dead Code Elimination because there is no effect on the outside world.
I would suggest adding some output to monitor what's going on, perhaps turn PC_out_data into an output:
val io = IO(new Bundle {
val in_enable = Input(Bool())
val PC_out_data = Output(UInt(32.W))
})
You'll have to replace references to PC_out_data with io.PC_out_data, but if you do this, anything that has an effect on the PC will no longer be deleted.
For more information, check out my answer to this question which discusses optimizations and how they remove signals (in addition to how names are propagated from Chisel to Verilog which you also might find interesting): How to keep all variable name In chisel when generate Verilog code

Convert JSON to DataSet with TRESTResponseDataSetAdapter

I need to consume a REST API that returns a JSON that resembles the following:
[
{
"purchaseCode": 1,
"totalItems": 5,
"totalPrice": 5102.04,
"deliveryAddress": {
"name": "Michael Jennette",
"country": "Brazil",
"state": "São Paulo",
"postCode": "16",
"landmark": ""
}
},
{
"purchaseCode": 2,
"totalItems": 3,
"totalPrice": 4312.65,
"deliveryAddress": {
"name": "David Samuel",
"country": "Brazil",
"state": "São Paulo",
"postCode": "40",
"landmark": ""
}
}
]
I can easily convert this JSON format to a class using TJSONObject.ParseJSONValue. The problem is that I need to print reports with this json's data. So it's more interesting to convert JSON to DataSet.
Before JSON existed, XML was heavily used. In XMLs that an object owned another object, the DataSet had to have a field of type DataSet that would be referenced by another DataSet. This way it is possible to convert all XML to DataSet.
I'm trying to do the same with JSON using the native component TRESTResponseDataSetAdapter. I have seen that I can specify the fields for ResponseDataSetAdapter and that each field can have "child fields".
Therefore, I defined "deliveryAddress" as the DataSet type and specified its "child fields". But when I run the request, I get an "Invalid Argument" error and then another "Invalid value for field "deliveryAddress" error.
Is it possible to convert this JSON format to DataSet using TRESTResponseDataSetAdapter? If yes, how? Or is there another way? I did not want to have to convert to classes and then manually fill each DataSet.
Sample project:
Server (WebBroker)
Project1.dpr
program Project1;
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Types,
IPPeerServer,
IPPeerAPI,
IdHTTPWebBrokerBridge,
Web.WebReq,
Web.WebBroker,
WebModuleUnit1 in 'WebModuleUnit1.pas' {WebModule1: TWebModule},
ServerConst1 in 'ServerConst1.pas';
{$R *.res}
function BindPort(Aport: Integer): Boolean;
var
LTestServer: IIPTestServer;
begin
Result := True;
try
LTestServer := PeerFactory.CreatePeer('', IIPTestServer) as IIPTestServer;
LTestServer.TestOpenPort(APort, nil);
except
Result := False;
end;
end;
function CheckPort(Aport: Integer): Integer;
begin
if BindPort(Aport) then
Result := Aport
else
Result := 0;
end;
procedure SetPort(const Aserver: TIdHTTPWebBrokerBridge; APort: String);
begin
if not (Aserver.Active) then
begin
APort := APort.Replace(cCommandSetPort, '').Trim;
if CheckPort(APort.ToInteger) > 0 then
begin
Aserver.DefaultPort := APort.ToInteger;
Writeln(Format(sPortSet, [APort]));
end
else
Writeln(Format(sPortInUse, [Aport]));
end
else
Writeln(sServerRunning);
Write(cArrow);
end;
procedure StartServer(const Aserver: TIdHTTPWebBrokerBridge);
begin
if not (Aserver.Active) then
begin
if CheckPort(Aserver.DefaultPort) > 0 then
begin
Writeln(Format(sStartingServer, [Aserver.DefaultPort]));
Aserver.Bindings.Clear;
Aserver.Active := True;
end
else
Writeln(Format(sPortInUse, [Aserver.DefaultPort.ToString]));
end
else
Writeln(sServerRunning);
Write(cArrow);
end;
procedure StopServer(const Aserver: TIdHTTPWebBrokerBridge);
begin
if Aserver.Active then
begin
Writeln(sStoppingServer);
Aserver.Active := False;
Aserver.Bindings.Clear;
Writeln(sServerStopped);
end
else
Writeln(sServerNotRunning);
Write(cArrow);
end;
procedure WriteCommands;
begin
Writeln(sCommands);
Write(cArrow);
end;
procedure WriteStatus(const Aserver: TIdHTTPWebBrokerBridge);
begin
Writeln(sIndyVersion + Aserver.SessionList.Version);
Writeln(sActive + Aserver.Active.ToString(TUseBoolStrs.True));
Writeln(sPort + Aserver.DefaultPort.ToString);
Writeln(sSessionID + Aserver.SessionIDCookieName);
Write(cArrow);
end;
procedure RunServer(APort: Integer);
var
LServer: TIdHTTPWebBrokerBridge;
LResponse: string;
begin
WriteCommands;
LServer := TIdHTTPWebBrokerBridge.Create(nil);
try
LServer.DefaultPort := APort;
while True do
begin
Readln(LResponse);
LResponse := LowerCase(LResponse);
if LResponse.StartsWith(cCommandSetPort) then
SetPort(LServer, LResponse)
else if sametext(LResponse, cCommandStart) then
StartServer(LServer)
else if sametext(LResponse, cCommandStatus) then
WriteStatus(LServer)
else if sametext(LResponse, cCommandStop) then
StopServer(LServer)
else if sametext(LResponse, cCommandHelp) then
WriteCommands
else if sametext(LResponse, cCommandExit) then
if LServer.Active then
begin
StopServer(LServer);
break
end
else
break
else
begin
Writeln(sInvalidCommand);
Write(cArrow);
end;
end;
finally
LServer.Free;
end;
end;
begin
try
if WebRequestHandler <> nil then
WebRequestHandler.WebModuleClass := WebModuleClass;
RunServer(8080);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end
end.
ServerConst1.pas
unit ServerConst1;
interface
resourcestring
sPortInUse = '- Error: Port %s already in use';
sPortSet = '- Port set to %s';
sServerRunning = '- The Server is already running';
sStartingServer = '- Starting HTTP Server on port %d';
sStoppingServer = '- Stopping Server';
sServerStopped = '- Server Stopped';
sServerNotRunning = '- The Server is not running';
sInvalidCommand = '- Error: Invalid Command';
sIndyVersion = '- Indy Version: ';
sActive = '- Active: ';
sPort = '- Port: ';
sSessionID = '- Session ID CookieName: ';
sCommands = 'Enter a Command: ' + slineBreak +
' - "start" to start the server'+ slineBreak +
' - "stop" to stop the server'+ slineBreak +
' - "set port" to change the default port'+ slineBreak +
' - "status" for Server status'+ slineBreak +
' - "help" to show commands'+ slineBreak +
' - "exit" to close the application';
const
cArrow = '->';
cCommandStart = 'start';
cCommandStop = 'stop';
cCommandStatus = 'status';
cCommandHelp = 'help';
cCommandSetPort = 'set port';
cCommandExit = 'exit';
implementation
end.
WebModuleUnit1.pas
unit WebModuleUnit1;
interface
uses System.SysUtils, System.Classes, Web.HTTPApp;
type
TWebModule1 = class(TWebModule)
procedure WebModule1jsonAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
WebModuleClass: TComponentClass = TWebModule1;
implementation
{%CLASSGROUP 'System.Classes.TPersistent'}
{$R *.dfm}
procedure TWebModule1.WebModule1jsonAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
Response.ContentType := 'application/json; charset=utf-8';
Response.Content :=
'[{"purchaseCode":1,"totalItems":5,"totalPrice":5102.04,"deliveryAddress":{"name":"Michael Jennette","country":"Brazil","state":"S\u00E3o Paulo","postCode":"16","landmark":""}},' +
'{"purchaseCode":2,"totalItems":3,"totalPrice":4312.65,"deliveryAddress":{"name":"David Samuel","country":"Brazil","state":"S\u00E3o Paulo","postCode":"40","landmark":""}}]';
end;
end.
WebModuleUnit1.dfm
object WebModule1: TWebModule1
OldCreateOrder = False
Actions = <
item
MethodType = mtGet
Name = 'json'
PathInfo = '/json'
OnAction = WebModule1jsonAction
end>
Height = 230
Width = 415
end
Client
Client1.dpr
program Client1;
uses
Vcl.Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Unit1.pas
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Data.DB, IPPeerClient, FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param,
FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
REST.Response.Adapter, REST.Client, Data.Bind.Components, Data.Bind.ObjectScope, Vcl.Grids, Vcl.DBGrids, Vcl.StdCtrls;
type
TForm1 = class(TForm)
btnRequest: TButton;
DBGrid1: TDBGrid;
DataSource1: TDataSource;
RESTClient1: TRESTClient;
RESTRequest1: TRESTRequest;
RESTResponse1: TRESTResponse;
RESTResponseDataSetAdapter1: TRESTResponseDataSetAdapter;
FDMemTable1: TFDMemTable;
FDMemTable2: TFDMemTable;
FDMemTable1purchaseCode: TIntegerField;
FDMemTable1totalItems: TIntegerField;
FDMemTable1totalPrice: TCurrencyField;
FDMemTable1deliveryAddress: TDataSetField;
FDMemTable2name: TStringField;
FDMemTable2country: TStringField;
FDMemTable2state: TStringField;
FDMemTable2postCode: TStringField;
FDMemTable2landmark: TStringField;
procedure btnRequestClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnRequestClick(Sender: TObject);
begin
RESTRequest1.Execute;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 362
ClientWidth = 724
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object btnRequest: TButton
Left = 24
Top = 24
Width = 75
Height = 25
Caption = 'Request'
TabOrder = 0
OnClick = btnRequestClick
end
object DBGrid1: TDBGrid
Left = 296
Top = 48
Width = 409
Height = 297
DataSource = DataSource1
TabOrder = 1
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'Tahoma'
TitleFont.Style = []
end
object DataSource1: TDataSource
DataSet = FDMemTable1
Left = 232
Top = 152
end
object RESTClient1: TRESTClient
Accept = 'application/json, text/plain; q=0.9, text/html;q=0.8,'
AcceptCharset = 'UTF-8, *;q=0.8'
BaseURL = 'http://localhost:8080/json'
Params = <>
HandleRedirects = True
RaiseExceptionOn500 = False
Left = 32
Top = 64
end
object RESTRequest1: TRESTRequest
Client = RESTClient1
Params = <>
Response = RESTResponse1
SynchronizedEvents = False
Left = 32
Top = 112
end
object RESTResponse1: TRESTResponse
ContentType = 'application/json'
Left = 32
Top = 160
end
object RESTResponseDataSetAdapter1: TRESTResponseDataSetAdapter
Dataset = FDMemTable1
FieldDefs = <
item
Name = 'purchaseCode'
DataType = ftInteger
end
item
Name = 'totalItems'
DataType = ftInteger
end
item
Name = 'totalPrice'
DataType = ftCurrency
end
item
Name = 'deliveryAddress'
ChildDefs = <
item
Name = 'name'
DataType = ftString
Size = 150
end
item
Name = 'country'
DataType = ftString
Size = 150
end
item
Name = 'state'
DataType = ftString
Size = 150
end
item
Name = 'postCode'
DataType = ftString
Size = 50
end
item
Name = 'landmark'
DataType = ftString
Size = 150
end>
DataType = ftDataSet
Size = 5
end>
Response = RESTResponse1
Left = 32
Top = 216
end
object FDMemTable1: TFDMemTable
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired]
UpdateOptions.CheckRequired = False
Left = 168
Top = 152
object FDMemTable1purchaseCode: TIntegerField
FieldName = 'purchaseCode'
end
object FDMemTable1totalItems: TIntegerField
FieldName = 'totalItems'
end
object FDMemTable1totalPrice: TCurrencyField
FieldName = 'totalPrice'
end
object FDMemTable1deliveryAddress: TDataSetField
FieldName = 'deliveryAddress'
end
end
object FDMemTable2: TFDMemTable
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired]
UpdateOptions.CheckRequired = False
Left = 168
Top = 224
object FDMemTable2name: TStringField
FieldName = 'name'
Size = 150
end
object FDMemTable2country: TStringField
FieldName = 'country'
Size = 150
end
object FDMemTable2state: TStringField
FieldName = 'state'
Size = 150
end
object FDMemTable2postCode: TStringField
FieldName = 'postCode'
Size = 50
end
object FDMemTable2landmark: TStringField
FieldName = 'landmark'
Size = 150
end
end
end

Functions giving different result with same parameters

I use GMLib to work with Google maps and now I have come to a point where I am very confused.
I have the functions GetDistance and GetHeading to calculate the distance and compass direction between 2 markers on my map.
When I call them from my procedure GetHeadingDistance I get the result I expect (distance and direction is correct)- aSearchCallInfo is a class containing info that needs to be updated with the values.
Now I am trying to add a function that lets the user press the right mouse button on the map and the get info about that location.
But in this case I get very wrong results. As far as I can see of the results it uses GMMarker.Items[1].Position as source even when I know that it is GMMarker.Items[0].Position I send as parameter.
When I try to debug the functions by writing values to a textfile during calculation, I can see that it is the correct values it gets to work with at the correct position.
(GMMarker.Items[0].Position is the position of the user of the software)
Any ideas as what I could try to get this solved?
procedure TfrmQthMap.GMMapRightClick(Sender: TObject; LatLng: TLatLng; X, Y: Double);
var
MessageText: string;
LL: TLatLng;
Heading: double;
Distance: double;
Qra: string;
begin
if GMMarker.Count > 0 then
begin
LL := TLatLng.Create;
try
LL.Lat := LatLng.Lat;
LL.Lng := LatLng.Lng;
Heading := GetHeading(GMMarker.Items[0].Position, LL);
Distance := GetDistance(GMMarker.Items[0].Position, LL);
Qra := Maidenhead(LatLng.LngToStr, LatLng.LatToStr);
finally
FreeAndNil(LL);
end;
MessageText := 'Data for det sted du klikkede på: ' + sLineBreak + sLineBreak +
Format('Længdegrad: %s', [LatLng.LngToStr(Precision)]) + sLineBreak +
Format('Breddegrad: %s', [LatLng.LatToStr(Precision)]) + sLineBreak +
Format('Afstand: %6.1f km', [Distance]) + sLineBreak +
Format('Retning: %6.1f °', [Heading]) + sLineBreak +
Format('Lokator: %s', [Qra]);
ShowMessage(MessageText);
end;
end;
procedure TfrmQthMap.GetHeadingDistance(aSearchCallInfo: TCallInfo);
var
Heading: double;
Distance: double;
begin
if GMMarker.Count > 1 then
begin
Heading := GetHeading(GMMarker.Items[0].Position, GMMarker.Items[1].Position);
Distance := GetDistance(GMMarker.Items[0].Position, GMMarker.Items[1].Position);
barFooter.Panels[PanelDist].Text := Format('Afstand: %6.1f km', [Distance]);
barFooter.Panels[PanelDir].Text := Format('Retning: %6.1f°', [Heading]);
aSearchCallInfo.Distance := Format('%6.1f km', [Distance]);
aSearchCallInfo.Heading := Format('%6.1f °', [Heading]);
aSearchCallInfo.SaveToDatabase;
end;
end;
function TfrmQthMap.GetDistance(aOrigin, aDest: TLatLng): double;
var
Distance: double;
begin
Distance := TGeometry.ComputeDistanceBetween(GMMap, aOrigin, aDest);
Distance := Distance / 1000;
Result := Distance;
end;
function TfrmQthMap.GetHeading(aOrigin, aDest: TLatLng): double;
var
Heading: double;
begin
Heading := TGeometry.ComputeHeading(GMMap, aOrigin, aDest);
Heading := 180 + Heading;
Result := Heading;
end;

Send email with attachment in Delphi

How do I send an attachment in an HTML formatted email?
I managed to send an email using stmp.gmail.com in HTML format, but my email has an attachment. The attachment gets converted to a string, but I need it to be in the original file format.
Code:
with FIdSmtp do
begin
// Configure IdSMTP
end;
FIdMessage.Clear;
FIdMessage.MessageParts.Clear;
FIdMessage.From.Address := 'EmailRemetente';
FIdMessage.From.Name := 'Apelido';
FIdMessage.Subject := 'Assunto';
FIdMessage.Body.Text := 'Mensagem';
FIdMessage.Recipients.EMailAddresses := 'aEmailDestinatario'; //email destino
FIdMessage.BccList.EMailAddresses := StringReplace(Trim(BCCList.Text),#13#10,',',[rfReplaceAll]);
FIdMessage.ccList.EMailAddresses := StringReplace(Trim(CCList.Text),#13#10,',',[rfReplaceAll]);
FIdMessage.ContentType := 'text/html'; // set html format
_Anexo := TStringList.Create;
try
_Anexo.Text := aAnexos;
for i := 0 to _Anexo.Count - 1 do
TIdAttachmentFile.Create(FIdMessage.MessageParts,_Anexo.Strings[i]);
finally
_Anexo.Free
end;
FIdSmtp.Send(FIdMessage);
Can someone help me?
Read my blog on Indy's website, I discussed this subject in some detail:
HTML Messages
New HTML Message Builder class
With that in mind, try this:
FIdMessage.Clear;
FIdMessage.From.Address := 'EmailRemetente';
FIdMessage.From.Name := 'Apelido';
FIdMessage.Subject := 'Assunto';
FIdMessage.Recipients.EMailAddresses := 'aEmailDestinatario';
FIdMessage.BccList.EMailAddresses := StringReplace(Trim(BCCList.Text),sLineBreak,',',[rfReplaceAll]);
FIdMessage.ccList.EMailAddresses := StringReplace(Trim(CCList.Text),sLineBreak,',',[rfReplaceAll]);
FIdMessage.ContentType := 'multipart/mixed';
with TIdText.Create(FIdMessage.MessageParts, nil) do
begin
ContentType := 'text/html';
Body.Text := 'Mensagem';
end;
_Anexo := TStringList.Create;
try
_Anexo.Text := aAnexos;
for i := 0 to _Anexo.Count - 1 do
TIdAttachmentFile.Create(FIdMessage.MessageParts, _Anexo.Strings[i]);
finally
_Anexo.Free
end;
Or this:
FIdMessage.Clear;
with TIdMessageBuilderHtml.Create do
try
Subject := 'Assunto';
Html.Text := 'Mensagem';
_Anexo := TStringList.Create;
try
_Anexo.Text := aAnexos;
for i := 0 to _Anexo.Count - 1 do
Attachments.Add(_Anexo.Strings[i]);
finally
_Anexo.Free
end;
FillMessage(FIdMessage);
finally
Free;
end;
FIdMessage.From.Address := 'EmailRemetente';
FIdMessage.From.Name := 'Apelido';
FIdMessage.Recipients.EMailAddresses := 'aEmailDestinatario';
FIdMessage.BccList.EMailAddresses := StringReplace(Trim(BCCList.Text),sLineBreak,',',[rfReplaceAll]);
FIdMessage.ccList.EMailAddresses := StringReplace(Trim(CCList.Text),sLineBreak,',',[rfReplaceAll]);

Is there a Delphi standard function for escaping HTML?

I've got a report that's supposed to take a grid control and produce HTML output. One of the columns in the grid can display any of a number of values, or <Any>. When this gets output to HTML, of course, it ends up blank.
I could probably write up some routine to use StringReplace to turn that into <Any> so it would display this particular case correctly, but I figure there's probably one in the RTL somewhere that's already been tested and does it right. Anyone know where I could find it?
I am 99 % sure that such a function does not exist in the RTL (as of Delphi 2009). Of course - however - it is trivial to write such a function.
Update
HTTPUtil.HTMLEscape is what you are looking for:
function HTMLEscape(const Str: string): string;
I don't dare to publish the code here (copyright violation, probably), but the routine is very simple. It encodes "<", ">", "&", and """ to <, >, &, and ". It also replaces characters #92, #160..#255 to decimal codes, e.g. \.
This latter step is unnecessary if the file is UTF-8, and also illogical, because higher special characters, such as ∮ are left as they are, while lower special characters, such as ×, are encoded.
Update 2
In response to the answer by Stijn Sanders, I made a simple performance test.
program Project1;
{$APPTYPE CONSOLE}
uses
Windows, SysUtils;
var
t1, t2, t3, t4: Int64;
i: Integer;
str: string;
const
N = 100000;
function HTMLEncode(const Data: string): string;
var
i: Integer;
begin
result := '';
for i := 1 to length(Data) do
case Data[i] of
'<': result := result + '<';
'>': result := result + '>';
'&': result := result + '&';
'"': result := result + '"';
else
result := result + Data[i];
end;
end;
function HTMLEncode2(Data: string):string;
begin
Result:=
StringReplace(
StringReplace(
StringReplace(
StringReplace(
Data,
'&','&',[rfReplaceAll]),
'<','<',[rfReplaceAll]),
'>','>',[rfReplaceAll]),
'"','"',[rfReplaceAll]);
end;
begin
QueryPerformanceCounter(t1);
for i := 0 to N - 1 do
str := HTMLEncode('Testing. Is 3*4<3+4? Do you like "A & B"');
QueryPerformanceCounter(t2);
QueryPerformanceCounter(t3);
for i := 0 to N - 1 do
str := HTMLEncode2('Testing. Is 3*4<3+4? Do you like "A & B"');
QueryPerformanceCounter(t4);
Writeln(IntToStr(t2-t1));
Writeln(IntToStr(t4-t3));
Readln;
end.
The output is
532031
801969
It seems here is a small contest :) Here is a one more implementation:
function HTMLEncode3(const Data: string): string;
var
iPos, i: Integer;
procedure Encode(const AStr: String);
begin
Move(AStr[1], result[iPos], Length(AStr) * SizeOf(Char));
Inc(iPos, Length(AStr));
end;
begin
SetLength(result, Length(Data) * 6);
iPos := 1;
for i := 1 to length(Data) do
case Data[i] of
'<': Encode('<');
'>': Encode('>');
'&': Encode('&');
'"': Encode('"');
else
result[iPos] := Data[i];
Inc(iPos);
end;
SetLength(result, iPos - 1);
end;
Update 1: Updated initially provided incorrect code.
Update 2: And the times:
HTMLEncode : 2286508597
HTMLEncode2: 3577001647
HTMLEncode3: 361039770
I usually just use this code:
function HTMLEncode(Data:string):string;
begin
Result:=
StringReplace(
StringReplace(
StringReplace(
StringReplace(
StringReplace(
Data,
'&','&',[rfReplaceAll]),
'<','<',[rfReplaceAll]),
'>','>',[rfReplaceAll]),
'"','"',[rfReplaceAll]),
#13#10,'<br />'#13#10,[rfReplaceAll]);
end;
(copyright? it's open source)
Unit HTTPApp has a function called HTMLEncode. It has also other HTML/HTTP related functions.
I dont know in which delphi version it was introduced but, there is the System.NetEncoding unit which has:
TNetEncoding.HTML.Encode
TNetEncoding.HTML.Decode
functions. Read up here. You dont need external libraries anymore for that.
From unit Soap.HTTPUtil or simply HTTPUtil for older delphi versions, you can use
function HTMLEscape(const Str: string): string;
var
i: Integer;
begin
Result := '';
for i := Low(Str) to High(Str) do
begin
case Str[i] of
'<' : Result := Result + '<'; { Do not localize }
'>' : Result := Result + '>'; { Do not localize }
'&' : Result := Result + '&'; { Do not localize }
'"' : Result := Result + '"'; { Do not localize }
{$IFNDEF UNICODE}
#92, Char(160) .. #255 : Result := Result + '&#' + IntToStr(Ord(Str[ i ])) +';'; { Do not localize }
{$ELSE}
// NOTE: Not very efficient
#$0080..#$FFFF : Result := Result + '&#' + IntToStr(Ord(Str[ i ])) +';'; { Do not localize }
{$ENDIF}
else
Result := Result + Str[i];
end;
end;
end;
how about that way of replacing special characters:
function HtmlWeg(sS: String): String;
var
ix,cc: Integer;
sC, sR: String;
begin
result := sS;
ix := pos('\u00',sS);
while ix >0 do
begin
sc := copy(sS,ix+4,2) ;
cc := StrtoIntdef('$' +sC,32);
sR := '' + chr(cc);
sS := Stringreplace(sS, '\u00'+sC,sR,[rfreplaceall]) ;
ix := pos('\u00',sS);
end;
result := sS;
end;
My function combines the for-loop with a minimal reallocation of the string:
function HtmlEncode(const Value: string): string;
var
i: Integer;
begin
Result := Value;
i := 1;
while i <= Length(Result) do
begin
if Result[i] = '<' then
begin
Result[i] := '&';
Insert('lt;', Result, i + 1);
Inc(i, 4);
end
else if Result[i] = '>' then
begin
Result[i] := '&';
Insert('gt;', Result, i + 1);
Inc(i, 4);
end
else if Result[i] = '"' then
begin
Result[i] := '&';
Insert('quot;', Result, i + 1);
Inc(i, 6);
end
else if Result[i] = '&' then
begin
Insert('amp;', Result, i + 1);
Inc(i, 5);
end
else
Inc(i);
end;
end;
in delphi You have the function
THTMLEncoding.HTML.Encode